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