ghc/interpreter/type.c

   1
   2 /* --------------------------------------------------------------------------
   3  * This is the Hugs type checker
   4  *
   5  * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
   6  * Haskell Group 1994-99, and is distributed as Open Source software
   7  * under the Artistic License; see the file "Artistic" that is included
   8  * in the distribution for details.
   9  *
  10  * $RCSfile: type.c,v $
  11  * $Revision: 1.5 $
  12  * $Date: 1999/03/09 14:51:16 $
  13  * ------------------------------------------------------------------------*/
  14
  15 #include "prelude.h"
  16 #include "storage.h"
  17 #include "backend.h"
  18 #include "connect.h"
  19 #include "link.h"
  20 #include "errors.h"
  21 #include "subst.h"
  22 #include "Assembler.h" /* for AsmCTypes */
  23
  24 /*#define DEBUG_TYPES*/
  25 /*#define DEBUG_KINDS*/
  26 /*#define DEBUG_DEFAULTS*/
  27 /*#define DEBUG_SELS*/
  28 /*#define DEBUG_DEPENDS*/
  29 /*#define DEBUG_DERIVING*/
  30 /*#define DEBUG_CODE*/
  31
  32 Bool catchAmbigs       = FALSE;         /* TRUE => functions with ambig.   */
  33                                         /*         types produce error     */
  34
  35
  36 /* --------------------------------------------------------------------------
  37  * Local function prototypes:
  38  * ------------------------------------------------------------------------*/
  39
  40 static Void   local emptyAssumption   Args((Void));
  41 static Void   local enterBindings     Args((Void));
  42 static Void   local leaveBindings     Args((Void));
  43 static Int    local defType           Args((Cell));
  44 static Type   local useType           Args((Cell));
  45 static Void   local markAssumList     Args((List));
  46 static Cell   local findAssum         Args((Text));
  47 static Pair   local findInAssumList   Args((Text,List));
  48 static List   local intsIntersect     Args((List,List));
  49 static List   local genvarAllAss      Args((List));
  50 static List   local genvarAnyAss      Args((List));
  51 static Int    local newVarsBind       Args((Cell));
  52 static Void   local newDefnBind       Args((Cell,Type));
  53
  54 static Void   local enterPendingBtyvs Args((Void));
  55 static Void   local leavePendingBtyvs Args((Void));
  56 static Cell   local patBtyvs          Args((Cell));
  57 static Void   local doneBtyvs         Args((Int));
  58 static Void   local enterSkolVars     Args((Void));
  59 static Void   local leaveSkolVars     Args((Int,Type,Int,Int));
  60
  61 static Void   local typeError         Args((Int,Cell,Cell,String,Type,Int));
  62 static Void   local reportTypeError   Args((Int,Cell,Cell,String,Type,Type));
  63 static Void   local cantEstablish     Args((Int,String,Cell,Type,List));
  64 static Void   local tooGeneral        Args((Int,Cell,Type,Type));
  65
  66 static Cell   local typeExpr          Args((Int,Cell));
  67
  68 static Cell   local typeAp            Args((Int,Cell));
  69 static Type   local typeExpected      Args((Int,String,Cell,Type,Int,Int,Bool));
  70 static Void   local typeAlt           Args((String,Cell,Cell,Type,Int,Int));
  71 static Int    local funcType          Args((Int));
  72 static Void   local typeCase          Args((Int,Int,Cell));
  73 static Void   local typeComp          Args((Int,Type,Cell,List));
  74 static Cell   local typeMonadComp     Args((Int,Cell));
  75 static Void   local typeDo            Args((Int,Cell));
  76 static Void   local typeConFlds       Args((Int,Cell));
  77 static Void   local typeUpdFlds       Args((Int,Cell));
  78 static Cell   local typeFreshPat      Args((Int,Cell));
  79
  80 static Void   local typeBindings      Args((List));
  81 static Void   local removeTypeSigs    Args((Cell));
  82
  83 static Void   local monorestrict      Args((List));
  84 static Void   local restrictedBindAss Args((Cell));
  85 static Void   local restrictedAss     Args((Int,Cell,Type));
  86
  87 static Void   local unrestricted      Args((List));
  88 static List   local itbscc            Args((List));
  89 static Void   local addEvidParams     Args((List,Cell));
  90
  91 static Void   local typeClassDefn     Args((Class));
  92 static Void   local typeInstDefn      Args((Inst));
  93 static Void   local typeMember        Args((String,Name,Cell,List,Cell,Int));
  94
  95 static Void   local typeBind          Args((Cell));
  96 static Void   local typeDefAlt        Args((Int,Cell,Pair));
  97 static Cell   local typeRhs           Args((Cell));
  98 static Void   local guardedType       Args((Int,Cell));
  99
 100 static Void   local genBind           Args((List,Cell));
 101 static Void   local genAss            Args((Int,List,Cell,Type));
 102 static Type   local genTest           Args((Int,Cell,List,Type,Type,Int));
 103 static Type   local generalize        Args((List,Type));
 104 static Bool   local equalTypes        Args((Type,Type));
 105
 106 static Void   local typeDefnGroup     Args((List));
 107 static Pair   local typeSel           Args((Name));
 108
 109
 110
 111 /* --------------------------------------------------------------------------
 112  * Assumptions:
 113  *
 114  * A basic typing statement is a pair (Var,Type) and an assumption contains
 115  * an ordered list of basic typing statements in which the type for a given
 116  * variable is given by the most recently added assumption about that var.
 117  *
 118  * In practice, the assumption set is split between a pair of lists, one
 119  * holding assumptions for vars defined in bindings, the other for vars
 120  * defined in patterns/binding parameters etc.  The reason for this
 121  * separation is that vars defined in bindings may be overloaded (with the
 122  * overloading being unknown until the whole binding is typed), whereas the
 123  * vars defined in patterns have no overloading.  A form of dependency
 124  * analysis (at least as far as calculating dependents within the same group
 125  * of value bindings) is required to implement this.  Where it is known that
 126  * no overloaded values are defined in a binding (i.e., when the `dreaded
 127  * monomorphism restriction' strikes), the list used to record dependents
 128  * is flagged with a NODEPENDS tag to avoid gathering dependents at that
 129  * level.
 130  *
 131  * To interleave between vars for bindings and vars for patterns, we use
 132  * a list of lists of typing statements for each.  These lists are always
 133  * the same length.  The implementation here is very similar to that of the
 134  * dependency analysis used in the static analysis component of this system.
 135  *
 136  * To deal with polymorphic recursion, variables defined in bindings can be
 137  * assigned types of the form (POLYREC,(def,use)), where def is a type
 138  * variable for the type of the defining occurence, and use is a type
 139  * scheme for (recursive) calls/uses of the variable.
 140  * ------------------------------------------------------------------------*/
 141
 142 static List defnBounds;                 /*::[[(Var,Type)]] possibly ovrlded*/
 143 static List varsBounds;                 /*::[[(Var,Type)]] not overloaded  */
 144 static List depends;                    /*::[?[Var]] dependents/NODEPENDS  */
 145 static List skolVars;                   /*::[[Var]] skolem vars            */
 146 static List localEvs;                   /*::[[(Pred,offset,ev)]]           */
 147 static List savedPs;                    /*::[[(Pred,offset,ev)]]           */
 148 static Cell dummyVar;                   /* Used to put extra tvars into ass*/
 149
 150 #define saveVarsAss()     List saveAssump = hd(varsBounds)
 151 #define restoreVarsAss()  hd(varsBounds)  = saveAssump
 152 #define addVarAssump(v,t) hd(varsBounds)  = cons(pair(v,t),hd(varsBounds))
 153 #define findTopBinding(v) findInAssumList(textOf(v),hd(defnBounds))
 154
 155 static Void local emptyAssumption() {   /* set empty type assumption       */
 156     defnBounds = NIL;
 157     varsBounds = NIL;
 158     depends    = NIL;
 159     skolVars   = NIL;
 160     localEvs   = NIL;
 161     savedPs    = NIL;
 162 }
 163
 164 static Void local enterBindings() {    /* Add new level to assumption sets */
 165     defnBounds = cons(NIL,defnBounds);
 166     varsBounds = cons(NIL,varsBounds);
 167     depends    = cons(NIL,depends);
 168 }
 169
 170 static Void local leaveBindings() {    /* Drop one level of assumptions    */
 171     defnBounds = tl(defnBounds);
 172     varsBounds = tl(varsBounds);
 173     depends    = tl(depends);
 174 }
 175
 176 static Int local defType(a)             /* Return type for defining occ.   */
 177 Cell a; {                               /* of a var from assumption pair  */
 178     return (isPair(a) && fst(a)==POLYREC) ? fst(snd(a)) : a;
 179 }
 180
 181 static Type local useType(a)            /* Return type for use of a var    */
 182 Cell a; {                               /* defined in an assumption        */
 183     return (isPair(a) && fst(a)==POLYREC) ? snd(snd(a)) : a;
 184 }
 185
 186 static Void local markAssumList(as)     /* Mark all types in assumption set*/
 187 List as; {                              /* :: [(Var, Type)]                */
 188     for (; nonNull(as); as=tl(as)) {    /* No need to mark generic types;  */
 189         Type t = defType(snd(hd(as)));  /* the only free variables in those*/
 190         if (!isPolyType(t))             /* must have been free earlier too */
 191             markType(t,0);
 192     }
 193 }
 194
 195 static Cell local findAssum(t)         /* Find most recent assumption about*/
 196 Text t; {                              /* variable named t, if any         */
 197     List defnBounds1 = defnBounds;     /* return translated variable, with */
 198     List varsBounds1 = varsBounds;     /* type in typeIs                   */
 199     List depends1    = depends;
 200
 201     while (nonNull(defnBounds1)) {
 202         Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
 203         if (nonNull(ass)) {
 204             typeIs = snd(ass);
 205             return fst(ass);
 206         }
 207
 208         ass = findInAssumList(t,hd(defnBounds1));     /* search defnBounds */
 209         if (nonNull(ass)) {
 210             Cell v = fst(ass);
 211             typeIs = snd(ass);
 212
 213             if (hd(depends1)!=NODEPENDS &&            /* save dependent?   */
 214                   isNull(v=varIsMember(t,hd(depends1))))
 215                 /* N.B. make new copy of variable and store this on list of*/
 216                 /* dependents, and in the assumption so that all uses of   */
 217                 /* the variable will be at the same node, if we need to    */
 218                 /* overwrite the call of a function with a translation...  */
 219                 hd(depends1) = cons(v=mkVar(t),hd(depends1));
 220
 221             return v;
 222         }
 223
 224         defnBounds1 = tl(defnBounds1);                /* look in next level*/
 225         varsBounds1 = tl(varsBounds1);                /* of assumption set */
 226         depends1    = tl(depends1);
 227     }
 228     return NIL;
 229 }
 230
 231 static Pair local findInAssumList(t,as)/* Search for assumption for var    */
 232 Text t;                                /* named t in list of assumptions as*/
 233 List as; {
 234     for (; nonNull(as); as=tl(as))
 235         if (textOf(fst(hd(as)))==t)
 236             return hd(as);
 237     return NIL;
 238 }
 239
 240 static List local intsIntersect(as,bs)  /* calculate intersection of lists */
 241 List as, bs; {                          /* of integers (as sets)           */
 242     List ts = NIL;                      /* destructively modifies as       */
 243     while (nonNull(as))
 244         if (intIsMember(intOf(hd(as)),bs)) {
 245             List temp = tl(as);
 246             tl(as)    = ts;
 247             ts        = as;
 248             as        = temp;
 249         }
 250         else
 251             as = tl(as);
 252     return ts;
 253 }
 254
 255 static List local genvarAllAss(as)      /* calculate generic vars that are */
 256 List as; {                              /* in every type in assumptions as */
 257     List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
 258     for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
 259         vs = intsIntersect(vs,genvarTyvar(intOf(defType(snd(hd(as)))),NIL));
 260     return vs;
 261 }
 262
 263 static List local genvarAnyAss(as)      /* calculate generic vars that are */
 264 List as; {                              /* in any type in assumptions as   */
 265     List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
 266     for (as=tl(as); nonNull(as); as=tl(as))
 267         vs = genvarTyvar(intOf(defType(snd(hd(as)))),vs);
 268     return vs;
 269 }
 270
 271 static Int local newVarsBind(v)        /* make new assump for pattern var  */
 272 Cell v; {
 273     Int beta = newTyvars(1);
 274     addVarAssump(v,mkInt(beta));
 275 #ifdef DEBUG_TYPES
 276     Printf("variable, assume ");
 277     printExp(stdout,v);
 278     Printf(" :: _%d\n",beta);
 279 #endif
 280     return beta;
 281 }
 282
 283 static Void local newDefnBind(v,type)  /* make new assump for defn var     */
 284 Cell v;                                /* and set type if given (nonNull)  */
 285 Type type; {
 286     Int  beta      = newTyvars(1);
 287     Cell ta        = mkInt(beta);
 288     instantiate(type);
 289     if (nonNull(type) && isPolyType(type))
 290         ta = pair(POLYREC,pair(ta,type));
 291     hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
 292 #ifdef DEBUG_TYPES
 293     Printf("definition, assume ");
 294     printExp(stdout,v);
 295     Printf(" :: _%d\n",beta);
 296 #endif
 297     bindTv(beta,typeIs,typeOff);       /* Bind beta to new type skeleton   */
 298 }
 299
 300 /* --------------------------------------------------------------------------
 301  * Predicates:
 302  * ------------------------------------------------------------------------*/
 303
 304 #include "preds.c"
 305
 306 /* --------------------------------------------------------------------------
 307  * Bound and skolemized type variables:
 308  * ------------------------------------------------------------------------*/
 309
 310 static List pendingBtyvs = NIL;
 311
 312 static Void local enterPendingBtyvs() {
 313     enterBtyvs();
 314     pendingBtyvs = cons(NIL,pendingBtyvs);
 315 }
 316
 317 static Void local leavePendingBtyvs() {
 318     List pts     = hd(pendingBtyvs);
 319     pendingBtyvs = tl(pendingBtyvs);
 320     for (; nonNull(pts); pts=tl(pts)) {
 321         Int  line = intOf(fst(hd(pts)));
 322         List vs   = snd(hd(pts));
 323         Int  i    = 0;
 324         clearMarks();
 325         for (; nonNull(vs); vs=tl(vs)) {
 326             Cell v = fst(hd(vs));
 327             Cell t = copyTyvar(intOf(snd(hd(vs))));
 328             if (!isOffset(t)) {
 329                 ERRMSG(line) "Type annotation uses variable " ETHEN ERREXPR(v);
 330                 ERRTEXT      " where a more specific type "   ETHEN ERRTYPE(t);
 331                 ERRTEXT      " was inferred"
 332                 EEND;
 333             }
 334             else if (offsetOf(t)!=i) {
 335                 List us = snd(hd(pts));
 336                 Int  j  = offsetOf(t);
 337                 if (j>=i)
 338                     internal("leavePendingBtyvs");
 339                 for (; j>0; j--)
 340                     us = tl(us);
 341                 ERRMSG(line) "Type annotation uses distinct variables " ETHEN
 342                 ERREXPR(v);  ERRTEXT " and " ETHEN ERREXPR(fst(hd(us)));
 343                 ERRTEXT      " where a single variable was inferred"
 344                 EEND;
 345             }
 346             else
 347                 i++;
 348         }
 349     }
 350     leaveBtyvs();
 351 }
 352
 353 static Cell local patBtyvs(p)           /* Strip bound type vars from pat  */
 354 Cell p; {
 355     if (whatIs(p)==BIGLAM) {
 356         List bts = hd(btyvars) = fst(snd(p));
 357         for (p=snd(snd(p)); nonNull(bts); bts=tl(bts)) {
 358             Int beta          = newTyvars(1);
 359             tyvar(beta)->kind = snd(hd(bts));
 360             snd(hd(bts))      = mkInt(beta);
 361         }
 362     }
 363     return p;
 364 }
 365
 366 static Void local doneBtyvs(l)
 367 Int l; {
 368     if (nonNull(hd(btyvars))) {         /* Save bound tyvars               */
 369         hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
 370         hd(btyvars)      = NIL;
 371     }
 372 }
 373
 374 static Void local enterSkolVars() {
 375     skolVars = cons(NIL,skolVars);
 376     localEvs = cons(NIL,localEvs);
 377     savedPs  = cons(preds,savedPs);
 378     preds    = NIL;
 379 }
 380
 381 static Void local leaveSkolVars(l,t,o,m)
 382 Int  l;
 383 Type t;
 384 Int  o;
 385 Int  m; {
 386     if (nonNull(hd(localEvs))) {        /* Check for local predicates      */
 387         List sks = hd(skolVars);
 388         List sps = NIL;
 389         if (isNull(sks)) {
 390             internal("leaveSkolVars");
 391         }
 392         markAllVars();                  /* Mark all variables in current   */
 393         do {                            /* substitution, then unmark sks.  */
 394             tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
 395             sks = tl(sks);
 396         } while (nonNull(sks));
 397         sps   = elimPredsUsing(hd(localEvs),sps);
 398         preds = revOnto(preds,sps);
 399     }
 400
 401     if (nonNull(hd(skolVars))) {        /* Check that Skolem vars do not   */
 402         List vs;                        /* escape their scope              */
 403         Int  i = 0;
 404
 405         clearMarks();                   /* Look for occurences in the      */
 406         for (; i<m; i++)                /* inferred type                   */
 407             markTyvar(o+i);
 408         markType(t,o);
 409
 410         for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
 411             Int vn = intOf(fst(hd(vs)));
 412             if (tyvar(vn)->offs == FIXED_TYVAR) {
 413                 Cell tv = copyTyvar(vn);
 414                 Type ty = liftRank2(t,o,m);
 415                 ERRMSG(l) "Existentially quantified variable in inferred type"
 416                 ETHEN
 417                 ERRTEXT   "\n*** Variable     : " ETHEN ERRTYPE(tv);
 418                 ERRTEXT   "\n*** From pattern : " ETHEN ERREXPR(snd(hd(vs)));
 419                 ERRTEXT   "\n*** Result type  : " ETHEN ERRTYPE(ty);
 420                 ERRTEXT   "\n"
 421                 EEND;
 422             }
 423         }
 424
 425         markBtyvs();                    /* Now check assumptions           */
 426         mapProc(markAssumList,defnBounds);
 427         mapProc(markAssumList,varsBounds);
 428
 429         for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
 430             Int vn = intOf(fst(hd(vs)));
 431             if (tyvar(vn)->offs == FIXED_TYVAR) {
 432                 ERRMSG(l)
 433                   "Existentially quantified variable escapes from pattern "
 434                 ETHEN ERREXPR(snd(hd(vs)));
 435                 ERRTEXT "\n"
 436                 EEND;
 437             }
 438         }
 439     }
 440     localEvs = tl(localEvs);
 441     skolVars = tl(skolVars);
 442     preds    = revOnto(preds,hd(savedPs));
 443     savedPs  = tl(savedPs);
 444 }
 445
 446 /* --------------------------------------------------------------------------
 447  * Type errors:
 448  * ------------------------------------------------------------------------*/
 449
 450 static Void local typeError(l,e,in,wh,t,o)
 451 Int    l;                             /* line number near type error       */
 452 String wh;                            /* place in which error occurs       */
 453 Cell   e;                             /* source of error                   */
 454 Cell   in;                            /* context if any (NIL if not)       */
 455 Type   t;                             /* should be of type (t,o)           */
 456 Int    o; {                           /* type inferred is (typeIs,typeOff) */
 457
 458     clearMarks();                     /* types printed here are monotypes  */
 459                                       /* use marking to give sensible names*/
 460 #ifdef DEBUG_KINDS
 461 { List vs = genericVars;
 462   for (; nonNull(vs); vs=tl(vs)) {
 463      Int v = intOf(hd(vs));
 464      Printf("%c :: ", ('a'+tyvar(v)->offs));
 465      printKind(stdout,tyvar(v)->kind);
 466      Putchar('\n');
 467   }
 468 }
 469 #endif
 470
 471     reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
 472 }
 473
 474 static Void local reportTypeError(l,e,in,wh,inft,expt)
 475 Int    l;                               /* Error printing part of typeError*/
 476 Cell   e, in;
 477 String wh;
 478 Type   inft, expt; {
 479     ERRMSG(l)   "Type error in %s", wh    ETHEN
 480     if (nonNull(in)) {
 481         ERRTEXT "\n*** Expression     : " ETHEN ERREXPR(in);
 482     }
 483     ERRTEXT     "\n*** Term           : " ETHEN ERREXPR(e);
 484     ERRTEXT     "\n*** Type           : " ETHEN ERRTYPE(inft);
 485     ERRTEXT     "\n*** Does not match : " ETHEN ERRTYPE(expt);
 486     if (unifyFails) {
 487         ERRTEXT "\n*** Because        : %s", unifyFails ETHEN
 488     }
 489     ERRTEXT "\n"
 490     EEND;
 491 }
 492
 493 #define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
 494                                        typeError(l,e,in,where,t,o);
 495 #define check(l,e,in,where,t,o)    e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
 496 #define inferType(t,o)             typeIs=t; typeOff=o
 497
 498 static Void local cantEstablish(line,wh,e,t,ps)
 499 Int    line;                            /* Complain when declared preds    */
 500 String wh;                              /* are not sufficient to discharge */
 501 Cell   e;                               /* or defer the inferred context.  */
 502 Type   t;
 503 List   ps; {
 504     ERRMSG(line) "Cannot justify constraints in %s", wh ETHEN
 505     ERRTEXT      "\n*** Expression    : " ETHEN ERREXPR(e);
 506     ERRTEXT      "\n*** Type          : " ETHEN ERRTYPE(t);
 507     ERRTEXT      "\n*** Given context : " ETHEN ERRCONTEXT(ps);
 508     ERRTEXT      "\n*** Constraints   : " ETHEN ERRCONTEXT(copyPreds(preds));
 509     ERRTEXT "\n"
 510     EEND;
 511 }
 512
 513 static Void local tooGeneral(l,e,dt,it) /* explicit type sig. too general  */
 514 Int  l;
 515 Cell e;
 516 Type dt, it; {
 517     ERRMSG(l) "Inferred type is not general enough" ETHEN
 518     ERRTEXT   "\n*** Expression    : " ETHEN ERREXPR(e);
 519     ERRTEXT   "\n*** Expected type : " ETHEN ERRTYPE(dt);
 520     ERRTEXT   "\n*** Inferred type : " ETHEN ERRTYPE(it);
 521     ERRTEXT   "\n"
 522     EEND;
 523 }
 524
 525 /* --------------------------------------------------------------------------
 526  * Typing of expressions:
 527  * ------------------------------------------------------------------------*/
 528
 529 #define EXPRESSION  0                   /* type checking expression        */
 530 #define NEW_PATTERN 1                   /* pattern, introducing new vars   */
 531 #define OLD_PATTERN 2                   /* pattern, involving bound vars   */
 532 static int tcMode = EXPRESSION;
 533
 534 #ifdef DEBUG_TYPES
 535 static Cell local mytypeExpr    Args((Int,Cell));
 536 static Cell local typeExpr(l,e)
 537 Int l;
 538 Cell e; {
 539     static int number = 0;
 540     Cell retv;
 541     int  mynumber = number++;
 542     Printf("%d) to check: ",mynumber);
 543     printExp(stdout,e);
 544     Putchar('\n');
 545     retv = mytypeExpr(l,e);
 546     Printf("%d) result: ",mynumber);
 547     printType(stdout,debugType(typeIs,typeOff));
 548     Putchar('\n');
 549     return retv;
 550 }
 551 static Cell local mytypeExpr(l,e)       /* Determine type of expr/pattern  */
 552 #else
 553 static Cell local typeExpr(l,e)         /* Determine type of expr/pattern  */
 554 #endif
 555 Int  l;
 556 Cell e; {
 557     static String cond    = "conditional";
 558     static String list    = "list";
 559     static String discr   = "case discriminant";
 560     static String aspat   = "as (@) pattern";
 561     static String typeSig = "type annotation";
 562     static String lambda  = "lambda expression";
 563     //printf("\n\n+++++++++++++++++++++++++++++++\n");
 564     //print(e,1000);
 565     //printf("\n\n");
 566     switch (whatIs(e)) {
 567
 568         /* The following cases can occur in either pattern or expr. mode   */
 569
 570         case AP         :
 571         case NAME       :
 572         case VAROPCELL  :
 573         case VARIDCELL  : return typeAp(l,e);
 574
 575         case TUPLE      : typeTuple(e);
 576                           break;
 577
 578 #if BIGNUMS
 579         case POSNUM     :
 580         case ZERONUM    :
 581         case NEGNUM     : {   Int alpha = newTyvars(1);
 582                               inferType(aVar,alpha);
 583                               return ap(ap(nameFromInteger,
 584                                            assumeEvid(predNum,alpha)),
 585                                            e);
 586                           }
 587 #endif
 588         case INTCELL    : {   Int alpha = newTyvars(1);
 589                               inferType(aVar,alpha);
 590                               return ap(ap(nameFromInt,
 591                                            assumeEvid(predNum,alpha)),
 592                                            e);
 593                           }
 594
 595         case FLOATCELL  : {   Int alpha = newTyvars(1);
 596                               inferType(aVar,alpha);
 597                               return ap(ap(nameFromDouble,
 598                                            assumeEvid(predFractional,alpha)),
 599                                            e);
 600                           }
 601
 602         case STRCELL    : inferType(typeString,0);
 603                           break;
 604
 605         case CHARCELL   : inferType(typeChar,0);
 606                           break;
 607
 608         case CONFLDS    : typeConFlds(l,e);
 609                           break;
 610
 611         case ESIGN      : snd(snd(e)) = localizeBtyvs(snd(snd(e)));
 612                           return typeExpected(l,typeSig,
 613                                               fst(snd(e)),snd(snd(e)),
 614                                               0,0,FALSE);
 615
 616 #if TREX
 617         case EXT        : {   Int beta = newTyvars(2);
 618                               Cell pi  = ap(e,aVar);
 619                               Type t   = fn(aVar,
 620                                          fn(ap(typeRec,bVar),
 621                                             ap(typeRec,ap(ap(e,aVar),bVar))));
 622                               tyvar(beta+1)->kind = ROW;
 623                               inferType(t,beta);
 624                               return ap(e,assumeEvid(pi,beta+1));
 625                           }
 626 #endif
 627
 628         /* The following cases can only occur in expr mode                 */
 629
 630         case UPDFLDS    : typeUpdFlds(l,e);
 631                           break;
 632
 633         case COND       : {   Int beta = newTyvars(1);
 634                               check(l,fst3(snd(e)),e,cond,typeBool,0);
 635                               check(l,snd3(snd(e)),e,cond,aVar,beta);
 636                               check(l,thd3(snd(e)),e,cond,aVar,beta);
 637                               tyvarType(beta);
 638                           }
 639                           break;
 640
 641         case LETREC     : enterBindings();
 642                           enterSkolVars();
 643                           mapProc(typeBindings,fst(snd(e)));
 644                           snd(snd(e)) = typeExpr(l,snd(snd(e)));
 645                           leaveBindings();
 646                           leaveSkolVars(l,typeIs,typeOff,0);
 647                           break;
 648
 649         case FINLIST    : {   Int  beta = newTyvars(1);
 650                               List xs;
 651                               for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
 652                                  check(l,hd(xs),e,list,aVar,beta);
 653                               }
 654                               inferType(listof,beta);
 655                           }
 656                           break;
 657
 658         case DOCOMP     : typeDo(l,e);
 659                           break;
 660
 661         case COMP       : return typeMonadComp(l,e);
 662
 663         case CASE       : {    Int beta = newTyvars(2);    /* discr result */
 664                                check(l,fst(snd(e)),NIL,discr,aVar,beta);
 665                                map2Proc(typeCase,l,beta,snd(snd(e)));
 666                                tyvarType(beta+1);
 667                           }
 668                           break;
 669
 670         case LAMBDA     : {   Int beta = newTyvars(1);
 671                               enterPendingBtyvs();
 672                               typeAlt(lambda,e,snd(e),aVar,beta,1);
 673                               leavePendingBtyvs();
 674                               tyvarType(beta);
 675                           }
 676                           break;
 677
 678 #if TREX
 679         case RECSEL     : {   Int beta = newTyvars(2);
 680                               Cell pi  = ap(snd(e),aVar);
 681                               Type t   = fn(ap(typeRec,
 682                                                ap(ap(snd(e),aVar),
 683                                                             bVar)),aVar);
 684                               tyvar(beta+1)->kind = ROW;
 685                               inferType(t,beta);
 686                               return ap(e,assumeEvid(pi,beta+1));
 687                           }
 688 #endif
 689
 690         /* The remaining cases can only occur in pattern mode: */
 691
 692         case WILDCARD   : inferType(aVar,newTyvars(1));
 693                           break;
 694
 695         case ASPAT      : {   Int beta = newTyvars(1);
 696                               snd(snd(e)) = typeExpr(l,snd(snd(e)));
 697                               bindTv(beta,typeIs,typeOff);
 698                               check(l,fst(snd(e)),e,aspat,aVar,beta);
 699                               tyvarType(beta);
 700                           }
 701                           break;
 702
 703         case LAZYPAT    : snd(e) = typeExpr(l,snd(e));
 704                           break;
 705
 706 #if NPLUSK
 707         case ADDPAT     : {   Int alpha = newTyvars(1);
 708                               inferType(typeVarToVar,alpha);
 709                               return ap(e,assumeEvid(predIntegral,alpha));
 710                           }
 711 #endif
 712
 713         default         : internal("typeExpr");
 714    }
 715
 716    return e;
 717 }
 718
 719 /* --------------------------------------------------------------------------
 720  * Typing rules for particular special forms:
 721  * ------------------------------------------------------------------------*/
 722
 723 static Cell local typeAp(l,e)           /* Type check application, which   */
 724 Int  l;                                 /* may be headed with a variable   */
 725 Cell e; {                               /* requires polymorphism, qualified*/
 726     static String app = "application";  /* types, and possible rank2 args. */
 727     Cell h = getHead(e);
 728     Int  n = argCount;
 729     Cell p = NIL;
 730     Cell a = e;
 731     Int  i;
 732     //print(h,1000);
 733     //printf("\n");
 734
 735     switch (whatIs(h)) {
 736         case NAME      : typeIs = name(h).type;
 737                          break;
 738
 739         case VAROPCELL :
 740         case VARIDCELL : if (tcMode==NEW_PATTERN) {
 741                              inferType(aVar,newVarsBind(e));
 742                          }
 743                          else {
 744                              Cell v = findAssum(textOf(h));
 745                              if (nonNull(v)) {
 746                                  h      = v;
 747                                  typeIs = (tcMode==OLD_PATTERN)
 748                                                 ? defType(typeIs)
 749                                                 : useType(typeIs);
 750                              }
 751                              else {
 752                                  h = findName(textOf(h));
 753                                  if (isNull(h))
 754                                      internal("typeAp0");
 755                                  typeIs = name(h).type;
 756                              }
 757                          }
 758                          break;
 759
 760         default        : h = typeExpr(l,h);
 761                          break;
 762     }
 763
 764     if (isNull(typeIs)) {
 765         //printf("\n NAME " );
 766         //print(h,1000);
 767         //printf(" TYPE " ); print(typeIs,1000);
 768         internal("typeAp1");
 769     }
 770
 771     instantiate(typeIs);                /* Deal with polymorphism ...      */
 772     if (nonNull(predsAre)) {            /* ... and with qualified types.   */
 773         List evs = NIL;
 774         for (; nonNull(predsAre); predsAre=tl(predsAre)) {
 775             evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
 776         }
 777         if (!isName(h) || !isCfun(h)) {
 778             h = applyToArgs(h,rev(evs));
 779         }
 780     }
 781
 782     if (whatIs(typeIs)==CDICTS) {       /* Deal with local dictionaries    */
 783         List evs = makePredAss(fst(snd(typeIs)),typeOff);
 784         List ps  = evs;
 785         typeIs   = snd(snd(typeIs));
 786         for (; nonNull(ps); ps=tl(ps)) {
 787             h = ap(h,thd3(hd(ps)));
 788         }
 789         if (tcMode==EXPRESSION) {
 790             preds = revOnto(evs,preds);
 791         } else {
 792             hd(localEvs) = revOnto(evs,hd(localEvs));
 793         }
 794     }
 795
 796     if (whatIs(typeIs)==EXIST) {        /* Deal with existential arguments */
 797         Int n  = intOf(fst(snd(typeIs)));
 798         typeIs = snd(snd(typeIs));
 799         if (!isCfun(getHead(h)) || n>typeFree) {
 800             internal("typeAp2");
 801         } else if (tcMode!=EXPRESSION) {
 802             Int alpha = typeOff + typeFree;
 803             for (; n>0; n--) {
 804                 bindTv(alpha-n,SKOLEM,0);
 805                 hd(skolVars) = cons(pair(mkInt(alpha-n),e),hd(skolVars));
 806             }
 807         }
 808     }
 809
 810     if (whatIs(typeIs)==RANK2) {        /* Deal with rank 2 arguments      */
 811         Int  alpha = typeOff;
 812         Int  m     = typeFree;
 813         Int  nr2   = intOf(fst(snd(typeIs)));
 814         Type body  = snd(snd(typeIs));
 815         List as    = e;
 816         Bool added = FALSE;
 817
 818         if (n<nr2) {                    /* Must have enough arguments      */
 819             ERRMSG(l)   "Use of " ETHEN ERREXPR(h);
 820             if (n>1) {
 821                 ERRTEXT " in "    ETHEN ERREXPR(e);
 822             }
 823             ERRTEXT     " requires at least %d argument%s\n",
 824                         nr2, (nr2==1 ? "" : "s")
 825             EEND;
 826         }
 827
 828         for (i=nr2; i<n; ++i)           /* Find rank two arguments         */
 829             as = fun(as);
 830
 831         for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
 832             Type expect = dropRank1(arg(fun(body)),alpha,m);
 833             if (isPolyType(expect)) {
 834                 if (tcMode==EXPRESSION)         /* poly/qual type in expr  */
 835                     hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
 836                 else if (hd(as)!=WILDCARD) {    /* Pattern binding/match   */
 837                     if (!isVar(hd(as))) {
 838                         ERRMSG(l) "Argument "    ETHEN ERREXPR(arg(as));
 839                         ERRTEXT   " in pattern " ETHEN ERREXPR(e);
 840                         ERRTEXT   " where a variable is required\n"
 841                         EEND;
 842                     }
 843                     if (tcMode==NEW_PATTERN) {  /* Pattern match           */
 844                         if (m>0 && !added) {
 845                             for (i=0; i<m; i++)
 846                                 addVarAssump(dummyVar,mkInt(alpha+i));
 847                             added = TRUE;
 848                         }
 849                         addVarAssump(hd(as),expect);
 850                     }
 851                     else {                      /* Pattern binding         */
 852                         Text t = textOf(hd(as));
 853                         Cell a = findInAssumList(t,hd(defnBounds));
 854                         if (isNull(a))
 855                             internal("typeAp3");
 856                         instantiate(expect);
 857                         if (nonNull(predsAre)) {
 858                             ERRMSG(l) "Cannot use pattern binding for " ETHEN
 859                             ERREXPR(hd(as));
 860                             ERRTEXT   " as a component with a qualified type\n"
 861                             EEND;
 862                         }
 863                         shouldBe(l,hd(as),e,app,aVar,intOf(defType(snd(a))));
 864                     }
 865                 }
 866             }
 867             else {                              /* Not a poly/qual type    */
 868                 check(l,hd(as),e,app,expect,alpha);
 869             }
 870             h = ap(h,hd(as));                   /* Save checked argument   */
 871         }
 872         inferType(body,alpha);
 873         n -= nr2;
 874     }
 875
 876     if (n>0) {                          /* Deal with remaining args        */
 877         Int beta = funcType(n);         /* check h::t1->t2->...->tn->rn+1  */
 878         shouldBe(l,h,e,app,aVar,beta);
 879         for (i=n; i>0; --i) {           /* check e_i::t_i for each i       */
 880             check(l,arg(a),e,app,aVar,beta+2*i-1);
 881             p = a;
 882             a = fun(a);
 883         }
 884         tyvarType(beta+2*n);            /* Inferred type is r_n+1          */
 885     }
 886
 887     if (isNull(p))                      /* Replace head with translation   */
 888         e = h;
 889     else
 890         fun(p) = h;
 891
 892     return e;
 893 }
 894
 895 static Cell local typeExpected(l,wh,e,reqd,alpha,n,addEvid)
 896 Int    l;                               /* Type check expression e in wh   */
 897 String wh;                              /* at line l, expecting type reqd, */
 898 Cell   e;                               /* and treating vars alpha through */
 899 Type   reqd;                            /* (alpha+n-1) as fixed.           */
 900 Int    alpha;
 901 Int    n;
 902 Bool   addEvid; {                       /* TRUE => add \ev -> ...          */
 903     List savePreds = preds;
 904     Type t;
 905     Int  o;
 906     Int  m;
 907     List ps;
 908     Int  i;
 909
 910     instantiate(reqd);
 911     t     = typeIs;
 912     o     = typeOff;
 913     m     = typeFree;
 914     ps    = makePredAss(predsAre,o);
 915
 916     preds = NIL;
 917     check(l,e,NIL,wh,t,o);
 918
 919     clearMarks();
 920     mapProc(markAssumList,defnBounds);
 921     mapProc(markAssumList,varsBounds);
 922     mapProc(markPred,savePreds);
 923     markBtyvs();
 924
 925     for (i=0; i<n; i++)
 926         markTyvar(alpha+i);
 927
 928     savePreds = elimPredsUsing(ps,savePreds);
 929     if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
 930         savePreds = elimPredsUsing(ps,savePreds);
 931     if (nonNull(preds)) {
 932         Type ty = copyType(t,o);
 933         List qs = copyPreds(ps);
 934         cantEstablish(l,wh,e,ty,qs);
 935     }
 936
 937     resetGenerics();
 938     for (i=0; i<m; i++)
 939         if (copyTyvar(o+i)!=mkOffset(i)) {
 940             List qs = copyPreds(ps);
 941             Type it = copyType(t,o);
 942             tooGeneral(l,e,reqd,generalize(qs,it));
 943         }
 944
 945     if (addEvid) {
 946         e     = qualifyExpr(l,ps,e);
 947         preds = savePreds;
 948     }
 949     else
 950         preds = revOnto(ps,savePreds);
 951
 952     inferType(t,o);
 953     return e;
 954 }
 955
 956 static Void local typeAlt(wh,e,a,t,o,m) /* Type check abstraction (Alt)    */
 957 String wh;                              /* a = ( [p1, ..., pn], rhs )      */
 958 Cell   e;
 959 Cell   a;
 960 Type   t;
 961 Int    o;
 962 Int    m; {
 963     Type origt = t;
 964     List ps    = fst(a) = patBtyvs(fst(a));
 965     Int  n     = length(ps);
 966     Int  l     = rhsLine(snd(a));
 967     Int  nr2   = 0;
 968     List as    = NIL;
 969     Bool added = FALSE;
 970
 971     saveVarsAss();
 972     enterSkolVars();
 973     if (whatIs(t)==RANK2) {
 974         if (n<(nr2=intOf(fst(snd(t))))) {
 975             ERRMSG(l) "Definition requires at least %d parameters on lhs",
 976                       intOf(fst(snd(t)))
 977             EEND;
 978         }
 979         t = snd(snd(t));
 980     }
 981
 982     while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
 983         Type ta = arg(fun(t));
 984         if (isPolyType(ta)) {
 985             if (hd(ps)!=WILDCARD) {
 986                 if (!isVar(hd(ps))) {
 987                    ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
 988                    ERRTEXT   " used where a variable or wildcard is required\n"
 989                    EEND;
 990                 }
 991                 if (m>0 && !added) {
 992                     Int i = 0;
 993                     for (; i<m; i++)
 994                         addVarAssump(dummyVar,mkInt(o+i));
 995                     added = TRUE;
 996                 }
 997                 addVarAssump(hd(ps),ta);
 998             }
 999         }
1000         else {
1001             hd(ps) = typeFreshPat(l,hd(ps));
1002             shouldBe(l,hd(ps),NIL,wh,ta,o);
1003         }
1004         t  = arg(t);
1005         ps = tl(ps);
1006         as = fn(ta,as);
1007         n--;
1008     }
1009
1010     if (n==0)
1011         snd(a) = typeRhs(snd(a));
1012     else {
1013         Int beta = funcType(n);
1014         Int i    = 0;
1015         for (; i<n; ++i) {
1016             hd(ps) = typeFreshPat(l,hd(ps));
1017             bindTv(beta+2*i+1,typeIs,typeOff);
1018             ps = tl(ps);
1019         }
1020         snd(a) = typeRhs(snd(a));
1021         bindTv(beta+2*n,typeIs,typeOff);
1022         tyvarType(beta);
1023     }
1024
1025     if (!unify(typeIs,typeOff,t,o)) {
1026         Type req, got;
1027         clearMarks();
1028         req = liftRank2(origt,o,m);
1029         liftRank2Args(as,o,m);
1030         got = ap(RANK2,pair(mkInt(nr2),revOnto(as,copyType(typeIs,typeOff))));
1031         reportTypeError(l,e,NIL,wh,got,req);
1032     }
1033
1034     restoreVarsAss();
1035     doneBtyvs(l);
1036     leaveSkolVars(l,origt,o,m);
1037 }
1038
1039 static Int local funcType(n)            /*return skeleton for function type*/
1040 Int n; {                                /*with n arguments, taking the form*/
1041     Int beta = newTyvars(2*n+1);        /*    r1 t1 r2 t2 ... rn tn rn+1   */
1042     Int i;                              /* with r_i := t_i -> r_i+1        */
1043     for (i=0; i<n; ++i)
1044         bindTv(beta+2*i,arrow,beta+2*i+1);
1045     return beta;
1046 }
1047
1048 static Void local typeCase(l,beta,c)   /* type check case: pat -> rhs      */
1049 Int  l;                                /* (case given by c == (pat,rhs))   */
1050 Int  beta;                             /* need:  pat :: (var,beta)         */
1051 Cell c; {                              /*        rhs :: (var,beta+1)       */
1052     static String casePat  = "case pattern";
1053     static String caseExpr = "case expression";
1054
1055     saveVarsAss();
1056     enterSkolVars();
1057     fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
1058     shouldBe(l,fst(c),NIL,casePat,aVar,beta);
1059     snd(c) = typeRhs(snd(c));
1060     shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,aVar,beta+1);
1061
1062     restoreVarsAss();
1063     doneBtyvs(l);
1064     leaveSkolVars(l,typeIs,typeOff,0);
1065 }
1066
1067 static Void local typeComp(l,m,e,qs)    /* type check comprehension        */
1068 Int  l;
1069 Type m;                                 /* monad (mkOffset(0))             */
1070 Cell e;
1071 List qs; {
1072     static String boolQual = "boolean qualifier";
1073     static String genQual  = "generator";
1074
1075     if (isNull(qs))                     /* no qualifiers left              */
1076         fst(e) = typeExpr(l,fst(e));
1077     else {
1078         Cell q   = hd(qs);
1079         List qs1 = tl(qs);
1080         switch (whatIs(q)) {
1081             case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
1082                             typeComp(l,m,e,qs1);
1083                             break;
1084
1085             case QWHERE   : enterBindings();
1086                             enterSkolVars();
1087                             mapProc(typeBindings,snd(q));
1088                             typeComp(l,m,e,qs1);
1089                             leaveBindings();
1090                             leaveSkolVars(l,typeIs,typeOff,0);
1091                             break;
1092
1093             case FROMQUAL : {   Int beta = newTyvars(1);
1094                                 saveVarsAss();
1095                                 check(l,snd(snd(q)),NIL,genQual,m,beta);
1096                                 enterSkolVars();
1097                                 fst(snd(q))
1098                                     = typeFreshPat(l,patBtyvs(fst(snd(q))));
1099                                 shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
1100                                 typeComp(l,m,e,qs1);
1101                                 restoreVarsAss();
1102                                 doneBtyvs(l);
1103                                 leaveSkolVars(l,typeIs,typeOff,0);
1104                             }
1105                             break;
1106
1107             case DOQUAL   : check(l,snd(q),NIL,genQual,m,newTyvars(1));
1108                             typeComp(l,m,e,qs1);
1109                             break;
1110         }
1111     }
1112 }
1113
1114 static Cell local typeMonadComp(l,e)    /* type check monad comprehension  */
1115 Int  l;
1116 Cell e; {
1117     Int  alpha        = newTyvars(1);
1118     Int  beta         = newTyvars(1);
1119     Cell mon          = ap(mkInt(beta),aVar);
1120     Cell m            = assumeEvid(predMonad,beta);
1121     tyvar(beta)->kind = starToStar;
1122 #if !MONAD_COMPS
1123     bindTv(beta,typeList,0);
1124 #endif
1125
1126     typeComp(l,mon,snd(e),snd(snd(e)));
1127     bindTv(alpha,typeIs,typeOff);
1128     inferType(mon,alpha);
1129     return ap(MONADCOMP,pair(m,snd(e)));
1130 }
1131
1132 static Void local typeDo(l,e)           /* type check do-notation          */
1133 Int  l;
1134 Cell e; {
1135     static String finGen = "final generator";
1136     Int  alpha           = newTyvars(1);
1137     Int  beta            = newTyvars(1);
1138     Cell mon             = ap(mkInt(beta),aVar);
1139     Cell m               = assumeEvid(predMonad,beta);
1140     tyvar(beta)->kind    = starToStar;
1141
1142     typeComp(l,mon,snd(e),snd(snd(e)));
1143     shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
1144     snd(e) = pair(m,snd(e));
1145 }
1146
1147 static Void local typeConFlds(l,e)      /* Type check a construction       */
1148 Int  l;
1149 Cell e; {
1150     static String conExpr = "value construction";
1151     Name c  = fst(snd(e));
1152     List fs = snd(snd(e));
1153     Type tc;
1154     Int  to;
1155     Int  tf;
1156     Int  i;
1157
1158     instantiate(name(c).type);
1159     for (; nonNull(predsAre); predsAre=tl(predsAre))
1160         assumeEvid(hd(predsAre),typeOff);
1161     if (whatIs(typeIs)==RANK2)
1162         typeIs = snd(snd(typeIs));
1163     tc = typeIs;
1164     to = typeOff;
1165     tf = typeFree;
1166
1167     for (; nonNull(fs); fs=tl(fs)) {
1168         Type t = tc;
1169         for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
1170             ;
1171         t = dropRank1(arg(fun(t)),to,tf);
1172         if (isPolyType(t))
1173             snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
1174         else {
1175             check(l,snd(hd(fs)),e,conExpr,t,to);
1176         }
1177     }
1178     for (i=name(c).arity; i>0; i--)
1179         tc = arg(tc);
1180     inferType(tc,to);
1181 }
1182
1183 static Void local typeUpdFlds(line,e)   /* Type check an update            */
1184 Int  line;                              /* (Written in what might seem a   */
1185 Cell e; {                               /* bizarre manner for the benefit  */
1186     static String update = "update";    /* of as yet unreleased extensions)*/
1187     List cs    = snd3(snd(e));          /* List of constructors            */
1188     List fs    = thd3(snd(e));          /* List of field specifications    */
1189     List ts    = NIL;                   /* List of types for fields        */
1190     Int  n     = length(fs);
1191     Int  alpha = newTyvars(2+n);
1192     Int  i;
1193     List fs1;
1194
1195     /* Calculate type and translation for each expr in the field list      */
1196     for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1197         snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
1198         bindTv(i,typeIs,typeOff);
1199     }
1200
1201     clearMarks();
1202     mapProc(markAssumList,defnBounds);
1203     mapProc(markAssumList,varsBounds);
1204     mapProc(markPred,preds);
1205     markBtyvs();
1206
1207     for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1208         resetGenerics();
1209         ts = cons(generalize(NIL,copyTyvar(i)),ts);
1210     }
1211     ts = rev(ts);
1212
1213     /* Type check expression to be updated                                 */
1214     fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
1215     bindTv(alpha,typeIs,typeOff);
1216
1217     for (; nonNull(cs); cs=tl(cs)) {    /* Loop through constrs            */
1218         Name c  = hd(cs);
1219         List ta = replicate(name(c).arity,NIL);
1220         Type td, tr;
1221         Int  od, or;
1222
1223         tcMode = NEW_PATTERN;           /* Domain type                     */
1224         instantiate(name(c).type);
1225         tcMode = EXPRESSION;
1226         td     = typeIs;
1227         od     = typeOff;
1228         for (; nonNull(predsAre); predsAre=tl(predsAre))
1229             assumeEvid(hd(predsAre),typeOff);
1230
1231         if (whatIs(typeIs)==RANK2) {
1232             ERRMSG(line) "Sorry, record update syntax cannot currently be "
1233                          "used for datatypes with polymorphic components"
1234             EEND;
1235         }
1236
1237         instantiate(name(c).type);      /* Range type                      */
1238         tr = typeIs;
1239         or = typeOff;
1240         for (; nonNull(predsAre); predsAre=tl(predsAre))
1241             assumeEvid(hd(predsAre),typeOff);
1242
1243         for (fs1=fs, i=1; nonNull(fs1); fs1=tl(fs1), i++) {
1244             Int n    = sfunPos(fst(hd(fs1)),c);
1245             Cell ta1 = ta;
1246             for (; n>1; n--)
1247                 ta1 = tl(ta1);
1248             hd(ta1) = mkInt(i);
1249         }
1250
1251         for (; nonNull(ta); ta=tl(ta)) {        /* For each cfun arg       */
1252             if (nonNull(hd(ta))) {              /* Field to updated?       */
1253                 Int  n = intOf(hd(ta));
1254                 Cell f = fs;
1255                 Cell t = ts;
1256                 for (; n-- > 1; f=tl(f), t=tl(t))
1257                     ;
1258                 f = hd(f);
1259                 t = hd(t);
1260                 instantiate(t);
1261                 shouldBe(line,snd(f),e,update,arg(fun(tr)),or);
1262             }                                   /* Unmentioned component   */
1263             else if (!unify(arg(fun(td)),od,arg(fun(tr)),or))
1264                 internal("typeUpdFlds");
1265
1266             tr = arg(tr);
1267             td = arg(td);
1268         }
1269
1270         inferType(td,od);                       /* Check domain type       */
1271         shouldBe(line,fst3(snd(e)),e,update,aVar,alpha);
1272         inferType(tr,or);                       /* Check range type        */
1273         shouldBe(line,e,NIL,update,aVar,alpha+1);
1274     }
1275     /* (typeIs,typeOff) still carry the result type when we exit the loop  */
1276 }
1277
1278 static Cell local typeFreshPat(l,p)    /* find type of pattern, assigning  */
1279 Int  l;                                /* fresh type variables to each var */
1280 Cell p; {                              /* bound in the pattern             */
1281     tcMode = NEW_PATTERN;
1282     p      = typeExpr(l,p);
1283     tcMode = EXPRESSION;
1284     return p;
1285 }
1286
1287 /* --------------------------------------------------------------------------
1288  * Type check group of bindings:
1289  * ------------------------------------------------------------------------*/
1290
1291 static Void local typeBindings(bs)      /* type check a binding group      */
1292 List bs; {
1293     Bool usesPatBindings = FALSE;       /* TRUE => pattern binding in bs   */
1294     Bool usesUntypedVar  = FALSE;       /* TRUE => var bind w/o type decl  */
1295     List bs1;
1296
1297     /* The following loop is used to determine whether the monomorphism    */
1298     /* restriction should be applied.  It could be written marginally more */
1299     /* efficiently by using breaks, but clarity is more important here ... */
1300
1301     for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) {  /* Analyse binding group    */
1302         Cell b = hd(bs1);
1303         if (!isVar(fst(b)))
1304             usesPatBindings = TRUE;
1305         else if (isNull(fst(hd(snd(snd(b)))))           /* no arguments    */
1306                  && whatIs(fst(snd(b)))==IMPDEPS)       /* implicitly typed*/
1307             usesUntypedVar  = TRUE;
1308     }
1309
1310     if (usesPatBindings || usesUntypedVar)
1311         monorestrict(bs);
1312     else
1313         unrestricted(bs);
1314
1315     mapProc(removeTypeSigs,bs);                /* Remove binding type info */
1316     hd(varsBounds) = revOnto(hd(defnBounds),   /* transfer completed assmps*/
1317                              hd(varsBounds));  /* out of defnBounds        */
1318     hd(defnBounds) = NIL;
1319     hd(depends)    = NIL;
1320 }
1321
1322 static Void local removeTypeSigs(b)    /* Remove type info from a binding  */
1323 Cell b; {
1324     snd(b) = snd(snd(b));
1325 }
1326
1327 /* --------------------------------------------------------------------------
1328  * Type check a restricted binding group:
1329  * ------------------------------------------------------------------------*/
1330
1331 static Void local monorestrict(bs)      /* Type restricted binding group   */
1332 List bs; {
1333     List savePreds = preds;
1334     Int  line      = isVar(fst(hd(bs))) ? rhsLine(snd(hd(snd(snd(hd(bs))))))
1335                                         : rhsLine(snd(snd(snd(hd(bs)))));
1336     hd(defnBounds) = NIL;
1337     hd(depends)    = NODEPENDS;         /* No need for dependents here     */
1338
1339     preds = NIL;                        /* Type check the bindings         */
1340     mapProc(restrictedBindAss,bs);
1341     mapProc(typeBind,bs);
1342     normPreds(line);
1343     elimTauts();
1344     preds = revOnto(preds,savePreds);
1345
1346     clearMarks();                       /* Mark fixed variables            */
1347     mapProc(markAssumList,tl(defnBounds));
1348     mapProc(markAssumList,tl(varsBounds));
1349     mapProc(markPred,preds);
1350     markBtyvs();
1351
1352     if (isNull(tl(defnBounds))) {       /* Top-level may need defaulting   */
1353         normPreds(line);
1354         if (nonNull(preds) && resolveDefs(genvarAnyAss(hd(defnBounds))))
1355             elimTauts();
1356
1357         clearMarks();
1358         reducePreds();
1359         if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4?     */
1360             elimTauts();
1361
1362         if (nonNull(preds)) {           /* Look for unresolved overloading */
1363             Cell v   = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
1364             Cell ass = findInAssumList(textOf(v),hd(varsBounds));
1365             preds    = scSimplify(preds);
1366
1367             ERRMSG(line) "Unresolved top-level overloading" ETHEN
1368             ERRTEXT     "\n*** Binding             : %s", textToStr(textOf(v))
1369             ETHEN
1370             if (nonNull(ass)) {
1371                 ERRTEXT "\n*** Inferred type       : " ETHEN ERRTYPE(snd(ass));
1372             }
1373             ERRTEXT     "\n*** Outstanding context : " ETHEN
1374                                                 ERRCONTEXT(copyPreds(preds));
1375             ERRTEXT     "\n"
1376             EEND;
1377         }
1378     }
1379
1380     map1Proc(genBind,NIL,bs);           /* Generalize types of def'd vars  */
1381 }
1382
1383 static Void local restrictedBindAss(b)  /* Make assums for vars in binding */
1384 Cell b; {                               /* gp with restricted overloading  */
1385
1386     if (isVar(fst(b))) {                /* function-binding?               */
1387         Cell t = fst(snd(b));
1388         if (whatIs(t)==IMPDEPS)  {      /* Discard implicitly typed deps   */
1389             fst(snd(b)) = t = NIL;      /* in a restricted binding group.  */
1390         }
1391         fst(snd(b)) = localizeBtyvs(t);
1392         restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
1393     } else {                            /* pattern-binding?                */
1394         List vs   = fst(b);
1395         List ts   = fst(snd(b));
1396         Int  line = rhsLine(snd(snd(snd(b))));
1397
1398         for (; nonNull(vs); vs=tl(vs)) {
1399             if (nonNull(ts)) {
1400                 restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
1401                 ts = tl(ts);
1402             } else {
1403                 restrictedAss(line,hd(vs),NIL);
1404             }
1405         }
1406     }
1407 }
1408
1409 static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
1410 Int  l;                                /* is t (if nonNull) in restricted  */
1411 Cell v;                                /* binding group                    */
1412 Type t; {
1413     newDefnBind(v,t);
1414     if (nonNull(predsAre)) {
1415         ERRMSG(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
1416         ETHEN
1417         ERRTEXT   " not permitted in restricted binding"
1418         EEND;
1419     }
1420 }
1421
1422 /* --------------------------------------------------------------------------
1423  * Unrestricted binding group:
1424  * ------------------------------------------------------------------------*/
1425
1426 static Void local unrestricted(bs)      /* Type unrestricted binding group */
1427 List bs; {
1428     List savePreds = preds;
1429     List imps      = NIL;               /* Implicitly typed bindings       */
1430     List exps      = NIL;               /* Explicitly typed bindings       */
1431     List bs1;
1432
1433     /* ----------------------------------------------------------------------
1434      * STEP 1: Separate implicitly typed bindings from explicitly typed
1435      * bindings and do a dependency analyis, where f depends on g iff f
1436      * is implicitly typed and involves a call to g.
1437      * --------------------------------------------------------------------*/
1438
1439     for (; nonNull(bs); bs=tl(bs)) {
1440         Cell b = hd(bs);
1441         if (whatIs(fst(snd(b)))==IMPDEPS)
1442             imps = cons(b,imps);        /* N.B. New lists are built to     */
1443         else                            /* avoid breaking the original     */
1444             exps = cons(b,exps);        /* list structure for bs.          */
1445     }
1446
1447     for (bs=imps; nonNull(bs); bs=tl(bs)) {
1448         Cell b  = hd(bs);               /* Restrict implicitly typed dep   */
1449         List ds = snd(fst(snd(b)));     /* lists to bindings in imps       */
1450         List cs = NIL;
1451         while (nonNull(ds)) {
1452             bs1 = tl(ds);
1453             if (cellIsMember(hd(ds),imps)) {
1454                 tl(ds) = cs;
1455                 cs     = ds;
1456             }
1457             ds = bs1;
1458         }
1459         fst(snd(b)) = cs;
1460     }
1461     imps = itbscc(imps);                /* Dependency analysis on imps     */
1462     for (bs=imps; nonNull(bs); bs=tl(bs))
1463         for (bs1=hd(bs); nonNull(bs1); bs1=tl(bs1))
1464             fst(snd(hd(bs1))) = NIL;    /* reset imps type fields          */
1465
1466 #ifdef DEBUG_DEPENDS
1467     Printf("Binding group:");
1468     for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
1469         Printf(" [imp:");
1470         for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
1471             Printf(" %s",textToStr(textOf(fst(hd(bs)))));
1472         Printf("]");
1473     }
1474     if (nonNull(exps)) {
1475         Printf(" [exp:");
1476         for (bs=exps; nonNull(bs); bs=tl(bs))
1477             Printf(" %s",textToStr(textOf(fst(hd(bs)))));
1478         Printf("]");
1479     }
1480     Printf("\n");
1481 #endif
1482
1483     /* ----------------------------------------------------------------------
1484      * STEP 2: Add type assumptions about any explicitly typed variable.
1485      * --------------------------------------------------------------------*/
1486
1487     for (bs=exps; nonNull(bs); bs=tl(bs)) {
1488         fst(snd(hd(bs))) = localizeBtyvs(fst(snd(hd(bs))));
1489         hd(varsBounds)   = cons(pair(fst(hd(bs)),fst(snd(hd(bs)))),
1490                                 hd(varsBounds));
1491     }
1492
1493     /* ----------------------------------------------------------------------
1494      * STEP 3: Calculate types for each group of implicitly typed bindings.
1495      * --------------------------------------------------------------------*/
1496
1497     for (; nonNull(imps); imps=tl(imps)) {
1498         Cell b   = hd(hd(imps));
1499         Int line = isVar(fst(b)) ? rhsLine(snd(hd(snd(snd(b)))))
1500                                  : rhsLine(snd(snd(snd(b))));
1501         hd(defnBounds) = NIL;
1502         hd(depends)    = NIL;
1503         for (bs1=hd(imps); nonNull(bs1); bs1=tl(bs1))
1504             newDefnBind(fst(hd(bs1)),NIL);
1505
1506         preds = NIL;
1507         mapProc(typeBind,hd(imps));
1508
1509         clearMarks();
1510         mapProc(markAssumList,tl(defnBounds));
1511         mapProc(markAssumList,tl(varsBounds));
1512         mapProc(markPred,savePreds);
1513         markBtyvs();
1514
1515         normPreds(line);
1516         savePreds = elimOuterPreds(savePreds);
1517         if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds)))) {
1518             savePreds = elimOuterPreds(savePreds);
1519         }
1520
1521         map1Proc(genBind,preds,hd(imps));
1522         if (nonNull(preds)) {
1523             map1Proc(addEvidParams,preds,hd(depends));
1524             map1Proc(qualifyBinding,preds,hd(imps));
1525         }
1526
1527         h98CheckType(line,"inferred type",
1528                         fst(hd(hd(defnBounds))),snd(hd(hd(defnBounds))));
1529         hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
1530     }
1531
1532     /* ----------------------------------------------------------------------
1533      * STEP 4: Now infer a type for each explicitly typed variable and
1534      * check for compatibility with the declared type.
1535      * --------------------------------------------------------------------*/
1536
1537     for (; nonNull(exps); exps=tl(exps)) {
1538         static String extbind = "explicitly typed binding";
1539         Cell b    = hd(exps);
1540         List alts = snd(snd(b));
1541         Int  line = rhsLine(snd(hd(alts)));
1542         Type t;
1543         Int  o;
1544         Int  m;
1545         List ps;
1546
1547         hd(defnBounds) = NIL;
1548         hd(depends)    = NODEPENDS;
1549         preds          = NIL;
1550
1551         instantiate(fst(snd(b)));
1552         o              = typeOff;
1553         m              = typeFree;
1554         t              = dropRank2(typeIs,o,m);
1555         ps             = makePredAss(predsAre,o);
1556
1557         enterPendingBtyvs();
1558         for (; nonNull(alts); alts=tl(alts))
1559             typeAlt(extbind,fst(b),hd(alts),t,o,m);
1560         leavePendingBtyvs();
1561
1562         if (nonNull(ps))                /* Add dict params, if necessary   */
1563             qualifyBinding(ps,b);
1564
1565         clearMarks();
1566         mapProc(markAssumList,tl(defnBounds));
1567         mapProc(markAssumList,tl(varsBounds));
1568         mapProc(markPred,savePreds);
1569         markBtyvs();
1570
1571         savePreds = elimPredsUsing(ps,savePreds);
1572         if (nonNull(preds)) {
1573             List vs = NIL;
1574             Int  i  = 0;
1575             for (; i<m; ++i)
1576                 vs = cons(mkInt(o+i),vs);
1577             if (resolveDefs(vs))
1578                 savePreds = elimPredsUsing(ps,savePreds);
1579             if (nonNull(preds)) {
1580                 clearMarks();
1581                 reducePreds();
1582                 if (nonNull(preds) && resolveDefs(vs))
1583                     savePreds = elimPredsUsing(ps,savePreds);
1584             }
1585         }
1586
1587         resetGenerics();                /* Make sure we're general enough  */
1588         ps = copyPreds(ps);
1589         t  = generalize(ps,liftRank2(t,o,m));
1590
1591         if (!sameSchemes(t,fst(snd(b))))
1592             tooGeneral(line,fst(b),fst(snd(b)),t);
1593         h98CheckType(line,"inferred type",fst(b),t);
1594
1595         if (nonNull(preds))             /* Check context was strong enough */
1596             cantEstablish(line,extbind,fst(b),t,ps);
1597     }
1598
1599     preds          = savePreds;                 /* Restore predicates      */
1600     hd(defnBounds) = NIL;
1601 }
1602
1603 #define  SCC             itbscc         /* scc for implicitly typed binds  */
1604 #define  LOWLINK         itblowlink
1605 #define  DEPENDS(t)      fst(snd(t))
1606 #define  SETDEPENDS(c,v) fst(snd(c))=v
1607 #include "scc.c"
1608 #undef   SETDEPENDS
1609 #undef   DEPENDS
1610 #undef   LOWLINK
1611 #undef   SCC
1612
1613 static Void local addEvidParams(qs,v)  /* overwrite VARID/OPCELL v with    */
1614 List qs;                               /* application of variable to evid. */
1615 Cell v; {                              /* parameters given by qs           */
1616     if (nonNull(qs)) {
1617         Cell nv;
1618
1619         if (!isVar(v))
1620             internal("addEvidParams");
1621
1622         for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
1623             nv = ap(nv,thd3(hd(qs)));
1624         fst(v) = nv;
1625         snd(v) = thd3(hd(qs));
1626     }
1627 }
1628
1629 /* --------------------------------------------------------------------------
1630  * Type check bodies of class and instance declarations:
1631  * ------------------------------------------------------------------------*/
1632
1633 static Void local typeClassDefn(c)      /* Type check implementations of   */
1634 Class c; {                              /* defaults for class c            */
1635
1636     /* ----------------------------------------------------------------------
1637      * Generate code for default dictionary builder function:
1638      *
1639      *   class.C sc1 ... scn d = let v1 ... = ...
1640      *                               vm ... = ...
1641      *                           in Make.C sc1 ... scn v1 ... vm
1642      *
1643      * where sci are superclass dictionary parameters, vj are implementations
1644      * for member functions, either taken from defaults, or using "error" to
1645      * produce a suitable error message.  (Additional line number values must
1646      * be added at appropriate places but, for clarity, these are not shown
1647      * above.)
1648      * --------------------------------------------------------------------*/
1649
1650     Int  beta   = newKindedVars(cclass(c).kinds);
1651     List params = makePredAss(cclass(c).supers,beta);
1652     Cell body   = cclass(c).dcon;
1653     Cell pat    = body;
1654     List mems   = cclass(c).members;
1655     List defs   = cclass(c).defaults;
1656     List dsels  = cclass(c).dsels;
1657     Cell d      = inventDictVar();
1658     List args   = NIL;
1659     List locs   = NIL;
1660     Cell l      = mkInt(cclass(c).line);
1661     List ps;
1662 //printf("\ntypeClassDefn %s\n", textToStr(cclass(c).text));
1663     for (ps=params; nonNull(ps); ps=tl(ps)) {
1664         Cell v = thd3(hd(ps));
1665         body   = ap(body,v);
1666         pat    = ap(pat,inventVar());
1667         args   = cons(v,args);
1668     }
1669     args   = revOnto(args,singleton(d));
1670     params = appendOnto(params,
1671                         singleton(triple(cclass(c).head,mkInt(beta),d)));
1672
1673     for (; nonNull(mems); mems=tl(mems)) {
1674         Cell v   = inventVar();         /* Pick a name for component       */
1675         Cell imp = NIL;
1676 //printf("   defaulti %s\n", textToStr(name(hd(mems)).text));
1677         if (nonNull(defs)) {            /* Look for default implementation */
1678             imp  = hd(defs);
1679             defs = tl(defs);
1680         }
1681
1682         if (isNull(imp)) {              /* Generate undefined member msg   */
1683             static String header = "Undefined member: ";
1684             String name = textToStr(name(hd(mems)).text);
1685             char   msg[FILENAME_MAX+1];
1686             Int    i;
1687             Int    j;
1688
1689             for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
1690                 msg[i] = header[i];
1691             for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
1692                 msg[i+j] = name[j];
1693             msg[i+j] = '\0';
1694
1695             imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
1696                                                     mkStr(findText(msg)))))));
1697         }
1698         else {                          /* Use default implementation      */
1699             fst(imp) = v;
1700             typeMember("default member binding",
1701                        hd(mems),
1702                        snd(imp),
1703                        params,
1704                        cclass(c).head,
1705                        beta);
1706         }
1707
1708         locs = cons(imp,locs);
1709         body = ap(body,v);
1710         pat  = ap(pat,v);
1711     }
1712     body     = ap(l,body);
1713     if (nonNull(locs))
1714         body = ap(LETREC,pair(singleton(locs),body));
1715     name(cclass(c).dbuild).defn
1716              = singleton(pair(args,body));
1717     genDefns = cons(cclass(c).dbuild,genDefns);
1718     cclass(c).defaults = NIL;
1719
1720     /* ----------------------------------------------------------------------
1721      * Generate code for superclass and member function selectors:
1722      * --------------------------------------------------------------------*/
1723
1724     args = getArgs(pat);
1725     pat  = singleton(pat);
1726     for (; nonNull(dsels); dsels=tl(dsels)) {
1727         name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
1728         args                 = tl(args);
1729         genDefns             = cons(hd(dsels),genDefns);
1730     }
1731     for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
1732         name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
1733                                                     hd(args))));
1734         args                = tl(args);
1735         genDefns            = cons(hd(mems),genDefns);
1736     }
1737 //printf("done\n" );
1738 }
1739
1740 static Void local typeInstDefn(in)      /* Type check implementations of   */
1741 Inst in; {                              /* member functions for instance in*/
1742
1743     /* ----------------------------------------------------------------------
1744      * Generate code for instance specific dictionary builder function:
1745      *
1746      *   inst.maker d1 ... dn = let sc1 = ...
1747      *                                  .
1748      *                                  .
1749      *                                  .
1750      *                              scm = ...
1751      *                              d   = f (class.C sc1 ... scm d)
1752      *           omit if the   /    f (Make.C sc1' ... scm' v1' ... vk')
1753      *          instance decl {         = let vj ... = ...
1754      *           has no imps   \          in Make.C sc1' ... scm' ... vj ...
1755      *                          in d
1756      *
1757      * where sci are superclass dictionaries, d and f are new names, vj
1758      * is a newly generated name corresponding to the implementation of a
1759      * member function.  (Additional line number values must be added at
1760      * appropriate places but, for clarity, these are not shown above.)
1761      * --------------------------------------------------------------------*/
1762
1763     Int  alpha   = newKindedVars(cclass(inst(in).c).kinds);
1764     List supers  = makePredAss(cclass(inst(in).c).supers,alpha);
1765     Int  beta    = newKindedVars(inst(in).kinds);
1766     List params  = makePredAss(inst(in).specifics,beta);
1767     Cell d       = inventDictVar();
1768     List evids   = cons(triple(inst(in).head,mkInt(beta),d),
1769                         appendOnto(dupList(params),supers));
1770
1771     List imps    = inst(in).implements;
1772     Cell l       = mkInt(inst(in).line);
1773     Cell dictDef = cclass(inst(in).c).dbuild;
1774     List args    = NIL;
1775     List locs    = NIL;
1776     List ps;
1777
1778     if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
1779         internal("typeInstDefn");
1780
1781     for (ps=params; nonNull(ps); ps=tl(ps))     /* Build arglist           */
1782         args = cons(thd3(hd(ps)),args);
1783     args = rev(args);
1784
1785     for (ps=supers; nonNull(ps); ps=tl(ps)) {   /* Superclass dictionaries */
1786         Cell pi = hd(ps);
1787         Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
1788         if (isNull(ev))
1789             ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
1790         if (isNull(ev)) {
1791             clearMarks();
1792             ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
1793             ERRTEXT "\n*** Instance            : " ETHEN
1794                 ERRPRED(copyPred(inst(in).head,beta));
1795             ERRTEXT "\n*** Context supplied    : " ETHEN
1796                 ERRCONTEXT(copyPreds(params));
1797             ERRTEXT "\n*** Required superclass : " ETHEN
1798                 ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
1799             ERRTEXT "\n"
1800             EEND;
1801         }
1802         locs    = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
1803         dictDef = ap(dictDef,thd3(pi));
1804     }
1805     dictDef = ap(dictDef,d);
1806
1807     if (isNull(imps))                           /* No implementations      */
1808         locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
1809     else {                                      /* Implementations supplied*/
1810         List mems  = cclass(inst(in).c).members;
1811         Cell f     = inventVar();
1812         Cell pat   = cclass(inst(in).c).dcon;
1813         Cell res   = pat;
1814         List locs1 = NIL;
1815
1816         locs       = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
1817                           locs);
1818
1819         for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc   */
1820             Cell v = inventVar();
1821             pat    = ap(pat,v);
1822             res    = ap(res,v);
1823         }
1824
1825         for (; nonNull(mems); mems=tl(mems)) {  /* For each member:        */
1826             Cell v   = inventVar();
1827             Cell imp = NIL;
1828
1829             if (nonNull(imps)) {                /* Look for implementation */
1830                 imp  = hd(imps);
1831                 imps = tl(imps);
1832             }
1833
1834             if (isNull(imp)) {                  /* If none, f will copy    */
1835                 pat = ap(pat,v);                /* its argument unchanged  */
1836                 res = ap(res,v);
1837             }
1838             else {                              /* Otherwise, add the impl */
1839                 pat      = ap(pat,WILDCARD);    /* to f as a local defn    */
1840                 res      = ap(res,v);
1841                 typeMember("instance member binding",
1842                            hd(mems),
1843                            snd(imp),
1844                            evids,
1845                            inst(in).head,
1846                            beta);
1847                 locs1    = cons(pair(v,snd(imp)),locs1);
1848             }
1849         }
1850         res = ap(l,res);
1851         if (nonNull(locs1))                     /* Build the body of f     */
1852             res = ap(LETREC,pair(singleton(locs1),res));
1853         pat  = singleton(pat);                  /* And the arglist for f   */
1854         locs = cons(pair(f,singleton(pair(pat,res))),locs);
1855     }
1856     d = ap(l,d);
1857
1858     name(inst(in).builder).defn                 /* Register builder imp    */
1859              = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
1860     genDefns = cons(inst(in).builder,genDefns);
1861 }
1862
1863 static Void local typeMember(wh,mem,alts,evids,head,beta)
1864 String wh;                              /* Type check alternatives alts of */
1865 Name   mem;                             /* member mem for inst type head   */
1866 Cell   alts;                            /* at offset beta using predicate  */
1867 List   evids;                           /* assignment evids                */
1868 Cell   head;
1869 Int    beta; {
1870     Int  line = rhsLine(snd(hd(alts)));
1871     Type t;
1872     Int  o;
1873     Int  m;
1874     List ps;
1875     List qs;
1876     Type rt;
1877
1878 #ifdef DEBUG_TYPES
1879     Printf("\nType check member: ");
1880     printExp(stdout,mem);
1881     Printf(" :: ");
1882     printType(stdout,name(mem).type);
1883     Printf("\n   for the instance: ");
1884     printPred(stdout,head);
1885     Printf("\n");
1886 #endif
1887
1888     instantiate(name(mem).type);        /* Find required type              */
1889     o  = typeOff;
1890     m  = typeFree;
1891     t  = dropRank2(typeIs,o,m);
1892     ps = makePredAss(predsAre,o);
1893     if (!unifyPred(hd(predsAre),typeOff,head,beta))
1894         internal("typeMember1");
1895     clearMarks();
1896     qs = copyPreds(ps);
1897     rt = generalize(qs,liftRank2(t,o,m));
1898
1899 #ifdef DEBUG_TYPES
1900     Printf("Required type is: ");
1901     printType(stdout,rt);
1902     Printf("\n");
1903 #endif
1904
1905     hd(defnBounds) = NIL;               /* Type check each alternative     */
1906     hd(depends)    = NODEPENDS;
1907     enterPendingBtyvs();
1908     for (preds=NIL; nonNull(alts); alts=tl(alts)) {
1909         typeAlt(wh,mem,hd(alts),t,o,m);
1910         qualify(tl(ps),hd(alts));       /* Add any extra dict params       */
1911     }
1912     leavePendingBtyvs();
1913
1914     evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts  */
1915                        evids);
1916     clearMarks();
1917     qs = elimPredsUsing(evids,NIL);
1918     if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
1919         qs = elimPredsUsing(evids,qs);
1920     if (nonNull(qs)) {
1921         ERRMSG(line)
1922                 "Implementation of %s requires extra context",
1923                  textToStr(name(mem).text) ETHEN
1924         ERRTEXT "\n*** Expected type   : " ETHEN ERRTYPE(rt);
1925         ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
1926         ERRTEXT "\n"
1927         EEND;
1928     }
1929
1930     resetGenerics();                    /* Make sure we're general enough  */
1931     ps = copyPreds(ps);
1932     t  = generalize(ps,liftRank2(t,o,m));
1933 #ifdef DEBUG_TYPES
1934     Printf("   Inferred type is: ");
1935     printType(stdout,t);
1936     Printf("\n");
1937 #endif
1938     if (!sameSchemes(t,rt))
1939         tooGeneral(line,mem,rt,t);
1940     if (nonNull(preds))
1941         cantEstablish(line,wh,mem,t,ps);
1942 //printf("done\n" );
1943 }
1944
1945 /* --------------------------------------------------------------------------
1946  * Type check bodies of bindings:
1947  * ------------------------------------------------------------------------*/
1948
1949 static Void local typeBind(b)          /* Type check binding               */
1950 Cell b; {
1951     if (isVar(fst(b))) {                               /* function binding */
1952         Cell ass = findTopBinding(fst(b));
1953         Int  beta;
1954
1955         if (isNull(ass))
1956             internal("typeBind");
1957
1958         beta = intOf(defType(snd(ass)));
1959         enterPendingBtyvs();
1960         map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
1961         leavePendingBtyvs();
1962     }
1963     else {                                             /* pattern binding  */
1964         static String lhsPat = "lhs pattern";
1965         static String rhs    = "right hand side";
1966         Int  beta            = newTyvars(1);
1967         Pair pb              = snd(snd(b));
1968         Int  l               = rhsLine(snd(pb));
1969
1970         tcMode  = OLD_PATTERN;
1971         enterPendingBtyvs();
1972         fst(pb) = patBtyvs(fst(pb));
1973         check(l,fst(pb),NIL,lhsPat,aVar,beta);
1974         tcMode  = EXPRESSION;
1975         snd(pb) = typeRhs(snd(pb));
1976         shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
1977         doneBtyvs(l);
1978         leavePendingBtyvs();
1979     }
1980 }
1981
1982 static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding  */
1983 Int  beta;
1984 Cell v;
1985 Pair a; {
1986     static String valDef = "function binding";
1987     typeAlt(valDef,v,a,aVar,beta,0);
1988 }
1989
1990 static Cell local typeRhs(e)           /* check type of rhs of definition  */
1991 Cell e; {
1992     switch (whatIs(e)) {
1993         case GUARDED : {   Int beta = newTyvars(1);
1994                            map1Proc(guardedType,beta,snd(e));
1995                            tyvarType(beta);
1996                        }
1997                        break;
1998
1999         case LETREC  : enterBindings();
2000                        enterSkolVars();
2001                        mapProc(typeBindings,fst(snd(e)));
2002                        snd(snd(e)) = typeRhs(snd(snd(e)));
2003                        leaveBindings();
2004                        leaveSkolVars(rhsLine(snd(snd(e))),typeIs,typeOff,0);
2005                        break;
2006
2007         case RSIGN   : fst(snd(e)) = typeRhs(fst(snd(e)));
2008                        shouldBe(rhsLine(fst(snd(e))),
2009                                 rhsExpr(fst(snd(e))),NIL,
2010                                 "result type",
2011                                 snd(snd(e)),0);
2012                        return fst(snd(e));
2013
2014         default      : snd(e) = typeExpr(intOf(fst(e)),snd(e));
2015                        break;
2016     }
2017     return e;
2018 }
2019
2020 static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
2021 Int  beta;                             /* should have gd :: Bool,          */
2022 Cell gded; {                           /*             ex :: (var,beta)     */
2023     static String guarded = "guarded expression";
2024     static String guard   = "guard";
2025     Int line = intOf(fst(gded));
2026
2027     gded     = snd(gded);
2028     check(line,fst(gded),NIL,guard,typeBool,0);
2029     check(line,snd(gded),NIL,guarded,aVar,beta);
2030 }
2031
2032 Cell rhsExpr(rhs)                      /* find first expression on a rhs   */
2033 Cell rhs; {
2034     switch (whatIs(rhs)) {
2035         case GUARDED : return snd(snd(hd(snd(rhs))));
2036         case LETREC  : return rhsExpr(snd(snd(rhs)));
2037         case RSIGN   : return rhsExpr(fst(snd(rhs)));
2038         default      : return snd(rhs);
2039     }
2040 }
2041
2042 Int rhsLine(rhs)                       /* find line number associated with */
2043 Cell rhs; {                            /* a right hand side                */
2044     switch (whatIs(rhs)) {
2045         case GUARDED : return intOf(fst(hd(snd(rhs))));
2046         case LETREC  : return rhsLine(snd(snd(rhs)));
2047         case RSIGN   : return rhsLine(fst(snd(rhs)));
2048         default      : return intOf(fst(rhs));
2049     }
2050 }
2051
2052 /* --------------------------------------------------------------------------
2053  * Calculate generalization of types and compare with declared type schemes:
2054  * ------------------------------------------------------------------------*/
2055
2056 static Void local genBind(ps,b)         /* Generalize the type of each var */
2057 List ps;                                /* defined in binding b, qualifying*/
2058 Cell b; {                               /* each with the predicates in ps. */
2059     Cell v = fst(b);
2060     Cell t = fst(snd(b));
2061
2062     if (isVar(fst(b)))
2063         genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
2064     else {
2065         Int line = rhsLine(snd(snd(snd(b))));
2066         for (; nonNull(v); v=tl(v)) {
2067             Type ty = NIL;
2068             if (nonNull(t)) {
2069                 ty = hd(t);
2070                 t  = tl(t);
2071             }
2072             genAss(line,ps,hd(v),ty);
2073         }
2074     }
2075 }
2076
2077 static Void local genAss(l,ps,v,dt)     /* Calculate inferred type of v and*/
2078 Int  l;                                 /* compare with declared type, dt, */
2079 List ps;                                /* if given & check for ambiguity. */
2080 Cell v;
2081 Type dt; {
2082     Cell ass = findTopBinding(v);
2083
2084     if (isNull(ass))
2085         internal("genAss");
2086
2087     snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
2088
2089 #ifdef DEBUG_TYPES
2090     printExp(stdout,v);
2091     Printf(" :: ");
2092     printType(stdout,snd(ass));
2093     Printf("\n");
2094 #endif
2095 }
2096
2097 static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred    */
2098 Int  l;                                 /* type (t,o) with context ps      */
2099 Cell v;                                 /* against declared type dt for v. */
2100 List ps;
2101 Type dt;
2102 Type t;
2103 Int  o; {
2104     Type bt = NIL;                      /* Body of inferred type           */
2105     Type it = NIL;                      /* Full inferred type              */
2106
2107     resetGenerics();                    /* Calculate Haskell typing        */
2108     ps = copyPreds(ps);
2109     bt = copyType(t,o);
2110     it = generalize(ps,bt);
2111
2112     if (nonNull(dt)) {                  /* If a declared type was given,   */
2113         instantiate(dt);                /* check body for match.           */
2114         if (!equalTypes(typeIs,bt))
2115             tooGeneral(l,v,dt,it);
2116     }
2117     else if (nonNull(ps))               /* Otherwise test for ambiguity in */
2118         if (isAmbiguous(it))            /* inferred type.                  */
2119             ambigError(l,"inferred type",v,it);
2120
2121     return it;
2122 }
2123
2124 static Type local generalize(qs,t)      /* calculate generalization of t   */
2125 List qs;                                /* having already marked fixed vars*/
2126 Type t; {                               /* with qualifying preds qs        */
2127     if (nonNull(qs))
2128         t = ap(QUAL,pair(qs,t));
2129     if (nonNull(genericVars)) {
2130         Kind k  = STAR;
2131         List vs = genericVars;
2132         for (; nonNull(vs); vs=tl(vs)) {
2133             Tyvar *tyv = tyvar(intOf(hd(vs)));
2134             Kind   ka  = tyv->kind;
2135             k = ap(ka,k);
2136         }
2137         t = mkPolyType(k,t);
2138 #ifdef DEBUG_KINDS
2139     Printf("Generalized type: ");
2140     printType(stdout,t);
2141     Printf(" ::: ");
2142     printKind(stdout,k);
2143     Printf("\n");
2144 #endif
2145     }
2146     return t;
2147 }
2148
2149 static Bool local equalTypes(t1,t2)    /* Compare simple types for equality*/
2150 Type t1, t2; {
2151
2152 et: if (whatIs(t1)!=whatIs(t2))
2153         return FALSE;
2154
2155     switch (whatIs(t1)) {
2156 #if TREX
2157         case EXT     :
2158 #endif
2159         case TYCON   :
2160         case OFFSET  :
2161         case TUPLE   : return t1==t2;
2162
2163         case INTCELL : return intOf(t1)!=intOf(t2);
2164
2165         case AP      : if (equalTypes(fun(t1),fun(t2))) {
2166                            t1 = arg(t1);
2167                            t2 = arg(t2);
2168                            goto et;
2169                        }
2170                        return FALSE;
2171
2172         default      : internal("equalTypes");
2173     }
2174
2175     return TRUE;/*NOTREACHED*/
2176 }
2177
2178 /* --------------------------------------------------------------------------
2179  * Entry points to type checker:
2180  * ------------------------------------------------------------------------*/
2181
2182 Type typeCheckExp(useDefs)              /* Type check top level expression */
2183 Bool useDefs; {                         /* using defaults if reqd          */
2184     Type type;
2185     List ctxt;
2186     Int  beta;
2187
2188     typeChecker(RESET);
2189     emptySubstitution();
2190     enterBindings();
2191     inputExpr = typeExpr(0,inputExpr);
2192     type      = typeIs;
2193     beta      = typeOff;
2194     clearMarks();
2195     normPreds(0);
2196     elimTauts();
2197     preds     = scSimplify(preds);
2198     if (useDefs && nonNull(preds)) {
2199         clearMarks();
2200         reducePreds();
2201         if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4?     */
2202             elimTauts();
2203     }
2204     resetGenerics();
2205     ctxt      = copyPreds(preds);
2206     type      = generalize(ctxt,copyType(type,beta));
2207     inputExpr = qualifyExpr(0,preds,inputExpr);
2208     h98CheckType(0,"inferred type",inputExpr,type);
2209     typeChecker(RESET);
2210     emptySubstitution();
2211     return type;
2212 }
2213
2214 Void typeCheckDefns() {                /* Type check top level bindings    */
2215     Target t  = length(selDefns)  + length(valDefns) +
2216                 length(instDefns) + length(classDefns);
2217     Target i  = 0;
2218     List   gs;
2219
2220     typeChecker(RESET);
2221     emptySubstitution();
2222     enterSkolVars();
2223     enterBindings();
2224     setGoal("Type checking",t);
2225
2226     for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
2227         mapOver(typeSel,hd(gs));
2228         soFar(i++);
2229     }
2230     for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
2231         typeDefnGroup(hd(gs));
2232         soFar(i++);
2233     }
2234     clearTypeIns();
2235     for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
2236         emptySubstitution();
2237         typeClassDefn(hd(gs));
2238         soFar(i++);
2239     }
2240     for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
2241         emptySubstitution();
2242         typeInstDefn(hd(gs));
2243         soFar(i++);
2244     }
2245
2246     typeChecker(RESET);
2247     emptySubstitution();
2248     done();
2249 }
2250
2251 static Void local typeDefnGroup(bs)     /* type check group of value defns */
2252 List bs; {                              /* (one top level scc)             */
2253     List as;
2254     // printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n");
2255     //{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){
2256     //   print(hd(qq),4);
2257     //   printf("\n");
2258     //}}
2259
2260     emptySubstitution();
2261     hd(defnBounds) = NIL;
2262     preds          = NIL;
2263     setTypeIns(bs);
2264     typeBindings(bs);                   /* find types for vars in bindings */
2265
2266     if (nonNull(preds)) {
2267         Cell v = fst(hd(hd(varsBounds)));
2268         Name n = findName(textOf(v));
2269         Int  l = nonNull(n) ? name(n).line : 0;
2270         preds  = scSimplify(preds);
2271         ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
2272         ERRCONTEXT(copyPreds(preds));
2273         ERRTEXT   " required for definition of " ETHEN
2274         ERREXPR(nonNull(n)?n:v);
2275         ERRTEXT   "\n"
2276         EEND;
2277     }
2278
2279     if (nonNull(hd(skolVars))) {
2280         Cell b = hd(bs);
2281         Name n = findName(isVar(fst(b)) ? textOf(fst(b)) : textOf(hd(fst(b))));
2282         Int  l = nonNull(n) ? name(n).line : 0;
2283         leaveSkolVars(l,typeUnit,0,0);
2284         enterSkolVars();
2285     }
2286
2287     for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
2288         Cell a = hd(as);                /* add infered types to environment*/
2289         Name n = findName(textOf(fst(a)));
2290         if (isNull(n))
2291             internal("typeDefnGroup");
2292         name(n).type = snd(a);
2293     }
2294     hd(varsBounds) = NIL;
2295 }
2296
2297 static Pair local typeSel(s)            /* Calculate a suitable type for a */
2298 Name s; {                               /* particular selector, s.         */
2299     List cns  = name(s).defn;
2300     Int  line = name(s).line;
2301     Type dom  = NIL;                    /* Inferred domain                 */
2302     Type rng  = NIL;                    /* Inferred range                  */
2303     Cell nv   = inventVar();
2304     List alts = NIL;
2305     Int  o;
2306     Int  m;
2307
2308 #ifdef DEBUG_SELS
2309     Printf("Selector %s, cns=",textToStr(name(s).text));
2310     printExp(stdout,cns);
2311     Putchar('\n');
2312 #endif
2313
2314     emptySubstitution();
2315     preds = NIL;
2316
2317     for (; nonNull(cns); cns=tl(cns)) {
2318         Name c   = fst(hd(cns));
2319         Int  n   = intOf(snd(hd(cns)));
2320         Int  a   = name(c).arity;
2321         Cell pat = c;
2322         Type dom1;
2323         Type rng1;
2324         Int  o1;
2325         Int  m1;
2326
2327         instantiate(name(c).type);      /* Instantiate constructor type    */
2328         o1 = typeOff;
2329         m1 = typeFree;
2330         for (; nonNull(predsAre); predsAre=tl(predsAre))
2331             assumeEvid(hd(predsAre),o1);
2332
2333         if (whatIs(typeIs)==RANK2)      /* Skip rank2 annotation, if any   */
2334             typeIs = snd(snd(typeIs));
2335         for (; --n>0; a--) {            /* Get range                       */
2336             pat    = ap(pat,WILDCARD);
2337             typeIs = arg(typeIs);
2338         }
2339         rng1   = dropRank1(arg(fun(typeIs)),o1,m1);
2340         pat    = ap(pat,nv);
2341         typeIs = arg(typeIs);
2342         while (--a>0) {                 /* And then look for domain        */
2343             pat    = ap(pat,WILDCARD);
2344             typeIs = arg(typeIs);
2345         }
2346         dom1   = typeIs;
2347
2348         if (isNull(dom)) {              /* Save first domain type and then */
2349             dom = dom1;                 /* unify with subsequent domains to*/
2350             o   = o1;                   /* match up preds and range types  */
2351             m   = m1;
2352         }
2353         else if (!unify(dom1,o1,dom,o))
2354             internal("typeSel1");
2355
2356         if (isNull(rng))                /* Compare component types         */
2357             rng = rng1;
2358         else if (!sameSchemes(rng1,rng)) {
2359             clearMarks();
2360             rng  = liftRank1(rng,o,m);
2361             rng1 = liftRank1(rng1,o1,m1);
2362             ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
2363                                  textToStr(name(s).text) ETHEN
2364             ERRTEXT "\n*** Field type     : "            ETHEN ERRTYPE(rng1);
2365             ERRTEXT "\n*** Does not match : "            ETHEN ERRTYPE(rng);
2366             ERRTEXT "\n"
2367             EEND;
2368         }
2369         alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
2370     }
2371     alts = rev(alts);
2372
2373     if (isNull(dom) || isNull(rng))     /* Should have been initialized by */
2374         internal("typeSel2");           /* now, assuming length cns >= 1.  */
2375
2376     clearMarks();                       /* No fixed variables here         */
2377     preds = scSimplify(preds);          /* Simplify context                */
2378     dom   = copyType(dom,o);            /* Calculate domain type           */
2379     instantiate(rng);
2380     rng   = copyType(typeIs,typeOff);
2381     if (nonNull(predsAre)) {
2382         List ps    = makePredAss(predsAre,typeOff);
2383         List alts1 = alts;
2384         for (; nonNull(alts1); alts1=tl(alts1)) {
2385             Cell body = nv;
2386             List qs   = ps;
2387             for (; nonNull(qs); qs=tl(qs))
2388                 body = ap(body,thd3(hd(qs)));
2389             snd(snd(hd(alts1))) = body;
2390         }
2391         preds = appendOnto(preds,ps);
2392     }
2393     name(s).type  = generalize(copyPreds(preds),fn(dom,rng));
2394     name(s).arity = 1 + length(preds);
2395     map1Proc(qualify,preds,alts);
2396
2397 #ifdef DEBUG_SELS
2398     Printf("Inferred arity = %d, type = ",name(s).arity);
2399     printType(stdout,name(s).type);
2400     Putchar('\n');
2401 #endif
2402
2403     return pair(s,alts);
2404 }
2405
2406
2407 /* --------------------------------------------------------------------------
2408  * Local function prototypes:
2409  * ------------------------------------------------------------------------*/
2410
2411 static Type local basicType Args((Char));
2412
2413
2414 static Type stateVar = BOGUS(600); //NIL;
2415 static Type alphaVar = BOGUS(601); //NIL;
2416 static Type betaVar  = BOGUS(602); //NIL;
2417 static Type gammaVar = BOGUS(603); //NIL;
2418 static Int  nextVar  = BOGUS(604); //0;
2419
2420 static Void clearTyVars( void )
2421 {
2422     stateVar = NIL;
2423     alphaVar = NIL;
2424     betaVar  = NIL;
2425     gammaVar = NIL;
2426     nextVar  = 0;
2427 }
2428
2429 static Type mkStateVar( void )
2430 {
2431     if (isNull(stateVar)) {
2432         stateVar = mkOffset(nextVar++);
2433     }
2434     return stateVar;
2435 }
2436
2437 static Type mkAlphaVar( void )
2438 {
2439     if (isNull(alphaVar)) {
2440         alphaVar = mkOffset(nextVar++);
2441     }
2442     return alphaVar;
2443 }
2444
2445 static Type mkBetaVar( void )
2446 {
2447     if (isNull(betaVar)) {
2448         betaVar = mkOffset(nextVar++);
2449     }
2450     return betaVar;
2451 }
2452
2453 static Type mkGammaVar( void )
2454 {
2455     if (isNull(gammaVar)) {
2456         gammaVar = mkOffset(nextVar++);
2457     }
2458     return gammaVar;
2459 }
2460
2461 static Type local basicType(k)
2462 Char k; {
2463     switch (k) {
2464     case CHAR_REP:
2465             return typeChar;
2466     case INT_REP:
2467             return typeInt;
2468 #ifdef PROVIDE_INT64
2469     case INT64_REP:
2470             return typeInt64;
2471 #endif
2472 #ifdef PROVIDE_INTEGER
2473     case INTEGER_REP:
2474             return typeInteger;
2475 #endif
2476 #ifdef PROVIDE_ADDR
2477     case ADDR_REP:
2478             return typeAddr;
2479 #endif
2480 #ifdef PROVIDE_WORD
2481     case WORD_REP:
2482             return typeWord;
2483 #endif
2484     case FLOAT_REP:
2485             return typeFloat;
2486     case DOUBLE_REP:
2487             return typeDouble;
2488 #ifdef PROVIDE_ARRAY
2489     case ARR_REP:     return ap(typePrimArray,mkAlphaVar());
2490     case BARR_REP:    return typePrimByteArray;
2491     case REF_REP:     return ap2(typeRef,mkStateVar(),mkAlphaVar());
2492     case MUTARR_REP:  return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
2493     case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar());
2494 #endif
2495 #ifdef PROVIDE_STABLE
2496     case STABLE_REP:
2497             return ap(typeStable,mkAlphaVar());
2498 #endif
2499 #ifdef PROVIDE_WEAK
2500     case WEAK_REP:
2501             return ap(typeWeak,mkAlphaVar());
2502     case IO_REP:
2503             return ap(typeIO,typeUnit);
2504 #endif
2505 #ifdef PROVIDE_FOREIGN
2506     case FOREIGN_REP:
2507             return typeForeign;
2508 #endif
2509 #ifdef PROVIDE_CONCURRENT
2510     case THREADID_REP:
2511             return typeThreadId;
2512     case MVAR_REP:
2513             return ap(typeMVar,mkAlphaVar());
2514 #endif
2515     case BOOL_REP:
2516             return typeBool;
2517     case HANDLER_REP:
2518             return fn(typeException,mkAlphaVar());
2519     case ERROR_REP:
2520             return typeException;
2521     case ALPHA_REP:
2522             return mkAlphaVar();  /* polymorphic */
2523     case BETA_REP:
2524             return mkBetaVar();   /* polymorphic */
2525     case GAMMA_REP:
2526             return mkGammaVar();  /* polymorphic */
2527     default:
2528             printf("Kind: '%c'\n",k);
2529             internal("basicType");
2530     }
2531     assert(0); return 0; /* NOTREACHED */
2532 }
2533
2534 /* Generate type of primop based on list of arg types and result types:
2535  *
2536  * eg primType "II" "II" = Int -> Int -> (Int,Int)
2537  *
2538  */
2539 Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
2540 {
2541     List rs    = NIL;
2542     List as    = NIL;
2543     List tvars = NIL; /* for polymorphic types */
2544     Type r;
2545
2546     clearTyVars();
2547
2548     /* build result types */
2549     for(; *r_kinds; ++r_kinds) {
2550         rs = cons(basicType(*r_kinds),rs);
2551     }
2552     /* Construct tuple of results */
2553     if (length(rs) == 0) {
2554         r = typeUnit;
2555     } else if (length(rs) == 1) {
2556         r = hd(rs);
2557     } else {
2558         r = mkTuple(length(rs));
2559         for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
2560             r = ap(r,hd(rs));
2561         }
2562     }
2563     /* Construct list of arguments */
2564     for(; *a_kinds; ++a_kinds) {
2565         as = cons(basicType(*a_kinds),as);
2566     }
2567     /* Apply any monad magic */
2568     if (monad == MONAD_IO) {
2569         r = ap(typeIO,r);
2570     } else if (monad == MONAD_ST) {
2571         r = ap2(typeST,mkStateVar(),r);
2572     }
2573     /* glue it all together */
2574     for(; nonNull(as); as=tl(as)) {
2575         r = fn(hd(as),r);
2576     }
2577     tvars = offsetTyvarsIn(r,NIL);
2578     if (nonNull(tvars)) {
2579         assert(length(tvars) == nextVar);
2580         r = mkPolyType(simpleKind(length(tvars)),r);
2581     }
2582 #if DEBUG_CODE
2583     if (debugCode) {
2584         printType(stdout,r); printf("\n");
2585     }
2586 #endif
2587     return r;
2588 }
2589
2590 /* forall a1 .. am. TC a1 ... am -> Int */
2591 Type conToTagType(t)
2592 Tycon t; {
2593     Type   ty  = t;
2594     List   tvars = NIL;
2595     Int    i   = 0;
2596     for (i=0; i<tycon(t).arity; ++i) {
2597         Offset tv = mkOffset(i);
2598         ty = ap(ty,tv);
2599         tvars = cons(tv,tvars);
2600     }
2601     ty = fn(ty,typeInt);
2602     if (nonNull(tvars)) {
2603         ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2604     }
2605     return ty;
2606 }
2607
2608 /* forall a1 .. am. Int -> TC a1 ... am */
2609 Type tagToConType(t)
2610 Tycon t; {
2611     Type   ty  = t;
2612     List   tvars = NIL;
2613     Int    i   = 0;
2614     for (i=0; i<tycon(t).arity; ++i) {
2615         Offset tv = mkOffset(i);
2616         ty = ap(ty,tv);
2617         tvars = cons(tv,tvars);
2618     }
2619     ty = fn(typeInt,ty);
2620     if (nonNull(tvars)) {
2621         ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2622     }
2623     return ty;
2624 }
2625
2626 /* --------------------------------------------------------------------------
2627  * Type checker control:
2628  * ------------------------------------------------------------------------*/
2629
2630 Void typeChecker(what)
2631 Int what; {
2632     switch (what) {
2633         case RESET   : tcMode       = EXPRESSION;
2634                        preds        = NIL;
2635                        pendingBtyvs = NIL;
2636                        emptyAssumption();
2637                        break;
2638
2639         case MARK    : mark(defnBounds);
2640                        mark(varsBounds);
2641                        mark(depends);
2642                        mark(pendingBtyvs);
2643                        mark(skolVars);
2644                        mark(localEvs);
2645                        mark(savedPs);
2646                        mark(dummyVar);
2647                        mark(preds);
2648                        mark(stdDefaults);
2649                        mark(arrow);
2650                        mark(boundPair);
2651                        mark(listof);
2652                        mark(typeVarToVar);
2653                        mark(predNum);
2654                        mark(predFractional);
2655                        mark(predIntegral);
2656                        mark(starToStar);
2657                        mark(predMonad);
2658 #if IO_MONAD
2659                        mark(typeProgIO);
2660 #endif
2661                        break;
2662
2663         case INSTALL : typeChecker(RESET);
2664                        dummyVar     = inventVar();
2665
2666 #if !IGNORE_MODULES
2667                        setCurrModule(modulePrelude);
2668 #endif
2669
2670                        starToStar   = simpleKind(1);
2671
2672                        typeUnit     = addPrimTycon(findText("()"),
2673                                                    STAR,0,DATATYPE,NIL);
2674                        typeArrow    = addPrimTycon(findText("(->)"),
2675                                                    simpleKind(2),2,
2676                                                    DATATYPE,NIL);
2677                        typeList     = addPrimTycon(findText("[]"),
2678                                                    starToStar,1,
2679                                                    DATATYPE,NIL);
2680
2681                        arrow        = fn(aVar,bVar);
2682                        listof       = ap(typeList,aVar);
2683                        boundPair    = ap(ap(mkTuple(2),aVar),aVar);
2684
2685                        nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
2686                        tycon(typeUnit).defn
2687                                     = singleton(nameUnit);
2688
2689                        nameNil      = addPrimCfun(findText("[]"),0,1,
2690                                                    mkPolyType(starToStar,
2691                                                               listof));
2692                        nameCons     = addPrimCfun(findText(":"),2,2,
2693                                                    mkPolyType(starToStar,
2694                                                               fn(aVar,
2695                                                               fn(listof,
2696                                                                  listof))));
2697                        name(nameCons).syntax
2698                                     = mkSyntax(RIGHT_ASS,5);
2699
2700                        tycon(typeList).defn
2701                                     = cons(nameNil,cons(nameCons,NIL));
2702
2703                        typeVarToVar = fn(aVar,aVar);
2704 #if TREX
2705                        typeNoRow    = addPrimTycon(findText("EmptyRow"),
2706                                                    ROW,0,DATATYPE,NIL);
2707                        typeRec      = addPrimTycon(findText("Rec"),
2708                                                    pair(ROW,STAR),1,
2709                                                    DATATYPE,NIL);
2710                        nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
2711                                                         ap(typeRec,typeNoRow));
2712 #else
2713                        /* bogus definitions to avoid changing the prelude */
2714                        addPrimCfun(findText("Rec"),      0,0,typeUnit);
2715                        addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
2716                        addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
2717 #endif
2718 #if IO_MONAD
2719                        nameUserErr  = addPrimCfun(inventText(),1,1,NIL);
2720                        nameNameErr  = addPrimCfun(inventText(),1,2,NIL);
2721                        nameSearchErr= addPrimCfun(inventText(),1,3,NIL);
2722 #if IO_HANDLES
2723                        nameIllegal  = addPrimCfun(inventText(),0,4,NIL);
2724                        nameWriteErr = addPrimCfun(inventText(),1,5,NIL);
2725                        nameEOFErr   = addPrimCfun(inventText(),1,6,NIL);
2726 #endif
2727 #endif
2728                        break;
2729     }
2730 }
2731
2732 /*-------------------------------------------------------------------------*/