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