ghc/interpreter/static.c

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