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