ghc/interpreter/type.c

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