ghc/interpreter/static.c

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