ghc/interpreter/static.c

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