ghc/interpreter/type.c

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