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