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