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.12 $
  13  * $Date: 1999/11/16 17:39:00 $
  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         genDefns             = cons(hd(dsels),genDefns);
1829     }
1830     for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
1831         name(hd(mems)).defn  = singleton(pair(pat,
1832                                               ap(mkInt(name(hd(mems)).line),
1833                                                  nthArg(i++,hd(pat)))));
1834         genDefns             = cons(hd(mems),genDefns);
1835     }
1836 }
1837
1838 static Void local typeInstDefn(in)      /* Type check implementations of   */
1839 Inst in; {                              /* member functions for instance in*/
1840
1841     /* ----------------------------------------------------------------------
1842      * Generate code for instance specific dictionary builder function:
1843      *
1844      *   inst.maker d1 ... dn = let sc1 = ...
1845      *                                  .
1846      *                                  .
1847      *                                  .
1848      *                              scm = ...
1849      *                              vj ... = ...
1850      *                              d      = Make.C sc1 ... scm v1 ... vk
1851      *                          in d
1852      *
1853      * where sci are superclass dictionaries, d is a new name, vj
1854      * is a newly generated name corresponding to the implementation of a
1855      * member function.  (Additional line number values must be added at
1856      * appropriate places but, for clarity, these are not shown above.)
1857      * If no implementation of a particular vj is available, then we use
1858      * the default implementation, partially applied to d.
1859      * --------------------------------------------------------------------*/
1860
1861     Int  alpha   = newKindedVars(cclass(inst(in).c).kinds);
1862     List supers  = makePredAss(cclass(inst(in).c).supers,alpha);
1863     Int  beta    = newKindedVars(inst(in).kinds);
1864     List params  = makePredAss(inst(in).specifics,beta);
1865     Cell d       = inventDictVar();
1866     List evids   = cons(triple(inst(in).head,mkInt(beta),d),
1867                         appendOnto(dupList(params),supers));
1868
1869     List imps    = inst(in).implements;
1870     Cell l       = mkInt(inst(in).line);
1871     Cell dictDef = cclass(inst(in).c).dcon;
1872     List mems    = cclass(inst(in).c).members;
1873     List defs    = cclass(inst(in).c).defaults;
1874     List args    = NIL;
1875     List locs    = NIL;
1876     List ps;
1877
1878     if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
1879         internal("typeInstDefn");
1880
1881     for (ps=params; nonNull(ps); ps=tl(ps))     /* Build arglist           */
1882         args = cons(thd3(hd(ps)),args);
1883     args = rev(args);
1884
1885     for (ps=supers; nonNull(ps); ps=tl(ps)) {   /* Superclass dictionaries */
1886         Cell pi = hd(ps);
1887         Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
1888         if (isNull(ev))
1889             ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
1890         if (isNull(ev)) {
1891             clearMarks();
1892             ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
1893             ERRTEXT "\n*** Instance            : " ETHEN
1894                 ERRPRED(copyPred(inst(in).head,beta));
1895             ERRTEXT "\n*** Context supplied    : " ETHEN
1896                 ERRCONTEXT(copyPreds(params));
1897             ERRTEXT "\n*** Required superclass : " ETHEN
1898                 ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
1899             ERRTEXT "\n"
1900             EEND;
1901         }
1902         locs    = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
1903         dictDef = ap(dictDef,thd3(pi));
1904     }
1905
1906     for (; nonNull(defs); defs=tl(defs)) {
1907         Cell imp = NIL;
1908         if (nonNull(imps)) {
1909             imp  = hd(imps);
1910             imps = tl(imps);
1911         }
1912         if (isNull(imp)) {
1913             dictDef = ap(dictDef,ap(hd(defs),d));
1914         } else {
1915             Cell v  = inventVar();
1916             dictDef = ap(dictDef,v);
1917             typeMember("instance member binding",
1918                        hd(mems),
1919                        snd(imp),
1920                        evids,
1921                        inst(in).head,
1922                        beta);
1923             locs     = cons(pair(v,snd(imp)),locs);
1924         }
1925         mems = tl(mems);
1926     }
1927     locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
1928
1929     name(inst(in).builder).defn                 /* Register builder imp    */
1930              = singleton(pair(args,ap(LETREC,pair(singleton(locs),
1931                                                   ap(l,d)))));
1932     genDefns = cons(inst(in).builder,genDefns);
1933 }
1934
1935 static Void local typeMember(wh,mem,alts,evids,head,beta)
1936 String wh;                              /* Type check alternatives alts of */
1937 Name   mem;                             /* member mem for inst type head   */
1938 Cell   alts;                            /* at offset beta using predicate  */
1939 List   evids;                           /* assignment evids                */
1940 Cell   head;
1941 Int    beta; {
1942     Int  line = rhsLine(snd(hd(alts)));
1943     Type t;
1944     Int  o;
1945     Int  m;
1946     List ps;
1947     List qs;
1948     Type rt;
1949
1950 #ifdef DEBUG_TYPES
1951     Printf("\nType check member: ");
1952     printExp(stdout,mem);
1953     Printf(" :: ");
1954     printType(stdout,name(mem).type);
1955     Printf("\n   for the instance: ");
1956     printPred(stdout,head);
1957     Printf("\n");
1958 #endif
1959
1960     instantiate(name(mem).type);        /* Find required type              */
1961     o  = typeOff;
1962     m  = typeFree;
1963     t  = dropRank2(typeIs,o,m);
1964     ps = makePredAss(predsAre,o);
1965     if (!unifyPred(hd(predsAre),typeOff,head,beta))
1966         internal("typeMember1");
1967     clearMarks();
1968     qs = copyPreds(ps);
1969     rt = generalize(qs,liftRank2(t,o,m));
1970
1971 #ifdef DEBUG_TYPES
1972     Printf("Required type is: ");
1973     printType(stdout,rt);
1974     Printf("\n");
1975 #endif
1976
1977     hd(defnBounds) = NIL;               /* Type check each alternative     */
1978     hd(depends)    = NODEPENDS;
1979     enterPendingBtyvs();
1980     for (preds=NIL; nonNull(alts); alts=tl(alts)) {
1981         typeAlt(wh,mem,hd(alts),t,o,m);
1982         qualify(tl(ps),hd(alts));       /* Add any extra dict params       */
1983     }
1984     improve(line,evids,preds);
1985     leavePendingBtyvs();
1986
1987     evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts  */
1988                        evids);
1989     clearMarks();
1990     normPreds(line);
1991     qs = elimPredsUsing(evids,NIL);
1992     if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
1993         qs = elimPredsUsing(evids,qs);
1994     if (nonNull(qs)) {
1995         ERRMSG(line)
1996                 "Implementation of %s requires extra context",
1997                  textToStr(name(mem).text) ETHEN
1998         ERRTEXT "\n*** Expected type   : " ETHEN ERRTYPE(rt);
1999         ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
2000         ERRTEXT "\n"
2001         EEND;
2002     }
2003
2004     resetGenerics();                    /* Make sure we're general enough  */
2005     ps = copyPreds(ps);
2006     t  = generalize(ps,liftRank2(t,o,m));
2007 #ifdef DEBUG_TYPES
2008     Printf("   Inferred type is: ");
2009     printType(stdout,t);
2010     Printf("\n");
2011 #endif
2012     if (!sameSchemes(t,rt))
2013         tooGeneral(line,mem,rt,t);
2014     if (nonNull(preds)) {
2015         preds = scSimplify(preds);
2016         cantEstablish(line,wh,mem,t,ps);
2017     }
2018 }
2019
2020 /* --------------------------------------------------------------------------
2021  * Type check bodies of bindings:
2022  * ------------------------------------------------------------------------*/
2023
2024 static Void local typeBind(b)          /* Type check binding               */
2025 Cell b; {
2026     if (isVar(fst(b))) {                               /* function binding */
2027         Cell ass = findTopBinding(fst(b));
2028         Int  beta;
2029
2030         if (isNull(ass))
2031             internal("typeBind");
2032
2033         beta = intOf(defType(snd(ass)));
2034         enterPendingBtyvs();
2035         map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
2036         leavePendingBtyvs();
2037     }
2038     else {                                             /* pattern binding  */
2039         static String lhsPat = "lhs pattern";
2040         static String rhs    = "right hand side";
2041         Int  beta            = newTyvars(1);
2042         Pair pb              = snd(snd(b));
2043         Int  l               = rhsLine(snd(pb));
2044
2045         tcMode  = OLD_PATTERN;
2046         enterPendingBtyvs();
2047         fst(pb) = patBtyvs(fst(pb));
2048         check(l,fst(pb),NIL,lhsPat,aVar,beta);
2049         tcMode  = EXPRESSION;
2050         snd(pb) = typeRhs(snd(pb));
2051         shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
2052         doneBtyvs(l);
2053         leavePendingBtyvs();
2054     }
2055 }
2056
2057 static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding  */
2058 Int  beta;
2059 Cell v;
2060 Pair a; {
2061     static String valDef = "function binding";
2062     typeAlt(valDef,v,a,aVar,beta,0);
2063 }
2064
2065 static Cell local typeRhs(e)           /* check type of rhs of definition  */
2066 Cell e; {
2067     switch (whatIs(e)) {
2068         case GUARDED : {   Int beta = newTyvars(1);
2069                            map1Proc(guardedType,beta,snd(e));
2070                            tyvarType(beta);
2071                        }
2072                        break;
2073
2074         case LETREC  : enterBindings();
2075                        enterSkolVars();
2076                        mapProc(typeBindings,fst(snd(e)));
2077                        snd(snd(e)) = typeRhs(snd(snd(e)));
2078                        leaveBindings();
2079                        leaveSkolVars(rhsLine(snd(snd(e))),typeIs,typeOff,0);
2080                        break;
2081
2082         case RSIGN   : fst(snd(e)) = typeRhs(fst(snd(e)));
2083                        shouldBe(rhsLine(fst(snd(e))),
2084                                 rhsExpr(fst(snd(e))),NIL,
2085                                 "result type",
2086                                 snd(snd(e)),0);
2087                        return fst(snd(e));
2088
2089         default      : snd(e) = typeExpr(intOf(fst(e)),snd(e));
2090                        break;
2091     }
2092     return e;
2093 }
2094
2095 static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
2096 Int  beta;                             /* should have gd :: Bool,          */
2097 Cell gded; {                           /*             ex :: (var,beta)     */
2098     static String guarded = "guarded expression";
2099     static String guard   = "guard";
2100     Int line = intOf(fst(gded));
2101
2102     gded     = snd(gded);
2103     check(line,fst(gded),NIL,guard,typeBool,0);
2104     check(line,snd(gded),NIL,guarded,aVar,beta);
2105 }
2106
2107 Cell rhsExpr(rhs)                      /* find first expression on a rhs   */
2108 Cell rhs; {
2109     STACK_CHECK
2110     switch (whatIs(rhs)) {
2111         case GUARDED : return snd(snd(hd(snd(rhs))));
2112         case LETREC  : return rhsExpr(snd(snd(rhs)));
2113         case RSIGN   : return rhsExpr(fst(snd(rhs)));
2114         default      : return snd(rhs);
2115     }
2116 }
2117
2118 Int rhsLine(rhs)                       /* find line number associated with */
2119 Cell rhs; {                            /* a right hand side                */
2120     STACK_CHECK
2121     switch (whatIs(rhs)) {
2122         case GUARDED : return intOf(fst(hd(snd(rhs))));
2123         case LETREC  : return rhsLine(snd(snd(rhs)));
2124         case RSIGN   : return rhsLine(fst(snd(rhs)));
2125         default      : return intOf(fst(rhs));
2126     }
2127 }
2128
2129 /* --------------------------------------------------------------------------
2130  * Calculate generalization of types and compare with declared type schemes:
2131  * ------------------------------------------------------------------------*/
2132
2133 static Void local genBind(ps,b)         /* Generalize the type of each var */
2134 List ps;                                /* defined in binding b, qualifying*/
2135 Cell b; {                               /* each with the predicates in ps. */
2136     Cell v = fst(b);
2137     Cell t = fst(snd(b));
2138
2139     if (isVar(fst(b)))
2140         genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
2141     else {
2142         Int line = rhsLine(snd(snd(snd(b))));
2143         for (; nonNull(v); v=tl(v)) {
2144             Type ty = NIL;
2145             if (nonNull(t)) {
2146                 ty = hd(t);
2147                 t  = tl(t);
2148             }
2149             genAss(line,ps,hd(v),ty);
2150         }
2151     }
2152 }
2153
2154 static Void local genAss(l,ps,v,dt)     /* Calculate inferred type of v and*/
2155 Int  l;                                 /* compare with declared type, dt, */
2156 List ps;                                /* if given & check for ambiguity. */
2157 Cell v;
2158 Type dt; {
2159     Cell ass = findTopBinding(v);
2160
2161     if (isNull(ass))
2162         internal("genAss");
2163
2164     snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
2165
2166 #ifdef DEBUG_TYPES
2167     printExp(stdout,v);
2168     Printf(" :: ");
2169     printType(stdout,snd(ass));
2170     Printf("\n");
2171 #endif
2172 }
2173
2174 static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred    */
2175 Int  l;                                 /* type (t,o) with context ps      */
2176 Cell v;                                 /* against declared type dt for v. */
2177 List ps;
2178 Type dt;
2179 Type t;
2180 Int  o; {
2181     Type bt = NIL;                      /* Body of inferred type           */
2182     Type it = NIL;                      /* Full inferred type              */
2183
2184     resetGenerics();                    /* Calculate Haskell typing        */
2185     ps = copyPreds(ps);
2186     bt = copyType(t,o);
2187     it = generalize(ps,bt);
2188
2189     if (nonNull(dt)) {                  /* If a declared type was given,   */
2190         instantiate(dt);                /* check body for match.           */
2191         if (!equalTypes(typeIs,bt))
2192             tooGeneral(l,v,dt,it);
2193     }
2194     else if (nonNull(ps))               /* Otherwise test for ambiguity in */
2195         if (isAmbiguous(it))            /* inferred type.                  */
2196             ambigError(l,"inferred type",v,it);
2197
2198     return it;
2199 }
2200
2201 static Type local generalize(qs,t)      /* calculate generalization of t   */
2202 List qs;                                /* having already marked fixed vars*/
2203 Type t; {                               /* with qualifying preds qs        */
2204     if (nonNull(qs))
2205         t = ap(QUAL,pair(qs,t));
2206     if (nonNull(genericVars)) {
2207         Kind k  = STAR;
2208         List vs = genericVars;
2209         for (; nonNull(vs); vs=tl(vs)) {
2210             Tyvar *tyv = tyvar(intOf(hd(vs)));
2211             Kind   ka  = tyv->kind;
2212             k = ap(ka,k);
2213         }
2214         t = mkPolyType(k,t);
2215 #ifdef DEBUG_KINDS
2216     Printf("Generalized type: ");
2217     printType(stdout,t);
2218     Printf(" ::: ");
2219     printKind(stdout,k);
2220     Printf("\n");
2221 #endif
2222     }
2223     return t;
2224 }
2225
2226 static Bool local equalTypes(t1,t2)    /* Compare simple types for equality*/
2227 Type t1, t2; {
2228     STACK_CHECK
2229 et: if (whatIs(t1)!=whatIs(t2))
2230         return FALSE;
2231
2232     switch (whatIs(t1)) {
2233 #if TREX
2234         case EXT     :
2235 #endif
2236         case TYCON   :
2237         case OFFSET  :
2238         case TUPLE   : return t1==t2;
2239
2240         case INTCELL : return intOf(t1)!=intOf(t2);
2241
2242         case AP      : if (equalTypes(fun(t1),fun(t2))) {
2243                            t1 = arg(t1);
2244                            t2 = arg(t2);
2245                            goto et;
2246                        }
2247                        return FALSE;
2248
2249         default      : internal("equalTypes");
2250     }
2251
2252     return TRUE;/*NOTREACHED*/
2253 }
2254
2255 /* --------------------------------------------------------------------------
2256  * Entry points to type checker:
2257  * ------------------------------------------------------------------------*/
2258
2259 Type typeCheckExp(useDefs)              /* Type check top level expression */
2260 Bool useDefs; {                         /* using defaults if reqd          */
2261     Type type;
2262     List ctxt;
2263     Int  beta;
2264
2265     typeChecker(RESET);
2266     emptySubstitution();
2267     enterBindings();
2268     inputExpr = typeExpr(0,inputExpr);
2269     type      = typeIs;
2270     beta      = typeOff;
2271     clearMarks();
2272     improve(0,NIL,preds);
2273     normPreds(0);
2274     elimTauts();
2275     preds     = scSimplify(preds);
2276     if (useDefs && nonNull(preds)) {
2277         clearMarks();
2278         reducePreds();
2279         if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4?     */
2280             elimTauts();
2281     }
2282     resetGenerics();
2283     ctxt      = copyPreds(preds);
2284     type      = generalize(ctxt,copyType(type,beta));
2285     inputExpr = qualifyExpr(0,preds,inputExpr);
2286     h98CheckType(0,"inferred type",inputExpr,type);
2287     typeChecker(RESET);
2288     emptySubstitution();
2289     return type;
2290 }
2291
2292 Void typeCheckDefns() {                /* Type check top level bindings    */
2293     Target t  = length(selDefns)  + length(valDefns) +
2294                 length(instDefns) + length(classDefns);
2295     Target i  = 0;
2296     List   gs;
2297
2298     typeChecker(RESET);
2299     emptySubstitution();
2300     enterSkolVars();
2301     enterBindings();
2302     setGoal("Type checking",t);
2303
2304     for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
2305         mapOver(typeSel,hd(gs));
2306         soFar(i++);
2307     }
2308     for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
2309         typeDefnGroup(hd(gs));
2310         soFar(i++);
2311     }
2312     clearTypeIns();
2313     for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
2314         emptySubstitution();
2315         typeClassDefn(hd(gs));
2316         soFar(i++);
2317     }
2318     for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
2319         emptySubstitution();
2320         typeInstDefn(hd(gs));
2321         soFar(i++);
2322     }
2323
2324     typeChecker(RESET);
2325     emptySubstitution();
2326     done();
2327 }
2328
2329 static Void local typeDefnGroup(bs)     /* type check group of value defns */
2330 List bs; {                              /* (one top level scc)             */
2331     List as;
2332
2333     emptySubstitution();
2334     hd(defnBounds) = NIL;
2335     preds          = NIL;
2336     setTypeIns(bs);
2337     typeBindings(bs);                   /* find types for vars in bindings */
2338
2339     if (nonNull(preds)) {
2340         Cell v = fst(hd(hd(varsBounds)));
2341         Name n = findName(textOf(v));
2342         Int  l = nonNull(n) ? name(n).line : 0;
2343         preds  = scSimplify(preds);
2344         ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
2345         ERRCONTEXT(copyPreds(preds));
2346         ERRTEXT   " required for definition of " ETHEN
2347         ERREXPR(nonNull(n)?n:v);
2348         ERRTEXT   "\n"
2349         EEND;
2350     }
2351
2352     if (nonNull(hd(skolVars))) {
2353         Cell b = hd(bs);
2354         Name n = findName(isVar(fst(b)) ? textOf(fst(b)) : textOf(hd(fst(b))));
2355         Int  l = nonNull(n) ? name(n).line : 0;
2356         leaveSkolVars(l,typeUnit,0,0);
2357         enterSkolVars();
2358     }
2359
2360     for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
2361         Cell a = hd(as);                /* add infered types to environment*/
2362         Name n = findName(textOf(fst(a)));
2363         if (isNull(n))
2364             internal("typeDefnGroup");
2365         name(n).type = snd(a);
2366     }
2367     hd(varsBounds) = NIL;
2368 }
2369
2370 static Pair local typeSel(s)            /* Calculate a suitable type for a */
2371 Name s; {                               /* particular selector, s.         */
2372     List cns  = name(s).defn;
2373     Int  line = name(s).line;
2374     Type dom  = NIL;                    /* Inferred domain                 */
2375     Type rng  = NIL;                    /* Inferred range                  */
2376     Cell nv   = inventVar();
2377     List alts = NIL;
2378     Int  o    = 0;                      /* bogus init to keep gcc -O happy */
2379     Int  m    = 0;                      /* bogus init to keep gcc -O happy */
2380
2381 #ifdef DEBUG_SELS
2382     Printf("Selector %s, cns=",textToStr(name(s).text));
2383     printExp(stdout,cns);
2384     Putchar('\n');
2385 #endif
2386
2387     emptySubstitution();
2388     preds = NIL;
2389
2390     for (; nonNull(cns); cns=tl(cns)) {
2391         Name c   = fst(hd(cns));
2392         Int  n   = intOf(snd(hd(cns)));
2393         Int  a   = name(c).arity;
2394         Cell pat = c;
2395         Type dom1;
2396         Type rng1;
2397         Int  o1;
2398         Int  m1;
2399
2400         instantiate(name(c).type);      /* Instantiate constructor type    */
2401         o1 = typeOff;
2402         m1 = typeFree;
2403         for (; nonNull(predsAre); predsAre=tl(predsAre))
2404             assumeEvid(hd(predsAre),o1);
2405
2406         if (whatIs(typeIs)==RANK2)      /* Skip rank2 annotation, if any   */
2407             typeIs = snd(snd(typeIs));
2408         for (; --n>0; a--) {            /* Get range                       */
2409             pat    = ap(pat,WILDCARD);
2410             typeIs = arg(typeIs);
2411         }
2412         rng1   = dropRank1(arg(fun(typeIs)),o1,m1);
2413         pat    = ap(pat,nv);
2414         typeIs = arg(typeIs);
2415         while (--a>0) {                 /* And then look for domain        */
2416             pat    = ap(pat,WILDCARD);
2417             typeIs = arg(typeIs);
2418         }
2419         dom1   = typeIs;
2420
2421         if (isNull(dom)) {              /* Save first domain type and then */
2422             dom = dom1;                 /* unify with subsequent domains to*/
2423             o   = o1;                   /* match up preds and range types  */
2424             m   = m1;
2425         }
2426         else if (!unify(dom1,o1,dom,o))
2427             internal("typeSel1");
2428
2429         if (isNull(rng))                /* Compare component types         */
2430             rng = rng1;
2431         else if (!sameSchemes(rng1,rng)) {
2432             clearMarks();
2433             rng  = liftRank1(rng,o,m);
2434             rng1 = liftRank1(rng1,o1,m1);
2435             ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
2436                                  textToStr(name(s).text) ETHEN
2437             ERRTEXT "\n*** Field type     : "            ETHEN ERRTYPE(rng1);
2438             ERRTEXT "\n*** Does not match : "            ETHEN ERRTYPE(rng);
2439             ERRTEXT "\n"
2440             EEND;
2441         }
2442         alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
2443     }
2444     alts = rev(alts);
2445
2446     if (isNull(dom) || isNull(rng))     /* Should have been initialized by */
2447         internal("typeSel2");           /* now, assuming length cns >= 1.  */
2448
2449     clearMarks();                       /* No fixed variables here         */
2450     preds = scSimplify(preds);          /* Simplify context                */
2451     dom   = copyType(dom,o);            /* Calculate domain type           */
2452     instantiate(rng);
2453     rng   = copyType(typeIs,typeOff);
2454     if (nonNull(predsAre)) {
2455         List ps    = makePredAss(predsAre,typeOff);
2456         List alts1 = alts;
2457         for (; nonNull(alts1); alts1=tl(alts1)) {
2458             Cell body = nv;
2459             List qs   = ps;
2460             for (; nonNull(qs); qs=tl(qs))
2461                 body = ap(body,thd3(hd(qs)));
2462             snd(snd(hd(alts1))) = body;
2463         }
2464         preds = appendOnto(preds,ps);
2465     }
2466     name(s).type  = generalize(copyPreds(preds),fn(dom,rng));
2467     name(s).arity = 1 + length(preds);
2468     map1Proc(qualify,preds,alts);
2469
2470 #ifdef DEBUG_SELS
2471     Printf("Inferred arity = %d, type = ",name(s).arity);
2472     printType(stdout,name(s).type);
2473     Putchar('\n');
2474 #endif
2475
2476     return pair(s,alts);
2477 }
2478
2479
2480 /* --------------------------------------------------------------------------
2481  * Local function prototypes:
2482  * ------------------------------------------------------------------------*/
2483
2484 static Type local basicType Args((Char));
2485
2486
2487 static Type stateVar = NIL;
2488 static Type alphaVar = NIL;
2489 static Type betaVar  = NIL;
2490 static Type gammaVar = NIL;
2491 static Type deltaVar = NIL;
2492 static Int  nextVar  = 0;
2493
2494 static Void clearTyVars( void )
2495 {
2496     stateVar = NIL;
2497     alphaVar = NIL;
2498     betaVar  = NIL;
2499     gammaVar = NIL;
2500     deltaVar = NIL;
2501     nextVar  = 0;
2502 }
2503
2504 static Type mkStateVar( void )
2505 {
2506     if (isNull(stateVar)) {
2507         stateVar = mkOffset(nextVar++);
2508     }
2509     return stateVar;
2510 }
2511
2512 static Type mkAlphaVar( void )
2513 {
2514     if (isNull(alphaVar)) {
2515         alphaVar = mkOffset(nextVar++);
2516     }
2517     return alphaVar;
2518 }
2519
2520 static Type mkBetaVar( void )
2521 {
2522     if (isNull(betaVar)) {
2523         betaVar = mkOffset(nextVar++);
2524     }
2525     return betaVar;
2526 }
2527
2528 static Type mkGammaVar( void )
2529 {
2530     if (isNull(gammaVar)) {
2531         gammaVar = mkOffset(nextVar++);
2532     }
2533     return gammaVar;
2534 }
2535
2536 static Type mkDeltaVar( void )
2537 {
2538     if (isNull(deltaVar)) {
2539         deltaVar = mkOffset(nextVar++);
2540     }
2541     return deltaVar;
2542 }
2543
2544 static Type local basicType(k)
2545 Char k; {
2546     switch (k) {
2547     case CHAR_REP:
2548             return typeChar;
2549     case INT_REP:
2550             return typeInt;
2551     case INTEGER_REP:
2552             return typeInteger;
2553     case ADDR_REP:
2554             return typeAddr;
2555     case WORD_REP:
2556             return typeWord;
2557     case FLOAT_REP:
2558             return typeFloat;
2559     case DOUBLE_REP:
2560             return typeDouble;
2561     case ARR_REP:
2562             return ap(typePrimArray,mkAlphaVar());
2563     case BARR_REP:
2564             return typePrimByteArray;
2565     case REF_REP:
2566             return ap2(typeRef,mkStateVar(),mkAlphaVar());
2567     case MUTARR_REP:
2568             return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
2569     case MUTBARR_REP:
2570             return ap(typePrimMutableByteArray,mkStateVar());
2571     case STABLE_REP:
2572             return ap(typeStable,mkAlphaVar());
2573 #ifdef PROVIDE_WEAK
2574     case WEAK_REP:
2575             return ap(typeWeak,mkAlphaVar());
2576     case IO_REP:
2577             return ap(typeIO,typeUnit);
2578 #endif
2579 #ifdef PROVIDE_FOREIGN
2580     case FOREIGN_REP:
2581             return typeForeign;
2582 #endif
2583     case THREADID_REP:
2584             return typeThreadId;
2585     case MVAR_REP:
2586             return ap(typeMVar,mkAlphaVar());
2587     case BOOL_REP:
2588             return typeBool;
2589     case HANDLER_REP:
2590             return fn(typeException,mkAlphaVar());
2591     case ERROR_REP:
2592             return typeException;
2593     case ALPHA_REP:
2594             return mkAlphaVar();  /* polymorphic */
2595     case BETA_REP:
2596             return mkBetaVar();   /* polymorphic */
2597     case GAMMA_REP:
2598             return mkGammaVar();  /* polymorphic */
2599     case DELTA_REP:
2600             return mkDeltaVar();  /* polymorphic */
2601     default:
2602             printf("Kind: '%c'\n",k);
2603             internal("basicType");
2604     }
2605     assert(0); return 0; /* NOTREACHED */
2606 }
2607
2608 /* Generate type of primop based on list of arg types and result types:
2609  *
2610  * eg primType "II" "II" = Int -> Int -> (Int,Int)
2611  *
2612  */
2613 Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
2614 {
2615     List rs    = NIL;
2616     List as    = NIL;
2617     List tvars = NIL; /* for polymorphic types */
2618     Type r;
2619
2620     clearTyVars();
2621
2622     /* build result types */
2623     for(; *r_kinds; ++r_kinds) {
2624         rs = cons(basicType(*r_kinds),rs);
2625     }
2626     /* Construct tuple of results */
2627     if (length(rs) == 0) {
2628         r = typeUnit;
2629     } else if (length(rs) == 1) {
2630         r = hd(rs);
2631     } else {
2632         r = mkTuple(length(rs));
2633         for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
2634             r = ap(r,hd(rs));
2635         }
2636     }
2637     /* Construct list of arguments */
2638     for(; *a_kinds; ++a_kinds) {
2639         as = cons(basicType(*a_kinds),as);
2640     }
2641     /* Apply any monad magic */
2642     if (monad == MONAD_IO) {
2643         r = ap(typeIO,r);
2644     } else if (monad == MONAD_ST) {
2645         r = ap2(typeST,mkStateVar(),r);
2646     }
2647     /* glue it all together */
2648     for(; nonNull(as); as=tl(as)) {
2649         r = fn(hd(as),r);
2650     }
2651     tvars = offsetTyvarsIn(r,NIL);
2652     if (nonNull(tvars)) {
2653         assert(length(tvars) == nextVar);
2654         r = mkPolyType(simpleKind(length(tvars)),r);
2655     }
2656 #if DEBUG_CODE
2657     if (debugCode) {
2658         printType(stdout,r); printf("\n");
2659     }
2660 #endif
2661     return r;
2662 }
2663
2664 /* forall a1 .. am. TC a1 ... am -> Int */
2665 Type conToTagType(t)
2666 Tycon t; {
2667     Type   ty  = t;
2668     List   tvars = NIL;
2669     Int    i   = 0;
2670     for (i=0; i<tycon(t).arity; ++i) {
2671         Offset tv = mkOffset(i);
2672         ty = ap(ty,tv);
2673         tvars = cons(tv,tvars);
2674     }
2675     ty = fn(ty,typeInt);
2676     if (nonNull(tvars)) {
2677         ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2678     }
2679     return ty;
2680 }
2681
2682 /* forall a1 .. am. Int -> TC a1 ... am */
2683 Type tagToConType(t)
2684 Tycon t; {
2685     Type   ty  = t;
2686     List   tvars = NIL;
2687     Int    i   = 0;
2688     for (i=0; i<tycon(t).arity; ++i) {
2689         Offset tv = mkOffset(i);
2690         ty = ap(ty,tv);
2691         tvars = cons(tv,tvars);
2692     }
2693     ty = fn(typeInt,ty);
2694     if (nonNull(tvars)) {
2695         ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2696     }
2697     return ty;
2698 }
2699
2700 /* --------------------------------------------------------------------------
2701  * Type checker control:
2702  * ------------------------------------------------------------------------*/
2703
2704 Void typeChecker(what)
2705 Int what; {
2706     switch (what) {
2707         case RESET   : tcMode       = EXPRESSION;
2708 +                      daSccs       = NIL;
2709                        preds        = NIL;
2710                        pendingBtyvs = NIL;
2711                        daSccs       = NIL;
2712                        emptyAssumption();
2713                        break;
2714
2715         case MARK    : mark(defnBounds);
2716                        mark(varsBounds);
2717                        mark(depends);
2718                        mark(pendingBtyvs);
2719                        mark(skolVars);
2720                        mark(localEvs);
2721                        mark(savedPs);
2722                        mark(dummyVar);
2723                        mark(daSccs);
2724                        mark(preds);
2725                        mark(stdDefaults);
2726                        mark(arrow);
2727                        mark(boundPair);
2728                        mark(listof);
2729                        mark(typeVarToVar);
2730                        mark(predNum);
2731                        mark(predFractional);
2732                        mark(predIntegral);
2733                        mark(starToStar);
2734                        mark(predMonad);
2735                        break;
2736
2737         case INSTALL : typeChecker(RESET);
2738                        dummyVar     = inventVar();
2739
2740                        setCurrModule(modulePrelude);
2741
2742                        starToStar   = simpleKind(1);
2743
2744                        typeUnit     = addPrimTycon(findText("()"),
2745                                                    STAR,0,DATATYPE,NIL);
2746                        typeArrow    = addPrimTycon(findText("(->)"),
2747                                                    simpleKind(2),2,
2748                                                    DATATYPE,NIL);
2749                        typeList     = addPrimTycon(findText("[]"),
2750                                                    starToStar,1,
2751                                                    DATATYPE,NIL);
2752
2753                        arrow        = fn(aVar,bVar);
2754                        listof       = ap(typeList,aVar);
2755                        boundPair    = ap(ap(mkTuple(2),aVar),aVar);
2756
2757                        nameUnit     = addPrimCfun(findText("()"),0,0,typeUnit);
2758                        tycon(typeUnit).defn
2759                                     = singleton(nameUnit);
2760
2761                        nameNil      = addPrimCfun(findText("[]"),0,1,
2762                                                    mkPolyType(starToStar,
2763                                                               listof));
2764                        nameCons     = addPrimCfun(findText(":"),2,2,
2765                                                    mkPolyType(starToStar,
2766                                                               fn(aVar,
2767                                                               fn(listof,
2768                                                                  listof))));
2769                        name(nameNil).parent =
2770                        name(nameCons).parent = typeList;
2771
2772                        name(nameCons).syntax
2773                                     = mkSyntax(RIGHT_ASS,5);
2774
2775                        tycon(typeList).defn
2776                                     = cons(nameNil,cons(nameCons,NIL));
2777
2778                        typeVarToVar = fn(aVar,aVar);
2779 #if TREX
2780                        typeNoRow    = addPrimTycon(findText("EmptyRow"),
2781                                                    ROW,0,DATATYPE,NIL);
2782                        typeRec      = addPrimTycon(findText("Rec"),
2783                                                    pair(ROW,STAR),1,
2784                                                    DATATYPE,NIL);
2785                        nameNoRec    = addPrimCfun(findText("EmptyRec"),0,0,
2786                                                         ap(typeRec,typeNoRow));
2787 #else
2788                        /* bogus definitions to avoid changing the prelude */
2789                        addPrimCfun(findText("Rec"),      0,0,typeUnit);
2790                        addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
2791                        addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
2792 #endif
2793                        break;
2794     }
2795 }
2796
2797 /*-------------------------------------------------------------------------*/