ghc/interpreter/static.c

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