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