ghc/interpreter/type.c

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