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