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