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