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