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