ghc/interpreter/static.c

   1
   2 /* --------------------------------------------------------------------------
   3  * Static Analysis for Hugs
   4  *
   5  * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
   6  * Yale Haskell Group, and the Oregon Graduate Institute of Science and
   7  * Technology, 1994-1999, All rights reserved.  It is distributed as
   8  * free software under the license in the file "License", which is
   9  * included in the distribution.
  10  *
  11  * $RCSfile: static.c,v $
  12  * $Revision: 1.33 $
  13  * $Date: 2000/03/31 04:13:27 $
  14  * ------------------------------------------------------------------------*/
  15
  16 #include "hugsbasictypes.h"
  17 #include "storage.h"
  18 #include "connect.h"
  19 #include "errors.h"
  20
  21 /* --------------------------------------------------------------------------
  22  * local function prototypes:
  23  * ------------------------------------------------------------------------*/
  24
  25 static Void   local kindError           ( Int,Constr,Constr,String,Kind,Int );
  26 static Void   local checkQualImport     ( Pair );
  27 static Void   local checkUnqualImport   ( Triple );
  28
  29 static Name   local lookupName          ( Text,List );
  30 static List   local checkSubentities    ( List,List,List,String,Text );
  31 static List   local checkExportTycon    ( List,Text,Cell,Tycon );
  32 static List   local checkExportClass    ( List,Text,Cell,Class );
  33 static List   local checkExport         ( List,Text,Cell );
  34 static List   local checkImportEntity   ( List,Module,Bool,Cell );
  35 static List   local resolveImportList   ( Module,Cell,Bool );
  36 static Void   local checkImportList     ( Pair );
  37
  38 static Void   local importEntity        ( Module,Cell );
  39 static Void   local importName          ( Module,Name );
  40 static Void   local importTycon         ( Module,Tycon );
  41 static Void   local importClass         ( Module,Class );
  42 static List   local checkExports        ( List, Module );
  43
  44 static Void   local checkTyconDefn      ( Tycon );
  45 static Void   local depConstrs          ( Tycon,List,Cell );
  46 static List   local addSels             ( Int,Name,List,List );
  47 static List   local selectCtxt          ( List,List );
  48 static Void   local checkSynonyms       ( List );
  49 static List   local visitSyn            ( List,Tycon,List );
  50 static Type   local instantiateSyn      ( Type,Type );
  51
  52 static Void   local checkClassDefn      ( Class );
  53 static Cell   local depPredExp          ( Int,List,Cell );
  54 static Void   local checkMems           ( Class,List,Cell );
  55 static Void   local checkMems2          ( Class,Cell );
  56 static Void   local addMembers          ( Class );
  57 static Name   local newMember           ( Int,Int,Cell,Type,Class );
  58 static Text   local generateText        ( String,Class );
  59
  60 static List   local classBindings       ( String,Class,List );
  61 static Name   local memberName          ( Class,Text );
  62 static List   local numInsert           ( Int,Cell,List );
  63
  64 static List   local maybeAppendVar      ( Cell,List );
  65
  66 static Type   local checkSigType        ( Int,String,Cell,Type );
  67 static Void   local checkOptQuantVars   ( Int,List,List );
  68 static Type   local depTopType          ( Int,List,Type );
  69 static Type   local depCompType         ( Int,List,Type );
  70 static Type   local depTypeExp          ( Int,List,Type );
  71 static Type   local depTypeVar          ( Int,List,Text );
  72 static List   local checkQuantVars      ( Int,List,List,Cell );
  73 static List   local otvars              ( Cell,List );
  74 static Bool   local osubset             ( List,List );
  75 static Void   local kindConstr          ( Int,Int,Int,Constr );
  76 static Kind   local kindAtom            ( Int,Constr );
  77 static Void   local kindPred            ( Int,Int,Int,Cell );
  78 static Void   local kindType            ( Int,String,Type );
  79 static Void   local fixKinds            ( Void );
  80
  81 static Void   local kindTCGroup         ( List );
  82 static Void   local initTCKind          ( Cell );
  83 static Void   local kindTC              ( Cell );
  84 static Void   local genTC               ( Cell );
  85
  86 static Void   local checkInstDefn       ( Inst );
  87 static Void   local insertInst          ( Inst );
  88 static Bool   local instCompare         ( Inst,Inst );
  89 static Name   local newInstImp          ( Inst );
  90 static Void   local kindInst            ( Inst,Int );
  91 static Void   local checkDerive         ( Tycon,List,List,Cell );
  92 static Void   local addDerInst          ( Int,Class,List,List,Type,Int );
  93 static Void   local deriveContexts      ( List );
  94 static Void   local initDerInst         ( Inst );
  95 static Void   local calcInstPreds       ( Inst );
  96 static Void   local maybeAddPred        ( Cell,Int,Int,List );
  97 static List   local calcFunDeps         ( List );
  98 static Cell   local copyAdj             ( Cell,Int,Int );
  99 static Void   local tidyDerInst         ( Inst );
 100 static List   local otvarsZonk          ( Cell,List,Int );
 101
 102 static Void   local addDerivImp         ( Inst );
 103
 104 static Void   local checkDefaultDefns   ( Void );
 105
 106 static Void   local checkForeignImport  ( Name );
 107 static Void   local checkForeignExport  ( Name );
 108
 109 static Cell   local tidyInfix           ( Int,Cell );
 110 static Pair   local attachFixity        ( Int,Cell );
 111 static Syntax local lookupSyntax        ( Text );
 112
 113 static Cell   local checkPat            ( Int,Cell );
 114 static Cell   local checkMaybeCnkPat    ( Int,Cell );
 115 static Cell   local checkApPat          ( Int,Int,Cell );
 116 static Void   local addToPatVars        ( Int,Cell );
 117 static Name   local conDefined          ( Int,Cell );
 118 static Void   local checkIsCfun         ( Int,Name );
 119 static Void   local checkCfunArgs       ( Int,Cell,Int );
 120 static Cell   local checkPatType        ( Int,String,Cell,Type );
 121 static Cell   local applyBtyvs          ( Cell );
 122 static Cell   local bindPat             ( Int,Cell );
 123 static Void   local bindPats            ( Int,List );
 124
 125 static List   local extractSigdecls     ( List );
 126 static List   local extractFixdecls     ( List );
 127 static List   local extractBindings     ( List );
 128 static List   local getPatVars          ( Int,Cell,List );
 129 static List   local addPatVar           ( Int,Cell,List );
 130 static List   local eqnsToBindings      ( List,List,List,List );
 131 static Void   local notDefined          ( Int,List,Cell );
 132 static Cell   local findBinding         ( Text,List );
 133 static Cell   local getAttr             ( List,Cell );
 134 static Void   local addSigdecl          ( List,Cell );
 135 static Void   local addFixdecl          ( List,List,List,List,Triple );
 136 static Void   local dupFixity           ( Int,Text );
 137 static Void   local missFixity          ( Int,Text );
 138
 139 static List   local dependencyAnal      ( List );
 140 static List   local topDependAnal       ( List );
 141 static Void   local addDepField         ( Cell );
 142 static Void   local remDepField         ( List );
 143 static Void   local remDepField1        ( Cell );
 144 static Void   local clearScope          ( Void );
 145 static Void   local withinScope         ( List );
 146 static Void   local leaveScope          ( Void );
 147 static Void   local saveSyntax          ( Cell,Cell );
 148
 149 static Void   local depBinding          ( Cell );
 150 static Void   local depDefaults         ( Class );
 151 static Void   local depInsts            ( Inst );
 152 static Void   local depClassBindings    ( List );
 153 static Void   local depAlt              ( Cell );
 154 static Void   local depRhs              ( Cell );
 155 static Void   local depGuard            ( Cell );
 156 static Cell   local depExpr             ( Int,Cell );
 157 static Void   local depPair             ( Int,Cell );
 158 static Void   local depTriple           ( Int,Cell );
 159 static Void   local depComp             ( Int,Cell,List );
 160 static Void   local depCaseAlt          ( Int,Cell );
 161 static Cell   local depVar              ( Int,Cell );
 162 static Cell   local depQVar             ( Int,Cell );
 163 static Void   local depConFlds          ( Int,Cell,Bool );
 164 static Void   local depUpdFlds          ( Int,Cell );
 165 static List   local depFields           ( Int,Cell,List,Bool );
 166 #if IPARAM
 167 static Void   local depWith             ( Int,Cell );
 168 static List   local depDwFlds           ( Int,Cell,List );
 169 #endif
 170 #if TREX
 171 static Cell   local depRecord           ( Int,Cell );
 172 #endif
 173
 174 static List   local tcscc               ( List,List );
 175 static List   local bscc                ( List );
 176
 177 static Void   local addRSsigdecls       ( Pair );
 178 static Void   local allNoPrevDef        ( Cell );
 179 static Void   local noPrevDef           ( Int,Cell );
 180 static Bool   local odiff               ( List,List );
 181
 182 static Void   local duplicateErrorAux   ( Int,Module,Text,String );
 183 #define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
 184 static Void   local checkTypeIn         ( Pair );
 185
 186 /* --------------------------------------------------------------------------
 187  * The code in this file is arranged in roughly the following order:
 188  *  - Kind inference preliminaries
 189  *  - Module declarations
 190  *  - Type declarations (data, type, newtype, type in)
 191  *  - Class declarations
 192  *  - Type signatures
 193  *  - Instance declarations
 194  *  - Default declarations
 195  *  - Primitive definitions
 196  *  - Patterns
 197  *  - Infix expressions
 198  *  - Value definitions
 199  *  - Top-level static analysis and control
 200  *  - Haskell 98 compatibility tests
 201  * ------------------------------------------------------------------------*/
 202
 203 /* --------------------------------------------------------------------------
 204  * Kind checking preliminaries:
 205  * ------------------------------------------------------------------------*/
 206
 207 Bool kindExpert = FALSE;                /* TRUE => display kind errors in  */
 208                                         /*         full detail             */
 209
 210 static Void local kindError(l,c,in,wh,k,o)
 211 Int    l;                               /* line number near constuctor exp */
 212 Constr c;                               /* constructor                     */
 213 Constr in;                              /* context (if any)                */
 214 String wh;                              /* place in which error occurs     */
 215 Kind   k;                               /* expected kind (k,o)             */
 216 Int    o; {                             /* inferred kind (typeIs,typeOff)  */
 217     clearMarks();
 218
 219     if (!kindExpert) {                  /* for those with a fear of kinds  */
 220         ERRMSG(l) "Illegal type" ETHEN
 221         if (nonNull(in)) {
 222             ERRTEXT " \"" ETHEN ERRTYPE(in);
 223             ERRTEXT "\""  ETHEN
 224         }
 225         ERRTEXT " in %s\n", wh
 226         EEND;
 227     }
 228
 229     ERRMSG(l) "Kind error in %s", wh ETHEN
 230     if (nonNull(in)) {
 231         ERRTEXT "\n*** expression     : " ETHEN ERRTYPE(in);
 232     }
 233     ERRTEXT "\n*** constructor    : " ETHEN ERRTYPE(c);
 234     ERRTEXT "\n*** kind           : " ETHEN ERRKIND(copyType(typeIs,typeOff));
 235     ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
 236     if (unifyFails) {
 237         ERRTEXT "\n*** because        : %s", unifyFails ETHEN
 238     }
 239     ERRTEXT "\n"
 240     EEND;
 241 }
 242
 243 #define shouldKind(l,c,in,wh,k,o)       if (!kunify(typeIs,typeOff,k,o)) \
 244                                             kindError(l,c,in,wh,k,o)
 245 #define checkKind(l,a,m,c,in,wh,k,o)    kindConstr(l,a,m,c); \
 246                                         shouldKind(l,c,in,wh,k,o)
 247 #define inferKind(k,o)                  typeIs=k; typeOff=o
 248
 249 static List unkindTypes;                /* types in need of kind annotation*/
 250 #if TREX
 251 Kind   extKind;                         /* Kind of extension, *->row->row  */
 252 #endif
 253
 254 /* --------------------------------------------------------------------------
 255  * Static analysis of modules:
 256  * ------------------------------------------------------------------------*/
 257
 258 Void startModule ( Module m )                    /* switch to a new module */
 259 {
 260     if (isNull(m)) internal("startModule");
 261     setCurrModule(m);
 262 }
 263
 264 Void setExportList(exps)              /* Add export list to current module */
 265 List exps; {
 266     module(currentModule).exports = exps;
 267 }
 268
 269 Void addQualImport(orig,new)         /* Add to qualified import list       */
 270 Cell orig;     /* Original name of module                                  */
 271 Cell new;  {   /* Name module is called within this module (or NIL)        */
 272     module(currentModule).qualImports =
 273       cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
 274 }
 275
 276 Void addUnqualImport(mod,entities)     /* Add to unqualified import list   */
 277 Cell mod;         /* Name of module                                        */
 278 List entities;  { /* List of entity names                                  */
 279     unqualImports = cons(pair(mod,entities),unqualImports);
 280 }
 281
 282 static Void local checkQualImport(i)   /* Process qualified import         */
 283 Pair i; {
 284     Module m = findModid(snd(i));
 285     if (isNull(m)) {
 286         ERRMSG(0) "Module \"%s\" not previously loaded",
 287                   textToStr(textOf(snd(i)))
 288         EEND;
 289     }
 290     snd(i)=m;
 291 }
 292
 293 static Void local checkUnqualImport(i) /* Process unqualified import       */
 294 Pair i; {
 295     Module m = findModid(fst(i));
 296     if (isNull(m)) {
 297         ERRMSG(0) "Module \"%s\" not previously loaded",
 298                   textToStr(textOf(fst(i)))
 299         EEND;
 300     }
 301     fst(i)=m;
 302 }
 303
 304 static Name local lookupName(t,nms)    /* find text t in list of Names     */
 305 Text t;
 306 List nms; { /* :: [Name] */
 307     for(; nonNull(nms); nms=tl(nms)) {
 308         if (t == name(hd(nms)).text)
 309             return hd(nms);
 310     }
 311     return NIL;
 312 }
 313
 314 static List local checkSubentities(imports,named,wanted,description,textParent)
 315 List   imports;
 316 List   named;       /* :: [ Q?(Var|Con)(Id|Op) ]                  */
 317 List   wanted;      /* :: [Name]                                  */
 318 String description; /* "<constructor>|<member> of <type>|<class>" */
 319 Text   textParent; {
 320     for(; nonNull(named); named=tl(named)) {
 321         Pair x = hd(named);
 322         /* ToDo: ignores qualifier; doesn't check that entity is in scope */
 323         Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
 324         Name n = lookupName(t,wanted);
 325         if (isNull(n)) {
 326             ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
 327                       textToStr(t),
 328                       description,
 329                       textToStr(textParent)
 330             EEND;
 331         }
 332         imports = cons(n,imports);
 333     }
 334     return imports;
 335 }
 336
 337 static List local checkImportEntity(imports,exporter,priv,entity)
 338 List   imports; /* Accumulated list of things to import */
 339 Module exporter;
 340 Bool priv;
 341 Cell entity; { /* Entry from import list */
 342     List oldImports = imports;
 343     Text t  = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
 344     List es = NIL;
 345     if (priv) {
 346       es = module(exporter).names;
 347       es = dupOnto(module(exporter).tycons,es);
 348       es = dupOnto(module(exporter).classes,es);
 349     } else {
 350       es = module(exporter).exports;
 351     }
 352
 353     for(; nonNull(es); es=tl(es)) {
 354         Cell e = hd(es); /* :: Entity
 355                              | (Entity, NIL|DOTDOT)
 356                              | tycon
 357                              | class
 358                           */
 359         if (isPair(e)) {
 360             Cell f = fst(e);
 361             if (isTycon(f)) {
 362                 if (tycon(f).text == t) {
 363                     imports = cons(f,imports);
 364                     if (!isIdent(entity)) {
 365                         switch (tycon(f).what) {
 366                         case NEWTYPE:
 367                         case DATATYPE:
 368                             if (DOTDOT == snd(entity)) {
 369                                 imports = dupOnto(tycon(f).defn,imports);
 370                             } else {
 371                                 imports = checkSubentities(
 372                                              imports,snd(entity),tycon(f).defn,
 373                                              "constructor of type",t);
 374                             }
 375                             break;
 376                         default:;
 377                           /* deliberate fall thru */
 378                         }
 379                     }
 380                 }
 381             } else if (isClass(f)) {
 382                 if (cclass(f).text == t) {
 383                     imports = cons(f,imports);
 384                     if (!isIdent(entity)) {
 385                         if (DOTDOT == snd(entity)) {
 386                             return dupOnto(cclass(f).members,imports);
 387                         } else {
 388                             return checkSubentities(
 389                                       imports,snd(entity),cclass(f).members,
 390                                       "member of class",t);
 391                         }
 392                     }
 393                 }
 394             } else {
 395                 internal("checkImportEntity2");
 396             }
 397         } else if (isName(e)) {
 398             if (isIdent(entity) && name(e).text == t) {
 399                 imports = cons(e,imports);
 400             }
 401         } else if (isTycon(e) && priv) {
 402             if (tycon(e).text == t) {
 403                 imports = cons(e,imports);
 404                 return dupOnto(tycon(e).defn,imports);
 405             }
 406         } else if (isClass(e) && priv) {
 407             if (cclass(e).text == t) {
 408                 imports = cons(e,imports);
 409                 return dupOnto(cclass(e).members,imports);
 410             }
 411         } else if (whatIs(e) == TUPLE && priv) {
 412           // do nothing
 413         } else {
 414             internal("checkImportEntity3");
 415         }
 416     }
 417     if (imports == oldImports) {
 418         ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
 419                   textToStr(t),
 420                   textToStr(module(exporter ).text)
 421         EEND;
 422     }
 423     return imports;
 424 }
 425
 426 static List local resolveImportList(m,impList,priv)
 427 Module m;  /* exporting module */
 428 Cell impList;
 429 Bool priv; {
 430     List imports = NIL;
 431     if (DOTDOT == impList) {
 432         List es = module(m).exports;
 433         for(; nonNull(es); es=tl(es)) {
 434             Cell e = hd(es);
 435             if (isName(e)) {
 436                 imports = cons(e,imports);
 437             } else {
 438                 Cell c = fst(e);
 439                 List subentities = NIL;
 440                 imports = cons(c,imports);
 441                 if (isTycon(c)
 442                     && (tycon(c).what == DATATYPE
 443                         || tycon(c).what == NEWTYPE))
 444                     subentities = tycon(c).defn;
 445                 else if (isClass(c))
 446                     subentities = cclass(c).members;
 447                 if (DOTDOT == snd(e)) {
 448                     imports = dupOnto(subentities,imports);
 449                 }
 450             }
 451         }
 452     } else {
 453         map2Accum(checkImportEntity,imports,m,priv,impList);
 454     }
 455     return imports;
 456 }
 457
 458 static Void local checkImportList(importSpec) /*Import a module unqualified*/
 459 Pair importSpec; {
 460     Module m       = fst(importSpec);
 461     Cell   impList = snd(importSpec);
 462
 463     List   imports = NIL; /* entities we want to import */
 464     List   hidden  = NIL; /* entities we want to hide   */
 465
 466     if (isPair(impList) && HIDDEN == fst(impList)) {
 467         /* Somewhat inefficient - but obviously correct:
 468          * imports = importsOf("module Foo") `setDifference` hidden;
 469          */
 470         hidden  = resolveImportList(m, snd(impList),FALSE);
 471         imports = resolveImportList(m, DOTDOT,FALSE);
 472     } else if (isPair(impList) && STAR == fst(impList)) {
 473         // Previously, I was forcing an import Prelude,
 474         // but this precluded doing things like
 475         // import Prelude hiding ( catch)
 476         // so, for now, you need to put an explicit
 477         // import Prelude if you use import privileged.
 478       imports = resolveImportList(m, snd(impList),TRUE);
 479     } else {
 480         imports = resolveImportList(m, impList,FALSE);
 481     }
 482
 483     for(; nonNull(imports); imports=tl(imports)) {
 484         Cell e = hd(imports);
 485         if (!cellIsMember(e,hidden))
 486             importEntity(m,e);
 487     }
 488     /* ToDo: hang onto the imports list for processing export list entries
 489      * of the form "module Foo"
 490      */
 491 }
 492
 493 static Void local importEntity(source,e)
 494 Module source;
 495 Cell e; {
 496     switch (whatIs(e)) {
 497       case NAME  : importName(source,e);
 498                    break;
 499       case TUPLE:
 500       case TYCON : importTycon(source,e);
 501                    break;
 502       case CLASS : importClass(source,e);
 503                    break;
 504       default: internal("importEntity");
 505     }
 506 }
 507
 508 static Void local importName(source,n)
 509 Module source;
 510 Name n; {
 511     Name clash = addName(n);
 512     if (nonNull(clash) && clash!=n) {
 513         ERRMSG(0) "Entity \"%s\" imported from module \"%s\""
 514                   " already defined in module \"%s\"",
 515                   textToStr(name(n).text),
 516                   textToStr(module(source).text),
 517                   textToStr(module(name(clash).mod).text)
 518         EEND;
 519     }
 520 }
 521
 522 static Void local importTycon(source,tc)
 523 Module source;
 524 Tycon tc; {
 525     Tycon clash=addTycon(tc);
 526     if (nonNull(clash) && clash!=tc) {
 527         ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
 528                   textToStr(tycon(tc).text),
 529                   textToStr(module(source).text),
 530                   textToStr(module(tycon(clash).mod).text)
 531         EEND;
 532     }
 533     if (nonNull(findClass(tycon(tc).text))) {
 534         ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
 535                   textToStr(tycon(tc).text),
 536                   textToStr(module(tycon(tc).mod).text)
 537         EEND;
 538     }
 539 }
 540
 541 static Void local importClass(source,c)
 542 Module source;
 543 Class c; {
 544     Class clash=addClass(c);
 545     if (nonNull(clash) && clash!=c) {
 546         ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
 547                   textToStr(cclass(c).text),
 548                   textToStr(module(source).text),
 549                   textToStr(module(cclass(clash).mod).text)
 550         EEND;
 551     }
 552     if (nonNull(findTycon(cclass(c).text))) {
 553         ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
 554                   textToStr(cclass(c).text),
 555                   textToStr(module(source).text)
 556         EEND;
 557     }
 558 }
 559
 560 static List local checkExportTycon(exports,mt,spec,tc)
 561 List  exports;
 562 Text  mt;
 563 Cell  spec;
 564 Tycon tc; {
 565     if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
 566         return cons(pair(tc,DOTDOT), exports);
 567     } else {
 568         return cons(pair(tc,NIL), exports);
 569     }
 570 }
 571
 572 static List local checkExportClass(exports,mt,spec,cl)
 573 List  exports;
 574 Text  mt;
 575 Class cl;
 576 Cell  spec; {
 577     if (DOTDOT == spec) {
 578         return cons(pair(cl,DOTDOT), exports);
 579     } else {
 580         return cons(pair(cl,NIL), exports);
 581     }
 582 }
 583
 584 static List local checkExport(exports,mt,e) /* Process entry in export list*/
 585 List exports;
 586 Text mt;
 587 Cell e; {
 588     if (isIdent(e)) {
 589         Cell export = NIL;
 590         List origExports = exports;
 591         if (nonNull(export=findQualName(e))) {
 592             exports=cons(export,exports);
 593         }
 594         if (isQCon(e) && nonNull(export=findQualTycon(e))) {
 595             exports = checkExportTycon(exports,mt,NIL,export);
 596         }
 597         if (isQCon(e) && nonNull(export=findQualClass(e))) {
 598             /* opaque class export */
 599             exports = checkExportClass(exports,mt,NIL,export);
 600         }
 601         if (exports == origExports) {
 602             ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
 603                       identToStr(e),
 604                       textToStr(mt)
 605             EEND;
 606         }
 607         return exports;
 608     } else if (MODULEENT == fst(e)) {
 609         Module m = findModid(snd(e));
 610         /* ToDo: shouldn't allow export of module we didn't import */
 611         if (isNull(m)) {
 612             ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
 613                       textToStr(textOf(snd(e))),
 614                       textToStr(mt)
 615             EEND;
 616         }
 617         if (m == currentModule) {
 618             /* Exporting the current module exports local definitions */
 619             List xs;
 620             for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
 621                 if (cclass(hd(xs)).mod==m)
 622                     exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
 623             }
 624             for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
 625                 if (tycon(hd(xs)).mod==m)
 626                     exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
 627             }
 628             for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
 629                 if (name(hd(xs)).mod==m)
 630                     exports = cons(hd(xs),exports);
 631             }
 632         } else {
 633             /* Exporting other modules imports all things imported
 634              * unqualified from it.
 635              * ToDo: we reexport everything exported by a module -
 636              * whether we imported it or not.  This gives the wrong
 637              * result for "module M(module N) where import N(x)"
 638              */
 639             exports = dupOnto(module(m).exports,exports);
 640         }
 641         return exports;
 642     } else {
 643         Cell ident = fst(e); /* class name or type name */
 644         Cell parts = snd(e); /* members or constructors */
 645         Cell nm;
 646         if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
 647             switch (tycon(nm).what) {
 648             case SYNONYM:
 649                 if (DOTDOT!=parts) {
 650                     ERRMSG(0) "Explicit constructor list given for type synonym"
 651                               " \"%s\" in export list of module \"%s\"",
 652                               identToStr(ident),
 653                               textToStr(mt)
 654                     EEND;
 655                 }
 656                 return cons(pair(nm,DOTDOT),exports);
 657             case RESTRICTSYN:
 658                 ERRMSG(0) "Transparent export of restricted type synonym"
 659                           " \"%s\" in export list of module \"%s\"",
 660                           identToStr(ident),
 661                           textToStr(mt)
 662                 EEND;
 663                 return exports; /* Not reached */
 664             case NEWTYPE:
 665             case DATATYPE:
 666                 if (DOTDOT==parts) {
 667                     return cons(pair(nm,DOTDOT),exports);
 668                 } else {
 669                     exports = checkSubentities(exports,parts,tycon(nm).defn,
 670                                                "constructor of type",
 671                                                tycon(nm).text);
 672                     return cons(pair(nm,DOTDOT), exports);
 673                 }
 674             default:
 675                 internal("checkExport1");
 676             }
 677         } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
 678             if (DOTDOT == parts) {
 679                 return cons(pair(nm,DOTDOT),exports);
 680             } else {
 681                 exports = checkSubentities(exports,parts,cclass(nm).members,
 682                                            "member of class",cclass(nm).text);
 683                 return cons(pair(nm,DOTDOT), exports);
 684             }
 685         } else {
 686             ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
 687                       identToStr(ident),
 688                       textToStr(mt)
 689             EEND;
 690         }
 691     }
 692     return exports; /* NOTUSED */
 693 }
 694
 695 static List local checkExports ( List exports, Module thisModule )
 696 {
 697     Module m  = thisModule;
 698     Text   mt = module(m).text;
 699     List   es = NIL;
 700
 701     map1Accum(checkExport,es,mt,exports);
 702
 703 #if DEBUG_MODULES
 704     for(xs=es; nonNull(xs); xs=tl(xs)) {
 705         Printf(" %s", textToStr(textOfEntity(hd(xs))));
 706     }
 707 #endif
 708     return es;
 709 }
 710
 711
 712 /* --------------------------------------------------------------------------
 713  * Static analysis of type declarations:
 714  *
 715  * Type declarations come in two forms:
 716  * - data declarations - define new constructed data types
 717  * - type declarations - define new type synonyms
 718  *
 719  * A certain amount of work is carried out as the declarations are
 720  * read during parsing.  In particular, for each type constructor
 721  * definition encountered:
 722  * - check that there is no previous definition of constructor
 723  * - ensure type constructor not previously used as a class name
 724  * - make a new entry in the type constructor table
 725  * - record line number of declaration
 726  * - Build separate lists of newly defined constructors for later use.
 727  * ------------------------------------------------------------------------*/
 728
 729 Void tyconDefn(line,lhs,rhs,what)       /* process new type definition     */
 730 Int  line;                              /* definition line number          */
 731 Cell lhs;                               /* left hand side of definition    */
 732 Cell rhs;                               /* right hand side of definition   */
 733 Cell what; {                            /* SYNONYM/DATATYPE/etc...         */
 734     Text t = textOf(getHead(lhs));
 735
 736     if (nonNull(findTycon(t))) {
 737         ERRMSG(line) "Repeated definition of type constructor \"%s\"",
 738                      textToStr(t)
 739         EEND;
 740     }
 741     else if (nonNull(findClass(t))) {
 742         ERRMSG(line) "\"%s\" used as both class and type constructor",
 743                      textToStr(t)
 744         EEND;
 745     }
 746     else {
 747         Tycon nw        = newTycon(t);
 748         tyconDefns      = cons(nw,tyconDefns);
 749         tycon(nw).line  = line;
 750         tycon(nw).arity = argCount;
 751         tycon(nw).what  = what;
 752         if (what==RESTRICTSYN) {
 753             h98DoesntSupport(line,"restricted type synonyms");
 754             typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
 755             rhs         = fst(rhs);
 756         }
 757         tycon(nw).defn  = pair(lhs,rhs);
 758     }
 759 }
 760
 761 Void setTypeIns(bs)                     /* set local synonyms for given    */
 762 List bs; {                              /* binding group                   */
 763     List cvs = typeInDefns;
 764     for (; nonNull(cvs); cvs=tl(cvs)) {
 765         Tycon c  = fst(hd(cvs));
 766         List  vs = snd(hd(cvs));
 767         for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
 768             if (nonNull(findBinding(textOf(hd(vs)),bs))) {
 769                 tycon(c).what = SYNONYM;
 770                 break;
 771             }
 772         }
 773     }
 774 }
 775
 776 Void clearTypeIns() {                   /* clear list of local synonyms    */
 777     for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
 778         tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
 779 }
 780
 781 /* --------------------------------------------------------------------------
 782  * Further analysis of Type declarations:
 783  *
 784  * In order to allow the definition of mutually recursive families of
 785  * data types, the static analysis of the right hand sides of type
 786  * declarations cannot be performed until all of the type declarations
 787  * have been read.
 788  *
 789  * Once parsing is complete, we carry out the following:
 790  *
 791  * - check format of lhs, extracting list of bound vars and ensuring that
 792  *   there are no repeated variables and no Skolem variables.
 793  * - run dependency analysis on rhs to check that only bound type vars
 794  *   appear in type and that all constructors are defined.
 795  *   Replace type variables by offsets, constructors by Tycons.
 796  * - use list of dependents to sort into strongly connected components.
 797  * - ensure that there is not more than one synonym in each group.
 798  * - kind-check each group of type definitions.
 799  *
 800  * - check that there are no previous definitions for constructor
 801  *   functions in data type definitions.
 802  * - install synonym expansions and constructor definitions.
 803  * ------------------------------------------------------------------------*/
 804
 805 static List tcDeps = NIL;               /* list of dependent tycons/classes*/
 806
 807 static Void local checkTyconDefn(d)     /* validate type constructor defn  */
 808 Tycon d; {
 809     Cell lhs    = fst(tycon(d).defn);
 810     Cell rhs    = snd(tycon(d).defn);
 811     Int  line   = tycon(d).line;
 812     List tyvars = getArgs(lhs);
 813     List temp;
 814                                         /* check for repeated tyvars on lhs*/
 815     for (temp=tyvars; nonNull(temp); temp=tl(temp))
 816         if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
 817             ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
 818                          textToStr(textOf(hd(temp)))
 819             EEND;
 820         }
 821
 822     tcDeps = NIL;                       /* find dependents                 */
 823     switch (whatIs(tycon(d).what)) {
 824         case RESTRICTSYN :
 825         case SYNONYM     : rhs = depTypeExp(line,tyvars,rhs);
 826                            if (cellIsMember(d,tcDeps)) {
 827                                ERRMSG(line) "Recursive type synonym \"%s\"",
 828                                             textToStr(tycon(d).text)
 829                                EEND;
 830                            }
 831                            break;
 832
 833         case DATATYPE    :
 834         case NEWTYPE     : depConstrs(d,tyvars,rhs);
 835                            rhs = fst(rhs);
 836                            break;
 837
 838         default          : internal("checkTyconDefn");
 839                            break;
 840     }
 841
 842     tycon(d).defn = rhs;
 843     tycon(d).kind = tcDeps;
 844     tcDeps        = NIL;
 845 }
 846
 847 static Void local depConstrs(t,tyvars,cd)
 848 Tycon t;                                /* Define constructor functions and*/
 849 List  tyvars;                           /* do dependency analysis for data */
 850 Cell  cd; {                             /* definitions (w or w/o deriving) */
 851     Int  line      = tycon(t).line;
 852     List ctxt      = NIL;
 853     Int  conNo     = 1;
 854     Type lhs       = t;
 855     List cs        = fst(cd);
 856     List derivs    = snd(cd);
 857     List compTypes = NIL;
 858     List sels      = NIL;
 859     Int  i;
 860
 861     for (i=0; i<tycon(t).arity; ++i)    /* build representation for tycon  */
 862         lhs = ap(lhs,mkOffset(i));      /* applied to full comp. of args   */
 863
 864     if (isQualType(cs)) {               /* allow for possible context      */
 865         ctxt = fst(snd(cs));
 866         cs   = snd(snd(cs));
 867         map2Over(depPredExp,line,tyvars,ctxt);
 868         h98CheckCtxt(line,"context",TRUE,ctxt,NIL);
 869     }
 870
 871     if (nonNull(cs) && isNull(tl(cs)))  /* Single constructor datatype?    */
 872         conNo = 0;
 873
 874     for (; nonNull(cs); cs=tl(cs)) {    /* For each constructor function:  */
 875         Cell con   = hd(cs);
 876         List sig   = dupList(tyvars);
 877         List evs   = NIL;               /* locally quantified vars         */
 878         List lps   = NIL;               /* locally bound predicates        */
 879         List ctxt1 = ctxt;              /* constructor function context    */
 880         List scs   = NIL;               /* strict components               */
 881         List fs    = NONE;              /* selector names                  */
 882         Type type  = lhs;               /* constructor function type       */
 883         Int  arity = 0;                 /* arity of constructor function   */
 884         Int  nr2   = 0;                 /* Number of rank 2 args           */
 885         Name n;                         /* name for constructor function   */
 886
 887         if (whatIs(con)==POLYTYPE) {    /* Locally quantified vars         */
 888             evs = fst(snd(con));
 889             con = snd(snd(con));
 890             sig = checkQuantVars(line,evs,sig,con);
 891         }
 892
 893         if (isQualType(con)) {          /* Local predicates                */
 894             List us;
 895             lps     = fst(snd(con));
 896             for (us = typeVarsIn(lps,NIL,NIL,NIL); nonNull(us); us=tl(us))
 897                 if (!varIsMember(textOf(hd(us)),evs)) {
 898                     ERRMSG(line)
 899                         "Variable \"%s\" in constraint is not locally bound",
 900                         textToStr(textOf(hd(us)))
 901                     EEND;
 902                 }
 903             map2Over(depPredExp,line,sig,lps);
 904             con     = snd(snd(con));
 905             arity   = length(lps);
 906         }
 907
 908         if (whatIs(con)==LABC) {        /* Skeletize constr components     */
 909             Cell fls = snd(snd(con));   /* get field specifications        */
 910             con      = fst(snd(con));
 911             fs       = NIL;
 912             for (; nonNull(fls); fls=tl(fls)) { /* for each field spec:    */
 913                 List vs     = fst(hd(fls));
 914                 Type t      = snd(hd(fls));     /* - scrutinize type       */
 915                 Bool banged = whatIs(t)==BANG;
 916                 t           = depCompType(line,sig,(banged ? arg(t) : t));
 917                 while (nonNull(vs)) {           /* - add named components  */
 918                     Cell us = tl(vs);
 919                     tl(vs)  = fs;
 920                     fs      = vs;
 921                     vs      = us;
 922                     con     = ap(con,t);
 923                     arity++;
 924                     if (banged)
 925                         scs = cons(mkInt(arity),scs);
 926                 }
 927             }
 928             fs  = rev(fs);
 929             scs = rev(scs);             /* put strict comps in ascend ord  */
 930         }
 931         else {                          /* Non-labelled constructor        */
 932             Cell c = con;
 933             Int  compNo;
 934             for (; isAp(c); c=fun(c))
 935                 arity++;
 936             for (compNo=arity, c=con; isAp(c); c=fun(c)) {
 937                 Type t = arg(c);
 938                 if (whatIs(t)==BANG) {
 939                     scs = cons(mkInt(compNo),scs);
 940                     t   = arg(t);
 941                 }
 942                 compNo--;
 943                 arg(c) = depCompType(line,sig,t);
 944             }
 945         }
 946
 947         if (nonNull(ctxt1))             /* Extract relevant part of context*/
 948             ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
 949
 950         for (i=arity; isAp(con); i--) { /* Calculate type of constructor   */
 951             Type ty  = fun(con);
 952             Type cmp = arg(con);
 953             fun(con) = typeArrow;
 954             if (isPolyOrQualType(cmp)) {
 955                 if (nonNull(derivs)) {
 956                     ERRMSG(line) "Cannot derive instances for types" ETHEN
 957                     ERRTEXT      " with polymorphic or qualified components"
 958                     EEND;
 959                 }
 960                 if (nr2==0)
 961                     nr2 = i;
 962             }
 963             if (nonNull(derivs))        /* and build list of components    */
 964                 compTypes = cons(cmp,compTypes);
 965             type     = ap(con,type);
 966             con      = ty;
 967         }
 968
 969         if (nr2>0) {                    /* Add rank 2 annotation           */
 970             type = ap(RANK2,pair(mkInt(nr2-length(lps)),type));
 971         }
 972
 973         if (nonNull(evs)) {             /* Add existential annotation      */
 974             if (nonNull(derivs)) {
 975                 ERRMSG(line) "Cannot derive instances for types" ETHEN
 976                 ERRTEXT      " with existentially typed components"
 977                 EEND;
 978             }
 979             if (fs!=NONE) {
 980                 ERRMSG(line)
 981                    "Cannot use selectors with existentially typed components"
 982                 EEND;
 983             }
 984             type = ap(EXIST,pair(mkInt(length(evs)),type));
 985         }
 986
 987         if (nonNull(lps)) {             /* Add local preds part to type    */
 988             type = ap(CDICTS,pair(lps,type));
 989         }
 990
 991         if (nonNull(ctxt1)) {           /* Add context part to type        */
 992             type = ap(QUAL,pair(ctxt1,type));
 993         }
 994
 995         if (nonNull(sig)) {             /* Add quantifiers to type         */
 996             List ts1 = sig;
 997             for (; nonNull(ts1); ts1=tl(ts1)) {
 998                 hd(ts1) = NIL;
 999             }
1000             type = mkPolyType(sig,type);
1001         }
1002
1003         n = findName(textOf(con));      /* Allocate constructor fun name   */
1004         if (isNull(n)) {
1005             n = newName(textOf(con),NIL);
1006         } else if (name(n).defn!=PREDEFINED) {
1007             duplicateError(line,name(n).mod,name(n).text,
1008                            "constructor function");
1009         }
1010         name(n).arity  = arity;         /* Save constructor fun details    */
1011         name(n).line   = line;
1012         name(n).parent = t;
1013         name(n).number = cfunNo(conNo++);
1014         name(n).type   = type;
1015         if (tycon(t).what==NEWTYPE) {
1016             if (nonNull(lps)) {
1017                 ERRMSG(line)
1018                    "A newtype constructor cannot have class constraints"
1019                 EEND;
1020             }
1021             if (arity!=1) {
1022                 ERRMSG(line)
1023                    "A newtype constructor must have exactly one argument"
1024                 EEND;
1025             }
1026             if (nonNull(scs)) {
1027                 ERRMSG(line)
1028                    "Illegal strictess annotation for newtype constructor"
1029                 EEND;
1030             }
1031             name(n).defn = nameId;
1032         } else {
1033             implementCfun(n,scs);
1034         }
1035
1036         hd(cs) = n;
1037         if (fs!=NONE) {
1038             sels = addSels(line,n,fs,sels);
1039         }
1040     }
1041
1042     if (nonNull(sels)) {
1043         sels     = rev(sels);
1044         fst(cd)  = appendOnto(fst(cd),sels);
1045         selDefns = cons(sels,selDefns);
1046     }
1047
1048     if (nonNull(derivs)) {              /* Generate derived instances      */
1049         map3Proc(checkDerive,t,ctxt,compTypes,derivs);
1050     }
1051 }
1052
1053 Int userArity(c)                        /* Find arity for cfun, ignoring   */
1054 Name c; {                               /* CDICTS parameters               */
1055     Int  a = name(c).arity;
1056     Type t = name(c).type;
1057     Int  w;
1058     if (isPolyType(t)) {
1059         t = monotypeOf(t);
1060     }
1061     if ((w=whatIs(t))==QUAL) {
1062         w = whatIs(t=snd(snd(t)));
1063     }
1064     if (w==CDICTS) {
1065         a -= length(fst(snd(t)));
1066     }
1067     return a;
1068 }
1069
1070
1071 static List local addSels(line,c,fs,ss) /* Add fields to selector list     */
1072 Int  line;                              /* line number of constructor      */
1073 Name c;                                 /* corresponding constr function   */
1074 List fs;                                /* list of fields (varids)         */
1075 List ss; {                              /* list of existing selectors      */
1076     Int sn    = 1;
1077     cfunSfuns = cons(pair(c,fs),cfunSfuns);
1078     for (; nonNull(fs); fs=tl(fs), ++sn) {
1079         List ns = ss;
1080         Text t  = textOf(hd(fs));
1081
1082         if (nonNull(varIsMember(t,tl(fs)))) {
1083             ERRMSG(line) "Repeated field name \"%s\" for constructor \"%s\"",
1084                          textToStr(t), textToStr(name(c).text)
1085             EEND;
1086         }
1087
1088         while (nonNull(ns) && t!=name(hd(ns)).text) {
1089             ns = tl(ns);
1090         }
1091
1092         if (nonNull(ns)) {
1093             name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
1094         } else {
1095             Name n = findName(t);
1096             if (nonNull(n)) {
1097                 ERRMSG(line) "Repeated definition for selector \"%s\"",
1098                              textToStr(t)
1099                 EEND;
1100             }
1101             n              = newName(t,c);
1102             name(n).line   = line;
1103             name(n).number = SELNAME;
1104             name(n).defn   = singleton(pair(c,mkInt(sn)));
1105             ss             = cons(n,ss);
1106         }
1107     }
1108     return ss;
1109 }
1110
1111 static List local selectCtxt(ctxt,vs)   /* calculate subset of context     */
1112 List ctxt;
1113 List vs; {
1114     if (isNull(vs)) {
1115         return NIL;
1116     } else {
1117         List ps = NIL;
1118         for (; nonNull(ctxt); ctxt=tl(ctxt)) {
1119             List us = offsetTyvarsIn(hd(ctxt),NIL);
1120             for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us)) {
1121             }
1122             if (isNull(us)) {
1123                 ps = cons(hd(ctxt),ps);
1124             }
1125         }
1126         return rev(ps);
1127     }
1128 }
1129
1130 static Void local checkSynonyms(ts)     /* Check for mutually recursive    */
1131 List ts; {                              /* synonyms                        */
1132     List syns = NIL;
1133     for (; nonNull(ts); ts=tl(ts)) {    /* build list of all synonyms      */
1134         Tycon t = hd(ts);
1135         switch (whatIs(tycon(t).what)) {
1136             case SYNONYM     :
1137             case RESTRICTSYN : syns = cons(t,syns);
1138                                break;
1139         }
1140     }
1141     while (nonNull(syns)) {             /* then visit each synonym         */
1142         syns = visitSyn(NIL,hd(syns),syns);
1143     }
1144 }
1145
1146 static List local visitSyn(path,t,syns) /* visit synonym definition to look*/
1147 List  path;                             /* for cycles                      */
1148 Tycon t;
1149 List  syns; {
1150     if (cellIsMember(t,path)) {         /* every elt in path depends on t  */
1151         ERRMSG(tycon(t).line)
1152             "Type synonyms \"%s\" and \"%s\" are mutually recursive",
1153             textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
1154         EEND;
1155     } else {
1156         List ds    = tycon(t).kind;
1157         List path1 = NIL;
1158         for (; nonNull(ds); ds=tl(ds)) {
1159             if (cellIsMember(hd(ds),syns)) {
1160                 if (isNull(path1)) {
1161                     path1 = cons(t,path);
1162                 }
1163                 syns = visitSyn(path1,hd(ds),syns);
1164             }
1165         }
1166     }
1167     tycon(t).defn = fullExpand(tycon(t).defn);
1168     return removeCell(t,syns);
1169 }
1170
1171 /* --------------------------------------------------------------------------
1172  * Expanding out all type synonyms in a type expression:
1173  * ------------------------------------------------------------------------*/
1174
1175 Type fullExpand(t)                      /* find full expansion of type exp */
1176 Type t; {                               /* assuming that all relevant      */
1177     Cell h = t;                         /* synonym defns of lower rank have*/
1178     Int  n = 0;                         /* already been fully expanded     */
1179     List args;
1180     for (args=NIL; isAp(h); h=fun(h), n++) {
1181         args = cons(fullExpand(arg(h)),args);
1182     }
1183     t = applyToArgs(h,args);
1184     if (isSynonym(h) && n>=tycon(h).arity) {
1185         if (n==tycon(h).arity) {
1186             t = instantiateSyn(tycon(h).defn,t);
1187         } else {
1188             Type p = t;
1189             while (--n > tycon(h).arity) {
1190                 p = fun(p);
1191             }
1192             fun(p) = instantiateSyn(tycon(h).defn,fun(p));
1193         }
1194     }
1195     return t;
1196 }
1197
1198 static Type local instantiateSyn(t,env) /* instantiate type according using*/
1199 Type t;                                 /* env to determine appropriate    */
1200 Type env; {                             /* values for OFFSET type vars     */
1201     switch (whatIs(t)) {
1202         case AP      : return ap(instantiateSyn(fun(t),env),
1203                                  instantiateSyn(arg(t),env));
1204
1205         case OFFSET  : return nthArg(offsetOf(t),env);
1206
1207         default      : return t;
1208     }
1209 }
1210
1211 /* --------------------------------------------------------------------------
1212  * Static analysis of class declarations:
1213  *
1214  * Performed in a similar manner to that used for type declarations.
1215  *
1216  * The first part of the static analysis is performed as the declarations
1217  * are read during parsing.  The parser ensures that:
1218  * - the class header and all superclass predicates are of the form
1219  *   ``Class var''
1220  *
1221  * The classDefn() function:
1222  * - ensures that there is no previous definition for class
1223  * - checks that class name has not previously been used as a type constr.
1224  * - make new entry in class table
1225  * - record line number of declaration
1226  * - build list of classes defined in current script for use in later
1227  *   stages of static analysis.
1228  * ------------------------------------------------------------------------*/
1229
1230 Void classDefn(line,head,ms,fds)       /* process new class definition     */
1231 Int  line;                             /* definition line number           */
1232 Cell head;                             /* class header :: ([Supers],Class) */
1233 List ms;                               /* class definition body            */
1234 List fds; {                            /* functional dependencies          */
1235     Text ct    = textOf(getHead(snd(head)));
1236     Int  arity = argCount;
1237
1238     if (nonNull(findClass(ct))) {
1239         ERRMSG(line) "Repeated definition of class \"%s\"",
1240                      textToStr(ct)
1241         EEND;
1242     } else if (nonNull(findTycon(ct))) {
1243         ERRMSG(line) "\"%s\" used as both class and type constructor",
1244                      textToStr(ct)
1245         EEND;
1246     } else {
1247         Class nw           = newClass(ct);
1248         cclass(nw).line    = line;
1249         cclass(nw).arity   = arity;
1250         cclass(nw).head    = snd(head);
1251         cclass(nw).supers  = fst(head);
1252         cclass(nw).members = ms;
1253         cclass(nw).level   = 0;
1254         cclass(nw).fds     = fds;
1255         cclass(nw).xfds    = NIL;
1256         classDefns         = cons(nw,classDefns);
1257         if (arity!=1)
1258             h98DoesntSupport(line,"multiple parameter classes");
1259     }
1260 }
1261
1262 /* --------------------------------------------------------------------------
1263  * Further analysis of class declarations:
1264  *
1265  * Full static analysis of class definitions must be postponed until the
1266  * complete script has been read and all static analysis on type definitions
1267  * has been completed.
1268  *
1269  * Once this has been achieved, we carry out the following checks on each
1270  * class definition:
1271  * - check that variables in header are distinct
1272  * - replace head by skeleton
1273  * - check superclass declarations, replace by skeletons
1274  * - split body of class into members and declarations
1275  * - make new name entry for each member function
1276  * - record member function number (eventually an offset into dictionary!)
1277  * - no member function has a previous definition ...
1278  * - no member function is mentioned more than once in the list of members
1279  * - each member function type is valid, replace vars by offsets
1280  * - qualify each member function type by class header
1281  * - only bindings for members appear in defaults
1282  * - only function bindings appear in defaults
1283  * - check that extended class hierarchy does not contain any cycles
1284  * ------------------------------------------------------------------------*/
1285
1286 static Void local checkClassDefn(c)    /* validate class definition        */
1287 Class c; {
1288     List tyvars = NIL;
1289     Int  args   = cclass(c).arity - 1;
1290     Cell temp   = cclass(c).head;
1291     List fs     = NIL;
1292     List ss     = NIL;
1293
1294     for (; isAp(temp); temp=fun(temp)) {
1295         if (!isVar(arg(temp))) {
1296             ERRMSG(cclass(c).line) "Type variable required in class head"
1297             EEND;
1298         }
1299         if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
1300             ERRMSG(cclass(c).line)
1301                 "Repeated type variable \"%s\" in class head",
1302                 textToStr(textOf(arg(temp)))
1303             EEND;
1304         }
1305         tyvars = cons(arg(temp),tyvars);
1306     }
1307
1308     for (fs=cclass(c).fds; nonNull(fs); fs=tl(fs)) {
1309         Pair fd = hd(fs);
1310         List vs = snd(fd);
1311
1312         /* Check for trivial dependency
1313          */
1314         if (isNull(vs)) {
1315             ERRMSG(cclass(c).line) "Functional dependency is trivial"
1316             EEND;
1317         }
1318
1319         /* Check for duplicated vars on right hand side, and for vars on
1320          * right that also appear on the left:
1321          */
1322         for (vs=snd(fd); nonNull(vs); vs=tl(vs)) {
1323             if (varIsMember(textOf(hd(vs)),fst(fd))) {
1324                 ERRMSG(cclass(c).line)
1325                     "Trivial dependency for variable \"%s\"",
1326                     textToStr(textOf(hd(vs)))
1327                 EEND;
1328             }
1329             if (varIsMember(textOf(hd(vs)),tl(vs))) {
1330                 ERRMSG(cclass(c).line)
1331                     "Repeated variable \"%s\" in functional dependency",
1332                     textToStr(textOf(hd(vs)))
1333                 EEND;
1334             }
1335             hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
1336         }
1337
1338         /* Check for duplicated vars on left hand side:
1339          */
1340         for (vs=fst(fd); nonNull(vs); vs=tl(vs)) {
1341             if (varIsMember(textOf(hd(vs)),tl(vs))) {
1342                 ERRMSG(cclass(c).line)
1343                     "Repeated variable \"%s\" in functional dependency",
1344                     textToStr(textOf(hd(vs)))
1345                 EEND;
1346             }
1347             hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
1348         }
1349     }
1350
1351     if (cclass(c).arity==0) {
1352         cclass(c).head = c;
1353     } else {
1354         Int args = cclass(c).arity - 1;
1355         for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
1356             arg(temp) = mkOffset(args);
1357         }
1358         arg(temp) = mkOffset(0);
1359         fun(temp) = c;
1360     }
1361
1362     tcDeps              = NIL;          /* find dependents                 */
1363     map2Over(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
1364     h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL);
1365     cclass(c).numSupers = length(cclass(c).supers);
1366     cclass(c).defaults  = extractBindings(cclass(c).members);   /* defaults*/
1367     ss                  = extractSigdecls(cclass(c).members);
1368     fs                  = extractFixdecls(cclass(c).members);
1369     cclass(c).members   = pair(ss,fs);
1370     map2Proc(checkMems,c,tyvars,ss);
1371
1372     cclass(c).kinds     = tcDeps;
1373     tcDeps              = NIL;
1374 }
1375
1376
1377 /* --------------------------------------------------------------------------
1378  * Functional dependencies are inherited from superclasses.
1379  * For example, if I've got the following classes:
1380  *
1381  * class C a b | a -> b
1382  * class C [b] a => D a b
1383  *
1384  * then C will have the dependency ([a], [b]) as expected, and D will inherit
1385  * the dependency ([b], [a]) from C.
1386  * When doing pairwise improvement, we have to consider not just improving
1387  * when we see a pair of Cs or a pair of Ds in the context, but when we've
1388  * got a C and a D as well.  In this case, we only improve when the
1389  * predicate in question matches the type skeleton in the relevant superclass
1390  * constraint.  E.g., we improve the pair (C [Int] a, D b Int) (unifying
1391  * a and b), but we don't improve the pair (C Int a, D b Int).
1392  * To implement functional dependency inheritance, we calculate
1393  * the closure of all functional dependencies, and store the result
1394  * in an additional field `xfds' (extended functional dependencies).
1395  * The `xfds' field is a list of functional dependency lists, annotated
1396  * with a list of predicate skeletons constraining when improvement can
1397  * happen against this dependency list.  For example, the xfds field
1398  * for C above would be:
1399  *     [([C a b], [([a], [b])])]
1400  * and the xfds field for D would be:
1401  *     [([C [b] a, D a b], [([b], [a])])]
1402  * Self-improvement (of a C with a C, or a D with a D) is treated as a
1403  * special case of an inherited dependency.
1404  * ------------------------------------------------------------------------*/
1405 static List local inheritFundeps ( Class c, Cell pi, Int o )
1406 {
1407     Int alpha = newKindedVars(cclass(c).kinds);
1408     List scs = cclass(c).supers;
1409     List xfds = NIL;
1410     Cell this = NIL;
1411     /* better not fail ;-) */
1412     if (!matchPred(pi,o,cclass(c).head,alpha))
1413         internal("inheritFundeps - predicate failed to match it's own head!");
1414     this = copyPred(pi,o);
1415     for (; nonNull(scs); scs=tl(scs)) {
1416         Class s = getHead(hd(scs));
1417         if (isClass(s)) {
1418             List sfds = inheritFundeps(s,hd(scs),alpha);
1419             for (; nonNull(sfds); sfds=tl(sfds)) {
1420                 Cell h = hd(sfds);
1421                 xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds);
1422             }
1423         }
1424     }
1425     if (nonNull(cclass(c).fds)) {
1426         List fds = NIL, fs = cclass(c).fds;
1427         for (; nonNull(fs); fs=tl(fs)) {
1428             fds = cons(pair(otvars(this,fst(hd(fs))),
1429                             otvars(this,snd(hd(fs)))),fds);
1430         }
1431         xfds = cons(pair(cons(this,NIL),fds),xfds);
1432     }
1433     return xfds;
1434 }
1435
1436 static Void local extendFundeps ( Class c )
1437 {
1438     Int alpha;
1439     emptySubstitution();
1440     alpha = newKindedVars(cclass(c).kinds);
1441     cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha);
1442
1443     /* we can now check for ambiguity */
1444     map1Proc(checkMems2,c,fst(cclass(c).members));
1445 }
1446
1447
1448 static Cell local depPredExp(line,tyvars,pred)
1449 Int  line;
1450 List tyvars;
1451 Cell pred; {
1452     Int  args = 0;
1453     Cell prev = NIL;
1454     Cell h    = pred;
1455     for (; isAp(h); args++) {
1456         arg(h) = depTypeExp(line,tyvars,arg(h));
1457         prev   = h;
1458         h      = fun(h);
1459     }
1460
1461     if (args==0) {
1462         h98DoesntSupport(line,"tag classes");
1463     } else if (args!=1) {
1464         h98DoesntSupport(line,"multiple parameter classes");
1465     }
1466
1467     if (isQCon(h)) {                    /* standard class constraint       */
1468         Class c = findQualClass(h);
1469         if (isNull(c)) {
1470             ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
1471             EEND;
1472         }
1473         if (isNull(prev)) {
1474             pred = c;
1475         } else {
1476             fun(prev) = c;
1477         }
1478         if (args!=cclass(c).arity) {
1479             ERRMSG(line) "Wrong number of arguments for class \"%s\"",
1480                         textToStr(cclass(c).text)
1481             EEND;
1482         }
1483         if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) {
1484             tcDeps = cons(c,tcDeps);
1485         }
1486     }
1487 #if TREX
1488     else if (isExt(h)) {                /* Lacks predicate                 */
1489         if (args!=1) {                  /* parser shouldn't let this happen*/
1490             ERRMSG(line) "Wrong number of arguments for lacks predicate"
1491             EEND;
1492         }
1493     }
1494 #endif
1495     else
1496 #if IPARAM
1497          if (whatIs(h) != IPCELL)
1498 #endif
1499     {
1500         internal("depPredExp");
1501     }
1502     return pred;
1503 }
1504
1505 static Void local checkMems(c,tyvars,m) /* check member function details   */
1506 Class c;
1507 List  tyvars;
1508 Cell  m; {
1509     Int  line = intOf(fst3(m));
1510     List vs   = snd3(m);
1511     Type t    = thd3(m);
1512     List sig  = NIL;
1513     List tvs  = NIL;
1514     List xtvs = NIL;
1515
1516     if (isPolyType(t)) {
1517         xtvs = fst(snd(t));
1518         t    = monotypeOf(t);
1519     }
1520
1521
1522     tyvars    = typeVarsIn(t,NIL,xtvs,tyvars);
1523                                         /* Look for extra type vars.       */
1524     checkOptQuantVars(line,xtvs,tyvars);
1525
1526     if (isQualType(t)) {                /* Overloaded member signatures?   */
1527         map2Over(depPredExp,line,tyvars,fst(snd(t)));
1528     } else {
1529         t = ap(QUAL,pair(NIL,t));
1530     }
1531
1532     fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate   */
1533     snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
1534
1535     for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify                */
1536         sig = ap(NIL,sig);
1537     }
1538     if (nonNull(sig)) {
1539         t = mkPolyType(sig,t);
1540     }
1541     thd3(m) = t;                                /* Save type               */
1542     take(cclass(c).arity,tyvars);               /* Delete extra type vars  */
1543
1544     if (isAmbiguous(t)) {
1545         ambigError(line,"class declaration",hd(vs),t);
1546     }
1547     h98CheckType(line,"member type",hd(vs),t);
1548 }
1549
1550 static Void local checkMems2(c,m) /* check member function details   */
1551 Class c;
1552 Cell  m; {
1553     Int  line = intOf(fst3(m));
1554     List vs   = snd3(m);
1555     Type t    = thd3(m);
1556 }
1557
1558 static Void local addMembers(c)         /* Add definitions of member funs  */
1559 Class c; {                              /* and other parts of class struct.*/
1560     List ms  = fst(cclass(c).members);
1561     List fs  = snd(cclass(c).members);
1562     List ns  = NIL;                     /* List of names                   */
1563     Int  mno;                           /* Member function number          */
1564
1565     for (mno=0; mno<cclass(c).numSupers; mno++) {
1566         ns = cons(newDSel(c,mno),ns);
1567     }
1568     cclass(c).dsels = rev(ns);          /* Save dictionary selectors       */
1569
1570     for (mno=1, ns=NIL; nonNull(ms); ms=tl(ms)) {
1571         Int  line = intOf(fst3(hd(ms)));
1572         List vs   = rev(snd3(hd(ms)));
1573         Type t    = thd3(hd(ms));
1574         for (; nonNull(vs); vs=tl(vs)) {
1575             ns = cons(newMember(line,mno++,hd(vs),t,c),ns);
1576         }
1577     }
1578     cclass(c).members    = rev(ns);     /* Save list of members            */
1579     cclass(c).numMembers = length(cclass(c).members);
1580
1581     for (; nonNull(fs); fs=tl(fs)) {    /* fixity declarations             */
1582         Int    line = intOf(fst3(hd(fs)));
1583         List   ops  = snd3(hd(fs));
1584         Syntax s    = intOf(thd3(hd(fs)));
1585         for (; nonNull(ops); ops=tl(ops)) {
1586             Name n = nameIsMember(textOf(hd(ops)),cclass(c).members);
1587             if (isNull(n)) {
1588                 missFixity(line,textOf(hd(ops)));
1589             } else if (name(n).syntax!=NO_SYNTAX) {
1590                 dupFixity(line,textOf(hd(ops)));
1591             }
1592             name(n).syntax = s;
1593         }
1594     }
1595
1596 /*  Not actually needed just yet; for the time being, dictionary code will
1597     not be passed through the type checker.
1598
1599     cclass(c).dtycon    = addPrimTycon(generateText("Dict.%s",c),
1600                                        NIL,
1601                                        cclass(c).arity,
1602                                        DATATYPE,
1603                                        NIL);
1604 */
1605
1606     mno                  = cclass(c).numSupers + cclass(c).numMembers;
1607     /* cclass(c).dcon       = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */
1608     cclass(c).dcon       = addPrimCfun(generateText(":D%s",c),mno,0,NIL);
1609     /* implementCfun(cclass(c).dcon,NIL);
1610        Don't manufacture a wrapper fn for dictionary constructors.
1611        Applications of dictionary constructors are always saturated,
1612        and translate.c:stgExpr() special-cases saturated constructor apps.
1613     */
1614
1615     if (mno==1) {                       /* Single entry dicts use newtype  */
1616         name(cclass(c).dcon).defn = nameId;
1617         if (nonNull(cclass(c).members)) {
1618             name(hd(cclass(c).members)).number = mfunNo(0);
1619         }
1620     }
1621     cclass(c).defaults   = classBindings("class",c,cclass(c).defaults);
1622 }
1623
1624 static Name local newMember(l,no,v,t,parent)
1625 Int   l;                                /* Make definition for member fn   */
1626 Int   no;
1627 Cell  v;
1628 Type  t;
1629 Class parent; {
1630     Name m = findName(textOf(v));
1631
1632     if (isNull(m)) {
1633         m = newName(textOf(v),parent);
1634     } else if (name(m).defn!=PREDEFINED) {
1635         ERRMSG(l) "Repeated definition for member function \"%s\"",
1636                   textToStr(name(m).text)
1637         EEND;
1638     }
1639
1640     name(m).line     = l;
1641     name(m).arity    = 1;
1642     name(m).number   = mfunNo(no);
1643     name(m).type     = t;
1644     return m;
1645 }
1646
1647 Name newDSel(c,no)                      /* Make definition for dict selectr*/
1648 Class c;
1649 Int   no; {
1650     Name s;
1651     char buf[16];
1652
1653     /* sprintf(buf,"sc%d.%s",no,"%s"); */
1654     sprintf(buf,"$p%d%s",no+1,"%s");
1655     s                = newName(generateText(buf,c),c);
1656     name(s).line     = cclass(c).line;
1657     name(s).arity    = 1;
1658     name(s).number   = DFUNNAME;
1659     return s;
1660 }
1661
1662 #define MAX_GEN  128
1663
1664 static Text local generateText(sk,c)    /* We need to generate names for   */
1665 String sk;                              /* certain objects corresponding   */
1666 Class  c; {                             /* to each class.                  */
1667     String cname = textToStr(cclass(c).text);
1668     char buffer[MAX_GEN+1];
1669
1670     if ((strlen(sk)+strlen(cname))>=MAX_GEN) {
1671         ERRMSG(0) "Please use a shorter name for class \"%s\"", cname
1672         EEND;
1673     }
1674     sprintf(buffer,sk,cname);
1675     return findText(buffer);
1676 }
1677
1678        Int visitClass(c)                /* visit class defn to check that  */
1679 Class c; {                              /* class hierarchy is acyclic      */
1680 #if TREX
1681     if (isExt(c)) {                     /* special case for lacks preds    */
1682         return 0;
1683     }
1684 #endif
1685     if (cclass(c).level < 0) {          /* already visiting this class?    */
1686         ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
1687                                textToStr(cclass(c).text)
1688         EEND;
1689     } else if (cclass(c).level == 0) {  /* visiting class for first time   */
1690         List scs = cclass(c).supers;
1691         Int  lev = 0;
1692         cclass(c).level = (-1);
1693         for (; nonNull(scs); scs=tl(scs)) {
1694             Int l = visitClass(getHead(hd(scs)));
1695             if (l>lev) lev=l;
1696         }
1697         cclass(c).level = 1+lev;        /* level = 1 + max level of supers */
1698     }
1699     return cclass(c).level;
1700 }
1701
1702 /* --------------------------------------------------------------------------
1703  * Process class and instance declaration binding groups:
1704  * ------------------------------------------------------------------------*/
1705
1706 static List local classBindings(where,c,bs)
1707 String where;                           /* Check validity of bindings bs   */
1708 Class  c;                               /* for class c (or an inst of c)   */
1709 List   bs; {                            /* sort into approp. member order  */
1710     List nbs = NIL;
1711
1712     for (; nonNull(bs); bs=tl(bs)) {
1713         Cell b    = hd(bs);
1714         Cell body = snd(snd(b));
1715         Name mnm;
1716
1717         if (!isVar(fst(b))) {           /* Only allow function bindings    */
1718             ERRMSG(rhsLine(snd(body)))
1719                 "Pattern binding illegal in %s declaration", where
1720             EEND;
1721         }
1722
1723         if (isNull(mnm=memberName(c,textOf(fst(b))))) {
1724             ERRMSG(rhsLine(snd(hd(body))))
1725                 "No member \"%s\" in class \"%s\"",
1726                 textToStr(textOf(fst(b))), textToStr(cclass(c).text)
1727             EEND;
1728         }
1729         snd(b) = body;
1730         nbs    = numInsert(mfunOf(mnm)-1,b,nbs);
1731     }
1732     return nbs;
1733 }
1734
1735 static Name local memberName(c,t)       /* return name of member function  */
1736 Class c;                                /* with name t in class c          */
1737 Text  t; {                              /* return NIL if not a member      */
1738     List ms = cclass(c).members;
1739     for (; nonNull(ms); ms=tl(ms)) {
1740         if (t==name(hd(ms)).text) {
1741             return hd(ms);
1742         }
1743     }
1744     return NIL;
1745 }
1746
1747 static List local numInsert(n,x,xs)    /* insert x at nth position in xs,  */
1748 Int  n;                                /* filling gaps with NIL            */
1749 Cell x;
1750 List xs; {
1751     List start = isNull(xs) ? cons(NIL,NIL) : xs;
1752
1753     for (xs=start; 0<n--; xs=tl(xs)) {
1754         if (isNull(tl(xs))) {
1755             tl(xs) = cons(NIL,NIL);
1756         }
1757     }
1758     hd(xs) = x;
1759     return start;
1760 }
1761
1762 /* --------------------------------------------------------------------------
1763  * Calculate set of variables appearing in a given type expression (possibly
1764  * qualified) as a list of distinct values.  The order in which variables
1765  * appear in the list is the same as the order in which those variables
1766  * occur in the type expression when read from left to right.
1767  * ------------------------------------------------------------------------*/
1768
1769 List local typeVarsIn(ty,us,ws,vs)      /*Calculate list of type variables*/
1770 Cell ty;                                /* used in type expression, reading*/
1771 List us;                                /* from left to right ignoring any */
1772 List ws;                                /* listed in us.                   */
1773 List vs; {                              /* ws = explicitly quantified vars */
1774     if (isNull(ty)) return vs;
1775     switch (whatIs(ty)) {
1776         case DICTAP    : return typeVarsIn(snd(snd(ty)),us,ws,vs);
1777         case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs);
1778
1779         case AP        : return typeVarsIn(snd(ty),us,ws,
1780                                            typeVarsIn(fst(ty),us,ws,vs));
1781
1782         case VARIDCELL :
1783         case VAROPCELL : if ((nonNull(findBtyvs(textOf(ty)))
1784                               && !varIsMember(textOf(ty),ws))
1785                              || varIsMember(textOf(ty),us)) {
1786                              return vs;
1787                          } else {
1788                              return maybeAppendVar(ty,vs);
1789                          }
1790
1791         case POLYTYPE  : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs);
1792
1793         case QUAL      : {   vs = typeVarsIn(fst(snd(ty)),us,ws,vs);
1794                              return typeVarsIn(snd(snd(ty)),us,ws,vs);
1795                          }
1796
1797         case BANG      : return typeVarsIn(snd(ty),us,ws,vs);
1798
1799         case LABC      : {   List fs = snd(snd(ty));
1800                              for (; nonNull(fs); fs=tl(fs)) {
1801                                 vs = typeVarsIn(snd(hd(fs)),us,ws,vs);
1802                              }
1803                              return vs;
1804                          }
1805         case TUPLE:
1806         case TYCON:
1807         case CONIDCELL:
1808         case QUALIDENT: return vs;
1809
1810         default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn");
1811     }
1812     assert(0);
1813 }
1814
1815 static List local maybeAppendVar(v,vs) /* append variable to list if not   */
1816 Cell v;                                /* already included                 */
1817 List vs; {
1818     Text t = textOf(v);
1819     List p = NIL;
1820     List c = vs;
1821
1822     while (nonNull(c)) {
1823         if (textOf(hd(c))==t) {
1824             return vs;
1825         }
1826         p = c;
1827         c = tl(c);
1828     }
1829
1830     if (nonNull(p)) {
1831         tl(p) = cons(v,NIL);
1832     } else {
1833         vs    = cons(v,NIL);
1834     }
1835
1836     return vs;
1837 }
1838
1839 /* --------------------------------------------------------------------------
1840  * Static analysis for type expressions is required to:
1841  *   - ensure that each type constructor or class used has been defined.
1842  *   - replace type variables by offsets, constructor names by Tycons.
1843  *   - ensure that the type is well-kinded.
1844  * ------------------------------------------------------------------------*/
1845
1846 static Type local checkSigType(line,where,e,type)
1847 Int    line;                            /* Check validity of type expr in  */
1848 String where;                           /* explicit type signature         */
1849 Cell   e;
1850 Type   type; {
1851     List tvs  = NIL;
1852     List sunk = NIL;
1853     List xtvs = NIL;
1854
1855     if (isPolyType(type)) {
1856         xtvs = fst(snd(type));
1857         type = monotypeOf(type);
1858     }
1859     tvs  = typeVarsIn(type,NIL,xtvs,NIL);
1860     sunk = unkindTypes;
1861     checkOptQuantVars(line,xtvs,tvs);
1862
1863     if (isQualType(type)) {
1864         map2Over(depPredExp,line,tvs,fst(snd(type)));
1865         snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
1866
1867         if (isAmbiguous(type)) {
1868             ambigError(line,where,e,type);
1869         }
1870     } else {
1871         type = depTopType(line,tvs,type);
1872     }
1873
1874     if (nonNull(tvs)) {
1875         if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) {
1876             ERRMSG(line) "Too many type variables in %s\n", where
1877             EEND;
1878         } else {
1879             List ts = tvs;
1880             for (; nonNull(ts); ts=tl(ts)) {
1881                 hd(ts) = NIL;
1882             }
1883             type    = mkPolyType(tvs,type);
1884         }
1885     }
1886
1887     unkindTypes = NIL;
1888     kindType(line,"type expression",type);
1889     fixKinds();
1890     unkindTypes = sunk;
1891
1892     h98CheckType(line,where,e,type);
1893     return type;
1894 }
1895
1896 static Void local checkOptQuantVars(line,xtvs,tvs)
1897 Int  line;
1898 List xtvs;                              /* Explicitly quantified vars      */
1899 List tvs; {                             /* Implicitly quantified vars      */
1900     if (nonNull(xtvs)) {
1901         List vs = tvs;
1902         for (; nonNull(vs); vs=tl(vs)) {
1903             if (!varIsMember(textOf(hd(vs)),xtvs)) {
1904                 ERRMSG(line) "Quantifier does not mention type variable \"%s\"",
1905                              textToStr(textOf(hd(vs)))
1906                 EEND;
1907             }
1908         }
1909         for (vs=xtvs; nonNull(vs); vs=tl(vs)) {
1910             if (!varIsMember(textOf(hd(vs)),tvs)) {
1911                 ERRMSG(line) "Quantified type variable \"%s\" is not used",
1912                              textToStr(textOf(hd(vs)))
1913                 EEND;
1914             }
1915             if (varIsMember(textOf(hd(vs)),tl(vs))) {
1916                 ERRMSG(line) "Quantified type variable \"%s\" is repeated",
1917                              textToStr(textOf(hd(vs)))
1918                 EEND;
1919             }
1920         }
1921     }
1922 }
1923
1924 static Type local depTopType(l,tvs,t)   /* Check top-level of type sig     */
1925 Int  l;
1926 List tvs;
1927 Type t; {
1928     Type prev = NIL;
1929     Type t1   = t;
1930     Int  nr2  = 0;
1931     Int  i    = 1;
1932     for (; getHead(t1)==typeArrow && argCount==2; ++i) {
1933         arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
1934         if (isPolyOrQualType(arg(fun(t1)))) {
1935             nr2 = i;
1936         }
1937         prev = t1;
1938         t1   = arg(t1);
1939     }
1940     if (nonNull(prev)) {
1941         arg(prev) = depTypeExp(l,tvs,t1);
1942     } else {
1943         t = depTypeExp(l,tvs,t1);
1944     }
1945     if (nr2>0) {
1946         t = ap(RANK2,pair(mkInt(nr2),t));
1947     }
1948     return t;
1949 }
1950
1951 static Type local depCompType(l,tvs,t)  /* Check component type for constr */
1952 Int  l;
1953 List tvs;
1954 Type t; {
1955   Int  ntvs = length(tvs);
1956   List nfr  = NIL;
1957   if (isPolyType(t)) {
1958     List vs  = fst(snd(t));
1959     t        = monotypeOf(t);
1960     tvs      = checkQuantVars(l,vs,tvs,t);
1961     nfr      = replicate(length(vs),NIL);
1962   }
1963   if (isQualType(t)) {
1964     map2Over(depPredExp,l,tvs,fst(snd(t)));
1965     snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
1966     if (isAmbiguous(t)) {
1967       ambigError(l,"type component",NIL,t);
1968     }
1969   } else {
1970     t = depTypeExp(l,tvs,t);
1971   }
1972   if (isNull(nfr)) {
1973     return t;
1974   }
1975   take(ntvs,tvs);
1976   return mkPolyType(nfr,t);
1977 }
1978
1979 static Type local depTypeExp(line,tyvars,type)
1980 Int  line;
1981 List tyvars;
1982 Type type; {
1983     switch (whatIs(type)) {
1984         case AP         : fst(type) = depTypeExp(line,tyvars,fst(type));
1985                           snd(type) = depTypeExp(line,tyvars,snd(type));
1986                           break;
1987
1988         case VARIDCELL  : return depTypeVar(line,tyvars,textOf(type));
1989
1990         case QUALIDENT  : if (isQVar(type)) {
1991                               ERRMSG(line) "Qualified type variables not allowed"
1992                               EEND;
1993                           }
1994                           /* deliberate fall through */
1995         case CONIDCELL  : {   Tycon tc = findQualTycon(type);
1996                               if (isNull(tc)) {
1997                                   ERRMSG(line)
1998                                       "Undefined type constructor \"%s\"",
1999                                       identToStr(type)
2000                                   EEND;
2001                               }
2002                               if (cellIsMember(tc,tyconDefns) &&
2003                                   !cellIsMember(tc,tcDeps)) {
2004                                   tcDeps = cons(tc,tcDeps);
2005                               }
2006                               return tc;
2007                           }
2008
2009 #if TREX
2010         case EXT        : h98DoesntSupport(line,"extensible records");
2011 #endif
2012         case TYCON      :
2013         case TUPLE      : break;
2014
2015         default         : internal("depTypeExp");
2016     }
2017     return type;
2018 }
2019
2020 static Type local depTypeVar(line,tyvars,tv)
2021 Int  line;
2022 List tyvars;
2023 Text tv; {
2024     Int offset = 0;
2025     Int found  = (-1);
2026
2027     for (; nonNull(tyvars); offset++) {
2028         if (tv==textOf(hd(tyvars))) {
2029             found = offset;
2030         }
2031         tyvars = tl(tyvars);
2032     }
2033     if (found<0) {
2034         Cell vt = findBtyvs(tv);
2035         if (nonNull(vt)) {
2036             return fst(vt);
2037         }
2038         ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
2039         EEND;
2040     }
2041     return mkOffset(found);
2042 }
2043
2044 static List local checkQuantVars(line,vs,tvs,body)
2045 Int  line;
2046 List vs;                                /* variables to quantify over      */
2047 List tvs;                               /* variables already in scope      */
2048 Cell body; {                            /* type/constr for scope of vars   */
2049     if (nonNull(vs)) {
2050         List bvs = typeVarsIn(body,NIL,NIL,NIL);
2051         List us  = vs;
2052         for (; nonNull(us); us=tl(us)) {
2053             Text u = textOf(hd(us));
2054             if (varIsMember(u,tl(us))) {
2055                 ERRMSG(line) "Duplicated quantified variable %s",
2056                              textToStr(u)
2057                 EEND;
2058             }
2059 #if 0
2060             if (varIsMember(u,tvs)) {
2061                 ERRMSG(line) "Local quantifier for %s hides an outer use",
2062                              textToStr(u)
2063                 EEND;
2064             }
2065 #endif
2066             if (!varIsMember(u,bvs)) {
2067                 ERRMSG(line) "Locally quantified variable %s is not used",
2068                              textToStr(u)
2069                 EEND;
2070             }
2071         }
2072         tvs = appendOnto(tvs,vs);
2073     }
2074     return tvs;
2075 }
2076
2077 /* --------------------------------------------------------------------------
2078  * Check for ambiguous types:
2079  * A type  Preds => type  is ambiguous if not (TV(P) `subset` TV(type))
2080  * ------------------------------------------------------------------------*/
2081
2082 List offsetTyvarsIn(t,vs)               /* add list of offset tyvars in t  */
2083 Type t;                                 /* to list vs                      */
2084 List vs; {
2085     switch (whatIs(t)) {
2086         case AP       : return offsetTyvarsIn(fun(t),
2087                                 offsetTyvarsIn(arg(t),vs));
2088
2089         case OFFSET   : if (cellIsMember(t,vs))
2090                             return vs;
2091                         else
2092                             return cons(t,vs);
2093
2094         case QUAL     : return offsetTyvarsIn(snd(t),vs);
2095
2096         case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
2097                         /* slightly inaccurate, but won't matter here      */
2098
2099         case EXIST    :
2100         case RANK2    : return offsetTyvarsIn(snd(snd(t)),vs);
2101
2102         default       : return vs;
2103     }
2104 }
2105
2106 List zonkTyvarsIn(t,vs)
2107 Type t;
2108 List vs; {
2109     switch (whatIs(t)) {
2110         case AP       : return zonkTyvarsIn(fun(t),
2111                                  zonkTyvarsIn(arg(t),vs));
2112
2113         case INTCELL  : if (cellIsMember(t,vs))
2114                             return vs;
2115                         else
2116                             return cons(t,vs);
2117
2118         /* this case will lead to a type error --
2119            much better than reporting an internal error ;-) */
2120         /* case OFFSET   : internal("zonkTyvarsIn"); */
2121
2122         default       : return vs;
2123     }
2124 }
2125
2126 static List local otvars(pi,os)         /* os is a list of offsets that    */
2127 Cell pi;                                /* refer to the arguments of pi;   */
2128 List os; {                              /* find list of offsets in those   */
2129     List us = NIL;                      /* positions                       */
2130     for (; nonNull(os); os=tl(os)) {
2131         us = offsetTyvarsIn(nthArg(offsetOf(hd(os)),pi),us);
2132     }
2133     return us;
2134 }
2135
2136 static List local otvarsZonk(pi,os,o)   /* same as above, but zonks        */
2137 Cell pi;
2138 List os; {
2139     List us = NIL;
2140     for (; nonNull(os); os=tl(os)) {
2141         Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o);
2142         us = zonkTyvarsIn(t,us);
2143     }
2144     return us;
2145 }
2146
2147 static Bool local odiff(us,vs)
2148 List us, vs; {
2149     while (nonNull(us) && cellIsMember(hd(us),vs)) {
2150         us = tl(us);
2151     }
2152     return us;
2153 }
2154
2155 static Bool local osubset(us,vs)        /* Determine whether us is subset  */
2156 List us, vs; {                          /* of vs                           */
2157     while (nonNull(us) && cellIsMember(hd(us),vs)) {
2158         us = tl(us);
2159     }
2160     return isNull(us);
2161 }
2162
2163 List oclose(fds,vs)     /* Compute closure of vs wrt to fds*/
2164 List fds;
2165 List vs; {
2166     Bool changed = TRUE;
2167     while (changed) {
2168         List fds1 = NIL;
2169         changed = FALSE;
2170         while (nonNull(fds)) {
2171             Cell fd   = hd(fds);
2172             List next = tl(fds);
2173             if (osubset(fst(fd),vs)) {  /* Test if fd applies              */
2174                 List os = snd(fd);
2175                 for (; nonNull(os); os=tl(os)) {
2176                     if (!cellIsMember(hd(os),vs)) {
2177                         vs      = cons(hd(os),vs);
2178                         changed = TRUE;
2179                     }
2180                 }
2181             } else {                    /* Didn't apply this time, so keep */
2182                 tl(fds) = fds1;
2183                 fds1    = fds;
2184             }
2185             fds = next;
2186         }
2187         fds = fds1;
2188     }
2189     return vs;
2190 }
2191
2192 Bool isAmbiguous(type)                  /* Determine whether type is       */
2193 Type type; {                            /* ambiguous                       */
2194     if (isPolyType(type)) {
2195         type = monotypeOf(type);
2196     }
2197     if (isQualType(type)) {             /* only qualified types can be     */
2198         List ps   = fst(snd(type));     /* ambiguous                       */
2199         List tvps = offsetTyvarsIn(ps,NIL);
2200         List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
2201         List fds  = calcFunDeps(ps);
2202
2203         tvts = oclose(fds,tvts);        /* Close tvts under fds            */
2204         return !osubset(tvps,tvts);
2205     }
2206     return FALSE;
2207 }
2208
2209 List calcFunDeps(ps)
2210 List ps; {
2211     List fds  = NIL;
2212     for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies        */
2213         Cell pi = hd(ps);
2214         Cell c  = getHead(pi);
2215         if (isClass(c)) {
2216             List xfs = cclass(c).xfds;
2217             for (; nonNull(xfs); xfs=tl(xfs)) {
2218                 List fs = snd(hd(xfs));
2219                 for (; nonNull(fs); fs=tl(fs)) {
2220                     fds = cons(pair(otvars(pi,fst(hd(fs))),
2221                                     otvars(pi,snd(hd(fs)))),fds);
2222                 }
2223             }
2224         }
2225 #if IPARAM
2226         else if (isIP(c)) {
2227             fds = cons(pair(NIL,offsetTyvarsIn(arg(pi),NIL)),fds);
2228         }
2229 #endif
2230     }
2231     return fds;
2232 }
2233
2234 List calcFunDepsPreds(ps)
2235 List ps; {
2236     List fds  = NIL;
2237     for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies        */
2238         Cell pi3 = hd(ps);
2239         Cell pi = fst3(pi3);
2240         Cell c  = getHead(pi);
2241         Int o = intOf(snd3(pi3));
2242         if (isClass(c)) {
2243             List xfs = cclass(c).xfds;
2244             for (; nonNull(xfs); xfs=tl(xfs)) {
2245                 List fs = snd(hd(xfs));
2246                 for (; nonNull(fs); fs=tl(fs)) {
2247                     fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
2248                                     otvarsZonk(pi,snd(hd(fs)),o)),fds);
2249                 }
2250             }
2251         }
2252 #if IPARAM
2253         else if (isIP(c)) {
2254             fds = cons(pair(NIL,zonkTyvarsIn(arg(pi),NIL)),fds);
2255         }
2256 #endif
2257     }
2258     return fds;
2259 }
2260
2261 Void ambigError(line,where,e,type)      /* produce error message for       */
2262 Int    line;                            /* ambiguity                       */
2263 String where;
2264 Cell   e;
2265 Type   type; {
2266     ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
2267     ERRTEXT      "\n*** ambiguous type : " ETHEN ERRTYPE(type);
2268     if (nonNull(e)) {
2269         ERRTEXT  "\n*** assigned to    : " ETHEN ERREXPR(e);
2270     }
2271     ERRTEXT      "\n"
2272     EEND;
2273 }
2274
2275 /* --------------------------------------------------------------------------
2276  * Kind inference for simple types:
2277  * ------------------------------------------------------------------------*/
2278
2279 static Void local kindConstr(line,alpha,m,c)
2280 Int  line;                              /* Determine kind of constructor   */
2281 Int  alpha;
2282 Int  m;
2283 Cell c; {
2284     Cell h = getHead(c);
2285     Int  n = argCount;
2286
2287 #ifdef DEBUG_KINDS
2288     Printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
2289     printType(stdout,c);
2290     Printf("\n");
2291 #endif
2292
2293     switch (whatIs(h)) {
2294         case POLYTYPE : if (n!=0) {
2295                             internal("kindConstr1");
2296                         } else {
2297                             static String pt = "polymorphic type";
2298                             Type  t  = dropRank1(c,alpha,m);
2299                             Kinds ks = polySigOf(t);
2300                             Int   m1 = 0;
2301                             Int   beta;
2302                             for (; isAp(ks); ks=tl(ks)) {
2303                                 m1++;
2304                             }
2305                             beta        = newKindvars(m1);
2306                             unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
2307                             checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
2308                         }
2309                         return;
2310
2311         case CDICTS   :
2312         case QUAL     : if (n!=0) {
2313                             internal("kindConstr2");
2314                         }
2315                         map3Proc(kindPred,line,alpha,m,fst(snd(c)));
2316                         kindConstr(line,alpha,m,snd(snd(c)));
2317                         return;
2318
2319         case EXIST    :
2320         case RANK2    : kindConstr(line,alpha,m,snd(snd(c)));
2321                         return;
2322
2323 #if TREX
2324         case EXT      : if (n!=2) {
2325                             ERRMSG(line)
2326                                 "Illegal use of row in " ETHEN ERRTYPE(c);
2327                             ERRTEXT "\n"
2328                             EEND;
2329                         }
2330                         break;
2331 #endif
2332
2333         case TYCON    : if (isSynonym(h) && n<tycon(h).arity) {
2334                             ERRMSG(line)
2335                               "Not enough arguments for type synonym \"%s\"",
2336                               textToStr(tycon(h).text)
2337                             EEND;
2338                         }
2339                         break;
2340     }
2341
2342     if (n==0) {                         /* trivial case, no arguments      */
2343         typeIs = kindAtom(alpha,c);
2344     } else {                            /* non-trivial application         */
2345         static String app = "constructor application";
2346         Cell   a = c;
2347         Int    i;
2348         Kind   k;
2349         Int    beta;
2350
2351         varKind(n);
2352         beta   = typeOff;
2353         k      = typeIs;
2354
2355         typeIs = kindAtom(alpha,h);     /* h  :: v1 -> ... -> vn -> w      */
2356         shouldKind(line,h,c,app,k,beta);
2357
2358         for (i=n; i>0; --i) {           /* ci :: vi for each 1 <- 1..n     */
2359             checkKind(line,alpha,m,arg(a),c,app,aVar,beta+i-1);
2360             a = fun(a);
2361         }
2362         tyvarType(beta+n);              /* inferred kind is w              */
2363     }
2364 }
2365
2366 static Kind local kindAtom(alpha,c)     /* Find kind of atomic constructor */
2367 Int  alpha;
2368 Cell c; {
2369     switch (whatIs(c)) {
2370         case TUPLE     : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
2371         case OFFSET    : return mkInt(alpha+offsetOf(c));
2372         case TYCON     : return tycon(c).kind;
2373         case INTCELL   : return c;
2374         case VARIDCELL :
2375         case VAROPCELL : {   Cell vt = findBtyvs(textOf(c));
2376                              if (nonNull(vt)) {
2377                                  return snd(vt);
2378                              }
2379                          }
2380 #if TREX
2381         case EXT       : return extKind;
2382 #endif
2383     }
2384 #if DEBUG_KINDS
2385     Printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
2386     printType(stdout,c);
2387     Printf("\n");
2388 #endif
2389     internal("kindAtom");
2390     return STAR;/* not reached */
2391 }
2392
2393 static Void local kindPred(l,alpha,m,pi)/* Check kinds of arguments in pred*/
2394 Int  l;
2395 Int  alpha;
2396 Int  m;
2397 Cell pi; {
2398 #if TREX
2399     if (isAp(pi) && isExt(fun(pi))) {
2400         static String lackspred = "lacks predicate";
2401         checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
2402         return;
2403     }
2404 #endif
2405 #if IPARAM
2406     if (isAp(pi) && whatIs(fun(pi)) == IPCELL) {
2407         static String ippred = "iparam predicate";
2408         checkKind(l,alpha,m,arg(pi),NIL,ippred,STAR,0);
2409         return;
2410     }
2411 #endif
2412     {   static String predicate = "class constraint";
2413         Class c  = getHead(pi);
2414         List  as = getArgs(pi);
2415         Kinds ks = cclass(c).kinds;
2416
2417         while (nonNull(ks)) {
2418             checkKind(l,alpha,m,hd(as),NIL,predicate,hd(ks),0);
2419             ks = tl(ks);
2420             as = tl(as);
2421         }
2422     }
2423 }
2424
2425 static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
2426 Int    line;                            /* is well-kinded                  */
2427 String wh;
2428 Type   type; {
2429     checkKind(line,0,0,type,NIL,wh,STAR,0);
2430 }
2431
2432 static Void local fixKinds() {          /* add kind annotations to types   */
2433     for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
2434         Pair pr   = hd(unkindTypes);
2435         Int  beta = intOf(fst(pr));
2436         Cell qts  = polySigOf(snd(pr));
2437         for (;;) {
2438             if (isNull(hd(qts))) {
2439                 hd(qts) = copyKindvar(beta++);
2440             } else {
2441                 internal("fixKinds");
2442             }
2443             if (nonNull(tl(qts))) {
2444                 qts = tl(qts);
2445             } else {
2446                 tl(qts) = STAR;
2447                 break;
2448             }
2449         }
2450 #ifdef DEBUG_KINDS
2451         Printf("Type expression: ");
2452         printType(stdout,snd(pr));
2453         Printf(" :: ");
2454         printKind(stdout,polySigOf(snd(pr)));
2455         Printf("\n");
2456 #endif
2457     }
2458 }
2459
2460 /* --------------------------------------------------------------------------
2461  * Kind checking of groups of type constructors and classes:
2462  * ------------------------------------------------------------------------*/
2463
2464 static Void local kindTCGroup(tcs)      /* find kinds for mutually rec. gp */
2465 List tcs; {                             /* of tycons and classes           */
2466     emptySubstitution();
2467     unkindTypes = NIL;
2468     mapProc(initTCKind,tcs);
2469     mapProc(kindTC,tcs);
2470     mapProc(genTC,tcs);
2471     fixKinds();
2472     emptySubstitution();
2473 }
2474
2475 static Void local initTCKind(c)         /* build initial kind/arity for c  */
2476 Cell c; {
2477     if (isTycon(c)) {                   /* Initial kind of tycon is:       */
2478         Int beta = newKindvars(1);      /*    v1 -> ... -> vn -> vn+1      */
2479         varKind(tycon(c).arity);        /* where n is the arity of c.      */
2480         bindTv(beta,typeIs,typeOff);    /* For data definitions, vn+1 == * */
2481         switch (whatIs(tycon(c).what)) {
2482             case NEWTYPE  :
2483             case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
2484         }
2485         tycon(c).kind = mkInt(beta);
2486     } else {
2487         Int n    = cclass(c).arity;
2488         Int beta = newKindvars(n);
2489         cclass(c).kinds = NIL;
2490         while (n>0) {
2491             n--;
2492             cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
2493         }
2494     }
2495 }
2496
2497 static Void local kindTC(c)             /* check each part of a tycon/class*/
2498 Cell c; {                               /* is well-kinded                  */
2499     if (isTycon(c)) {
2500         static String cfun = "constructor function";
2501         static String tsyn = "synonym definition";
2502         Int line = tycon(c).line;
2503         Int beta = tyvar(intOf(tycon(c).kind))->offs;
2504         Int m    = tycon(c).arity;
2505         switch (whatIs(tycon(c).what)) {
2506             case NEWTYPE     :
2507             case DATATYPE    : {   List cs = tycon(c).defn;
2508                                    if (isQualType(cs)) {
2509                                        map3Proc(kindPred,line,beta,m,
2510                                                                 fst(snd(cs)));
2511                                        tycon(c).defn = cs = snd(snd(cs));
2512                                    }
2513                                    for (; hasCfun(cs); cs=tl(cs)) {
2514                                        kindType(line,cfun,name(hd(cs)).type);
2515                                    }
2516                                    break;
2517                                }
2518
2519             default          : checkKind(line,beta,m,tycon(c).defn,NIL,
2520                                                         tsyn,aVar,beta+m);
2521         }
2522     }
2523     else {                              /* scan type exprs in class defn to*/
2524         List ms   = fst(cclass(c).members);
2525         Int  m    = cclass(c).arity;    /* determine the class signature   */
2526         Int  beta = newKindvars(m);
2527         kindPred(cclass(c).line,beta,m,cclass(c).head);
2528         map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
2529         for (; nonNull(ms); ms=tl(ms)) {
2530             Int  line = intOf(fst3(hd(ms)));
2531             Type type = thd3(hd(ms));
2532             kindType(line,"member function type signature",type);
2533         }
2534     }
2535 }
2536
2537 static Void local genTC(c)              /* generalise kind inferred for    */
2538 Cell c; {                               /* given tycon/class               */
2539     if (isTycon(c)) {
2540         tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
2541 #ifdef DEBUG_KINDS
2542         Printf("%s :: ",textToStr(tycon(c).text));
2543         printKind(stdout,tycon(c).kind);
2544         Putchar('\n');
2545 #endif
2546     } else {
2547         Kinds ks = cclass(c).kinds;
2548         for (; nonNull(ks); ks=tl(ks)) {
2549             hd(ks) = copyKindvar(intOf(hd(ks)));
2550         }
2551 #ifdef DEBUG_KINDS
2552         Printf("%s :: ",textToStr(cclass(c).text));
2553         printKinds(stdout,cclass(c).kinds);
2554         Putchar('\n');
2555 #endif
2556     }
2557 }
2558
2559 /* --------------------------------------------------------------------------
2560  * Static analysis of instance declarations:
2561  *
2562  * The first part of the static analysis is performed as the declarations
2563  * are read during parsing:
2564  * - make new entry in instance table
2565  * - record line number of declaration
2566  * - build list of instances defined in current script for use in later
2567  *   stages of static analysis.
2568  * ------------------------------------------------------------------------*/
2569
2570 Void instDefn(line,head,ms)            /* process new instance definition  */
2571 Int  line;                             /* definition line number           */
2572 Cell head;                             /* inst header :: (context,Class)   */
2573 List ms; {                             /* instance members                 */
2574     Inst nw             = newInst();
2575     inst(nw).line       = line;
2576     inst(nw).specifics  = fst(head);
2577     inst(nw).head       = snd(head);
2578     inst(nw).implements = ms;
2579     instDefns           = cons(nw,instDefns);
2580 }
2581
2582 /* --------------------------------------------------------------------------
2583  * Further static analysis of instance declarations:
2584  *
2585  * Makes the following checks:
2586  * - Class part of header has form C (T a1 ... an) where C is a known
2587  *   class, and T is a known datatype constructor (or restricted synonym),
2588  *   and there is no previous C-T instance, and (T a1 ... an) has a kind
2589  *   appropriate for the class C.
2590  * - Each element of context is a valid class expression, with type vars
2591  *   drawn from a1, ..., an.
2592  * - All bindings are function bindings
2593  * - All bindings define member functions for class C
2594  * - Arrange bindings into appropriate order for member list
2595  * - No top level type signature declarations
2596  * ------------------------------------------------------------------------*/
2597
2598 Bool allowOverlap = FALSE;              /* TRUE => allow overlapping insts */
2599 Name nameListMonad = NIL;               /* builder function for List Monad */
2600
2601 static Void local checkInstDefn(in)     /* Validate instance declaration   */
2602 Inst in; {
2603     Int  line   = inst(in).line;
2604     List tyvars = typeVarsIn(inst(in).head,NIL,NIL,NIL);
2605     List tvps = NIL, tvts = NIL;
2606     List fds = NIL;
2607
2608     if (haskell98) {                    /* Check for `simple' type         */
2609         List tvs = NIL;
2610         Cell t   = arg(inst(in).head);
2611         for (; isAp(t); t=fun(t)) {
2612             if (!isVar(arg(t))) {
2613                 ERRMSG(line)
2614                    "syntax error in instance head (variable expected)"
2615                 EEND;
2616             }
2617             if (varIsMember(textOf(arg(t)),tvs)) {
2618                 ERRMSG(line) "repeated type variable \"%s\" in instance head",
2619                              textToStr(textOf(arg(t)))
2620                 EEND;
2621             }
2622             tvs = cons(arg(t),tvs);
2623         }
2624         if (isVar(t)) {
2625             ERRMSG(line)
2626                 "syntax error in instance head (constructor expected)"
2627             EEND;
2628         }
2629     }
2630
2631     /* add in the tyvars from the `specifics' so that we don't
2632        prematurely complain about undefined tyvars */
2633     tyvars = typeVarsIn(inst(in).specifics,NIL,NIL,tyvars);
2634     inst(in).head = depPredExp(line,tyvars,inst(in).head);
2635
2636     if (haskell98) {
2637         Type h = getHead(arg(inst(in).head));
2638         if (isSynonym(h)) {
2639             ERRMSG(line) "Cannot use type synonym in instance head"
2640             EEND;
2641         }
2642     }
2643
2644     map2Over(depPredExp,line,tyvars,inst(in).specifics);
2645
2646     /* OK, now we start over, and test for ambiguity */
2647     tvts = offsetTyvarsIn(inst(in).head,NIL);
2648     tvps = offsetTyvarsIn(inst(in).specifics,NIL);
2649     fds  = calcFunDeps(inst(in).specifics);
2650     tvts = oclose(fds,tvts);
2651     tvts = odiff(tvps,tvts);
2652     if (!isNull(tvts)) {
2653         ERRMSG(line) "Undefined type variable \"%s\"",
2654           textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars)))
2655         EEND;
2656     }
2657
2658     h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL);
2659     inst(in).numSpecifics = length(inst(in).specifics);
2660     inst(in).c            = getHead(inst(in).head);
2661     if (!isClass(inst(in).c)) {
2662         ERRMSG(line) "Illegal predicate in instance declaration"
2663         EEND;
2664     }
2665
2666     if (nonNull(cclass(inst(in).c).fds)) {
2667         List fds = cclass(inst(in).c).fds;
2668         for (; nonNull(fds); fds=tl(fds)) {
2669             List as = otvars(inst(in).head, fst(hd(fds)));
2670             List bs = otvars(inst(in).head, snd(hd(fds)));
2671             List fs = calcFunDeps(inst(in).specifics);
2672             as = oclose(fs,as);
2673             if (!osubset(bs,as)) {
2674                 ERRMSG(inst(in).line)
2675                    "Instance is more general than a dependency allows"
2676                 ETHEN
2677                 ERRTEXT "\n*** Instance         : "
2678                 ETHEN ERRPRED(inst(in).head);
2679                 ERRTEXT "\n*** For class        : "
2680                 ETHEN ERRPRED(cclass(inst(in).c).head);
2681                 ERRTEXT "\n*** Under dependency : "
2682                 ETHEN ERRFD(hd(fds));
2683                 ERRTEXT "\n"
2684                 EEND;
2685             }
2686         }
2687     }
2688
2689     kindInst(in,length(tyvars));
2690     insertInst(in);
2691
2692     if (nonNull(extractSigdecls(inst(in).implements))) {
2693         ERRMSG(line)
2694           "Type signature declarations not permitted in instance declaration"
2695         EEND;
2696     }
2697     if (nonNull(extractFixdecls(inst(in).implements))) {
2698         ERRMSG(line)
2699           "Fixity declarations not permitted in instance declaration"
2700         EEND;
2701     }
2702     inst(in).implements = classBindings("instance",
2703                                         inst(in).c,
2704                                         extractBindings(inst(in).implements));
2705     inst(in).builder    = newInstImp(in);
2706     if (!preludeLoaded && isNull(nameListMonad) && isAp(inst(in).head)
2707         && fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
2708         nameListMonad = inst(in).builder;
2709     }
2710 }
2711
2712 static Void local insertInst(in)        /* Insert instance into class      */
2713 Inst in; {
2714     Class c    = inst(in).c;
2715     List  ins  = cclass(c).instances;
2716     List  prev = NIL;
2717
2718     if (nonNull(cclass(c).fds)) {       /* Check for conflicts with fds    */
2719         List ins1 = cclass(c).instances;
2720         for (; nonNull(ins1); ins1=tl(ins1)) {
2721             List fds = cclass(c).fds;
2722             substitution(RESET);
2723             for (; nonNull(fds); fds=tl(fds)) {
2724                 Int  alpha = newKindedVars(inst(in).kinds);
2725                 Int  beta  = newKindedVars(inst(hd(ins1)).kinds);
2726                 List as    = fst(hd(fds));
2727                 Bool same  = TRUE;
2728                 for (; same && nonNull(as); as=tl(as)) {
2729                     Int n = offsetOf(hd(as));
2730                     same &= unify(nthArg(n,inst(in).head),alpha,
2731                                   nthArg(n,inst(hd(ins1)).head),beta);
2732                 }
2733                 if (isNull(as) && same) {
2734                     for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
2735                         Int n = offsetOf(hd(as));
2736                         same &= sameType(nthArg(n,inst(in).head),alpha,
2737                                          nthArg(n,inst(hd(ins1)).head),beta);
2738                     }
2739                     if (!same) {
2740                         ERRMSG(inst(in).line)
2741                            "Instances are not consistent with dependencies"
2742                         ETHEN
2743                         ERRTEXT "\n*** This instance    : "
2744                         ETHEN ERRPRED(inst(in).head);
2745                         ERRTEXT "\n*** Conflicts with   : "
2746                         ETHEN ERRPRED(inst(hd(ins)).head);
2747                         ERRTEXT "\n*** For class        : "
2748                         ETHEN ERRPRED(cclass(c).head);
2749                         ERRTEXT "\n*** Under dependency : "
2750                         ETHEN ERRFD(hd(fds));
2751                         ERRTEXT "\n"
2752                         EEND;
2753                     }
2754                 }
2755             }
2756         }
2757     }
2758
2759
2760     substitution(RESET);
2761     while (nonNull(ins)) {              /* Look for overlap w/ other insts */
2762         Int alpha = newKindedVars(inst(in).kinds);
2763         Int beta  = newKindedVars(inst(hd(ins)).kinds);
2764         if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
2765             Cell pi  = copyPred(inst(in).head,alpha);
2766             if (allowOverlap && !haskell98) {
2767                 Bool bef = instCompare(in,hd(ins));
2768                 Bool aft = instCompare(hd(ins),in);
2769                 if (bef && !aft) {      /* in comes strictly before hd(ins)*/
2770                     break;
2771                 }
2772                 if (aft && !bef) {      /* in comes strictly after hd(ins) */
2773                     prev = ins;
2774                     ins  = tl(ins);
2775                     continue;
2776                 }
2777             }
2778 #if MULTI_INST
2779             if (multiInstRes && nonNull(inst(in).specifics)) {
2780                 break;
2781             } else {
2782 #endif
2783             ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
2784                                   textToStr(cclass(c).text)
2785             ETHEN
2786             ERRTEXT "\n*** This instance   : " ETHEN ERRPRED(inst(in).head);
2787             ERRTEXT "\n*** Overlaps with   : " ETHEN
2788                                                ERRPRED(inst(hd(ins)).head);
2789             ERRTEXT "\n*** Common instance : " ETHEN
2790                                                ERRPRED(pi);
2791             ERRTEXT "\n"
2792             EEND;
2793         }
2794 #if MULTI_INST
2795             }
2796 #endif
2797         prev = ins;                     /* No overlap detected, so move on */
2798         ins  = tl(ins);                 /* to next instance                */
2799     }
2800     substitution(RESET);
2801
2802     if (nonNull(prev)) {                /* Insert instance at this point   */
2803         tl(prev) = cons(in,ins);
2804     } else {
2805         cclass(c).instances = cons(in,ins);
2806     }
2807 }
2808
2809 static Bool local instCompare(ia,ib)    /* See if ia is an instance of ib  */
2810 Inst ia, ib;{
2811     Int alpha = newKindedVars(inst(ia).kinds);
2812     Int beta  = newKindedVars(inst(ib).kinds);
2813     return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
2814 }
2815
2816 static Name local newInstImp(in)        /* Make definition for inst builder*/
2817 Inst in; {
2818     Name b         = newName(inventText(),in);
2819     name(b).line   = inst(in).line;
2820     name(b).arity  = inst(in).numSpecifics;
2821     name(b).number = DFUNNAME;
2822     return b;
2823 }
2824
2825 /* --------------------------------------------------------------------------
2826  * Kind checking of instance declaration headers:
2827  * ------------------------------------------------------------------------*/
2828
2829 static Void local kindInst(in,freedom)  /* check predicates in instance    */
2830 Inst in;
2831 Int  freedom; {
2832     Int beta;
2833
2834     emptySubstitution();
2835     beta = newKindvars(freedom);
2836     kindPred(inst(in).line,beta,freedom,inst(in).head);
2837     if (whatIs(inst(in).specifics)!=DERIVE) {
2838         map3Proc(kindPred,inst(in).line,beta,freedom,inst(in).specifics);
2839     }
2840     for (inst(in).kinds = NIL; 0<freedom--; ) {
2841         inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
2842     }
2843 #ifdef DEBUG_KINDS
2844     Printf("instance ");
2845     printPred(stdout,inst(in).head);
2846     Printf(" :: ");
2847     printKinds(stdout,inst(in).kinds);
2848     Putchar('\n');
2849 #endif
2850     emptySubstitution();
2851 }
2852
2853 /* --------------------------------------------------------------------------
2854  * Process derived instance requests:
2855  * ------------------------------------------------------------------------*/
2856
2857 static List derivedInsts;               /* list of derived instances       */
2858
2859 static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
2860 Tycon t;                                /* for tycon t, with explicit      */
2861 List  p;                                /* context p, component types ts   */
2862 List  ts;                               /* and named class ct              */
2863 Cell  ct; {
2864     Int   line = tycon(t).line;
2865     Class c    = findQualClass(ct);
2866     if (isNull(c)) {
2867         ERRMSG(line) "Unknown class \"%s\" in derived instance",
2868                      identToStr(ct)
2869         EEND;
2870     }
2871     addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
2872 }
2873
2874 static Void local addDerInst(line,c,p,cts,t,a)  /* Add a derived instance  */
2875 Int   line;
2876 Class c;
2877 List  p, cts;
2878 Type  t;
2879 Int   a; {
2880     Inst in;
2881     Cell head = t;                              /* Build instance head     */
2882     Int  i    = 0;
2883
2884     for (; i<a; i++) {
2885         head = ap(head,mkOffset(i));
2886     }
2887     head = ap(c,head);
2888
2889     in                  = newInst();
2890     inst(in).c          = c;
2891     inst(in).line       = line;
2892     inst(in).head       = head;
2893     inst(in).specifics  = ap(DERIVE,pair(dupList(p),cts));
2894     inst(in).implements = NIL;
2895     inst(in).kinds      = mkInt(a);
2896     derivedInsts        = cons(in,derivedInsts);
2897 }
2898
2899 Void addTupInst(c,n)                    /* Request derived instance of c   */
2900 Class c;                                /* for mkTuple(n) constructor      */
2901 Int   n; {
2902     Int  m   = n;
2903     List cts = NIL;
2904     while (0<m--) {
2905         cts = cons(mkOffset(m),cts);
2906     }
2907     cts = rev(cts);
2908     addDerInst(0,c,NIL,cts,mkTuple(n),n);
2909 }
2910
2911 #if TREX
2912 Inst addRecShowInst(c,e)                /* Generate instance for ShowRecRow*/
2913 Class c;                                /* c *must* be ShowRecRow          */
2914 Ext   e; {
2915     Inst in               = newInst();
2916     inst(in).c            = c;
2917     inst(in).head         = ap(c,ap2(e,aVar,bVar));
2918     inst(in).kinds        = extKind;
2919     inst(in).specifics    = cons(ap(classShow,aVar),
2920                                  cons(ap(e,bVar),
2921                                       cons(ap(c,bVar),NIL)));
2922     inst(in).numSpecifics = 3;
2923     inst(in).builder      = implementRecShw(extText(e),in);
2924     cclass(c).instances   = appendOnto(cclass(c).instances,singleton(in));
2925     return in;
2926 }
2927
2928 Inst addRecEqInst(c,e)                  /* Generate instance for EqRecRow  */
2929 Class c;                                /* c *must* be EqRecRow            */
2930 Ext   e; {
2931     Inst in               = newInst();
2932     inst(in).c            = c;
2933     inst(in).head         = ap(c,ap2(e,aVar,bVar));
2934     inst(in).kinds        = extKind;
2935     inst(in).specifics    = cons(ap(classEq,aVar),
2936                                  cons(ap(e,bVar),
2937                                       cons(ap(c,bVar),NIL)));
2938     inst(in).numSpecifics = 3;
2939     inst(in).builder      = implementRecEq(extText(e),in);
2940     cclass(c).instances   = appendOnto(cclass(c).instances,singleton(in));
2941     return in;
2942 }
2943 #endif
2944
2945 /* --------------------------------------------------------------------------
2946  * Calculation of contexts for derived instances:
2947  *
2948  * Allowing arbitrary types to appear in contexts makes it rather harder
2949  * to decide what the context for a derived instance should be.  For
2950  * example, given:
2951  *
2952  *    data T a = MkT [a] deriving Show,
2953  *
2954  * we could have either of the following:
2955  *
2956  *    instance (Show [a]) => Show (T a) where ...
2957  *    instance (Show a) => Show (T a) where ...
2958  *
2959  * (assuming, of course, that instance (Show a) => Show [a]).  For now, we
2960  * choose to reduce contexts in the hope of detecting errors at an earlier
2961  * stage---in contrast with value definitions, there is no way for a user
2962  * to provide something analogous to a `type signature' by which they might
2963  * be able to control this behaviour themselves.  We eliminate tautological
2964  * predicates, but only allow predicates to appear in the final result if
2965  * they have at least one argument with a variable at its head.
2966  *
2967  * In general, we have to deal with mutually recursive instance declarations.
2968  * We find a solution in the obvious way by iterating to find a fixed point.
2969  * Of course, without restrictions on the form of instance declarations, we
2970  * cannot be sure that this will always terminate!
2971  *
2972  * For each instance we maintain a pair of the form DERIVE (ctxt,ps).
2973  * Ctxt is a list giving the parts of the context that have been produced
2974  * so far in the form of predicate skeletons.  During the calculation of
2975  * derived instances, we attach a dummy NIL value to the end of the list
2976  * which acts as a kind of `variable': other parts of the system maintain
2977  * pointers to this variable, and use it to detect when the context has
2978  * been extended with new elements.  Meanwhile, ps is a list containing
2979  * predicates (pi,o) together with (delayed) substitutions of the form
2980  * (o,xs) where o is an offset and xs is one of the context variables
2981  * described above, which may have been partially instantiated.
2982  * ------------------------------------------------------------------------*/
2983
2984 static Bool instsChanged;
2985
2986 static Void local deriveContexts(is)    /* Calc contexts for derived insts */
2987 List is; {
2988     emptySubstitution();
2989     mapProc(initDerInst,is);            /* Prepare derived instances       */
2990
2991     do {                                /* Main calculation of contexts    */
2992         instsChanged = FALSE;
2993         mapProc(calcInstPreds,is);
2994     } while (instsChanged);
2995
2996     mapProc(tidyDerInst,is);            /* Tidy up results                 */
2997 }
2998
2999 static Void local initDerInst(in)       /* Prepare instance for calculation*/
3000 Inst in; {                              /* of derived instance context     */
3001     Cell spcs = inst(in).specifics;
3002     Int  beta = newKindedVars(inst(in).kinds);
3003     if (whatIs(spcs)!=DERIVE) {
3004         internal("initDerInst");
3005     }
3006     fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
3007     for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
3008         hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
3009     }
3010     inst(in).numSpecifics = beta;
3011
3012 #ifdef DEBUG_DERIVING
3013     Printf("initDerInst: ");
3014     printPred(stdout,inst(in).head);
3015     Printf("\n");
3016     printContext(stdout,snd(snd(inst(in).specifics)));
3017     Printf("\n");
3018 #endif
3019 }
3020
3021 static Void local calcInstPreds(in)     /* Calculate next approximation    */
3022 Inst in; {                              /* of the context for a derived    */
3023     List retain = NIL;                  /* instance                        */
3024     List ps     = snd(snd(inst(in).specifics));
3025     List spcs   = fst(snd(inst(in).specifics));
3026     Int  beta   = inst(in).numSpecifics;
3027     Int  its    = 1;
3028     Int  factor = 1+length(ps);
3029
3030 #ifdef DEBUG_DERIVING
3031     Printf("calcInstPreds: ");
3032     printPred(stdout,inst(in).head);
3033     Printf("\n");
3034 #endif
3035
3036     while (nonNull(ps)) {
3037         Cell p = hd(ps);
3038         ps     = tl(ps);
3039         if (its++ >= factor*cutoff) {
3040             Cell bpi = inst(in).head;
3041             ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
3042             ERRTEXT " after %d iterations.", its-1   ETHEN
3043             ERRTEXT
3044                 "\n*** This may indicate that the problem is undecidable.  However,\n"
3045             ETHEN ERRTEXT
3046                 "*** you may still try to increase the cutoff limit using the -c\n"
3047             ETHEN ERRTEXT
3048                 "*** option and then try again.  (The current setting is -c%d)\n",
3049                 cutoff
3050             EEND;
3051         }
3052         if (isInt(fst(p))) {                    /* Delayed substitution?   */
3053             List qs = snd(p);
3054             for (; nonNull(hd(qs)); qs=tl(qs)) {
3055                 ps = cons(pair(hd(qs),fst(p)),ps);
3056             }
3057             retain = cons(pair(fst(p),qs),retain);
3058         }
3059 #if TREX
3060         else if (isExt(fun(fst(p)))) {          /* Lacks predicate         */
3061             Text   l = extText(fun(fst(p)));
3062             Type   t = arg(fst(p));
3063             Int    o = intOf(snd(p));
3064             Type   h;
3065             Tyvar *tyv;
3066
3067             deRef(tyv,t,o);
3068             h = getDerefHead(t,o);
3069             while (isExt(h) && argCount==2 && l!=extText(h)) {
3070                 t = arg(t);
3071                 deRef(tyv,t,o);
3072                 h = getDerefHead(t,o);
3073             }
3074             if (argCount==0 && isOffset(h)) {
3075                 maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
3076             } else if (argCount!=0 || h!=typeNoRow) {
3077                 Cell bpi = inst(in).head;
3078                 Cell pi  = copyPred(fun(p),intOf(snd(p)));
3079                 ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
3080                 ERRTEXT " because predicate " ETHEN ERRPRED(pi);
3081                 ERRTEXT " does not hold\n"
3082                 EEND;
3083             }
3084         }
3085 #endif
3086         else {                                  /* Class predicate         */
3087             Cell pi  = fst(p);
3088             Int  o   = intOf(snd(p));
3089             Inst in1 = findInstFor(pi,o);
3090             if (nonNull(in1)) {
3091                 List qs  = inst(in1).specifics;
3092                 Int  off = mkInt(typeOff);
3093                 if (whatIs(qs)==DERIVE) {       /* Still being derived     */
3094                     for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) {
3095                         ps = cons(pair(hd(qs),off),ps);
3096                     }
3097                     retain = cons(pair(off,qs),retain);
3098                 } else {                        /* Previously def'd inst   */
3099                     for (; nonNull(qs); qs=tl(qs)) {
3100                         ps = cons(pair(hd(qs),off),ps);
3101                     }
3102                 }
3103             } else {                            /* No matching instance    */
3104                 Cell qi = pi;
3105                 while (isAp(qi) && isOffset(getDerefHead(arg(qi),o))) {
3106                     qi = fun(qi);
3107                 }
3108                 if (isAp(qi)) {
3109                     Cell bpi = inst(in).head;
3110                     pi       = copyPred(pi,o);
3111                     ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
3112                     ERRTEXT " is required to derive "       ETHEN ERRPRED(bpi);
3113                     ERRTEXT "\n"
3114                     EEND;
3115                 } else {
3116                     maybeAddPred(pi,o,beta,spcs);
3117                 }
3118             }
3119         }
3120     }
3121     snd(snd(inst(in).specifics)) = retain;
3122 }
3123
3124 static Void local maybeAddPred(pi,o,beta,ps)
3125 Cell pi;                                /* Add predicate pi to the list ps,*/
3126 Int  o;                                 /* setting the instsChanged flag if*/
3127 Int  beta;                              /* pi is not already a member and  */
3128 List ps; {                              /* using beta to adjust vars       */
3129     Cell c = getHead(pi);
3130     for (; nonNull(ps); ps=tl(ps)) {
3131         if (isNull(hd(ps))) {           /* reached the `dummy' end of list?*/
3132             hd(ps)       = copyAdj(pi,o,beta);
3133             tl(ps)       = pair(NIL,NIL);
3134             instsChanged = TRUE;
3135             return;
3136         } else if (c==getHead(hd(ps)) && samePred(pi,o,hd(ps),beta)) {
3137             return;
3138         }
3139     }
3140 }
3141
3142 static Cell local copyAdj(c,o,beta)     /* Copy (c,o), replacing vars with */
3143 Cell c;                                 /* offsets relative to beta.       */
3144 Int  o;
3145 Int  beta; {
3146     switch (whatIs(c)) {
3147         case AP     : {   Cell l = copyAdj(fst(c),o,beta);
3148                           Cell r = copyAdj(snd(c),o,beta);
3149                           return ap(l,r);
3150                       }
3151
3152         case OFFSET : {   Int   vn   = o+offsetOf(c);
3153                           Tyvar *tyv = tyvar(vn);
3154                           if (isBound(tyv)) {
3155                               return copyAdj(tyv->bound,tyv->offs,beta);
3156                           }
3157                           vn -= beta;
3158                           if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) {
3159                               internal("copyAdj");
3160                           }
3161                           return mkOffset(vn);
3162                       }
3163     }
3164     return c;
3165 }
3166
3167 static Void local tidyDerInst(in)       /* Tidy up results of derived inst */
3168 Inst in; {                              /* calculations                    */
3169     Int  o  = inst(in).numSpecifics;
3170     List ps = tl(rev(fst(snd(inst(in).specifics))));
3171     clearMarks();
3172     copyPred(inst(in).head,o);
3173     inst(in).specifics    = simpleContext(ps,o);
3174     h98CheckCtxt(inst(in).line,"derived instance",FALSE,inst(in).specifics,in);
3175     inst(in).numSpecifics = length(inst(in).specifics);
3176
3177 #ifdef DEBUG_DERIVING
3178     Printf("Derived instance: ");
3179     printContext(stdout,inst(in).specifics);
3180     Printf(" ||- ");
3181     printPred(stdout,inst(in).head);
3182     Printf("\n");
3183 #endif
3184 }
3185
3186 /* --------------------------------------------------------------------------
3187  * Generate code for derived instances:
3188  * ------------------------------------------------------------------------*/
3189
3190 static Void local addDerivImp(in)
3191 Inst in; {
3192     List  imp = NIL;
3193     Type  t   = getHead(arg(inst(in).head));
3194     Class c   = inst(in).c;
3195     if (c==classEq) {
3196         imp = deriveEq(t);
3197     } else if (c==classOrd) {
3198         imp = deriveOrd(t);
3199     } else if (c==classEnum) {
3200         imp = deriveEnum(t);
3201     } else if (c==classIx) {
3202         imp = deriveIx(t);
3203     } else if (c==classShow) {
3204         imp = deriveShow(t);
3205     } else if (c==classRead) {
3206         imp = deriveRead(t);
3207     } else if (c==classBounded) {
3208         imp = deriveBounded(t);
3209     } else {
3210         ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
3211                               textToStr(cclass(inst(in).c).text)
3212         EEND;
3213     }
3214
3215     kindInst(in,intOf(inst(in).kinds));
3216     insertInst(in);
3217     inst(in).builder    = newInstImp(in);
3218     inst(in).implements = classBindings("derived instance",
3219                                         inst(in).c,
3220                                         imp);
3221 }
3222
3223
3224 /* --------------------------------------------------------------------------
3225  * Default definitions; only one default definition is permitted in a
3226  * given script file.  If no default is supplied, then a standard system
3227  * default will be used where necessary.
3228  * ------------------------------------------------------------------------*/
3229
3230 Void defaultDefn(line,defs)             /* Handle default types definition */
3231 Int  line;
3232 List defs; {
3233     if (defaultLine!=0) {
3234         ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
3235         ERRTEXT     "a single script file.\n"
3236         EEND;
3237     }
3238     defaultDefns = defs;
3239     defaultLine  = line;
3240 }
3241
3242 static Void local checkDefaultDefns() { /* check that default types are    */
3243     List ds = NIL;                      /* well-kinded instances of Num    */
3244
3245     if (defaultLine!=0) {
3246         map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
3247         emptySubstitution();
3248         unkindTypes = NIL;
3249         map2Proc(kindType,defaultLine,"default type",defaultDefns);
3250         fixKinds();
3251         emptySubstitution();
3252         mapOver(fullExpand,defaultDefns);
3253     } else {
3254         defaultDefns = stdDefaults;
3255     }
3256
3257     if (isNull(classNum)) {
3258         classNum = findClass(findText("Num"));
3259     }
3260
3261     for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
3262         if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
3263             ERRMSG(defaultLine)
3264                 "Default types must be instances of the Num class"
3265             EEND;
3266         }
3267     }
3268 }
3269
3270
3271 /* --------------------------------------------------------------------------
3272  * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
3273  * They are used to "import" C functions into a module.
3274  * They are usually not written by hand but, rather, generated automatically
3275  * by GreenCard, IDL compilers or whatever.  We support foreign import
3276  * (static) and foreign import dynamic.  In the latter case, extName==NIL.
3277  *
3278  * Foreign export declarations generate C wrappers for Hugs functions.
3279  * Hugs only provides "foreign export dynamic" because it's not obvious
3280  * what "foreign export static" would mean in an interactive setting.
3281  * ------------------------------------------------------------------------*/
3282
3283 Void foreignImport(line,callconv,extName,intName,type)
3284                                               /* Handle foreign imports    */
3285 Cell line;
3286 Text callconv;
3287 Pair extName;
3288 Cell intName;
3289 Cell type; {
3290     Text t = textOf(intName);
3291     Name n = findName(t);
3292     Int  l = intOf(line);
3293
3294     if (isNull(n)) {
3295         n = newName(t,NIL);
3296     } else if (name(n).defn!=PREDEFINED) {
3297         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
3298         EEND;
3299     }
3300     name(n).line     = l;
3301     name(n).defn     = extName;
3302     name(n).type     = type;
3303     name(n).callconv = callconv;
3304     foreignImports   = cons(n,foreignImports);
3305 }
3306
3307 static Void local checkForeignImport(p)   /* Check foreign import          */
3308 Name p; {
3309     emptySubstitution();
3310     name(p).type = checkSigType(name(p).line,
3311                                 "foreign import declaration",
3312                                 p,
3313                                 name(p).type);
3314     /* We don't expand synonyms here because we don't want the IO
3315      * part to be expanded.
3316      * name(p).type = fullExpand(name(p).type);
3317      */
3318     implementForeignImport(p);
3319 }
3320
3321 Void foreignExport(line,callconv,extName,intName,type)
3322                                               /* Handle foreign exports    */
3323 Cell line;
3324 Text callconv;
3325 Cell extName;
3326 Cell intName;
3327 Cell type; {
3328     Text t = textOf(intName);
3329     Name n = findName(t);
3330     Int  l = intOf(line);
3331
3332     if (isNull(n)) {
3333         n = newName(t,NIL);
3334     } else if (name(n).defn!=PREDEFINED) {
3335         ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
3336         EEND;
3337     }
3338     name(n).line     = l;
3339     name(n).defn     = NIL;  /* nothing to say */
3340     name(n).type     = type;
3341     name(n).callconv = callconv;
3342     foreignExports   = cons(n,foreignExports);
3343 }
3344
3345 static Void local checkForeignExport(p)       /* Check foreign export      */
3346 Name p; {
3347     emptySubstitution();
3348     name(p).type = checkSigType(name(p).line,
3349                                 "foreign export declaration",
3350                                 p,
3351                                 name(p).type);
3352     implementForeignExport(p);
3353 }
3354
3355
3356
3357 /* --------------------------------------------------------------------------
3358  * Static analysis of patterns:
3359  *
3360  * Patterns are parsed as ordinary (atomic) expressions.  Static analysis
3361  * makes the following checks:
3362  *  - Patterns are well formed (according to pattern syntax), including the
3363  *    special case of (n+k) patterns.
3364  *  - All constructor functions have been defined and are used with the
3365  *    correct number of arguments.
3366  *  - No variable name is used more than once in a pattern.
3367  *
3368  * The list of pattern variables occuring in each pattern is accumulated in
3369  * a global list `patVars', which must be initialised to NIL at appropriate
3370  * points before using these routines to check for valid patterns.  This
3371  * mechanism enables the pattern checking routine to be mapped over a list
3372  * of patterns, ensuring that no variable occurs more than once in the
3373  * complete pattern list (as is required on the lhs of a function defn).
3374  * ------------------------------------------------------------------------*/
3375
3376 static List patVars;                   /* List of vars bound in pattern    */
3377
3378 static Cell local checkPat(line,p)     /* Check valid pattern syntax       */
3379 Int  line;
3380 Cell p; {
3381     switch (whatIs(p)) {
3382         case VARIDCELL :
3383         case VAROPCELL : addToPatVars(line,p);
3384                          break;
3385
3386         case INFIX     : return checkPat(line,tidyInfix(line,snd(p)));
3387
3388         case AP        : return checkMaybeCnkPat(line,p);
3389
3390         case NAME      :
3391         case QUALIDENT :
3392         case CONIDCELL :
3393         case CONOPCELL : return checkApPat(line,0,p);
3394
3395         case WILDCARD  :
3396         case STRCELL   :
3397         case CHARCELL  :
3398         case FLOATCELL : break;
3399         case INTCELL   : break;
3400
3401         case ASPAT     : addToPatVars(line,fst(snd(p)));
3402                          snd(snd(p)) = checkPat(line,snd(snd(p)));
3403                          break;
3404
3405         case LAZYPAT   : snd(p) = checkPat(line,snd(p));
3406                          break;
3407
3408         case FINLIST   : map1Over(checkPat,line,snd(p));
3409                          break;
3410
3411         case CONFLDS   : depConFlds(line,p,TRUE);
3412                          break;
3413
3414         case ESIGN     : snd(snd(p)) = checkPatType(line,
3415                                                     "pattern",
3416                                                     fst(snd(p)),
3417                                                     snd(snd(p)));
3418                          fst(snd(p)) = checkPat(line,fst(snd(p)));
3419                          break;
3420
3421         default        : ERRMSG(line) "Illegal pattern syntax"
3422                          EEND;
3423     }
3424     return p;
3425 }
3426
3427 static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with   */
3428 Int  l;                                /* the possibility of n+k pattern   */
3429 Cell p; {
3430     Cell h = getHead(p);
3431
3432     if (argCount==2 && isVar(h) && textOf(h)==textPlus) {       /* n+k     */
3433         Cell v = arg(fun(p));
3434         if (!isInt(arg(p))) {
3435             ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
3436             EEND;
3437         }
3438         if (intOf(arg(p))<=0) {
3439             ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
3440             EEND;
3441         }
3442         fst(fun(p))      = ADDPAT;
3443         intValOf(fun(p)) = intOf(arg(p));
3444         arg(p)           = checkPat(l,v);
3445         return p;
3446     }
3447     return checkApPat(l,0,p);
3448 }
3449
3450 static Cell local checkApPat(line,args,p)
3451 Int  line;                             /* check validity of application    */
3452 Int  args;                             /* of constructor to arguments      */
3453 Cell p; {
3454     switch (whatIs(p)) {
3455         case AP        : fun(p) = checkApPat(line,args+1,fun(p));
3456                          arg(p) = checkPat(line,arg(p));
3457                          break;
3458
3459         case TUPLE     : if (tupleOf(p)!=args) {
3460                              ERRMSG(line) "Illegal tuple pattern"
3461                              EEND;
3462                          }
3463                          break;
3464
3465 #if TREX
3466         case EXT       : h98DoesntSupport(line,"extensible records");
3467                          if (args!=2) {
3468                              ERRMSG(line) "Illegal record pattern"
3469                              EEND;
3470                          }
3471                          break;
3472 #endif
3473
3474         case QUALIDENT : if (!isQCon(p)) {
3475                             ERRMSG(line)
3476                                 "Illegal use of qualified variable in pattern"
3477                             EEND;
3478                          }
3479                          /* deliberate fall through */
3480         case CONIDCELL :
3481         case CONOPCELL : p = conDefined(line,p);
3482                          checkCfunArgs(line,p,args);
3483                          break;
3484
3485         case NAME      : checkIsCfun(line,p);
3486                          checkCfunArgs(line,p,args);
3487                          break;
3488
3489         default        : ERRMSG(line) "Illegal pattern syntax"
3490                          EEND;
3491     }
3492     return p;
3493 }
3494
3495 static Void local addToPatVars(line,v)  /* Add variable v to list of vars  */
3496 Int  line;                              /* in current pattern, checking    */
3497 Cell v; {                               /* for repeated variables.         */
3498     Text t = textOf(v);
3499     List p = NIL;
3500     List n = patVars;
3501
3502     for (; nonNull(n); p=n, n=tl(n)) {
3503         if (textOf(hd(n))==t) {
3504             ERRMSG(line) "Repeated variable \"%s\" in pattern",
3505                          textToStr(t)
3506             EEND;
3507         }
3508     }
3509
3510     if (isNull(p)) {
3511          patVars = cons(v,NIL);
3512     } else {
3513          tl(p)   = cons(v,NIL);
3514     }
3515 }
3516
3517 static Name local conDefined(line,nm)  /* check that nm is the name of a   */
3518 Int  line;                             /* previously defined constructor   */
3519 Cell nm; {                             /* function.                        */
3520     Name n = findQualName(nm);
3521     if (isNull(n)) {
3522         ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
3523         EEND;
3524     }
3525     checkIsCfun(line,n);
3526     return n;
3527 }
3528
3529 static Void local checkIsCfun(line,c)  /* Check that c is a constructor fn */
3530 Int  line;
3531 Name c; {
3532     if (!isCfun(c)) {
3533         ERRMSG(line) "\"%s\" is not a constructor function",
3534                      textToStr(name(c).text)
3535         EEND;
3536     }
3537 }
3538
3539 static Void local checkCfunArgs(line,c,args)
3540 Int  line;                             /* Check constructor applied with   */
3541 Cell c;                                /* correct number of arguments      */
3542 Int  args; {
3543     Int a = userArity(c);
3544     if (a!=args) {
3545         ERRMSG(line)
3546           "Constructor \"%s\" must have exactly %d argument%s in pattern",
3547           textToStr(name(c).text), a, ((a==1)?"":"s")
3548         EEND;
3549     }
3550 }
3551
3552 static Cell local checkPatType(l,wh,e,t)/* Check type appearing in pattern */
3553 Int    l;
3554 String wh;
3555 Cell   e;
3556 Type   t; {
3557     List tvs = typeVarsIn(t,NIL,NIL,NIL);
3558     h98DoesntSupport(l,"pattern type annotations");
3559     for (; nonNull(tvs); tvs=tl(tvs)) {
3560         Int beta    = newKindvars(1);
3561         hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars));
3562     }
3563     t = checkSigType(l,"pattern type",e,t);
3564     if (isPolyOrQualType(t) || whatIs(t)==RANK2) {
3565         ERRMSG(l) "Illegal syntax in %s type annotation", wh
3566         EEND;
3567     }
3568     return t;
3569 }
3570
3571 static Cell local applyBtyvs(pat)       /* Record bound type vars in pat   */
3572 Cell pat; {
3573     List bts = hd(btyvars);
3574     leaveBtyvs();
3575     if (nonNull(bts)) {
3576         pat = ap(BIGLAM,pair(bts,pat));
3577         for (; nonNull(bts); bts=tl(bts)) {
3578             snd(hd(bts)) = copyKindvar(intOf(snd(hd(bts))));
3579         }
3580     }
3581     return pat;
3582 }
3583
3584 /* --------------------------------------------------------------------------
3585  * Maintaining lists of bound variables and local definitions, for
3586  * dependency and scope analysis.
3587  * ------------------------------------------------------------------------*/
3588
3589 static List bounds;                    /* list of lists of bound vars      */
3590 static List bindings;                  /* list of lists of binds in scope  */
3591 static List depends;                   /* list of lists of dependents      */
3592
3593 /* bounds   :: [[Var]]        -- var equality used on Vars     */
3594 /* bindings :: [[([Var],?)]]  -- var equality used on Vars     */
3595 /* depends  :: [[Var]]        -- pointer equality used on Vars */
3596
3597 #define saveBvars()      hd(bounds)    /* list of bvars in current scope   */
3598 #define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables  */
3599
3600 static Cell local bindPat(line,p)      /* add new bound vars for pattern   */
3601 Int  line;
3602 Cell p; {
3603     patVars    = NIL;
3604     p          = checkPat(line,p);
3605     hd(bounds) = revOnto(patVars,hd(bounds));
3606     return p;
3607 }
3608
3609 static Void local bindPats(line,ps)    /* add new bound vars for patterns  */
3610 Int  line;
3611 List ps; {
3612     patVars    = NIL;
3613     map1Over(checkPat,line,ps);
3614     hd(bounds) = revOnto(patVars,hd(bounds));
3615 }
3616
3617 /* --------------------------------------------------------------------------
3618  * Before processing value and type signature declarations, all data and
3619  * type definitions have been processed so that:
3620  * - all valid type constructors (with their arities) are known.
3621  * - all valid constructor functions (with their arities and types) are
3622  *   known.
3623  *
3624  * The result of parsing a list of value declarations is a list of Eqns:
3625  *       Eqn ::= (SIGDECL,(Line,[Var],type))
3626  *            |  (FIXDECL,(Line,[Op],SyntaxInt))
3627  *            |  (Expr,Rhs)
3628  * The ordering of the equations in this list is the reverse of the original
3629  * ordering in the script parsed.  This is a consequence of the structure of
3630  * the parser ... but also turns out to be most convenient for the static
3631  * analysis.
3632  *
3633  * As the first stage of the static analysis of value declarations, each
3634  * list of Eqns is converted to a list of Bindings.  As part of this
3635  * process:
3636  * - The ordering of the list of Bindings produced is the same as in the
3637  *   original script.
3638  * - When a variable (function) is defined over a number of lines, all
3639  *   of the definitions should appear together and each should give the
3640  *   same arity to the variable being defined.
3641  * - No variable can have more than one definition.
3642  * - For pattern bindings:
3643  *   - Each lhs is a valid pattern/function lhs, all constructor functions
3644  *     have been defined and are used with the correct number of arguments.
3645  *   - Each lhs contains no repeated pattern variables.
3646  *   - Each equation defines at least one variable (e.g. True = False is
3647  *     not allowed).
3648  * - Types appearing in type signatures are well formed:
3649  *    - Type constructors used are defined and used with correct number
3650  *      of arguments.
3651  *    - type variables are replaced by offsets, type constructor names
3652  *      by Tycons.
3653  * - Every variable named in a type signature declaration is defined by
3654  *   one or more equations elsewhere in the script.
3655  * - No variable has more than one type declaration.
3656  * - Similar properties for fixity declarations.
3657  *
3658  * ------------------------------------------------------------------------*/
3659
3660 #define bindingAttr(b) fst(snd(b))     /* type(s)/fixity(ies) for binding  */
3661 #define fbindAlts(b)   snd(snd(b))     /* alternatives for function binding*/
3662
3663 static List local extractSigdecls(es)  /* Extract the SIGDECLS from list   */
3664 List es; {                             /* of equations                     */
3665     List sigdecls = NIL;               /* :: [(Line,[Var],Type)]           */
3666
3667     for(; nonNull(es); es=tl(es)) {
3668         if (fst(hd(es))==SIGDECL) {                  /* type-declaration?  */
3669             Pair sig  = snd(hd(es));
3670             Int  line = intOf(fst3(sig));
3671             List vs   = snd3(sig);
3672             for(; nonNull(vs); vs=tl(vs)) {
3673                 if (isQualIdent(hd(vs))) {
3674                     ERRMSG(line) "Type signature for qualified variable \"%s\" is not allowed",
3675                                  identToStr(hd(vs))
3676                     EEND;
3677                 }
3678             }
3679             sigdecls = cons(sig,sigdecls);           /* discard SIGDECL tag*/
3680         }
3681     }
3682     return sigdecls;
3683 }
3684
3685 static List local extractFixdecls(es)   /* Extract the FIXDECLS from list  */
3686 List es; {                              /* of equations                    */
3687     List fixdecls = NIL;                /* :: [(Line,SyntaxInt,[Op])]      */
3688
3689     for(; nonNull(es); es=tl(es)) {
3690         if (fst(hd(es))==FIXDECL) {                  /* fixity declaration?*/
3691             fixdecls = cons(snd(hd(es)),fixdecls);   /* discard FIXDECL tag*/
3692         }
3693     }
3694     return fixdecls;
3695 }
3696
3697 static List local extractBindings(ds)   /* extract untyped bindings from   */
3698 List ds; {                              /* given list of equations         */
3699     Cell lastVar   = NIL;               /* = var def'd in last eqn (if any)*/
3700     Int  lastArity = 0;                 /* = number of args in last defn   */
3701     List bs        = NIL;               /* :: [Binding]                    */
3702
3703     for(; nonNull(ds); ds=tl(ds)) {
3704         Cell d = hd(ds);
3705         if (fst(d)==FUNBIND) {          /* Function bindings               */
3706             Cell rhs    = snd(snd(d));
3707             Int  line   = rhsLine(rhs);
3708             Cell lhs    = fst(snd(d));
3709             Cell v      = getHead(lhs);
3710             Cell newAlt = pair(getArgs(lhs),rhs);
3711             if (!isVar(v)) {
3712                 internal("FUNBIND");
3713             }
3714             if (nonNull(lastVar) && textOf(v)==textOf(lastVar)) {
3715                 if (argCount!=lastArity) {
3716                     ERRMSG(line) "Equations give different arities for \"%s\"",
3717                                  textToStr(textOf(v))
3718                     EEND;
3719                 }
3720                 fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
3721             }
3722             else {
3723                 lastVar   = v;
3724                 lastArity = argCount;
3725                 notDefined(line,bs,v);
3726                 bs        = cons(pair(v,pair(NIL,singleton(newAlt))),bs);
3727             }
3728
3729         } else if (fst(d)==PATBIND) {   /* Pattern bindings                */
3730             Cell rhs  = snd(snd(d));
3731             Int  line = rhsLine(rhs);
3732             Cell pat  = fst(snd(d));
3733             while (whatIs(pat)==ESIGN) {/* Move type annotations to rhs   */
3734                 Cell p        = fst(snd(pat));
3735                 fst(snd(pat)) = rhs;
3736                 snd(snd(d))   = rhs = pat;
3737                 fst(snd(d))   = pat = p;
3738                 fst(rhs)      = RSIGN;
3739             }
3740             if (isVar(pat)) {           /* Convert simple pattern bind to */
3741                 notDefined(line,bs,pat);/* a function binding             */
3742                 bs = cons(pair(pat,pair(NIL,singleton(pair(NIL,rhs)))),bs);
3743             } else {
3744                 List vs = getPatVars(line,pat,NIL);
3745                 if (isNull(vs)) {
3746                     ERRMSG(line) "No variables defined in lhs pattern"
3747                     EEND;
3748                 }
3749                 map2Proc(notDefined,line,bs,vs);
3750                 bs          = cons(pair(vs,pair(NIL,snd(d))),bs);
3751             }
3752             lastVar = NIL;
3753         }
3754     }
3755     return bs;
3756 }
3757
3758 static List local getPatVars(line,p,vs) /* Find list of variables bound in */
3759 Int  line;                              /* pattern p                       */
3760 Cell p;
3761 List vs; {
3762     switch (whatIs(p)) {
3763         case AP         : do {
3764                               vs = getPatVars(line,arg(p),vs);
3765                               p  = fun(p);
3766                           } while (isAp(p));
3767                           return vs;    /* Ignore head of application      */
3768
3769         case CONFLDS    : {   List pfs = snd(snd(p));
3770                               for (; nonNull(pfs); pfs=tl(pfs)) {
3771                                   if (isVar(hd(pfs))) {
3772                                       vs = addPatVar(line,hd(pfs),vs);
3773                                   } else {
3774                                       vs = getPatVars(line,snd(hd(pfs)),vs);
3775                                   }
3776                               }
3777                           }
3778                           return vs;
3779
3780         case FINLIST    : {   List ps = snd(p);
3781                               for (; nonNull(ps); ps=tl(ps)) {
3782                                   vs = getPatVars(line,hd(ps),vs);
3783                               }
3784                           }
3785                           return vs;
3786
3787         case ESIGN      : return getPatVars(line,fst(snd(p)),vs);
3788
3789         case LAZYPAT    :
3790         case NEG        :
3791         case ONLY       :
3792         case INFIX      : return getPatVars(line,snd(p),vs);
3793
3794         case ASPAT      : return addPatVar(line,fst(snd(p)),
3795                                              getPatVars(line,snd(snd(p)),vs));
3796
3797         case VARIDCELL  :
3798         case VAROPCELL  : return addPatVar(line,p,vs);
3799
3800         case CONIDCELL  :
3801         case CONOPCELL  :
3802         case QUALIDENT  :
3803         case INTCELL    :
3804         case FLOATCELL  :
3805         case CHARCELL   :
3806         case STRCELL    :
3807         case NAME       :
3808         case WILDCARD   : return vs;
3809
3810         default         : internal("getPatVars");
3811     }
3812     return vs;
3813 }
3814
3815 static List local addPatVar(line,v,vs)  /* Add var to list of previously   */
3816 Int  line;                              /* encountered variables           */
3817 Cell v;
3818 List vs; {
3819     if (varIsMember(textOf(v),vs)) {
3820         ERRMSG(line) "Repeated use of variable \"%s\" in pattern binding",
3821                      textToStr(textOf(v))
3822         EEND;
3823     }
3824     return cons(v,vs);
3825 }
3826
3827 static List local eqnsToBindings(es,ts,cs,ps)
3828 List es;                                /* Convert list of equations to    */
3829 List ts;                                /* list of typed bindings          */
3830 List cs;
3831 List ps; {
3832     List bs = extractBindings(es);
3833     map1Proc(addSigdecl,bs,extractSigdecls(es));
3834     map4Proc(addFixdecl,bs,ts,cs,ps,extractFixdecls(es));
3835     return bs;
3836 }
3837
3838 static Void local notDefined(line,bs,v)/* check if name already defined in */
3839 Int  line;                             /* list of bindings                 */
3840 List bs;
3841 Cell v; {
3842     if (nonNull(findBinding(textOf(v),bs))) {
3843         ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
3844         EEND;
3845     }
3846 }
3847
3848 static Cell local findBinding(t,bs)    /* look for binding for variable t  */
3849 Text t;                                /* in list of bindings bs           */
3850 List bs; {
3851     for (; nonNull(bs); bs=tl(bs)) {
3852         if (isVar(fst(hd(bs)))) {                     /* function-binding? */
3853             if (textOf(fst(hd(bs)))==t) {
3854                 return hd(bs);
3855             }
3856         } else if (nonNull(varIsMember(t,fst(hd(bs))))){/* pattern-binding?*/
3857             return hd(bs);
3858         }
3859     }
3860     return NIL;
3861 }
3862
3863 static Cell local getAttr(bs,v)         /* Locate type/fixity attribute    */
3864 List bs;                                /* for variable v in bindings bs   */
3865 Cell v; {
3866     Text t = textOf(v);
3867     Cell b = findBinding(t,bs);
3868
3869     if (isNull(b)) {                                    /* No binding      */
3870         return NIL;
3871     } else if (isVar(fst(b))) {                         /* func binding?   */
3872         if (isNull(bindingAttr(b))) {
3873             bindingAttr(b) = pair(NIL,NIL);
3874         }
3875         return bindingAttr(b);
3876     } else {                                            /* pat binding?    */
3877         List vs = fst(b);
3878         List as = bindingAttr(b);
3879
3880         if (isNull(as)) {
3881             bindingAttr(b) = as = replicate(length(vs),NIL);
3882         }
3883
3884         while (nonNull(vs) && t!=textOf(hd(vs))) {
3885             vs = tl(vs);
3886             as = tl(as);
3887         }
3888
3889         if (isNull(vs)) {
3890             internal("getAttr");
3891         } else if (isNull(hd(as))) {
3892             hd(as) = pair(NIL,NIL);
3893         }
3894         return hd(as);
3895     }
3896 }
3897
3898 static Void local addSigdecl(bs,sigdecl)/* add type information to bindings*/
3899 List bs;                               /* :: [Binding]                     */
3900 Cell sigdecl; {                        /* :: (Line,[Var],Type)             */
3901     Int  l    = intOf(fst3(sigdecl));
3902     List vs   = snd3(sigdecl);
3903     Type type = checkSigType(l,"type declaration",hd(vs),thd3(sigdecl));
3904
3905     for (; nonNull(vs); vs=tl(vs)) {
3906         Cell v    = hd(vs);
3907         Pair attr = getAttr(bs,v);
3908         if (isNull(attr)) {
3909             ERRMSG(l) "Missing binding for variable \"%s\" in type signature",
3910                       textToStr(textOf(v))
3911             EEND;
3912         } else if (nonNull(fst(attr))) {
3913             ERRMSG(l) "Repeated type signature for \"%s\"",
3914                       textToStr(textOf(v))
3915             EEND;
3916         }
3917         fst(attr) = type;
3918     }
3919 }
3920
3921 static Void local addFixdecl(bs,ts,cs,ps,fixdecl)
3922 List   bs;
3923 List   ts;
3924 List   cs;
3925 List   ps;
3926 Triple fixdecl; {
3927     Int  line = intOf(fst3(fixdecl));
3928     List ops  = snd3(fixdecl);
3929     Cell sy   = thd3(fixdecl);
3930
3931     for (; nonNull(ops); ops=tl(ops)) {
3932         Cell op   = hd(ops);
3933         Text t    = textOf(op);
3934         Cell attr = getAttr(bs,op);
3935         if (nonNull(attr)) {            /* Found name in binding?          */
3936             if (nonNull(snd(attr))) {
3937                 dupFixity(line,t);
3938             }
3939             snd(attr) = sy;
3940         } else {                        /* Look in tycons, classes, prims  */
3941             Name n   = NIL;
3942             List ts1 = ts;
3943             List cs1 = cs;
3944             List ps1 = ps;
3945             for (; isNull(n) && nonNull(ts1); ts1=tl(ts1)) {    /* tycons  */
3946                 Tycon tc = hd(ts1);
3947                 if (tycon(tc).what==DATATYPE || tycon(tc).what==NEWTYPE) {
3948                     n = nameIsMember(t,tycon(tc).defn);
3949                 }
3950             }
3951             for (; isNull(n) && nonNull(cs1); cs1=tl(cs1)) {    /* classes */
3952                 n = nameIsMember(t,cclass(hd(cs1)).members);
3953             }
3954             for (; isNull(n) && nonNull(ps1); ps1=tl(ps1)) {    /* prims   */
3955                 n = nameIsMember(t,hd(ps1));
3956             }
3957
3958             if (isNull(n)) {
3959                 missFixity(line,t);
3960             } else if (name(n).syntax!=NO_SYNTAX) {
3961                 dupFixity(line,t);
3962             }
3963             name(n).syntax = intOf(sy);
3964         }
3965     }
3966 }
3967
3968 static Void local dupFixity(line,t)     /* Report repeated fixity decl     */
3969 Int  line;
3970 Text t; {
3971     ERRMSG(line)
3972         "Repeated fixity declaration for operator \"%s\"", textToStr(t)
3973     EEND;
3974 }
3975
3976 static Void local missFixity(line,t)    /* Report missing op for fixity    */
3977 Int  line;
3978 Text t; {
3979     ERRMSG(line)
3980         "Cannot find binding for operator \"%s\" in fixity declaration",
3981         textToStr(t)
3982     EEND;
3983 }
3984
3985 /* --------------------------------------------------------------------------
3986  * Dealing with infix operators:
3987  *
3988  * Expressions involving infix operators or unary minus are parsed as
3989  * elements of the following type:
3990  *
3991  *     data InfixExp = Only Exp | Neg InfixExp | Infix InfixExp Op Exp
3992  *
3993  * (The algorithms here do not assume that negation can be applied only once,
3994  * i.e., that - - x is a syntax error, as required by the Haskell report.
3995  * Instead, that restriction is captured by the grammar itself, given above.)
3996  *
3997  * There are rules of precedence and grouping, expressed by two functions:
3998  *
3999  *     prec :: Op -> Int;   assoc :: Op -> Assoc    (Assoc = {L, N, R})
4000  *
4001  * InfixExp values are rearranged accordingly when a complete expression
4002  * has been read using a simple shift-reduce parser whose result may be taken
4003  * to be a value of the following type:
4004  *
4005  *     data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
4006  *
4007  * The machine on which this parser is based can be defined as follows:
4008  *
4009  *     tidy                         :: InfixExp -> [(Op,Exp)] -> Exp
4010  *     tidy (Only a)      []         = a
4011  *     tidy (Only a)      ((o,b):ss) = tidy (Only (Apply o a b)) ss
4012  *     tidy (Infix a o b) []         = tidy a [(o,b)]
4013  *     tidy (Infix a o b) ((p,c):ss)
4014  *                      | shift  o p = tidy a ((o,b):(p,c):ss)
4015  *                      | red    o p = tidy (Infix a o (Apply p b c)) ss
4016  *                      | ambig  o p = Error "ambiguous use of operators"
4017  *     tidy (Neg e)       []         = tidy (tidyNeg e) []
4018  *     tidy (Neg e)       ((o,b):ss)
4019  *                      | nshift o   = tidy (Neg (underNeg o b e)) ss
4020  *                      | nred   o   = tidy (tidyNeg e) ((o,b):ss)
4021  *                      | nambig o   = Error "illegal use of negation"
4022  *
4023  * At each stage, the parser can either shift, reduce, accept, or error.
4024  * The transitions when dealing with juxtaposed operators o and p are
4025  * determined by the following rules:
4026  *
4027  *     shift o p  = (prec o > prec p)
4028  *               || (prec o == prec p && assoc o == L && assoc p == L)
4029  *
4030  *     red o p    = (prec o < prec p)
4031  *               || (prec o == prec p && assoc o == R && assoc p == R)
4032  *
4033  *     ambig o p  = (prec o == prec p)
4034  *               && (assoc o == N || assoc p == N || assoc o /= assoc p)
4035  *
4036  * The transitions when dealing with juxtaposed unary minus and infix
4037  * operators are as follows.  The precedence of unary minus (infixl 6) is
4038  * hardwired in to these definitions, as it is to the definitions of the
4039  * Haskell grammar in the official report.
4040  *
4041  *     nshift o   = (prec o > 6)
4042  *     nred   o   = (prec o < 6) || (prec o == 6 && assoc o == L)
4043  *     nambig o   = prec o == 6 && (assoc o == R || assoc o == N)
4044  *
4045  * An InfixExp of the form (Neg e) means negate the last thing in
4046  * the InfixExp e; we can force this negation using:
4047  *
4048  *     tidyNeg              :: OpExp -> OpExp
4049  *     tidyNeg (Only e)      = Only (Negate e)
4050  *     tidyNeg (Infix a o b) = Infix a o (Negate b)
4051  *     tidyNeg (Neg e)       = tidyNeg (tidyNeg e)
4052  *
4053  * On the other hand, if we want to sneak application of an infix operator
4054  * under a negation, then we use:
4055  *
4056  *     underNeg                  :: Op -> Exp -> OpExp -> OpExp
4057  *     underNeg o b (Only e)      = Only (Apply o e b)
4058  *     underNeg o b (Neg e)       = Neg (underNeg o b e)
4059  *     underNeg o b (Infix e p f) = Infix e p (Apply o f b)
4060  *
4061  * As a concession to efficiency, we lower the number of calls to syntaxOf
4062  * by keeping track of the values of sye, sys throughout the process.  The
4063  * value APPLIC is used to indicate that the syntax value is unknown.
4064  * ------------------------------------------------------------------------*/
4065
4066 static Cell local tidyInfix(line,e)     /* Convert infixExp to Exp         */
4067 Int  line;
4068 Cell e; {                               /* :: OpExp                        */
4069     Cell   s   = NIL;                   /* :: [(Op,Exp)]                   */
4070     Syntax sye = APPLIC;                /* Syntax of op in e (init unknown)*/
4071     Syntax sys = APPLIC;                /* Syntax of op in s (init unknown)*/
4072     Cell   d   = e;
4073
4074     while (fst(d)!=ONLY) {              /* Attach fixities to operators    */
4075         if (fst(d)==NEG) {
4076             d = snd(d);
4077         } else {
4078             fun(fun(d)) = attachFixity(line,fun(fun(d)));
4079             d           = arg(fun(d));
4080         }
4081     }
4082
4083     for (;;)
4084         switch (whatIs(e)) {
4085             case ONLY : e = snd(e);
4086                         while (nonNull(s)) {
4087                             Cell next   = arg(fun(s));
4088                             arg(fun(s)) = e;
4089                             fun(fun(s)) = snd(fun(fun(s)));
4090                             e           = s;
4091                             s           = next;
4092                         }
4093                         return e;
4094
4095             case NEG  : if (nonNull(s)) {
4096                             if (sys==APPLIC) {  /* calculate sys           */
4097                                 sys = intOf(fst(fun(fun(s))));
4098                             }
4099
4100                             if (precOf(sys)==UMINUS_PREC &&     /* nambig  */
4101                                 assocOf(sys)!=UMINUS_ASSOC) {
4102                                 ERRMSG(line)
4103                                  "Ambiguous use of unary minus with \""
4104                                 ETHEN ERREXPR(snd(fun(fun(s))));
4105                                 ERRTEXT "\""
4106                                 EEND;
4107                             }
4108
4109                             if (precOf(sys)>UMINUS_PREC) {      /* nshift  */
4110                                 Cell e1    = snd(e);
4111                                 Cell t     = s;
4112                                 s          = arg(fun(s));
4113                                 while (whatIs(e1)==NEG)
4114                                     e1 = snd(e1);
4115                                 arg(fun(t)) = arg(e1);
4116                                 fun(fun(t)) = snd(fun(fun(t)));
4117                                 arg(e1)     = t;
4118                                 sys         = APPLIC;
4119                                 continue;
4120                             }
4121                         }
4122
4123                         /* Intentional fall-thru for nreduce and isNull(s) */
4124
4125                         {   Cell prev = e;              /* e := tidyNeg e  */
4126                             Cell temp = arg(prev);
4127                             Int  nneg = 1;
4128                             for (; whatIs(temp)==NEG; nneg++) {
4129                                 fun(prev) = nameNegate;
4130                                 prev      = temp;
4131                                 temp      = arg(prev);
4132                             }
4133                             if (isInt(arg(temp))) {     /* special cases   */
4134                                 if (nneg&1)             /* for literals    */
4135                                     arg(temp) = mkInt(-intOf(arg(temp)));
4136                             }
4137                             else if (isFloat(arg(temp))) {
4138                                 if (nneg&1)
4139                                     arg(temp) = floatNegate(arg(temp));
4140                                                 //mkFloat(-floatOf(arg(temp)));
4141                             }
4142                             else {
4143                                 fun(prev) = nameNegate;
4144                                 arg(prev) = arg(temp);
4145                                 arg(temp) = e;
4146                             }
4147                             e = temp;
4148                         }
4149                         continue;
4150
4151             default   : if (isNull(s)) {/* Move operation onto empty stack */
4152                             Cell next   = arg(fun(e));
4153                             s           = e;
4154                             arg(fun(s)) = NIL;
4155                             e           = next;
4156                             sys         = sye;
4157                             sye         = APPLIC;
4158                         }
4159                         else {          /* deal with pair of operators     */
4160
4161                             if (sye==APPLIC) {  /* calculate sys and sye   */
4162                                 sye = intOf(fst(fun(fun(e))));
4163                             }
4164                             if (sys==APPLIC) {
4165                                 sys = intOf(fst(fun(fun(s))));
4166                             }
4167
4168                             if (precOf(sye)==precOf(sys) &&     /* ambig   */
4169                                 (assocOf(sye)!=assocOf(sys) ||
4170                                  assocOf(sye)==NON_ASS)) {
4171                                 ERRMSG(line) "Ambiguous use of operator \""
4172                                 ETHEN ERREXPR(snd(fun(fun(e))));
4173                                 ERRTEXT "\" with \""
4174                                 ETHEN ERREXPR(snd(fun(fun(s))));
4175                                 ERRTEXT "\""
4176                                 EEND;
4177                             }
4178
4179                             if (precOf(sye)>precOf(sys) ||      /* shift   */
4180                                 (precOf(sye)==precOf(sys) &&
4181                                  assocOf(sye)==LEFT_ASS &&
4182                                  assocOf(sys)==LEFT_ASS)) {
4183                                 Cell next   = arg(fun(e));
4184                                 arg(fun(e)) = s;
4185                                 s           = e;
4186                                 e           = next;
4187                                 sys         = sye;
4188                                 sye         = APPLIC;
4189                             }
4190                             else {                              /* reduce  */
4191                                 Cell next   = arg(fun(s));
4192                                 arg(fun(s)) = arg(e);
4193                                 fun(fun(s)) = snd(fun(fun(s)));
4194                                 arg(e)      = s;
4195                                 s           = next;
4196                                 sys         = APPLIC;
4197                                 /* sye unchanged */
4198                             }
4199                         }
4200                         continue;
4201         }
4202 }
4203
4204 static Pair local attachFixity(line,op) /* Attach fixity to operator in an */
4205 Int  line;                              /* infix expression                */
4206 Cell op; {
4207     Syntax sy = DEF_OPSYNTAX;
4208
4209     switch (whatIs(op)) {
4210         case VAROPCELL :
4211         case VARIDCELL : if ((sy=lookupSyntax(textOf(op)))==NO_SYNTAX) {
4212                              Name n = findName(textOf(op));
4213                              if (isNull(n)) {
4214                                 ERRMSG(line) "Undefined variable \"%s\"",
4215                                              textToStr(textOf(op))
4216                                 EEND;
4217                              }
4218                              sy = syntaxOf(n);
4219                              op = n;
4220                          }
4221                          break;
4222
4223         case CONOPCELL :
4224         case CONIDCELL : sy = syntaxOf(op = conDefined(line,op));
4225                          break;
4226
4227         case QUALIDENT : {   Name n = findQualName(op);
4228                              if (nonNull(n)) {
4229                                  op = n;
4230                                  sy = syntaxOf(n);
4231                              } else {
4232                                  ERRMSG(line)
4233                                    "Undefined qualified variable \"%s\"",
4234                                    identToStr(op)
4235                                  EEND;
4236                              }
4237                          }
4238                          break;
4239     }
4240     if (sy==APPLIC) {
4241         sy = DEF_OPSYNTAX;
4242     }
4243     return pair(mkInt(sy),op);          /* Pair fixity with (possibly)     */
4244                                         /* translated operator             */
4245 }
4246
4247 static Syntax local lookupSyntax(t)     /* Try to find fixity for var in   */
4248 Text t; {                               /* enclosing bindings              */
4249     List bounds1   = bounds;
4250     List bindings1 = bindings;
4251
4252     while (nonNull(bindings1)) {
4253         if (nonNull(varIsMember(t,hd(bounds1)))) {
4254             return DEF_OPSYNTAX;
4255         } else {
4256             Cell b = findBinding(t,hd(bindings1));
4257             if (nonNull(b)) {
4258                 Cell a = fst(snd(b));
4259                 if (isVar(fst(b))) {    /* Function binding                */
4260                     if (nonNull(a) && nonNull(snd(a))) {
4261                         return intOf(snd(a));
4262                     }
4263                 } else {                /* Pattern binding                 */
4264                     List vs = fst(b);
4265                     while (nonNull(vs) && nonNull(a)) {
4266                         if (t==textOf(hd(vs))) {
4267                             if (nonNull(hd(a)) && isInt(snd(hd(a)))) {
4268                                 return intOf(snd(hd(a)));
4269                             }
4270                             break;
4271                         }
4272                         vs = tl(vs);
4273                         a  = tl(a);
4274                     }
4275                 }
4276                 return DEF_OPSYNTAX;
4277             }
4278         }
4279         bounds1   = tl(bounds1);
4280         bindings1 = tl(bindings1);
4281     }
4282     return NO_SYNTAX;
4283 }
4284
4285 /* --------------------------------------------------------------------------
4286  * To facilitate dependency analysis, lists of bindings are temporarily
4287  * augmented with an additional field, which is used in two ways:
4288  * - to build the `adjacency lists' for the dependency graph. Represented by
4289  *   a list of pointers to other bindings in the same list of bindings.
4290  * - to hold strictly positive integer values (depth first search numbers) of
4291  *   elements `on the stack' during the strongly connected components search
4292  *   algorithm, or a special value mkInt(0), once the binding has been added
4293  *   to a particular strongly connected component.
4294  *
4295  * Using this extra field, the type of each list of declarations during
4296  * dependency analysis is [Binding'] where:
4297  *
4298  *    Binding' ::= (Var, (Attr, (Dep, [Alt])))         -- function binding
4299  *              |  ([Var], ([Attr], (Dep, (Pat,Rhs)))) -- pattern binding
4300  *
4301  * ------------------------------------------------------------------------*/
4302
4303 #define depVal(d) (fst(snd(snd(d))))    /* Access to dependency information*/
4304
4305 static List local dependencyAnal(bs)    /* Separate lists of bindings into */
4306 List bs; {                              /* mutually recursive groups in    */
4307                                         /* order of dependency             */
4308     mapProc(addDepField,bs);            /* add extra field for dependents  */
4309     mapProc(depBinding,bs);             /* find dependents of each binding */
4310     bs = bscc(bs);                      /* sort to strongly connected comps*/
4311     mapProc(remDepField,bs);            /* remove dependency info field    */
4312     return bs;
4313 }
4314
4315 static List local topDependAnal(bs)     /* Like dependencyAnal(), but at   */
4316 List bs; {                              /* top level, reporting on progress*/
4317     List xs;
4318     Int  i = 0;
4319
4320     setGoal("Dependency analysis",(Target)(length(bs)));
4321
4322     mapProc(addDepField,bs);           /* add extra field for dependents   */
4323     for (xs=bs; nonNull(xs); xs=tl(xs)) {
4324         emptySubstitution();
4325         depBinding(hd(xs));
4326         soFar((Target)(i++));
4327     }
4328     bs = bscc(bs);                     /* sort to strongly connected comps */
4329     mapProc(remDepField,bs);           /* remove dependency info field     */
4330     done();
4331     return bs;
4332 }
4333
4334 static Void local addDepField(b)       /* add extra field to binding to    */
4335 Cell b; {                              /* hold list of dependents          */
4336     snd(snd(b)) = pair(NIL,snd(snd(b)));
4337 }
4338
4339 static Void local remDepField(bs)      /* remove dependency field from     */
4340 List bs; {                             /* list of bindings                 */
4341     mapProc(remDepField1,bs);
4342 }
4343
4344 static Void local remDepField1(b)      /* remove dependency field from     */
4345 Cell b; {                              /* single binding                   */
4346     snd(snd(b)) = snd(snd(snd(b)));
4347 }
4348
4349 static Void local clearScope() {       /* initialise dependency scoping    */
4350     bounds   = NIL;
4351     bindings = NIL;
4352     depends  = NIL;
4353 }
4354
4355 static Void local withinScope(bs)       /* Enter scope of bindings bs      */
4356 List bs; {
4357     bounds   = cons(NIL,bounds);
4358     bindings = cons(bs,bindings);
4359     depends  = cons(NIL,depends);
4360 }
4361
4362 static Void local leaveScope() {        /* Leave scope of last withinScope */
4363     List bs       = hd(bindings);       /* Remove fixity info from binds   */
4364     Bool toplevel = isNull(tl(bindings));
4365     for (; nonNull(bs); bs=tl(bs)) {
4366         Cell b = hd(bs);
4367         if (isVar(fst(b))) {            /* Variable binding                */
4368             Cell a = fst(snd(b));
4369             if (isPair(a)) {
4370                 if (toplevel) {
4371                     saveSyntax(fst(b),snd(a));
4372                 }
4373                 fst(snd(b)) = fst(a);
4374             }
4375         } else {                        /* Pattern binding                 */
4376             List vs = fst(b);
4377             List as = fst(snd(b));
4378             while (nonNull(vs) && nonNull(as)) {
4379                 if (isPair(hd(as))) {
4380                     if (toplevel) {
4381                         saveSyntax(hd(vs),snd(hd(as)));
4382                     }
4383                     hd(as) = fst(hd(as));
4384                 }
4385                 vs = tl(vs);
4386                 as = tl(as);
4387             }
4388         }
4389     }
4390     bounds   = tl(bounds);
4391     bindings = tl(bindings);
4392     depends  = tl(depends);
4393 }
4394
4395 static Void local saveSyntax(v,sy)      /* Save syntax of top-level var    */
4396 Cell v;                                 /* in corresponding Name           */
4397 Cell sy; {
4398     Name n = findName(textOf(v));
4399     if (isNull(n) || name(n).syntax!=NO_SYNTAX) {
4400         internal("saveSyntax");
4401     }
4402     if (nonNull(sy)) {
4403         name(n).syntax = intOf(sy);
4404     }
4405 }
4406
4407 /* --------------------------------------------------------------------------
4408  * As a side effect of the dependency analysis we also make the following
4409  * checks:
4410  * - Each lhs is a valid pattern/function lhs, all constructor functions
4411  *   have been defined and are used with the correct number of arguments.
4412  * - No lhs contains repeated pattern variables.
4413  * - Expressions used on the rhs of an eqn should be well formed.  This
4414  *   includes:
4415  *   - Checking for valid patterns (including repeated vars) in lambda,
4416  *     case, and list comprehension expressions.
4417  *   - Recursively checking local lists of equations.
4418  * - No free (i.e. unbound) variables are used in the declaration list.
4419  * ------------------------------------------------------------------------*/
4420
4421 static Void local depBinding(b)        /* find dependents of binding       */
4422 Cell b; {
4423     Cell defpart = snd(snd(snd(b)));   /* definition part of binding       */
4424
4425     hd(depends) = NIL;
4426
4427     if (isVar(fst(b))) {               /* function-binding?                */
4428         mapProc(depAlt,defpart);
4429         if (isNull(fst(snd(b)))) {      /* Save dep info if no type sig    */
4430             fst(snd(b)) = pair(ap(IMPDEPS,hd(depends)),NIL);
4431         } else if (isNull(fst(fst(snd(b))))) {
4432             fst(fst(snd(b))) = ap(IMPDEPS,hd(depends));
4433         }
4434     } else {                           /* pattern-binding?                 */
4435         Int line = rhsLine(snd(defpart));
4436         enterBtyvs();
4437         patVars = NIL;
4438         fst(defpart) = checkPat(line,fst(defpart));
4439         depRhs(snd(defpart));
4440 #if 0
4441         if (nonNull(hd(btyvars))) {
4442             ERRMSG(line)
4443               "Sorry, no type variables are allowed in pattern binding type annotations"
4444             EEND;
4445         }
4446 #endif
4447         fst(defpart) = applyBtyvs(fst(defpart));
4448     }
4449     depVal(b) = hd(depends);
4450 }
4451
4452 static Void local depDefaults(c)       /* dependency analysis on defaults  */
4453 Class c; {                             /* from class definition            */
4454     depClassBindings(cclass(c).defaults);
4455 }
4456
4457 static Void local depInsts(in)         /* dependency analysis on instance  */
4458 Inst in; {                             /* bindings                         */
4459     depClassBindings(inst(in).implements);
4460 }
4461
4462 static Void local depClassBindings(bs) /* dependency analysis on list of   */
4463 List bs; {                             /* bindings, possibly containing    */
4464     for (; nonNull(bs); bs=tl(bs)) {   /* NIL bindings ...                 */
4465         if (nonNull(hd(bs))) {         /* No need to add extra field for   */
4466            mapProc(depAlt,snd(hd(bs)));/* dependency information...        */
4467         }
4468     }
4469 }
4470
4471 static Void local depAlt(a)             /* Find dependents of alternative  */
4472 Cell a; {
4473     List obvs = saveBvars();            /* Save list of bound variables    */
4474     enterBtyvs();
4475     bindPats(rhsLine(snd(a)),fst(a));   /* add new bound vars for patterns */
4476     depRhs(snd(a));                     /* find dependents of rhs          */
4477     fst(a)    = applyBtyvs(fst(a));
4478     restoreBvars(obvs);                 /* restore original list of bvars  */
4479 }
4480
4481 static Void local depRhs(r)             /* Find dependents of rhs          */
4482 Cell r; {
4483     switch (whatIs(r)) {
4484         case GUARDED : mapProc(depGuard,snd(r));
4485                        break;
4486
4487         case LETREC  : fst(snd(r)) = eqnsToBindings(fst(snd(r)),NIL,NIL,NIL);
4488                        withinScope(fst(snd(r)));
4489                        fst(snd(r)) = dependencyAnal(fst(snd(r)));
4490                        hd(depends) = fst(snd(r));
4491                        depRhs(snd(snd(r)));
4492                        leaveScope();
4493                        break;
4494
4495         case RSIGN   : snd(snd(r)) = checkPatType(rhsLine(fst(snd(r))),
4496                                                   "result",
4497                                                   rhsExpr(fst(snd(r))),
4498                                                   snd(snd(r)));
4499                        depRhs(fst(snd(r)));
4500                        break;
4501
4502         default      : snd(r) = depExpr(intOf(fst(r)),snd(r));
4503                        break;
4504     }
4505 }
4506
4507 static Void local depGuard(g)          /* find dependents of single guarded*/
4508 Cell g; {                              /* expression                       */
4509     depPair(intOf(fst(g)),snd(g));
4510 }
4511
4512 static Cell local depExpr(line,e)      /* find dependents of expression    */
4513 Int  line;
4514 Cell e; {
4515   //Printf( "\n\n"); print(e,100); Printf("\n");
4516   //printExp(stdout,e);
4517     switch (whatIs(e)) {
4518
4519         case VARIDCELL  :
4520         case VAROPCELL  : return depVar(line,e);
4521
4522         case CONIDCELL  :
4523         case CONOPCELL  : return conDefined(line,e);
4524
4525         case QUALIDENT  : if (isQVar(e)) {
4526                               return depQVar(line,e);
4527                           } else { /* QConOrConOp */
4528                               return conDefined(line,e);
4529                           }
4530
4531         case INFIX     : return depExpr(line,tidyInfix(line,snd(e)));
4532
4533 #if TREX
4534         case RECSEL     : break;
4535
4536         case AP         : if (isAp(e) && isAp(fun(e)) && isExt(fun(fun(e)))) {
4537                               return depRecord(line,e);
4538                           } else {
4539                               Cell nx = e;
4540                               Cell a;
4541                               do {
4542                                   a      = nx;
4543                                   arg(a) = depExpr(line,arg(a));
4544                                   nx     = fun(a);
4545                               } while (isAp(nx));
4546                               fun(a) = depExpr(line,fun(a));
4547                           }
4548                           break;
4549 #else
4550         case AP         : depPair(line,e);
4551                           break;
4552 #endif
4553
4554 #if IPARAM
4555         case IPVAR      :
4556 #endif
4557
4558         case NAME       :
4559         case TUPLE      :
4560         case STRCELL    :
4561         case CHARCELL   :
4562         case FLOATCELL  :
4563         case BIGCELL    :
4564         case INTCELL    : break;
4565
4566         case COND       : depTriple(line,snd(e));
4567                           break;
4568
4569         case FINLIST    : map1Over(depExpr,line,snd(e));
4570                           break;
4571
4572         case LETREC     : fst(snd(e)) = eqnsToBindings(fst(snd(e)),NIL,NIL,NIL);
4573                           withinScope(fst(snd(e)));
4574                           fst(snd(e)) = dependencyAnal(fst(snd(e)));
4575                           hd(depends) = fst(snd(e));
4576                           snd(snd(e)) = depExpr(line,snd(snd(e)));
4577                           leaveScope();
4578                           break;
4579
4580         case LAMBDA     : depAlt(snd(e));
4581                           break;
4582
4583         case DOCOMP     : /* fall-thru */
4584         case COMP       : depComp(line,snd(e),snd(snd(e)));
4585                           break;
4586
4587         case ESIGN      : fst(snd(e)) = depExpr(line,fst(snd(e)));
4588                           snd(snd(e)) = checkSigType(line,
4589                                                      "expression",
4590                                                      fst(snd(e)),
4591                                                      snd(snd(e)));
4592                           break;
4593
4594         case CASE       : fst(snd(e)) = depExpr(line,fst(snd(e)));
4595                           map1Proc(depCaseAlt,line,snd(snd(e)));
4596                           break;
4597
4598         case CONFLDS    : depConFlds(line,e,FALSE);
4599                           break;
4600
4601         case UPDFLDS    : depUpdFlds(line,e);
4602                           break;
4603
4604 #if IPARAM
4605         case WITHEXP    : depWith(line,e);
4606                           break;
4607 #endif
4608
4609         case ASPAT      : ERRMSG(line) "Illegal `@' in expression"
4610                           EEND;
4611
4612         case LAZYPAT    : ERRMSG(line) "Illegal `~' in expression"
4613                           EEND;
4614
4615         case WILDCARD   : ERRMSG(line) "Illegal `_' in expression"
4616                           EEND;
4617
4618 #if TREX
4619         case EXT        : ERRMSG(line) "Illegal application of record"
4620                           EEND;
4621 #endif
4622
4623         default         : internal("depExpr");
4624    }
4625    return e;
4626 }
4627
4628 static Void local depPair(line,e)       /* find dependents of pair of exprs*/
4629 Int  line;
4630 Cell e; {
4631     fst(e) = depExpr(line,fst(e));
4632     snd(e) = depExpr(line,snd(e));
4633 }
4634
4635 static Void local depTriple(line,e)     /* find dependents of triple exprs */
4636 Int  line;
4637 Cell e; {
4638     fst3(e) = depExpr(line,fst3(e));
4639     snd3(e) = depExpr(line,snd3(e));
4640     thd3(e) = depExpr(line,thd3(e));
4641 }
4642
4643 static Void local depComp(l,e,qs)       /* find dependents of comprehension*/
4644 Int  l;
4645 Cell e;
4646 List qs; {
4647     if (isNull(qs)) {
4648         fst(e) = depExpr(l,fst(e));
4649     } else {
4650         Cell q   = hd(qs);
4651         List qs1 = tl(qs);
4652         switch (whatIs(q)) {
4653             case FROMQUAL : {   List obvs   = saveBvars();
4654                                 snd(snd(q)) = depExpr(l,snd(snd(q)));
4655                                 enterBtyvs();
4656                                 fst(snd(q)) = bindPat(l,fst(snd(q)));
4657                                 depComp(l,e,qs1);
4658                                 fst(snd(q)) = applyBtyvs(fst(snd(q)));
4659                                 restoreBvars(obvs);
4660                             }
4661                             break;
4662
4663             case QWHERE   : snd(q)      = eqnsToBindings(snd(q),NIL,NIL,NIL);
4664                             withinScope(snd(q));
4665                             snd(q)      = dependencyAnal(snd(q));
4666                             hd(depends) = snd(q);
4667                             depComp(l,e,qs1);
4668                             leaveScope();
4669                             break;
4670
4671             case DOQUAL   : /* fall-thru */
4672             case BOOLQUAL : snd(q) = depExpr(l,snd(q));
4673                             depComp(l,e,qs1);
4674                             break;
4675         }
4676     }
4677 }
4678
4679 static Void local depCaseAlt(line,a)    /* Find dependents of case altern. */
4680 Int  line;
4681 Cell a; {
4682     List obvs = saveBvars();            /* Save list of bound variables    */
4683     enterBtyvs();
4684     fst(a)    = bindPat(line,fst(a));   /* Add new bound vars for pats     */
4685     depRhs(snd(a));                     /* Find dependents of rhs          */
4686     fst(a)    = applyBtyvs(fst(a));
4687     restoreBvars(obvs);                 /* Restore original list of bvars  */
4688 }
4689
4690 static Cell local depVar(line,e)        /* Register occurrence of variable */
4691 Int line;
4692 Cell e; {
4693     List bounds1   = bounds;
4694     List bindings1 = bindings;
4695     List depends1  = depends;
4696     Text t         = textOf(e);
4697     Cell n;
4698
4699     while (nonNull(bindings1)) {
4700         n = varIsMember(t,hd(bounds1));   /* look for t in bound variables */
4701         if (nonNull(n)) {
4702             return n;
4703         }
4704         n = findBinding(t,hd(bindings1)); /* look for t in var bindings    */
4705         if (nonNull(n)) {
4706             if (!cellIsMember(n,hd(depends1))) {
4707                 hd(depends1) = cons(n,hd(depends1));
4708             }
4709            return (isVar(fst(n)) ? fst(n) : e);
4710         }
4711
4712         bounds1   = tl(bounds1);
4713         bindings1 = tl(bindings1);
4714         depends1  = tl(depends1);
4715     }
4716
4717     if (isNull(n=findName(t))) {               /* check global definitions */
4718         ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
4719         EEND;
4720     }
4721
4722 #if 0
4723     what is this for??
4724     if (!moduleThisScript(name(n).mod)) {
4725         return n;
4726     }
4727 #endif
4728     /* Later phases of the system cannot cope if we resolve references
4729      * to unprocessed objects too early.  This is the main reason that
4730      * we cannot cope with recursive modules at the moment.
4731      */
4732     return e;
4733 }
4734
4735 static Cell local depQVar(line,e)/* register occurrence of qualified variable */
4736 Int line;
4737 Cell e; {
4738     Name n = findQualName(e);
4739     if (isNull(n)) {                            /* check global definitions */
4740         ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
4741         EEND;
4742     }
4743     if (name(n).mod != currentModule) {
4744         return n;
4745     }
4746     if (fst(e) == VARIDCELL) {
4747         e = mkVar(qtextOf(e));
4748     } else {
4749         e = mkVarop(qtextOf(e));
4750     }
4751     return depVar(line,e);
4752 }
4753
4754 static Void local depConFlds(line,e,isP)/* check construction using fields */
4755 Int  line;
4756 Cell e;
4757 Bool isP; {
4758     Name c = conDefined(line,fst(snd(e)));
4759     if (isNull(snd(snd(e))) ||
4760         nonNull(cellIsMember(c,depFields(line,e,snd(snd(e)),isP)))) {
4761         fst(snd(e)) = c;
4762     } else {
4763         ERRMSG(line) "Constructor \"%s\" does not have selected fields in ",
4764                      textToStr(name(c).text)
4765         ETHEN ERREXPR(e);
4766         ERRTEXT "\n"
4767         EEND;
4768     }
4769     if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
4770         List scs = fst(name(c).defn);   /* List of strict components       */
4771         Type t   = name(c).type;
4772         Int  a   = userArity(c);
4773         List fs  = snd(snd(e));
4774         List ss;
4775         if (isPolyType(t)) {            /* Find tycon that c belongs to    */
4776             t = monotypeOf(t);
4777         }
4778         if (isQualType(t)) {
4779             t = snd(snd(t));
4780         }
4781         if (whatIs(t)==CDICTS) {
4782             t = snd(snd(t));
4783         }
4784         while (0<a--) {
4785             t = arg(t);
4786         }
4787         while (isAp(t)) {
4788             t = fun(t);
4789         }
4790         for (ss=tycon(t).defn; hasCfun(ss); ss=tl(ss)) {
4791         }
4792         /* Now we know the tycon t that c belongs to, and the corresponding
4793          * list of selectors for that type, ss.  Now we have to check that
4794          * each of the fields identified by scs appears in fs, using ss to
4795          * cross reference, and convert integers to selector names.
4796          */
4797         for (; nonNull(scs); scs=tl(scs)) {
4798             Int  i   = intOf(hd(scs));
4799             List ss1 = ss;
4800             for (; nonNull(ss1); ss1=tl(ss1)) {
4801                 List cns = name(hd(ss1)).defn;
4802                 for (; nonNull(cns); cns=tl(cns)) {
4803                     if (fst(hd(cns))==c) {
4804                         break;
4805                     }
4806                 }
4807                 if (nonNull(cns) && intOf(snd(hd(cns)))==i) {
4808                     break;
4809                 }
4810             }
4811             if (isNull(ss1)) {
4812                 internal("depConFlds");
4813             } else {
4814                 Name s   = hd(ss1);
4815                 List fs1 = fs;
4816                 for (; nonNull(fs1) && s!=fst(hd(fs1)); fs1=tl(fs1)) {
4817                 }
4818                 if (isNull(fs1)) {
4819                     ERRMSG(line) "Construction does not define strict field"
4820                     ETHEN
4821                     ERRTEXT      "\nExpression : " ETHEN ERREXPR(e);
4822                     ERRTEXT      "\nField      : " ETHEN ERREXPR(s);
4823                     ERRTEXT      "\n"
4824                     EEND;
4825                 }
4826             }
4827         }
4828     }
4829 }
4830
4831 static Void local depUpdFlds(line,e)    /* check update using fields       */
4832 Int  line;
4833 Cell e; {
4834     if (isNull(thd3(snd(e)))) {
4835         ERRMSG(line) "Empty field list in update"
4836         EEND;
4837     }
4838     fst3(snd(e)) = depExpr(line,fst3(snd(e)));
4839     snd3(snd(e)) = depFields(line,e,thd3(snd(e)),FALSE);
4840 }
4841
4842 static List local depFields(l,e,fs,isP) /* check field binding list        */
4843 Int  l;
4844 Cell e;
4845 List fs;
4846 Bool isP; {
4847     List cs = NIL;
4848     List ss = NIL;
4849
4850     for (; nonNull(fs); fs=tl(fs)) {    /* for each field binding          */
4851         Cell fb = hd(fs);
4852         Name s;
4853
4854         if (isVar(fb)) {                /* expand  var  to  var = var      */
4855             h98DoesntSupport(l,"missing field bindings");
4856             fb = hd(fs) = pair(fb,fb);
4857         }
4858
4859         s = findQualName(fst(fb));      /* check for selector              */
4860         if (nonNull(s) && isSfun(s)) {
4861             fst(fb) = s;
4862         } else {
4863             ERRMSG(l) "\"%s\" is not a selector function/field name",
4864                       textToStr(textOf(fst(fb)))
4865             EEND;
4866         }
4867
4868         if (isNull(ss)) {               /* for first named selector        */
4869             List scs = name(s).defn;    /* calculate list of constructors  */
4870             for (; nonNull(scs); scs=tl(scs)) {
4871                 cs = cons(fst(hd(scs)),cs);
4872             }
4873             ss = singleton(s);          /* initialize selector list        */
4874         } else {                        /* for subsequent selectors        */
4875             List ds = cs;               /* intersect constructor lists     */
4876             for (cs=NIL; nonNull(ds); ) {
4877                 List scs = name(s).defn;
4878                 while (nonNull(scs) && fst(hd(scs))!=hd(ds)) {
4879                     scs = tl(scs);
4880                 }
4881                 if (isNull(scs)) {
4882                     ds = tl(ds);
4883                 } else {
4884                     List next = tl(ds);
4885                     tl(ds)    = cs;
4886                     cs        = ds;
4887                     ds        = next;
4888                 }
4889             }
4890
4891             if (cellIsMember(s,ss)) {   /* check for repeated uses         */
4892                 ERRMSG(l) "Repeated field name \"%s\" in field list",
4893                           textToStr(name(s).text)
4894                 EEND;
4895             }
4896             ss = cons(s,ss);
4897         }
4898
4899         if (isNull(cs)) {               /* Are there any matching constrs? */
4900             ERRMSG(l) "No constructor has all of the fields specified in "
4901             ETHEN ERREXPR(e);
4902             ERRTEXT "\n"
4903             EEND;
4904         }
4905
4906         snd(fb) = (isP ? checkPat(l,snd(fb)) : depExpr(l,snd(fb)));
4907     }
4908     return cs;
4909 }
4910
4911 #if IPARAM
4912 static Void local depWith(line,e)       /* check with using fields         */
4913 Int  line;
4914 Cell e; {
4915     fst(snd(e)) = depExpr(line,fst(snd(e)));
4916     snd(snd(e)) = depDwFlds(line,e,snd(snd(e)));
4917 }
4918
4919 static List local depDwFlds(l,e,fs)/* check field binding list     */
4920 Int  l;
4921 Cell e;
4922 List fs;
4923 {
4924     Cell c = fs;
4925     for (; nonNull(c); c=tl(c)) {       /* for each field binding          */
4926         snd(hd(c)) = depExpr(l,snd(hd(c)));
4927     }
4928     return fs;
4929 }
4930 #endif
4931
4932 #if TREX
4933 static Cell local depRecord(line,e)     /* find dependents of record and   */
4934 Int  line;                              /* sort fields into approp. order  */
4935 Cell e; {                               /* to make construction and update */
4936     List exts = NIL;                    /* more efficient.                 */
4937     Cell r    = e;
4938
4939     h98DoesntSupport(line,"extensible records");
4940     do {                                /* build up list of extensions     */
4941         Text   t    = extText(fun(fun(r)));
4942         String s    = textToStr(t);
4943         List   prev = NIL;
4944         List   nx   = exts;
4945         while (nonNull(nx) && strcmp(textToStr(extText(fun(fun(nx)))),s)>0) {
4946             prev = nx;
4947             nx   = extRow(nx);
4948         }
4949         if (nonNull(nx) && t==extText(fun(fun(nx)))) {
4950             ERRMSG(line) "Repeated label \"%s\" in record ", s
4951             ETHEN ERREXPR(e);
4952             ERRTEXT "\n"
4953             EEND;
4954         }
4955         if (isNull(prev)) {
4956             exts = cons(fun(r),exts);
4957         } else {
4958             tl(prev) = cons(fun(r),nx);
4959         }
4960         extField(r) = depExpr(line,extField(r));
4961         r           = extRow(r);
4962     } while (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r))));
4963     r = depExpr(line,r);
4964     return revOnto(exts,r);
4965 }
4966 #endif
4967
4968
4969 /* --------------------------------------------------------------------------
4970  * Several parts of this program require an algorithm for sorting a list
4971  * of values (with some added dependency information) into a list of strongly
4972  * connected components in which each value appears before its dependents.
4973  *
4974  * Each of these algorithms is obtained by parameterising a standard
4975  * algorithm in "scc.c" as shown below.
4976  * ------------------------------------------------------------------------*/
4977
4978 #define  SCC2            tcscc          /* make scc algorithm for Tycons   */
4979 #define  LOWLINK         tclowlink
4980 #define  DEPENDS(c)      (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
4981 #define  SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else cclass(c).kinds=v
4982 #include "scc.c"
4983 #undef   SETDEPENDS
4984 #undef   DEPENDS
4985 #undef   LOWLINK
4986 #undef   SCC2
4987
4988 #define  SCC             bscc           /* make scc algorithm for Bindings */
4989 #define  LOWLINK         blowlink
4990 #define  DEPENDS(t)      depVal(t)
4991 #define  SETDEPENDS(c,v) depVal(c)=v
4992 #include "scc.c"
4993 #undef   SETDEPENDS
4994 #undef   DEPENDS
4995 #undef   LOWLINK
4996 #undef   SCC
4997
4998 /* --------------------------------------------------------------------------
4999  * Main static analysis:
5000  * ------------------------------------------------------------------------*/
5001
5002 Void checkExp() {                       /* Top level static check on Expr  */
5003     staticAnalysis(RESET);
5004     clearScope();                       /* Analyse expression in the scope */
5005     withinScope(NIL);                   /* of no local bindings            */
5006     inputExpr = depExpr(0,inputExpr);
5007     leaveScope();
5008     staticAnalysis(RESET);
5009 }
5010
5011 #if EXPLAIN_INSTANCE_RESOLUTION
5012 Void checkContext(void) {               /* Top level static check on Expr  */
5013     List vs, qs;
5014
5015     staticAnalysis(RESET);
5016     clearScope();                       /* Analyse expression in the scope */
5017     withinScope(NIL);                   /* of no local bindings            */
5018     qs = inputContext;
5019     for (vs = NIL; nonNull(qs); qs=tl(qs)) {
5020         vs = typeVarsIn(hd(qs),NIL,NIL,vs);
5021     }
5022     map2Proc(depPredExp,0,vs,inputContext);
5023     leaveScope();
5024     staticAnalysis(RESET);
5025 }
5026 #endif
5027
5028 Void checkDefns ( Module thisModule ) { /* Top level static analysis       */
5029
5030     staticAnalysis(RESET);
5031
5032     setCurrModule(thisModule);
5033
5034     /* Resolve module references */
5035     mapProc(checkQualImport,  module(thisModule).qualImports);
5036     mapProc(checkUnqualImport,unqualImports);
5037     /* Add "import Prelude" if there`s no explicit import */
5038     if (thisModule!=modulePrelude
5039         && isNull(cellAssoc(modulePrelude,unqualImports))
5040         && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
5041         unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
5042     } else {
5043         /* Every module (including the Prelude) implicitly contains
5044          * "import qualified Prelude"
5045          */
5046         module(thisModule).qualImports
5047            =cons(pair(mkCon(textPrelude),modulePrelude),
5048                  module(thisModule).qualImports);
5049     }
5050     mapProc(checkImportList, unqualImports);
5051
5052     /* Note: there's a lot of side-effecting going on here, so
5053        don't monkey about with the order of operations here unless
5054        you know what you are doing */
5055     if (!combined) linkPreludeTC();     /* Get prelude tycons and classes  */
5056
5057     mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions      */
5058     checkSynonyms(tyconDefns);          /* check synonym definitions       */
5059     mapProc(checkClassDefn,classDefns); /* process class definitions       */
5060     mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds     */
5061     mapProc(visitClass,classDefns);     /* check class hierarchy           */
5062     mapProc(extendFundeps,classDefns);  /* finish class definitions        */
5063                                         /* (convenient if we do this after */
5064                                         /* calling `visitClass' so that we */
5065                                         /* know the class hierarchy is     */
5066                                         /* acyclic)                        */
5067
5068     mapProc(addMembers,classDefns);     /* add definitions for member funs */
5069
5070     if (!combined) linkPreludeCM();     /* Get prelude cfuns and mfuns     */
5071
5072     instDefns = rev(instDefns);         /* process instance definitions    */
5073     mapProc(checkInstDefn,instDefns);
5074
5075     setCurrModule(thisModule);
5076     mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN    */
5077     valDefns   = eqnsToBindings(valDefns,tyconDefns,classDefns,/*primDefns*/NIL);
5078     mapProc(allNoPrevDef,valDefns);     /* check against previous defns    */
5079     mapProc(addDerivImp,derivedInsts);  /* Add impls for derived instances */
5080     deriveContexts(derivedInsts);       /* Calculate derived inst contexts */
5081     instDefns  = appendOnto(instDefns,derivedInsts);
5082     checkDefaultDefns();                /* validate default definitions    */
5083
5084     mapProc(allNoPrevDef,valDefns);     /* check against previous defns    */
5085
5086     if (!combined) linkPrimNames();     /* link primitive names           */
5087
5088     mapProc(checkForeignImport,foreignImports); /* check foreign imports   */
5089     mapProc(checkForeignExport,foreignExports); /* check foreign exports   */
5090     foreignImports = NIL;
5091     foreignExports = NIL;
5092
5093     /* Every top-level name has now been created - so we can build the     */
5094     /* export list.  Note that this has to happen before dependency        */
5095     /* analysis so that references to Prelude.foo will be resolved         */
5096     /* when compiling the prelude.                                         */
5097     module(thisModule).exports
5098        = checkExports ( module(thisModule).exports, thisModule );
5099
5100     mapProc(checkTypeIn,typeInDefns);   /* check restricted synonym defns  */
5101
5102     clearScope();
5103     withinScope(valDefns);
5104     valDefns = topDependAnal(valDefns); /* top level dependency ordering   */
5105     mapProc(depDefaults,classDefns);    /* dep. analysis on class defaults */
5106     mapProc(depInsts,instDefns);        /* dep. analysis on inst defns     */
5107     leaveScope();
5108
5109     /* ToDo: evalDefaults should match current evaluation module */
5110     evalDefaults = defaultDefns;        /* Set defaults for evaluator      */
5111
5112     staticAnalysis(RESET);
5113 }
5114
5115
5116
5117
5118 static Void local addRSsigdecls(pr)     /* add sigdecls from TYPE ... IN ..*/
5119 Pair pr; {
5120     List vs = snd(pr);                  /* get list of variables           */
5121     for (; nonNull(vs); vs=tl(vs)) {
5122         if (fst(hd(vs))==SIGDECL) {     /* find a sigdecl                  */
5123             valDefns = cons(hd(vs),valDefns);   /* add to valDefns         */
5124             hd(vs)   = hd(snd3(snd(hd(vs))));   /* and replace with var    */
5125         }
5126     }
5127 }
5128
5129 static Void local allNoPrevDef(b)        /* ensure no previous bindings for*/
5130 Cell b; {                                /* variables in new binding       */
5131     if (isVar(fst(b))) {
5132         noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
5133     } else {
5134         Int line = rhsLine(snd(snd(snd(b))));
5135         map1Proc(noPrevDef,line,fst(b));
5136     }
5137 }
5138
5139 static Void local noPrevDef(line,v)      /* ensure no previous binding for */
5140 Int  line;                               /* new variable                   */
5141 Cell v; {
5142     Name n = findName(textOf(v));
5143
5144     if (isNull(n)) {
5145         n            = newName(textOf(v),NIL);
5146         name(n).defn = PREDEFINED;
5147     } else if (name(n).defn!=PREDEFINED) {
5148         duplicateError(line,name(n).mod,name(n).text,"variable");
5149     }
5150     name(n).line = line;
5151 }
5152
5153 static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
5154 Int    line;
5155 Module mod;
5156 Text   t;
5157 String kind; {
5158     if (mod == currentModule) {
5159         ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
5160                      textToStr(t)
5161         EEND;
5162     } else {
5163         ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
5164                      textToStr(t)
5165         EEND;
5166     }
5167 }
5168
5169 static Void local checkTypeIn(cvs)      /* Check that vars in restricted   */
5170 Pair cvs; {                             /* synonym are defined             */
5171     Tycon c  = fst(cvs);
5172     List  vs = snd(cvs);
5173
5174     for (; nonNull(vs); vs=tl(vs)) {
5175         if (isNull(findName(textOf(hd(vs))))) {
5176             ERRMSG(tycon(c).line)
5177                 "No top level binding of \"%s\" for restricted synonym \"%s\"",
5178                 textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
5179             EEND;
5180         }
5181     }
5182 }
5183
5184 /* --------------------------------------------------------------------------
5185  * Haskell 98 compatibility tests:
5186  * ------------------------------------------------------------------------*/
5187
5188 Bool h98Pred(allowArgs,pi)              /* Check syntax of Hask98 predicate*/
5189 Bool allowArgs;
5190 Cell pi; {
5191     return isClass(getHead(pi)) && argCount==1 &&
5192            isOffset(getHead(arg(pi))) && (argCount==0 || allowArgs);
5193 }
5194
5195 Cell h98Context(allowArgs,ps)           /* Check syntax of Hask98 context  */
5196 Bool allowArgs;
5197 List ps; {
5198     for (; nonNull(ps); ps=tl(ps)) {
5199         if (!h98Pred(allowArgs,hd(ps))) {
5200             return hd(ps);
5201         }
5202     }
5203     return NIL;
5204 }
5205
5206 Void h98CheckCtxt(line,wh,allowArgs,ps,in)
5207 Int    line;                            /* Report illegal context/predicate*/
5208 String wh;
5209 Bool   allowArgs;
5210 List   ps;
5211 Inst   in; {
5212     if (haskell98) {
5213         Cell pi = h98Context(allowArgs,ps);
5214         if (nonNull(pi)) {
5215             ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh ETHEN
5216             if (nonNull(in)) {
5217                 ERRTEXT  "\n*** Instance   : " ETHEN ERRPRED(inst(in).head);
5218             }
5219             ERRTEXT      "\n*** Constraint : " ETHEN ERRPRED(pi);
5220             if (nonNull(ps) && nonNull(tl(ps))) {
5221                 ERRTEXT  "\n*** Context    : " ETHEN ERRCONTEXT(ps);
5222             }
5223             ERRTEXT      "\n"
5224             EEND;
5225         }
5226     }
5227 }
5228
5229 Void h98CheckType(line,wh,e,t)          /* Check for Haskell 98 type       */
5230 Int    line;
5231 String wh;
5232 Cell   e;
5233 Type   t; {
5234     if (haskell98) {
5235         Type ty = t;
5236         if (isPolyType(t))
5237             t = monotypeOf(t);
5238         if (isQualType(t)) {
5239             Cell pi = h98Context(TRUE,fst(snd(t)));
5240             if (nonNull(pi)) {
5241                 ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh
5242                 ETHEN
5243                 ERRTEXT  "\n*** Expression : " ETHEN ERREXPR(e);
5244                 ERRTEXT  "\n*** Type       : " ETHEN ERRTYPE(ty);
5245                 ERRTEXT  "\n"
5246                 EEND;
5247             }
5248         }
5249     }
5250 }
5251
5252 Void h98DoesntSupport(line,wh)          /* Report feature missing in H98   */
5253 Int    line;
5254 String wh; {
5255     if (haskell98) {
5256         ERRMSG(line) "Haskell 98 does not support %s", wh
5257         EEND;
5258     }
5259 }
5260
5261 /* --------------------------------------------------------------------------
5262  * Static Analysis control:
5263  * ------------------------------------------------------------------------*/
5264
5265 Void staticAnalysis(what)
5266 Int what; {
5267     switch (what) {
5268         case RESET   : cfunSfuns    = NIL;
5269                        daSccs       = NIL;
5270                        patVars      = NIL;
5271                        bounds       = NIL;
5272                        bindings     = NIL;
5273                        depends      = NIL;
5274                        tcDeps       = NIL;
5275                        derivedInsts = NIL;
5276                        diVars       = NIL;
5277                        diNum        = 0;
5278                        unkindTypes  = NIL;
5279                        break;
5280
5281         case MARK    : mark(daSccs);
5282                        mark(patVars);
5283                        mark(bounds);
5284                        mark(bindings);
5285                        mark(depends);
5286                        mark(tcDeps);
5287                        mark(derivedInsts);
5288                        mark(diVars);
5289                        mark(cfunSfuns);
5290                        mark(unkindTypes);
5291 #if TREX
5292                        mark(extKind);
5293 #endif
5294                        break;
5295
5296         case POSTPREL: break;
5297
5298         case PREPREL : staticAnalysis(RESET);
5299 #if TREX
5300                        extKind = pair(STAR,pair(ROW,ROW));
5301 #endif
5302     }
5303 }
5304
5305 /*-------------------------------------------------------------------------*/