home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / hugs101.zip / hugs101sc.zip / hugsdist / src / type.c < prev    next >
C/C++ Source or Header  |  1995-03-02  |  62KB  |  1,914 lines
  1. /* --------------------------------------------------------------------------
  2.  * type.c:      Copyright (c) Mark P Jones 1991-1994.   All rights reserved.
  3.  *              See NOTICE for details and conditions of use etc...
  4.  *              Hugs Version 1.0 August 1994, derived from Gofer 2.30a
  5.  *
  6.  * This is the Hugs type checker
  7.  * ------------------------------------------------------------------------*/
  8.  
  9. #include "prelude.h"
  10. #include "storage.h"
  11. #include "connect.h"
  12. #include "errors.h"
  13.  
  14. /*#define DEBUG_TYPES*/
  15. /*#define DEBUG_KINDS*/
  16. /*#define DEBUG_DICTS*/
  17. /*#define DEBUG_DEFAULTS*/
  18.  
  19. Bool catchAmbigs       = FALSE;        /* TRUE => functions with ambig.   */
  20.                     /*        types produce error       */
  21.  
  22. Type typeString, typeBool;        /* Important primitive types       */
  23. Type typeInt,    typeChar;
  24. Type typeFloat,  typeBin;
  25. Type typeDouble, typeInteger;
  26. Type typeMaybe;
  27.  
  28. Class classEq,   classOrd;        /* `standard' classes           */
  29. Class classText, classBinary;
  30. Class classIx,   classEnum;
  31.  
  32. Class classReal,       classIntegral;    /* `numeric' classes           */
  33. Class classRealFrac,   classRealFloat;
  34. Class classFractional, classFloating;
  35. Class classNum;
  36.  
  37. List stdDefaults;            /* standard default values       */
  38.  
  39. Name nameFromInt, nameFromDouble;    /* coercion of numerics           */
  40. Name nameFromInteger;
  41. Name nameEq,      nameOrdcmp;        /* derivable names           */
  42. Name nameLe,      nameShowsPrec;
  43. Name nameIndex,      nameInRange;
  44. Name nameRange;
  45. Name nameMult,      namePlus;
  46. Name nameTrue,      nameFalse;        /* primitive boolean constructors  */
  47. Name nameNil,     nameCons;        /* primitive list constructors       */
  48. Name nameJust,      nameNothing;        /* primitive Maybe constructors       */
  49.  
  50. #if    IO_DIALOGUE
  51. Type   typeDialogue;
  52. Name   nameReadFile,    nameWriteFile;    /* I/O name primitives           */
  53. Name   nameAppendFile,  nameReadChan;
  54. Name   nameAppendChan,  nameEcho;
  55. Name   nameGetArgs,     nameGetProgName;
  56. Name   nameGetEnv;
  57. Name   nameSuccess,     nameStr;
  58. Name   nameFailure,     nameStrList;
  59. Name   nameWriteError;
  60. Name   nameReadError,   nameSearchError;
  61. Name   nameFormatError, nameOtherError;
  62. #endif
  63.  
  64. #if    IO_MONAD
  65. Type   typeIO, typeProgIO;        /* for the IO monad, IO and IO ()  */
  66. Type   typeWorld, typeST;        /* built on top of IO = ST World   */
  67. Type   typeMutVar;
  68. #if    HASKELL_ARRAYS
  69. Type   typeMutArr;
  70. #endif
  71. #endif
  72.  
  73. #if    HASKELL_ARRAYS
  74. Type   typeArray;
  75. #endif
  76.  
  77. /* --------------------------------------------------------------------------
  78.  * Data structures for storing a substitution:
  79.  *
  80.  * For various reasons, this implementation uses structure sharing, instead of
  81.  * a copying approach.    In principal, this is fast and avoids the need to
  82.  * build new type expressions.    Unfortunately, this implementation will not
  83.  * be able to handle *very* large expressions.
  84.  *
  85.  * The substitution is represented by an array of type variables each of
  86.  * which is a triple:
  87.  *    bound    a (skeletal) type expression, or NIL if the variable
  88.  *        is not bound.
  89.  *    offs    offset of skeleton in bound.  If isNull(bound), then offs is
  90.  *        used to indicate whether that variable is generic (i.e. free
  91.  *        in the current assumption set) or fixed (i.e. bound in the
  92.  *        current assumption set).  Generic variables are assigned
  93.  *        offset numbers whilst copying type expressions (t,o) to
  94.  *        obtain their most general form.
  95.  *    kind    kind of value bound to type variable (`type variable' is
  96.  *        rather inaccurate -- `constructor variable' would be better).
  97.  * ------------------------------------------------------------------------*/
  98.  
  99. typedef struct {            /* Each type variable contains:       */
  100.     Type bound;                /* A type skeleton (unbound==NIL)  */
  101.     Int  offs;                /* Offset for skeleton           */
  102.     Kind kind;                /* kind annotation           */
  103. } Tyvar;
  104.  
  105. static    Int      numTyvars;        /* no. type vars currently in use  */
  106. #if     FIXED_SUBST
  107. static    Tyvar      tyvars[NUM_TYVARS];    /* storage for type variables       */
  108. #else
  109. static  Tyvar    *tyvars = 0;        /* storage for type variables       */
  110. static  Int       maxTyvars = 0;
  111. #endif
  112. static    Int      typeOff;        /* offset of result type        */
  113. static    Type      typeIs;        /* skeleton of result type       */
  114. static    List      predsAre;        /* list of predicates in type       */
  115. #define tyvar(n)  (tyvars+(n))        /* nth type variable           */
  116. #define tyvNum(t) ((t)-tyvars)        /* and the corresp. inverse funct. */
  117. static    Int      nextGeneric;            /* number of generics found so far */
  118. static  List      genericVars;        /* list of generic vars           */
  119.  
  120.                         /* offs values when isNull(bound): */
  121. #define FIXED_TYVAR    0            /* fixed in current assumption       */
  122. #define UNUSED_GENERIC 1            /* not fixed, not yet encountered  */
  123. #define GENERIC        2            /* GENERIC+n==nth generic var found*/
  124.  
  125. /* --------------------------------------------------------------------------
  126.  * Local function prototypes:
  127.  * ------------------------------------------------------------------------*/
  128.  
  129. static Void   local emptySubstitution Args((Void));
  130. static Void   local expandSubst       Args((Int));
  131. static Int    local newTyvars         Args((Int));
  132. static Int    local newKindedVars     Args((Kind));
  133. static Tyvar *local getTypeVar        Args((Type,Int));
  134. static Void   local tyvarType         Args((Int));
  135. static Void   local bindTv            Args((Int,Type,Int));
  136. static Void   local expandSyn          Args((Tycon, Int, Type *, Int *));
  137. static Void   local expandSyn1          Args((Tycon, Type *, Int *));
  138. static Cell   local getDerefHead      Args((Type,Int));
  139.  
  140. static Void   local clearMarks        Args((Void));
  141. static Void   local resetGenericsFrom Args((Int));
  142. static Void   local markTyvar         Args((Int));
  143. static Void   local markType          Args((Type,Int));
  144.  
  145. static Type   local copyTyvar         Args((Int));
  146. static Type   local copyType          Args((Type,Int));
  147. static List   local genvarTyvar          Args((Int,List));
  148. static List   local genvarType          Args((Type,Int,List));
  149. #ifdef DEBUG_TYPES
  150. static Type   local debugTyvar          Args((Int));
  151. static Type   local debugType          Args((Type,Int));
  152. #endif
  153.  
  154. static Bool   local doesntOccurIn     Args((Type,Int));
  155.  
  156. static Bool   local varToVarBind      Args((Tyvar *,Tyvar *));
  157. static Bool   local varToTypeBind     Args((Tyvar *,Type,Int));
  158. static Bool   local kvarToVarBind     Args((Tyvar *,Tyvar *));
  159. static Bool   local kvarToTypeBind    Args((Tyvar *,Type,Int));
  160. static Bool   local unify             Args((Type,Int,Type,Int));
  161. static Bool   local sameType          Args((Type,Int,Type,Int));
  162. static Bool   local kunify          Args((Kind,Int,Kind,Int));
  163.  
  164. static Void   local kindError          Args((Int,Constr,Constr,String,Kind,Int));
  165. static Void   local kindConstr          Args((Int,Constr));
  166. static Kind   local kindAtom          Args((Constr));
  167. static Void   local kindPred          Args((Int,Cell));
  168. static Void   local kindType          Args((Int,String,Type));
  169. static Void   local fixKinds          Args((Void));
  170.  
  171. static Void   local initTCKind          Args((Cell));
  172. static Void   local kindTC          Args((Cell));
  173. static Void   local genTC          Args((Cell));
  174. static Kind   local copyKindvar          Args((Int));
  175. static Kind   local copyKind          Args((Kind,Int));
  176.  
  177. static Bool   local eqKind          Args((Kind,Kind));
  178. static Kind   local getKind          Args((Cell,Int));
  179.  
  180. static Kind   local makeSimpleKind    Args((Int));
  181. static Kind   local simpleKind          Args((Int));
  182. static Kind   local makeVarKind          Args((Int));
  183. static Void   local varKind          Args((Int));
  184.  
  185. static Void   local emptyAssumption   Args((Void));
  186. static Void   local enterBindings     Args((Void));
  187. static Void   local leaveBindings     Args((Void));
  188. static Void   local markAssumList     Args((List));
  189. static Cell   local findAssum         Args((Text));
  190. static Pair   local findInAssumList   Args((Text,List));
  191. static List   local intsIntersect     Args((List,List));
  192. static List   local genvarAllAss      Args((List));
  193. static List   local genvarAnyAss      Args((List));
  194. static Int    local newVarsBind       Args((Cell));
  195. static Void   local newDefnBind       Args((Cell,Type));
  196. static Void   local instantiate       Args((Type));
  197.  
  198. static Void   local typeError         Args((Int,Cell,Cell,String,Type,Int));
  199. static Void   local reportTypeError   Args((Int,Cell,Cell,String,Type,Type));
  200. static Cell   local typeExpr          Args((Int,Cell));
  201. static Cell   local varIntro          Args((Cell,Type));
  202. static Void   local typeEsign         Args((Int,Cell));
  203. static Void   local typeCase          Args((Int,Int,Cell));
  204. static Void   local typeComp          Args((Int,Type,Cell,List));
  205. static Cell   local typeFreshPat      Args((Int,Cell));
  206.  
  207. static Cell   local typeAp            Args((Int,Cell));
  208. static Void   local typeAlt           Args((Cell));
  209. static Int    local funcType          Args((Int));
  210.  
  211. static Void   local typeTuple         Args((Cell));
  212. static Type   local makeTupleType     Args((Int));
  213.  
  214. static Void   local typeBindings      Args((List));
  215. static Void   local removeTypeSigs    Args((Cell));
  216.  
  217. static Void   local monorestrict      Args((List));
  218. static Void   local restrictedBindAss Args((Cell));
  219. static Void   local restrictedAss     Args((Int,Cell,Type));
  220.  
  221. static Void   local unrestricted      Args((List));
  222. static Void   local addEvidParams     Args((List,Cell));
  223.  
  224. static Void   local typeInstDefn      Args((Inst));
  225. static Void   local typeClassDefn     Args((Class));
  226. static Void   local typeMembers          Args((String,List,List,List,List,Type));
  227. static Void   local typeMember          Args((String,Name,Name,List,List,Type));
  228.  
  229. static Void   local typeBind          Args((Cell));
  230. static Void   local typeDefAlt        Args((Int,Cell,Pair));
  231. static Cell   local typeRhs           Args((Cell));
  232. static Void   local guardedType       Args((Int,Cell));
  233.  
  234. static Void   local genBind          Args((List,List,Cell));
  235. static Void   local genAss          Args((Int,List,List,Cell,Type));
  236. static Type   local generalize          Args((List,Type));
  237. static Void   local tooGeneral        Args((Int,Cell,Type,Type));
  238.  
  239. static Bool   local checkSchemes      Args((Type,Type));
  240. static Bool   local checkQuals        Args((List,List));
  241. static Bool   local equalTypes        Args((Type,Type));
  242.  
  243. static Void   local typeDefnGroup     Args((List));
  244.  
  245. /* --------------------------------------------------------------------------
  246.  * Frequently used type skeletons:
  247.  * ------------------------------------------------------------------------*/
  248.  
  249. static Type  var;            /* mkOffset(0)                  */
  250. static Type  arrow;            /* mkOffset(0) -> mkOffset(1)      */
  251. static Type  boundPair;            /* (mkOffset(0),mkOffset(0))       */
  252. static Type  typeList;            /* [ mkOffset(0) ]                */
  253. static Type  typeUnit;            /* ()                   */
  254. static Type  typeVarToVar;        /* mkOffset(0) -> mkOffset(0)         */
  255. #if    IO_MONAD
  256. static Type  typeSTab;            /* ST a b               */
  257. #endif
  258.  
  259. static Cell  predNum;            /* Num (mkOffset(0))           */
  260. static Cell  predFractional;        /* Fractional (mkOffset(0))       */
  261. static Cell  predIntegral;        /* Integral (mkOffset(0))       */
  262. static Kind  starToStar;        /* Type -> Type               */
  263.  
  264. /* --------------------------------------------------------------------------
  265.  * Basic operations on current substitution:
  266.  * ------------------------------------------------------------------------*/
  267.  
  268. #include "subst.c"
  269.  
  270. /* --------------------------------------------------------------------------
  271.  * Kind expressions:
  272.  *
  273.  * In the same way that values have types, type constructors (and more
  274.  * generally, expressions built from such constructors) have kinds.
  275.  * The syntax of kinds in the current implementation is very simple:
  276.  *
  277.  *      kind ::= STAR        -- the kind of types
  278.  *        |  kind => kind -- constructors
  279.  *        |  variables    -- either INTCELL or OFFSET
  280.  *
  281.  * ------------------------------------------------------------------------*/
  282.  
  283. #include "kind.c"
  284.  
  285. /* --------------------------------------------------------------------------
  286.  * Assumptions:
  287.  *
  288.  * A basic typing statement is a pair (Var,Type) and an assumption contains
  289.  * an ordered list of basic typing statements in which the type for a given
  290.  * variable is given by the most recently added assumption about that var.
  291.  *
  292.  * In practice, the assumption set is split between a pair of lists, one
  293.  * holding assumptions for vars defined in bindings, the other for vars
  294.  * defined in patterns/binding parameters etc.    The reason for this
  295.  * separation is that vars defined in bindings may be overloaded (with the
  296.  * overloading being unknown until the whole binding is typed), whereas the
  297.  * vars defined in patterns have no overloading.  A form of dependency
  298.  * analysis (at least as far as calculating dependents within the same group
  299.  * of value bindings) is required to implement this.  Where it is known that
  300.  * no overloaded values are defined in a binding (i.e. when the `dreaded
  301.  * monomorphism restriction' strikes), the list used to record dependents
  302.  * is flagged with a NODEPENDS tag to avoid gathering dependents at that
  303.  * level.
  304.  *
  305.  * To interleave between vars for bindings and vars for patterns, we use
  306.  * a list of lists of typing statements for each.  These lists are always
  307.  * the same length.  The implementation here is very similar to that of the
  308.  * dependency analysis used in the static analysis component of this system.
  309.  * ------------------------------------------------------------------------*/
  310.  
  311. static List defnBounds;                   /*::[[(Var,Type)]] possibly ovrlded*/
  312. static List varsBounds;                   /*::[[(Var,Type)]] not overloaded  */
  313. static List depends;                   /*::[?[Var]] dependents/NODEPENDS  */
  314.  
  315. #define saveVarsAssump() List saveAssump = hd(varsBounds)
  316. #define restoreVarsAss() hd(varsBounds)  = saveAssump
  317.  
  318. static Void local emptyAssumption() {      /* set empty type assumption       */
  319.     defnBounds = NIL;
  320.     varsBounds = NIL;
  321.     depends    = NIL;
  322. }
  323.  
  324. static Void local enterBindings() {    /* Add new level to assumption sets */
  325.     defnBounds = cons(NIL,defnBounds);
  326.     varsBounds = cons(NIL,varsBounds);
  327.     depends    = cons(NIL,depends);
  328. }
  329.  
  330. static Void local leaveBindings() {    /* Drop one level of assumptions    */
  331.     defnBounds = tl(defnBounds);
  332.     varsBounds = tl(varsBounds);
  333.     depends    = tl(depends);
  334. }
  335.  
  336. static Void local markAssumList(as)    /* Mark all types in assumption set */
  337. List as; {                   /* :: [(Var, Type)]           */
  338.     for (; nonNull(as); as=tl(as))     /* No need to mark generic types;   */
  339.     if (!isPolyType(snd(hd(as))))  /* the only free variables in those */
  340.         markType(snd(hd(as)),0);   /* must have been free earlier too  */
  341. }
  342.  
  343. static Cell local findAssum(t)           /* Find most recent assumption about*/
  344. Text t; {                   /* variable named t, if any       */
  345.     List defnBounds1 = defnBounds;     /* return translated variable, with */
  346.     List varsBounds1 = varsBounds;     /* type in typeIs           */
  347.     List depends1    = depends;
  348.  
  349.     while (nonNull(defnBounds1)) {
  350.     Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
  351.     if (nonNull(ass)) {
  352.         typeIs = snd(ass);
  353.         return fst(ass);
  354.     }
  355.  
  356.     ass = findInAssumList(t,hd(defnBounds1));     /* search defnBounds */
  357.     if (nonNull(ass)) {
  358.         Cell v = fst(ass);
  359.             typeIs = snd(ass);
  360.  
  361.         if (hd(depends1)!=NODEPENDS &&          /* save dependent?   */
  362.           isNull(v=varIsMember(t,hd(depends1))))
  363.         /* N.B. make new copy of variable and store this on list of*/
  364.         /* dependents, and in the assumption so that all uses of   */
  365.         /* the variable will be at the same node, if we need to    */
  366.         /* overwrite the call of a function with a translation...  */
  367.         hd(depends1) = cons(v=mkVar(t),hd(depends1));
  368.  
  369.         return v;
  370.     }
  371.  
  372.     defnBounds1 = tl(defnBounds1);              /* look in next level*/
  373.     varsBounds1 = tl(varsBounds1);              /* of assumption set */
  374.     depends1    = tl(depends1);
  375.     }
  376.     return NIL;
  377. }
  378.  
  379. static Pair local findInAssumList(t,as)/* Search for assumption for var    */
  380. Text t;                       /* named t in list of assumptions as*/
  381. List as; {
  382.     for (; nonNull(as); as=tl(as))
  383.     if (textOf(fst(hd(as)))==t)
  384.         return hd(as);
  385.     return NIL;
  386. }
  387.  
  388. static List local intsIntersect(as,bs)    /* calculate intersection of lists */
  389. List as, bs; {                /* of integers (as sets)       */
  390.     List ts = NIL;            /* destructively modifies as       */
  391.     while (nonNull(as))
  392.     if (intIsMember(intOf(hd(as)),bs)) {
  393.         List temp = tl(as);
  394.         tl(as)    = ts;
  395.         ts          = as;
  396.         as          = temp;
  397.         }
  398.     else
  399.         as = tl(as);
  400.     return ts;
  401. }
  402.  
  403. static List local genvarAllAss(as)    /* calculate generic vars that are */
  404. List as; {                /* in every type in assumptions as */
  405.     List vs = genvarTyvar(intOf(snd(hd(as))),NIL);
  406.     for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
  407.     vs = intsIntersect(vs,genvarTyvar(intOf(snd(hd(as))),NIL));
  408.     return vs;
  409. }
  410.  
  411. static List local genvarAnyAss(as)    /* calculate generic vars that are */
  412. List as; {                /* in any type in assumptions as   */
  413.     List vs = genvarTyvar(intOf(snd(hd(as))),NIL);
  414.     for (as=tl(as); nonNull(as); as=tl(as))
  415.     vs = genvarTyvar(intOf(snd(hd(as))),vs);
  416.     return vs;
  417. }
  418.  
  419. #define findTopBinding(v)  findInAssumList(textOf(v),hd(defnBounds))
  420.  
  421. static Int local newVarsBind(v)        /* make new assump for pattern var  */
  422. Cell v; {
  423.     Int beta       = newTyvars(1);
  424.     hd(varsBounds) = cons(pair(v,mkInt(beta)), hd(varsBounds));
  425. #ifdef DEBUG_TYPES
  426.     printf("variable, assume ");
  427.     printExp(stdout,v);
  428.     printf(" :: _%d\n",beta);
  429. #endif
  430.     return beta;
  431. }
  432.  
  433. static Void local newDefnBind(v,type)  /* make new assump for defn var       */
  434. Cell v;                    /* and set type if given (nonNull)  */
  435. Type type; {
  436.     Int beta       = newTyvars(1);
  437.     hd(defnBounds) = cons(pair(v,mkInt(beta)), hd(defnBounds));
  438.     instantiate(type);
  439. #ifdef DEBUG_TYPES
  440.     printf("definition, assume ");
  441.     printExp(stdout,v);
  442.     printf(" :: _%d\n",beta);
  443. #endif
  444.     bindTv(beta,typeIs,typeOff);       /* Bind beta to new type skeleton   */
  445. }
  446.  
  447. static Void local instantiate(type)    /* instantiate type expr, if nonNull*/
  448. Type type; {
  449.     predsAre = NIL;
  450.     typeIs   = type;
  451.     typeOff  = 0;
  452.  
  453.     if (nonNull(typeIs)) {           /* instantiate type expression ?    */
  454.  
  455.     if (isPolyType(typeIs)) {      /* Polymorphic type scheme ?       */
  456.         typeOff = newKindedVars(polySigOf(typeIs));
  457.         typeIs  = monoTypeOf(typeIs);
  458.     }
  459.  
  460.     if (whatIs(typeIs)==QUAL) {    /* Qualified type?           */
  461.         predsAre = fst(snd(typeIs));
  462.         typeIs   = snd(snd(typeIs));
  463.     }
  464.     }
  465. }
  466.  
  467. /* --------------------------------------------------------------------------
  468.  * Predicate sets:
  469.  *
  470.  * A predicate set is represented by a list of triples (C t, o, used)
  471.  * which indicates that type (t,o) must be an instance of class C, with
  472.  * evidence required at the node pointed to by used.  Note that the `used'
  473.  * node may need to be overwritten at a later stage if this evidence is
  474.  * to be derived from some other predicates by entailment.
  475.  * ------------------------------------------------------------------------*/
  476.  
  477. #include "preds.c"
  478.  
  479. /* --------------------------------------------------------------------------
  480.  * Type errors:
  481.  * ------------------------------------------------------------------------*/
  482.  
  483. static Void local typeError(l,e,in,wh,t,o)
  484. Int    l;                  /* line number near type error       */
  485. String wh;                  /* place in which error occurs       */
  486. Cell   e;                  /* source of error           */
  487. Cell   in;                  /* context if any (NIL if not)       */
  488. Type   t;                  /* should be of type (t,o)       */
  489. Int    o; {                  /* type inferred is (typeIs,typeOff) */
  490.  
  491.     clearMarks();              /* types printed here are monotypes  */
  492.                       /* use marking to give sensible names*/
  493. #ifdef DEBUG_KINDS
  494. { List vs = genericVars;
  495.   for (; nonNull(vs); vs=tl(vs)) {
  496.      Int v = intOf(hd(vs));
  497.      printf("%c :: ", ('a'+tyvar(v)->offs));
  498.      printKind(stdout,tyvar(v)->kind);
  499.      putchar('\n');
  500.   }
  501. }
  502. #endif
  503.  
  504.     reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
  505. }
  506.  
  507. static Void local reportTypeError(l,e,in,wh,inft,expt)
  508. Int    l;                /* error printing part of typeError*/
  509. Cell   e, in;                /* separated out for the benefit of*/
  510. String wh;                /* typing runST               */
  511. Type   inft, expt; {
  512.     ERROR(l) "Type error in %s", wh   ETHEN
  513.     if (nonNull(in)) {
  514.     ERRTEXT "\n*** expression     : " ETHEN ERREXPR(in);
  515.     }
  516.     ERRTEXT "\n*** term           : " ETHEN ERREXPR(e);
  517.     ERRTEXT "\n*** type           : " ETHEN ERRTYPE(inft);
  518.     ERRTEXT "\n*** does not match : " ETHEN ERRTYPE(expt);
  519.     if (unifyFails) {
  520.     ERRTEXT "\n*** because        : %s", unifyFails ETHEN
  521.     }
  522.     ERRTEXT "\n"
  523.     EEND;
  524. }
  525.  
  526. #define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
  527.                        typeError(l,e,in,where,t,o);
  528. #define check(l,e,in,where,t,o)    e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
  529. #define inferType(t,o)           typeIs=t; typeOff=o
  530.  
  531. /* --------------------------------------------------------------------------
  532.  * Typing of expressions:
  533.  * ------------------------------------------------------------------------*/
  534.  
  535. #define EXPRESSION  0            /* type checking expression       */
  536. #define NEW_PATTERN 1            /* pattern, introducing new vars   */
  537. #define OLD_PATTERN 2            /* pattern, involving bound vars   */
  538. static int tcMode = EXPRESSION;
  539.  
  540. #ifdef DEBUG_TYPES
  541. static Cell local mytypeExpr    Args((Int,Cell));
  542. static Cell local typeExpr(l,e)
  543. Int l;
  544. Cell e; {
  545.     static int number = 0;
  546.     Cell   retv;
  547.     int    mynumber   = number++;
  548.     printf("%d) to check: ",mynumber);
  549.     printExp(stdout,e);
  550.     putchar('\n');
  551.     retv = mytypeExpr(l,e);
  552.     printf("%d) result: ",mynumber);
  553.     printType(stdout,debugType(typeIs,typeOff));
  554.     putchar('\n');
  555.     return retv;
  556. }
  557. static Cell local mytypeExpr(l,e)    /* Determine type of expr/pattern  */
  558. #else
  559. static Cell local typeExpr(l,e)        /* Determine type of expr/pattern  */
  560. #endif
  561. Int  l;
  562. Cell e; {
  563.     static String cond    = "conditional";
  564.     static String list    = "list";
  565.     static String discr = "case discriminant";
  566.     static String aspat = "as (@) pattern";
  567.  
  568.     switch (whatIs(e)) {
  569.  
  570.     /* The following cases can occur in either pattern or expr. mode   */
  571.  
  572.     case AP     : return typeAp(l,e);
  573.  
  574.     case NAME    : if (isNull(name(e).type))
  575.                   internal("typeExpr1");
  576.               else {
  577.                   Cell tt = varIntro(e,name(e).type);
  578.                   return (name(e).defn==CFUN) ? e : tt;
  579.               }
  580.  
  581.     case TUPLE    : typeTuple(e);
  582.               break;
  583.  
  584. #if BIGNUMS
  585.     case POSNUM    :
  586.     case ZERONUM    :
  587.     case NEGNUM    : {   Int alpha = newTyvars(1);
  588.                   inferType(var,alpha);
  589.                   return ap(ap(nameFromInteger,
  590.                        assumeEvid(predNum,alpha)),
  591.                        e);
  592.               }
  593. #endif
  594.     case INTCELL    : {   Int alpha = newTyvars(1);
  595.                   inferType(var,alpha);
  596.                   return ap(ap(nameFromInt,
  597.                        assumeEvid(predNum,alpha)),
  598.                        e);
  599.               }
  600.  
  601.     case FLOATCELL    : {   Int alpha = newTyvars(1);
  602.                   inferType(var,alpha);
  603.                   return ap(ap(nameFromDouble,
  604.                        assumeEvid(predFractional,alpha)),
  605.                        e);
  606.               }
  607.  
  608.     case STRCELL    : inferType(typeString,0);
  609.               break;
  610.  
  611.     case UNIT    : inferType(typeUnit,0);
  612.               break;
  613.  
  614.     case CHARCELL    : inferType(typeChar,0);
  615.               break;
  616.  
  617.     case VAROPCELL    :
  618.     case VARIDCELL    : if (tcMode!=NEW_PATTERN) {
  619.                   Cell a = findAssum(textOf(e));
  620.                   if (nonNull(a))
  621.                   return varIntro(a,typeIs);
  622.                   else {
  623.                    a = findName(textOf(e));
  624.                    if (isNull(a) || isNull(name(a).type))
  625.                        internal("typeExpr2");
  626.                    return varIntro(a,name(a).type);
  627.                   }
  628.               }
  629.               else {
  630.                   inferType(var,newVarsBind(e));
  631.               }
  632.               break;
  633.  
  634.     /* The following cases can only occur in expr mode           */
  635.  
  636.     case COND    : {   Int beta = newTyvars(1);
  637.                   check(l,fst3(snd(e)),e,cond,typeBool,0);
  638.                   check(l,snd3(snd(e)),e,cond,var,beta);
  639.                   check(l,thd3(snd(e)),e,cond,var,beta);
  640.                   tyvarType(beta);
  641.               }
  642.               break;
  643.  
  644.     case LETREC    : enterBindings();
  645.               mapProc(typeBindings,fst(snd(e)));
  646.               snd(snd(e)) = typeExpr(l,snd(snd(e)));
  647.               leaveBindings();
  648.               break;
  649.  
  650.     case FINLIST    : {   Int  beta = newTyvars(1);
  651.                   List xs;
  652.                   for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
  653.                  check(l,hd(xs),e,list,var,beta);
  654.                   }
  655.                   inferType(typeList,beta);
  656.               }
  657.               break;
  658.  
  659.     case COMP    : {   Int beta = newTyvars(1);
  660.                               typeComp(l,typeList,snd(e),snd(snd(e)));
  661.                   bindTv(beta,typeIs,typeOff);
  662.                   inferType(typeList,beta);
  663.               }
  664.               break;
  665.  
  666. #if IO_MONAD
  667.     case RUNST    : {   Int beta = newTyvars(2);
  668.                   static String enc = "encapsulation";
  669.                   check(l,snd(e),e,enc,typeSTab,beta);
  670.                   clearMarks();
  671.                   mapProc(markAssumList,defnBounds);
  672.                   mapProc(markAssumList,varsBounds);
  673.                   mapProc(markPred,preds);
  674.                   markTyvar(beta+1);
  675.                   tyvarType(beta);
  676.                   if (typeIs!=var
  677.                    || tyvar(typeOff)->offs==FIXED_TYVAR) {
  678.                   Int alpha = newTyvars(2);
  679.                   bindTv(alpha+1,var,beta+1);
  680.                   reportTypeError(l,snd(e),e,enc,
  681.                           copyType(typeSTab,beta),
  682.                           copyType(typeSTab,alpha));
  683.                   }
  684.                   tyvarType(beta+1);
  685.               }
  686.               break;
  687. #endif
  688.  
  689.     case ESIGN    : typeEsign(l,e);
  690.               return fst(snd(e));
  691.  
  692.     case CASE    : {    Int beta = newTyvars(2);    /* discr result */
  693.                    check(l,fst(snd(e)),NIL,discr,var,beta);
  694.                    map2Proc(typeCase,l,beta,snd(snd(e)));
  695.                    tyvarType(beta+1);
  696.               }
  697.               break;
  698.  
  699.     case LAMBDA    : typeAlt(snd(e));
  700.               break;
  701.  
  702.     /* The remaining cases can only occur in pattern mode: */
  703.  
  704.     case WILDCARD    : inferType(var,newTyvars(1));
  705.               break;
  706.  
  707.     case ASPAT    : {   Int beta = newTyvars(1);
  708.                   snd(snd(e)) = typeExpr(l,snd(snd(e)));
  709.                   bindTv(beta,typeIs,typeOff);
  710.                   check(l,fst(snd(e)),e,aspat,var,beta);
  711.                   tyvarType(beta);
  712.               }
  713.               break;
  714.  
  715.     case LAZYPAT    : snd(e) = typeExpr(l,snd(e));
  716.               break;
  717.  
  718. #if NPLUSK
  719.     case ADDPAT    : {   Int alpha = newTyvars(1);
  720.                   inferType(typeVarToVar,alpha);
  721.                   return ap(e,assumeEvid(predIntegral,alpha));
  722.               }
  723. #endif
  724.  
  725.     default     : internal("typeExpr3");
  726.    }
  727.  
  728.    return e;
  729. }
  730.  
  731. static Cell local varIntro(v,type)    /* make translation of var v with  */
  732. Cell v;                    /* given type adding any extra dict*/
  733. Type type; {                /* params required           */
  734.     /* N.B. In practice, v will either be a NAME or a VARID/OPCELL       */
  735.     for (instantiate(type); nonNull(predsAre); predsAre=tl(predsAre))
  736.     v = ap(v,assumeEvid(hd(predsAre),typeOff));
  737.     return v;
  738. }
  739.  
  740. static Void local typeEsign(l,e)    /* Type check expression type sig  */
  741. Int  l;
  742. Cell e; {
  743.     static String typeSig = "type signature expression";
  744.     List savePreds = preds;
  745.     Int  alpha        = newTyvars(1);
  746.     Type nt;                /* complete infered type       */
  747.  
  748.     instantiate(snd(snd(e)));
  749.     bindTv(alpha,typeIs,typeOff);
  750.     preds = makeEvidArgs(predsAre,typeOff);
  751.  
  752.     check(l,fst(snd(e)),NIL,typeSig,var,alpha);
  753.  
  754.     clearMarks();
  755.     mapProc(markAssumList,defnBounds);
  756.     mapProc(markAssumList,varsBounds);
  757.     mapProc(markPred,savePreds);
  758.  
  759.     savePreds = elimConstPreds(l,typeSig,savePreds);
  760.     if (nonNull(hpreds) && resolveDefs(genvarTyvar(alpha,NIL),hpreds))
  761.     savePreds = elimConstPreds(l,typeSig,savePreds);
  762.     resetGenericsFrom(0);
  763.     nt = copyTyvar(alpha);        /* order of copying is *important* */
  764.     nt = generalize(copyPreds(hpreds),nt);
  765.  
  766.     if (!checkSchemes(snd(snd(e)),nt))
  767.     tooGeneral(l,fst(snd(e)),snd(snd(e)),nt);
  768.  
  769.     tyvarType(alpha);
  770.     preds = revOnto(preds,savePreds);
  771. }
  772.  
  773. static Void local typeCase(l,beta,c)   /* type check case: pat -> rhs       */
  774. Int  l;                    /* (case given by c == (pat,rhs))   */
  775. Int  beta;                   /* need:  pat :: (var,beta)       */
  776. Cell c; {                   /*     rhs :: (var,beta+1)       */
  777.     static String casePat  = "case pattern";
  778.     static String caseExpr = "case expression";
  779.  
  780.     saveVarsAssump();
  781.  
  782.     fst(c) = typeFreshPat(l,fst(c));
  783.     shouldBe(l,fst(c),NIL,casePat,var,beta);
  784.     snd(c) = typeRhs(snd(c));
  785.     shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,var,beta+1);
  786.  
  787.     restoreVarsAss();
  788. }
  789.  
  790. static Void local typeComp(l,m,e,qs)    /* type check comprehension       */
  791. Int  l;
  792. Type m;                    /* monad (mkOffset(0))           */
  793. Cell e;
  794. List qs; {
  795.     static String boolQual = "boolean qualifier";
  796.     static String genQual  = "generator";
  797.  
  798.     if (isNull(qs))            /* no qualifiers left           */
  799.     fst(e) = typeExpr(l,fst(e));
  800.     else {
  801.     Cell q   = hd(qs);
  802.     List qs1 = tl(qs);
  803.     switch (whatIs(q)) {
  804.         case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
  805.                 typeComp(l,m,e,qs1);
  806.                 break;
  807.  
  808.         case QWHERE   : enterBindings();
  809.                 mapProc(typeBindings,snd(q));
  810.                 typeComp(l,m,e,qs1);
  811.                 leaveBindings();
  812.                 break;
  813.  
  814.         case FROMQUAL : {   Int beta = newTyvars(1);
  815.                 saveVarsAssump();
  816.                                 check(l,snd(snd(q)),NIL,genQual,m,beta);
  817.                 fst(snd(q)) = typeFreshPat(l,fst(snd(q)));
  818.                 shouldBe(l,fst(snd(q)),NIL,genQual,var,beta);
  819.                 typeComp(l,m,e,qs1);
  820.                 restoreVarsAss();
  821.                 }
  822.                 break;
  823.     }
  824.     }
  825. }
  826.  
  827. static Cell local typeFreshPat(l,p)    /* find type of pattern, assigning  */
  828. Int  l;                    /* fresh type variables to each var */
  829. Cell p; {                   /* bound in the pattern           */
  830.     tcMode = NEW_PATTERN;
  831.     p       = typeExpr(l,p);
  832.     tcMode = EXPRESSION;
  833.     return p;
  834. }
  835.  
  836. /* --------------------------------------------------------------------------
  837.  * Note the pleasing duality in the typing of application and abstraction:-)
  838.  * ------------------------------------------------------------------------*/
  839.  
  840. static Cell local typeAp(l,e)        /* Type check application       */
  841. Int  l;
  842. Cell e; {
  843.     static String app = "application";
  844.     Cell h    = getHead(e);        /* e = h e1 e2 ... en           */
  845.     Int  n    = argCount;        /* save no. of arguments       */
  846.     Int  beta = funcType(n);
  847.     Cell p    = NIL;            /* points to previous AP node       */
  848.     Cell a    = e;            /* points to current AP node       */
  849.     Int  i;
  850.  
  851.     check(l,h,e,app,var,beta);        /* check h::t1->t2->...->tn->rn+1  */
  852.     for (i=n; i>0; --i) {        /* check e_i::t_i for each i       */
  853.     check(l,arg(a),e,app,var,beta+2*i-1);
  854.     p = a;
  855.     a = fun(a);
  856.     }
  857.     fun(p) = h;                /* replace head with translation   */
  858.     tyvarType(beta+2*n);        /* inferred type is r_n+1       */
  859.     return e;
  860. }
  861.  
  862. static Void local typeAlt(a)        /* Type check abstraction (Alt)       */
  863. Cell a; {                /* a = ( [p1, ..., pn], rhs )       */
  864.     List ps      = fst(a);
  865.     Int  n      = length(ps);
  866.     Int  beta      = funcType(n);
  867.     Int  l      = rhsLine(snd(a));
  868.     Int  i;
  869.  
  870.     saveVarsAssump();
  871.  
  872.     for (i=0; i<n; ++i) {
  873.     hd(ps) = typeFreshPat(l,hd(ps));
  874.     bindTv(beta+2*i+1,typeIs,typeOff);
  875.     ps = tl(ps);
  876.     }
  877.     snd(a) = typeRhs(snd(a));
  878.     bindTv(beta+2*n,typeIs,typeOff);
  879.     tyvarType(beta);
  880.  
  881.     restoreVarsAss();
  882. }
  883.  
  884. static Int local funcType(n)        /*return skeleton for function type*/
  885. Int n; {                /*with n arguments, taking the form*/
  886.     Int beta = newTyvars(2*n+1);    /*    r1 t1 r2 t2 ... rn tn rn+1   */
  887.     Int i;                /* with r_i := t_i -> r_i+1       */
  888.     for (i=0; i<n; ++i)
  889.     bindTv(beta+2*i,arrow,beta+2*i+1);
  890.     return beta;
  891. }
  892.  
  893. /* --------------------------------------------------------------------------
  894.  * Tuple type constructors: are generated as necessary.  The most common
  895.  * n-tuple constructors (n<MAXTUPCON) are held in a cache to avoid
  896.  * repeated generation of the constructor types.
  897.  *
  898.  * ???Maybe this cache should extend to all valid tuple constrs???
  899.  * ------------------------------------------------------------------------*/
  900.  
  901. #define MAXTUPCON 10
  902. static Type tupleConTypes[MAXTUPCON];
  903.  
  904. static Void local typeTuple(e)           /* find type for tuple constr, using*/
  905. Cell e; {                   /* tupleConTypes to cache previously*/
  906.     Int n   = tupleOf(e);           /* calculated tuple constr. types.  */
  907.     typeOff = newTyvars(n);
  908.     if (n>=MAXTUPCON)
  909.      typeIs = makeTupleType(n);
  910.     else if (tupleConTypes[n])
  911.      typeIs = tupleConTypes[n];
  912.     else
  913.      typeIs = tupleConTypes[n] = makeTupleType(n);
  914. }
  915.  
  916. static Type local makeTupleType(n)     /* construct type for tuple constr. */
  917. Int n; {                   /* t1 -> ... -> tn -> (t1,...,tn)   */
  918.     Type h = mkTuple(n);
  919.     Int  i;
  920.  
  921.     for (i=0; i<n; ++i)
  922.     h = ap(h,mkOffset(i));
  923.     while (0<n--)
  924.     h = fn(mkOffset(n),h);
  925.     return h;
  926. }
  927.  
  928. /* --------------------------------------------------------------------------
  929.  * Type check group of bindings:
  930.  * ------------------------------------------------------------------------*/
  931.  
  932. static Void local typeBindings(bs)    /* type check a binding group       */
  933. List bs; {
  934.     Bool usesPatBindings = FALSE;    /* TRUE => pattern binding in bs   */
  935.     Bool usesUntypedVar  = FALSE;    /* TRUE => var bind w/o type decl  */
  936.     List bs1;
  937.  
  938.     /* The following loop is used to determine whether the monomorphism       */
  939.     /* restriction should be applied.  It could be written marginally more */
  940.     /* efficiently by using breaks, but clarity is more important here ... */
  941.  
  942.     for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) {  /* Analyse binding group    */
  943.     Cell b = hd(bs1);
  944.     if (!isVar(fst(b)))
  945.         usesPatBindings = TRUE;
  946.     else if (isNull(fst(hd(snd(snd(b))))) && isNull(fst(snd(b))))
  947.         usesUntypedVar  = TRUE;
  948.     }
  949.  
  950.     hd(defnBounds) = NIL;
  951.     hd(depends)       = NIL;
  952.  
  953.     if (usesPatBindings || usesUntypedVar)
  954.     monorestrict(bs);
  955.     else
  956.     unrestricted(bs);
  957.  
  958.     mapProc(removeTypeSigs,bs);               /* Remove binding type info */
  959.     hd(varsBounds) = revOnto(hd(defnBounds),   /* transfer completed assmps*/
  960.                  hd(varsBounds));  /* out of defnBounds        */
  961.     hd(defnBounds) = NIL;
  962.     hd(depends)    = NIL;
  963. }
  964.  
  965. static Void local removeTypeSigs(b)    /* Remove type info from a binding  */
  966. Cell b; {
  967.     snd(b) = snd(snd(b));
  968. }
  969.  
  970. /* --------------------------------------------------------------------------
  971.  * Type check a restricted binding group:
  972.  * ------------------------------------------------------------------------*/
  973.  
  974. static Void local monorestrict(bs)    /* Type restricted binding group   */
  975. List bs; {
  976.     static String binding = "binding";
  977.     List   savePreds      = preds;
  978.     Int    line       = isVar(fst(hd(bs)))
  979.                 ? rhsLine(snd(hd(snd(snd(hd(bs))))))
  980.                 : rhsLine(snd(snd(snd(hd(bs)))));
  981.  
  982.     hd(depends) = NODEPENDS;           /* No need for dependents here       */
  983.     preds       = NIL;
  984.  
  985.     mapProc(restrictedBindAss,bs);     /* add assumptions for vars in bs   */
  986.     mapProc(typeBind,bs);           /* type check each binding       */
  987.  
  988.     clearMarks();               /* mark fixed variables           */
  989.     mapProc(markAssumList,tl(defnBounds));
  990.     mapProc(markAssumList,tl(varsBounds));
  991.     mapProc(markPred,savePreds);
  992.     if (nonNull(tl(defnBounds)))
  993.     mapProc(markPred,preds);
  994.  
  995.     savePreds = elimConstPreds(line,binding,savePreds);
  996.  
  997.     if (isNull(tl(defnBounds))) {    /* top-level may need defaulting   */
  998.     if (nonNull(hpreds) &&
  999.         resolveDefs(genvarAnyAss(hd(defnBounds)),hpreds))
  1000.         savePreds = elimConstPreds(line,binding,savePreds);
  1001.     if (nonNull(preds)) {        /* look for unresolved overloading */
  1002.         Cell v   = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
  1003.         Cell ass = findInAssumList(textOf(v),hd(varsBounds));
  1004.  
  1005.         ERROR(line) "Unresolved top-level overloading" ETHEN
  1006.         ERRTEXT     "\n*** Binding             : %s", textToStr(textOf(v))
  1007.         ETHEN
  1008.         if (nonNull(ass)) {
  1009.         ERRTEXT "\n*** Inferred type       : " ETHEN ERRTYPE(snd(ass));
  1010.         }
  1011.         ERRTEXT     "\n*** Outstanding context : " ETHEN
  1012.                         ERRCONTEXT(copyPreds(hpreds));
  1013.         ERRTEXT     "\n"
  1014.         EEND;
  1015.     }
  1016.     }
  1017.     preds     = appendOnto(preds,savePreds);
  1018.     hpreds    = NIL;
  1019.  
  1020.     map2Proc(genBind,NIL,NIL,bs);    /* Generalize types of def'd vars  */
  1021. }
  1022.  
  1023. static Void local restrictedBindAss(b) /* make assums for vars in binding  */
  1024. Cell b; {                   /* gp with restricted overloading   */
  1025.  
  1026.     if (isVar(fst(b)))               /* function-binding?           */
  1027.     restrictedAss(intOf(rhsLine(snd(hd(snd(snd(b)))))),
  1028.               fst(b),
  1029.               fst(snd(b)));
  1030.     else {                   /* pattern-binding?           */
  1031.     List vs   = fst(b);
  1032.     List ts   = fst(snd(b));
  1033.     Int  line = rhsLine(snd(snd(b)));
  1034.  
  1035.     for (; nonNull(vs); vs=tl(vs))
  1036.         if (nonNull(ts)) {
  1037.         restrictedAss(line,hd(vs),hd(ts));
  1038.         ts = tl(ts);
  1039.         }
  1040.         else
  1041.         restrictedAss(line,hd(vs),NIL);
  1042.     }
  1043. }
  1044.  
  1045. static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
  1046. Int  l;                    /* is t (if nonNull) in restricted  */
  1047. Cell v;                    /* binding group            */
  1048. Type t; {
  1049.     newDefnBind(v,t);
  1050.     if (nonNull(predsAre)) {
  1051.     ERROR(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
  1052.     ETHEN
  1053.     ERRTEXT  " not permitted in restricted binding"
  1054.     EEND;
  1055.     }
  1056. }
  1057.  
  1058. /* --------------------------------------------------------------------------
  1059.  * Unrestricted binding group:
  1060.  * ------------------------------------------------------------------------*/
  1061.  
  1062. static Void local unrestricted(bs)    /* Type unrestricted binding group */
  1063. List bs; {
  1064.     static String binding = "binding";
  1065.     Int    line           = rhsLine(snd(hd(snd(snd(hd(bs))))));
  1066.     List   savePreds      = preds;
  1067.     List   bs1;
  1068.  
  1069.     preds = NIL;
  1070.  
  1071.     for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) {   /* Add assumptions about   */
  1072.     Cell b = hd(bs1);            /* each bound var -- can   */
  1073.     newDefnBind(fst(b),fst(snd(b)));    /* assume function binding */
  1074.     for (; nonNull(predsAre); predsAre=tl(predsAre))
  1075.         assumeEvid(hd(predsAre),typeOff);
  1076.     }
  1077.  
  1078.     mapProc(typeBind,bs);            /* type check each binding */
  1079.  
  1080.     clearMarks();                /* Mark fixed variables       */
  1081.     mapProc(markAssumList,tl(defnBounds));
  1082.     mapProc(markAssumList,tl(varsBounds));
  1083.     mapProc(markPred,savePreds);
  1084.  
  1085.     savePreds = elimConstPreds(line,binding,savePreds);
  1086.     if (nonNull(hpreds) && resolveDefs(genvarAllAss(hd(defnBounds)),hpreds))
  1087.     savePreds = elimConstPreds(line,binding,savePreds);
  1088.  
  1089.     map2Proc(genBind,preds,hpreds,bs);    /* Generalize types of def'd vars  */
  1090.  
  1091.     if (nonNull(preds)) {        /* Add dictionary params, if nec.  */
  1092.     map1Proc(addEvidParams,preds,hd(depends));
  1093.     map1Proc(qualifyBinding,preds,bs);
  1094.     }
  1095.  
  1096.     preds  = savePreds;            /* restore predicates           */
  1097.     hpreds = NIL;
  1098. }
  1099.  
  1100. static Void local addEvidParams(qs,v)  /* overwrite VARID/OPCELL v with       */
  1101. List qs;                   /* application of variable to evid. */
  1102. Cell v; {                   /* parameters given by qs       */
  1103.     if (nonNull(qs)) {
  1104.     Cell nv;
  1105.  
  1106.     if (!isVar(v))
  1107.         internal("addEvidParams");
  1108.  
  1109.     for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
  1110.         nv = ap(nv,thd3(hd(qs)));
  1111.     fst(v) = nv;
  1112.     snd(v) = thd3(hd(qs));
  1113.     }
  1114. }
  1115.  
  1116. /* --------------------------------------------------------------------------
  1117.  * Type check bodies of class and instance declarations:
  1118.  * ------------------------------------------------------------------------*/
  1119.  
  1120. static Void local typeInstDefn(in)    /* type check implementations of   */
  1121. Inst in; {                /* member functions for instance in*/
  1122.     Int i;
  1123.     Cell head = inst(in).t;
  1124.     List sig  = NIL;
  1125.     List k    = kindAtom(inst(in).t);
  1126.  
  1127.     for (i=0; i<inst(in).arity; ++i)
  1128.     head = ap(head,mkOffset(i));
  1129.     for (i=0; i<inst(in).arity; ++i, k=snd(k))
  1130.     sig  = cons(fst(k),sig);
  1131.     sig = rev(sig);
  1132.  
  1133.     typeMembers("instance member binding",
  1134.         class(inst(in).c).members,
  1135.         inst(in).implements,
  1136.         inst(in).specifics,
  1137.         sig,
  1138.         head);
  1139. }
  1140.  
  1141. static Void local typeClassDefn(c)    /* type check implementations of   */
  1142. Class c; {                /* defaults for class c           */
  1143.     typeMembers("default member binding",
  1144.         class(c).members,
  1145.         class(c).defaults,
  1146.         singleton(ap(c,var)),
  1147.         singleton(class(c).sig),
  1148.         var);
  1149. }
  1150.  
  1151. static Void local typeMembers(wh,ms,is,specifics,sig,head)
  1152. String wh;                /* type check implementations `is' */
  1153. List   ms;                /* of members `ms' for a specific  */
  1154. List   is;                /* class instance           */
  1155. List   specifics;
  1156. List   sig;
  1157. Type   head; {
  1158.     while (nonNull(is)) {
  1159.     if (isName(hd(is)))
  1160.         typeMember(wh,hd(ms),hd(is),specifics,sig,head);
  1161.     is = tl(is);
  1162.     ms = tl(ms);
  1163.     }
  1164. }
  1165.  
  1166. static Void local typeMember(wh,m,i,specifics,sig,head)
  1167. String wh;                /* type check implementation i of  */
  1168. Name   m;                /* member m for instance type head */
  1169. Name   i;                /* (with kinds given by sig) and   */
  1170. List   specifics;            /* using the given specifics       */
  1171. List   sig;
  1172. Type   head; {
  1173.     Int  line = rhsLine(snd(hd(name(i).defn)));
  1174.     Int  alpha, beta;
  1175.     Type required, inferred;
  1176.     List extras;
  1177.  
  1178. #ifdef DEBUG_TYPES
  1179.     printf("Line %d, instance type: ",line);
  1180.     printType(stdout,head);
  1181.     putchar('\n');
  1182. #endif
  1183.  
  1184.     emptySubstitution();
  1185.     hd(defnBounds) = NIL;
  1186.     hd(depends)    = NODEPENDS;
  1187.     preds          = NIL;
  1188.  
  1189.     alpha    = newTyvars(1);        /* Set required instance of m       */
  1190.     beta     = newKindedVars(sig);
  1191.     instantiate(name(m).type);
  1192.     bindTv(alpha,typeIs,typeOff);
  1193.     bindTv(typeOff,head,beta);
  1194.     extras   = makeEvidArgs(tl(predsAre),typeOff);
  1195.     required = copyTyvar(alpha);
  1196.  
  1197. #ifdef DEBUG_TYPES
  1198.     printf("Checking implementation of: ");
  1199.     printExp(stdout,m);
  1200.     printf(" :: ");
  1201.     printType(stdout,required);
  1202.     printf("\n");
  1203. #endif
  1204.  
  1205.     map2Proc(typeDefAlt,alpha,m,name(i).defn);
  1206.  
  1207.     if (nonNull(extras)) {        /* Now deal with predicates ...    */
  1208.     List ps = NIL;
  1209.     while (nonNull(preds)) {        /* discharge preds entailed by       */
  1210.         List nx = tl(preds);    /* the `extras'               */
  1211.         Cell pi = hd(preds);
  1212.         Cell ev = simpleEntails(extras,fst3(pi),intOf(snd3(pi)));
  1213.         if (nonNull(ev))
  1214.         overEvid(thd3(pi),ev);
  1215.         else {
  1216.         tl(preds) = ps;
  1217.         ps        = preds;
  1218.         }
  1219.         preds = nx;
  1220.     }
  1221.     preds = rev(ps);
  1222.     map1Proc(qualify,extras,name(i).defn);
  1223.     }
  1224.  
  1225.     clearMarks();
  1226.     if (nonNull(elimConstPreds(line,wh,NIL)) ||    /* discharge const preds   */
  1227.     (resolveDefs(genvarTyvar(alpha,NIL),hpreds) &&
  1228.      nonNull(elimConstPreds(line,wh,NIL))))
  1229.     internal("typeMember");
  1230.  
  1231.     resetGenericsFrom(0);
  1232.     inferred = copyTyvar(alpha);    /* Compare with inferred type       */
  1233.     if (!equalTypes(required,inferred))
  1234.     tooGeneral(line,m,required,inferred);
  1235.  
  1236. #ifdef DEBUG_TYPES
  1237.     printf("preds = "); printContext(stdout,copyPreds(preds)); putchar('\n');
  1238.     printf("hpreds= "); printContext(stdout,copyPreds(hpreds)); putchar('\n');
  1239. #endif
  1240.  
  1241.     for (; nonNull(hpreds); hpreds=tl(hpreds)) {
  1242.     List ps = specifics;
  1243.     Cell pi = hd(hpreds);
  1244.     Int  i  = 0;
  1245.     Cell ev = NIL;
  1246.     for (; isNull(ev) && nonNull(ps); ps=tl(ps), ++i)
  1247.         if (sameType(arg(fst3(pi)),intOf(snd3(pi)),arg(hd(ps)),beta))
  1248.         ev = superEvid(mkOffset(i),fun(hd(ps)),fun(fst3(pi)));
  1249.     if (nonNull(ev))
  1250.         overEvid(thd3(pi),ev);
  1251.     else {
  1252.         ERROR(line) "Insufficient class constraints in %s", wh ETHEN
  1253.         ERRTEXT "\n*** Context  : " ETHEN ERRCONTEXT(specifics);
  1254.         ERRTEXT "\n*** Required : " ETHEN
  1255.         ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
  1256.         ERRTEXT "\n"
  1257.         EEND;
  1258.     }
  1259.     }
  1260.  
  1261.     mapOver(tidyEvid,evids);            /* avoid unnec. indirects. */
  1262.  
  1263. #ifdef DEBUG_TYPES
  1264.     printf("evids = "); printExp(stdout,evids); putchar('\n');
  1265. #endif
  1266.  
  1267.     map1Proc(qualify,preds,name(i).defn);    /* add extra dict params   */
  1268.     name(i).type = evids;            /* save evidence       */
  1269.     overDefns    = cons(i,overDefns);        /* add to list of impls.   */
  1270. }
  1271.  
  1272. /* --------------------------------------------------------------------------
  1273.  * Type check bodies of bindings:
  1274.  * ------------------------------------------------------------------------*/
  1275.  
  1276. static Void local typeBind(b)           /* Type check binding           */
  1277. Cell b; {
  1278.     if (isVar(fst(b))) {                   /* function binding */
  1279.     Cell ass = findTopBinding(fst(b));
  1280.     Int  beta;
  1281.  
  1282.     if (isNull(ass) || !isInt(snd(ass)))
  1283.         internal("typeBind");
  1284.  
  1285.     beta = intOf(snd(ass));
  1286.     map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
  1287.     }
  1288.     else {                           /* pattern binding  */
  1289.     static String lhsPat = "lhs pattern";
  1290.     static String rhs    = "right hand side";
  1291.     Int  beta         = newTyvars(1);
  1292.     Pair pb             = snd(snd(b));
  1293.     Int  l             = rhsLine(snd(pb));
  1294.  
  1295.     tcMode  = OLD_PATTERN;
  1296.     check(l,fst(pb),NIL,lhsPat,var,beta);
  1297.     tcMode  = EXPRESSION;
  1298.     snd(pb) = typeRhs(snd(pb));
  1299.     shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,var,beta);
  1300.     }
  1301. }
  1302.  
  1303. static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding  */
  1304. Int  beta;
  1305. Cell v;
  1306. Pair a; {
  1307.     static String valDef = "function binding";
  1308.     Int l         = rhsLine(snd(a));
  1309.     typeAlt(a);
  1310.     shouldBe(l,v,NIL,valDef,var,beta);
  1311. }
  1312.  
  1313. static Cell local typeRhs(e)           /* check type of rhs of definition  */
  1314. Cell e; {
  1315.     switch (whatIs(e)) {
  1316.     case GUARDED : {   Int beta = newTyvars(1);
  1317.                map1Proc(guardedType,beta,snd(e));
  1318.                tyvarType(beta);
  1319.                }
  1320.                break;
  1321.  
  1322.     case LETREC  : enterBindings();
  1323.                mapProc(typeBindings,fst(snd(e)));
  1324.                snd(snd(e)) = typeRhs(snd(snd(e)));
  1325.                leaveBindings();
  1326.                break;
  1327.  
  1328.     default      : snd(e) = typeExpr(intOf(fst(e)),snd(e));
  1329.                break;
  1330.     }
  1331.     return e;
  1332. }
  1333.  
  1334. static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
  1335. Int  beta;                   /* should have gd :: Bool,       */
  1336. Cell gded; {                   /*          ex :: (var,beta)       */
  1337.     static String guarded = "guarded expression";
  1338.     static String guard   = "guard";
  1339.     Int line = intOf(fst(gded));
  1340.  
  1341.     gded     = snd(gded);
  1342.     check(line,fst(gded),NIL,guard,typeBool,0);
  1343.     check(line,snd(gded),NIL,guarded,var,beta);
  1344. }
  1345.  
  1346. Cell rhsExpr(rhs)               /* find first expression on a rhs   */
  1347. Cell rhs; {
  1348.     switch (whatIs(rhs)) {
  1349.     case GUARDED : return snd(snd(hd(snd(rhs))));
  1350.     case LETREC  : return rhsExpr(snd(snd(rhs)));
  1351.     default      : return snd(rhs);
  1352.     }
  1353. }
  1354.  
  1355. Int rhsLine(rhs)               /* find line number associated with */
  1356. Cell rhs; {                   /* a right hand side           */
  1357.     switch (whatIs(rhs)) {
  1358.     case GUARDED : return intOf(fst(hd(snd(rhs))));
  1359.     case LETREC  : return rhsLine(snd(snd(rhs)));
  1360.     default      : return intOf(fst(rhs));
  1361.     }
  1362. }
  1363.  
  1364. /* --------------------------------------------------------------------------
  1365.  * Calculate generalization of types and compare with declared type schemes:
  1366.  * ------------------------------------------------------------------------*/
  1367.  
  1368. static Void local genBind(ps,hps,b)    /* Generalize the type of each var */
  1369. List ps;                /* defined in binding b, qualifying*/
  1370. List hps;                /* each with the predicates in ps  */
  1371. Cell b; {                /* and using Haskell predicates hps*/
  1372.     Cell v = fst(b);
  1373.     Cell t = fst(snd(b));
  1374.  
  1375.     if (isVar(fst(b)))
  1376.     genAss(rhsLine(snd(hd(snd(snd(b))))),ps,hps,v,t);
  1377.     else {
  1378.     Int line = rhsLine(snd(snd(b)));
  1379.     for (; nonNull(v); v=tl(v)) {
  1380.         Type ty = NIL;
  1381.         if (nonNull(t)) {
  1382.         ty = hd(t);
  1383.         t  = tl(t);
  1384.         }
  1385.         genAss(line,ps,hps,hd(v),ty);
  1386.     }
  1387.     }
  1388. }
  1389.  
  1390. static Void local genAss(l,ps,hps,v,t)    /* Calculate inferred type of v and*/
  1391. Int  l;                    /* compare with declared type, t,  */
  1392. List ps;                /* if given.  Use Haskell preds hps*/
  1393. List hps;                /* to check correct unambig typing */
  1394. Cell v;                    /* and ps to calculate GTC type    */
  1395. Type t; {
  1396.     Cell ass = findTopBinding(v);
  1397.     Type it;
  1398.     Int  ng;
  1399.     Type ht;
  1400.  
  1401.     if (isNull(ass) || !isInt(snd(ass)))
  1402.     internal("genAss");
  1403.  
  1404.     resetGenericsFrom(0);        /* Calculate Haskell typing       */
  1405.     it  = copyTyvar(intOf(snd(ass)));
  1406.     ng  = nextGeneric;
  1407.     hps = copyPreds(hps);
  1408.     ht  = generalize(hps,it);
  1409.  
  1410.     if (nextGeneric!=ng)        /* If a new generic variable was   */
  1411.     ambigError(l,            /* introduced by copyHPreds, then  */
  1412.            "inferred type",    /* the inferred type is ambiguous  */
  1413.            v,
  1414.            ht);
  1415.  
  1416.     if (nonNull(t) && !checkSchemes(t,ht))
  1417.     tooGeneral(l,v,t,ht);        /* Compare with declared type       */
  1418.  
  1419.     snd(ass) = generalize(copyPreds(ps),it);
  1420. }
  1421.  
  1422. static Type local generalize(qs,t)    /* calculate generalization of t   */
  1423. List qs;                /* having already marked fixed vars*/
  1424. Type t; {                /* with qualifying preds qs       */
  1425.     if (nonNull(qs))
  1426.     t = ap(QUAL,pair(qs,t));
  1427.     if (nonNull(genericVars)) {
  1428.     Kind k  = STAR;
  1429.     List vs = genericVars;
  1430.     for (; nonNull(vs); vs=tl(vs))
  1431.         k = ap(tyvar(intOf(hd(vs)))->kind,k);
  1432.     t = mkPolyType(k,t);
  1433. #ifdef DEBUG_KINDS
  1434.     printf("Generalised type: ");
  1435.     printType(stdout,t);
  1436.     printf(" ::: ");
  1437.     printKind(stdout,k);
  1438.     printf("\n");
  1439. #endif
  1440.     }
  1441.     return t;
  1442. }
  1443.  
  1444. static Void local tooGeneral(l,e,dt,it)    /* explicit type sig. too general  */
  1445. Int  l;
  1446. Cell e;
  1447. Type dt, it; {
  1448.     ERROR(l) "Declared type too general" ETHEN
  1449.     ERRTEXT  "\n*** Expression    : "     ETHEN ERREXPR(e);
  1450.     ERRTEXT  "\n*** Declared type : "     ETHEN ERRTYPE(dt);
  1451.     ERRTEXT  "\n*** Inferred type : "     ETHEN ERRTYPE(it);
  1452.     ERRTEXT  "\n"
  1453.     EEND;
  1454. }
  1455.  
  1456. /* --------------------------------------------------------------------------
  1457.  * Compare type schemes:
  1458.  *
  1459.  * In comparing declared and inferred type schemes, we require that the type
  1460.  * parts of the two type schemes are identical.  However, for the predicate
  1461.  * parts of the two type schemes, we require only that each inferred
  1462.  * predicate is included in the list of declared predicates:
  1463.  *
  1464.  * e.g. Declared        Inferred
  1465.  *      (Eq a, Eq a)    Eq a        OK
  1466.  *      (Ord a, Eq a)   Ord a        OK
  1467.  *      ()              Ord a        NOT ACCEPTED
  1468.  *    Ord a        ()        IMPOSSIBLE, by construction, the
  1469.  *                    inferred context will be at least as
  1470.  *                    restricted as the declared context.
  1471.  * ------------------------------------------------------------------------*/
  1472.  
  1473. static Bool local checkSchemes(sd,si)    /* Compare type schemes           */
  1474. Type sd;                /* declared scheme           */
  1475. Type si; {                /* inferred scheme           */
  1476.     Bool bd = isPolyType(sd);
  1477.     Bool bi = isPolyType(si);
  1478.     if (bd || bi) {
  1479.         if (bd && bi && eqKind(polySigOf(sd),polySigOf(si))) {
  1480.             sd = monoTypeOf(sd);
  1481.             si = monoTypeOf(si);
  1482.         }
  1483.         else
  1484.             return FALSE;
  1485.     }
  1486.  
  1487.     bd = (whatIs(sd)==QUAL);
  1488.     bi = (whatIs(si)==QUAL);
  1489.     if (bd && bi && checkQuals(fst(snd(sd)),fst(snd(si)))) {
  1490.     sd = snd(snd(sd));
  1491.     si = snd(snd(si));
  1492.     }
  1493.     else if (bd && !bi && isNull(fst(snd(sd))))    /* maybe somebody gave an   */
  1494.     sd = snd(snd(sd));            /* explicitly null context? */
  1495.     else if (!bd && bi && isNull(fst(snd(si))))
  1496.     si = snd(snd(si));
  1497.     else if (bd || bi)
  1498.     return FALSE;
  1499.  
  1500.     return equalTypes(sd,si);
  1501. }
  1502.  
  1503. static Bool local checkQuals(qsd,qsi)  /* Compare lists of qualifying preds*/
  1504. List qsd, qsi; {
  1505.     for (; nonNull(qsi); qsi=tl(qsi)) {            /* check qsi < qsd */
  1506.     Class c  = fun(hd(qsi));
  1507.     Type  o  = arg(hd(qsi));
  1508.     List  qs = qsd;
  1509.     for (; nonNull(qs); qs=tl(qs))
  1510.        if (c==fun(hd(qs)) && o==arg(hd(qs)))
  1511.         break;
  1512.     if (isNull(qs))
  1513.         return FALSE;
  1514.     }
  1515.     return TRUE;
  1516. }
  1517.  
  1518. static Bool local equalTypes(t1,t2)    /* Compare simple types for equality*/
  1519. Type t1, t2; {
  1520.  
  1521. et: if (whatIs(t1)!=whatIs(t2))
  1522.     return FALSE;
  1523.  
  1524.     switch (whatIs(t1)) {
  1525.     case TYCON   :
  1526.     case OFFSET  :
  1527.     case TUPLE   : return t1==t2;
  1528.  
  1529.     case INTCELL : return intOf(t1)!=intOf(t2);
  1530.  
  1531.     case UNIT    :
  1532.     case ARROW   :
  1533.     case LIST    : return TRUE;
  1534.  
  1535.     case AP      : if (equalTypes(fun(t1),fun(t2))) {
  1536.                t1 = arg(t1);
  1537.                t2 = arg(t2);
  1538.                goto et;
  1539.                }
  1540.                        return FALSE;
  1541.  
  1542.     default      : internal("equalTypes");
  1543.     }
  1544.  
  1545.     return TRUE;/*NOTREACHED*/
  1546. }
  1547.  
  1548. /* --------------------------------------------------------------------------
  1549.  * Entry points to type checker:
  1550.  * ------------------------------------------------------------------------*/
  1551.  
  1552. Type typeCheckExp(useDefs)        /* Type check top level expression */
  1553. Bool useDefs; {                /* using defaults if reqd       */
  1554.     static String expr = "expression";
  1555.     Type type;
  1556.  
  1557.     typeChecker(RESET);
  1558.     enterBindings();
  1559.     inputExpr = typeExpr(0,inputExpr);
  1560.     clearMarks();
  1561.     if (nonNull(elimConstPreds(0,expr,NIL)) ||
  1562.     (useDefs && resolveDefs(NIL,hpreds) &&
  1563.      nonNull(elimConstPreds(0,expr,NIL))))
  1564.     internal("typeCheckExp");
  1565.     resetGenericsFrom(0);
  1566.     type = copyType(typeIs,typeOff);
  1567.     type = generalize(copyPreds(hpreds),type);
  1568.     if (nonNull(preds)) {        /* qualify input expression with   */
  1569.     if (whatIs(inputExpr)!=LAMBDA)    /* additional dictionary params       */
  1570.         inputExpr = ap(LAMBDA,pair(NIL,pair(mkInt(0),inputExpr)));
  1571.     qualify(preds,snd(inputExpr));
  1572.     }
  1573.     typeChecker(RESET);
  1574.     return type;
  1575. }
  1576.  
  1577. Void typeCheckDefns() {            /* Type check top level bindings    */
  1578.     Target t  = length(valDefns) + length(instDefns) + length(classDefns);
  1579.     Target i  = 0;
  1580.     List   gs;
  1581.  
  1582.     typeChecker(RESET);
  1583.     enterBindings();
  1584.     dictsPending = NIL;
  1585.     setGoal("Type checking",t);
  1586.  
  1587.     for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
  1588.     typeDefnGroup(hd(gs));
  1589.     soFar(i++);
  1590.     }
  1591.     clearTypeIns();
  1592.     for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
  1593.     typeInstDefn(hd(gs));
  1594.     soFar(i++);
  1595.     }
  1596.     for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
  1597.     typeClassDefn(hd(gs));
  1598.     soFar(i++);
  1599.     }
  1600.  
  1601.     makePendingDicts();
  1602.     typeChecker(RESET);
  1603.     done();
  1604. }
  1605.  
  1606. static Void local typeDefnGroup(bs)    /* type check group of value defns */
  1607. List bs; {                /* (one top level scc)           */
  1608.     List as;
  1609.  
  1610.     emptySubstitution();
  1611.     hd(defnBounds) = NIL;
  1612.     preds       = NIL;
  1613.     setTypeIns(bs);
  1614.     typeBindings(bs);            /* find types for vars in bindings */
  1615.  
  1616.     if (nonNull(preds))
  1617.     internal("typeDefnGroup");
  1618.  
  1619.     for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
  1620.     Cell a = hd(as);        /* add infered types to environment*/
  1621.     Name n = findName(textOf(fst(a)));
  1622.     if (isNull(n))
  1623.         internal("typeDefnGroup");
  1624.     name(n).type = snd(a);
  1625.     }
  1626.     hd(varsBounds) = NIL;
  1627. }
  1628.  
  1629. /* --------------------------------------------------------------------------
  1630.  * Type checker control:
  1631.  * ------------------------------------------------------------------------*/
  1632.  
  1633. Void typeChecker(what)
  1634. Int what; {
  1635.     Int  i;
  1636.  
  1637.     switch (what) {
  1638.     case RESET   : tcMode        = EXPRESSION;
  1639.                matchMode    = FALSE;
  1640.                unkindTypes  = NIL;
  1641.                emptySubstitution();
  1642.                emptyAssumption();
  1643.                preds        = NIL;
  1644.                evids        = NIL;
  1645.                hpreds        = NIL;
  1646.                dictsPending = UNIT;
  1647.                break;
  1648.  
  1649.     case MARK    : for (i=0; i<MAXTUPCON; ++i)
  1650.                mark(tupleConTypes[i]);
  1651.                for (i=0; i<MAXKINDFUN; ++i) {
  1652.                mark(simpleKindCache[i]);
  1653.                mark(varKindCache[i]);
  1654.                }
  1655.                for (i=0; i<numTyvars; ++i)
  1656.                mark(tyvars[i].bound);
  1657.                mark(typeIs);
  1658.                mark(predsAre);
  1659.                mark(defnBounds);
  1660.                mark(varsBounds);
  1661.                mark(depends);
  1662.                mark(preds);
  1663.                mark(evids);
  1664.                mark(hpreds);
  1665.                mark(dictsPending);
  1666.                mark(stdDefaults);
  1667.                mark(unkindTypes);
  1668.                mark(genericVars);
  1669.                mark(arrow);
  1670.                mark(boundPair);
  1671.                mark(typeList);
  1672.                mark(typeVarToVar);
  1673.                mark(predNum);
  1674.                mark(predFractional);
  1675.                mark(predIntegral);
  1676.                mark(starToStar);
  1677. #if IO_MONAD
  1678.                mark(typeProgIO);
  1679.                mark(typeSTab);
  1680. #endif
  1681.                break;
  1682.  
  1683.     case INSTALL : typeChecker(RESET);
  1684.  
  1685.                for (i=0; i<MAXTUPCON; ++i)
  1686.                tupleConTypes[i] = NIL;
  1687.                for (i=0; i<MAXKINDFUN; ++i) {
  1688.                simpleKindCache[i] = NIL;
  1689.                varKindCache[i]    = NIL;
  1690.                }
  1691.  
  1692.                var        = mkOffset(0);
  1693.                arrow        = fn(var,mkOffset(1));
  1694.                boundPair    = ap(ap(mkTuple(2),var),var);
  1695.                starToStar   = simpleKind(1);
  1696.  
  1697.                typeList     = ap(LIST,var);
  1698.                nameNil        = addPrimCfun("[]",0,0,
  1699.                            mkPolyType(starToStar,
  1700.                                   typeList));
  1701.                nameCons     = addPrimCfun(":",2,1,
  1702.                            mkPolyType(starToStar,
  1703.                                   fn(var,
  1704.                                   fn(typeList,
  1705.                                  typeList))));
  1706.  
  1707.                typeUnit     = UNIT;
  1708.  
  1709.                typeInt        = addPrimTycon("Int",STAR,0,DATATYPE,NIL);
  1710.                typeChar     = addPrimTycon("Char",STAR,0,DATATYPE,NIL);
  1711.                typeBin      = addPrimTycon("Bin",STAR,0,DATATYPE,NIL);
  1712.                typeFloat    = addPrimTycon("Float",STAR,0,DATATYPE,
  1713.                                       NIL);
  1714.                typeDouble   = addPrimTycon("Double",STAR,0,DATATYPE,
  1715.                                       NIL);
  1716.                typeInteger  = addPrimTycon("Integer",STAR,0,DATATYPE,
  1717.                                       NIL);
  1718.  
  1719.                stdDefaults  = cons(typeInt,cons(typeFloat,NIL));
  1720.  
  1721.                typeVarToVar = ap(ap(ARROW,var),var);
  1722.  
  1723. #if HASKELL_ARRAYS
  1724.                typeArray    = addPrimTycon("Array",simpleKind(2),2,
  1725.                            DATATYPE,NIL);
  1726. #endif
  1727. #if IO_MONAD
  1728.                typeWorld    = addPrimTycon("RealWorld",STAR,0,
  1729.                            DATATYPE,NIL);
  1730.                typeST        = addPrimTycon("ST",simpleKind(2),2,
  1731.                            DATATYPE,NIL);
  1732.                typeSTab        = ap(ap(typeST,mkOffset(0)),mkOffset(1));
  1733.                typeIO        = addPrimTycon("IO",starToStar,0,SYNONYM,
  1734.                            ap(typeST,typeWorld));
  1735.                typeProgIO   = ap(typeIO,UNIT);
  1736.                typeMutVar   = addPrimTycon("MutVar",simpleKind(2),2,
  1737.                            DATATYPE,NIL);
  1738. #if HASKELL_ARRAYS
  1739.                typeMutArr   = addPrimTycon("MutArr",simpleKind(3),3,
  1740.                            DATATYPE,NIL);
  1741. #endif
  1742. #endif
  1743.                break;
  1744.     }
  1745. }
  1746.  
  1747. Void linkPreludeCore() {        /* Hook to items defined in prelude */
  1748.     if (isNull(typeBool)) {        /* but only do it the first time    */
  1749.     Int i;
  1750.  
  1751. #if IO_DIALOGUE
  1752.     Type req     = findTycon(findText("Request"));
  1753.     Type rsp     = findTycon(findText("Response"));
  1754.     Type ioe     = findTycon(findText("IOError"));
  1755.     typeDialogue = findTycon(findText("Dialogue"));
  1756.  
  1757.     if (isNull(req) || isNull(rsp) ||
  1758.         isNull(ioe) || isNull(typeDialogue)) {
  1759.         ERROR(0) "Prelude does not define I/O datatypes"
  1760.         EEND;
  1761.     }
  1762.  
  1763.     nameReadFile    = findName(findText("ReadFile"));
  1764.     nameWriteFile   = findName(findText("WriteFile"));
  1765.     nameAppendFile  = findName(findText("AppendFile"));
  1766.     nameReadChan    = findName(findText("ReadChan"));
  1767.     nameAppendChan  = findName(findText("AppendChan"));
  1768.     nameEcho        = findName(findText("Echo"));
  1769.     nameGetArgs     = findName(findText("GetArgs"));
  1770.     nameGetProgName = findName(findText("GetProgName"));
  1771.     nameGetEnv      = findName(findText("GetEnv"));
  1772.  
  1773.     if (isNull(nameReadFile)   || isNull(nameWriteFile)   ||
  1774.         isNull(nameAppendFile) || isNull(nameReadChan)    ||
  1775.         isNull(nameAppendChan) || isNull(nameEcho)        ||
  1776.         isNull(nameGetArgs)    || isNull(nameGetProgName) ||
  1777.         isNull(nameGetEnv)) {
  1778.         ERROR(0) "Prelude does not define Request constructors"
  1779.         EEND;
  1780.     }
  1781.  
  1782.     nameSuccess = findName(findText("Success"));
  1783.     nameStr     = findName(findText("Str"));
  1784.     nameFailure = findName(findText("Failure"));
  1785.     nameStrList = findName(findText("StrList"));
  1786.  
  1787.     if (isNull(nameSuccess) || isNull(nameStr)     ||
  1788.         isNull(nameFailure) || isNull(nameStrList)) {
  1789.         ERROR(0) "Prelude does not define Response constructors"
  1790.         EEND;
  1791.     }
  1792.  
  1793.     nameWriteError  = findName(findText("WriteError"));
  1794.     nameReadError   = findName(findText("ReadError"));
  1795.     nameSearchError = findName(findText("SearchError"));
  1796.     nameFormatError = findName(findText("FormatError"));
  1797.     nameOtherError  = findName(findText("OtherError"));
  1798.  
  1799.     if (isNull(nameWriteError)  || isNull(nameReadError)   ||
  1800.         isNull(nameSearchError) || isNull(nameFormatError) ||
  1801.         isNull(nameOtherError)) {
  1802.         ERROR(0) "Prelude does not define IOError constructors"
  1803.         EEND;
  1804.     }
  1805. #endif
  1806.     typeBool  = findTycon(findText("Bool"));
  1807.     nameFalse = findName(findText("False"));
  1808.     nameTrue  = findName(findText("True"));
  1809.  
  1810.     if (isNull(typeBool) || isNull(nameFalse) || isNull(nameTrue)) {
  1811.         ERROR(0) "Prelude does not define Bool type"
  1812.         EEND;
  1813.     }
  1814.  
  1815.     typeString = findTycon(findText("String"));
  1816.     if (isNull(typeString)) {
  1817.         ERROR(0) "Prelude does not define String type"
  1818.         EEND;
  1819.     }
  1820.  
  1821.     typeMaybe   = findTycon(findText("HugsMaybe"));
  1822.     nameJust    = findName(findText("HugsJust"));
  1823.     nameNothing = findName(findText("HugsNothing"));
  1824.  
  1825.     if (isNull(typeMaybe) || isNull(nameJust) || isNull(nameNothing)) {
  1826.         ERROR(0) "Prelude does not define HugsMaybe type"
  1827.         EEND;
  1828.     }
  1829.  
  1830.     classEq     = findClass(findText("Eq"));
  1831.     classOrd    = findClass(findText("Ord"));
  1832.     classText   = findClass(findText("Text"));
  1833.     classBinary = findClass(findText("Binary"));
  1834.     classIx     = findClass(findText("Ix"));
  1835.     classEnum   = findClass(findText("Enum"));
  1836.  
  1837.     if (isNull(classEq)     || isNull(classOrd) || isNull(classText) ||
  1838.             isNull(classBinary) || isNull(classIx)  || isNull(classEnum)) {
  1839.         ERROR(0) "Prelude does not define standard classes"
  1840.         EEND;
  1841.     }
  1842.  
  1843.     classReal       = findClass(findText("Real"));
  1844.     classIntegral   = findClass(findText("Integral"));
  1845.     classRealFrac   = findClass(findText("RealFrac"));
  1846.     classRealFloat  = findClass(findText("RealFloat"));
  1847.     classFractional = findClass(findText("Fractional"));
  1848.     classFloating   = findClass(findText("Floating"));
  1849.     classNum        = findClass(findText("Num"));
  1850.  
  1851.     if (isNull(classReal)       || isNull(classIntegral)  ||
  1852.         isNull(classRealFrac)   || isNull(classRealFloat) ||
  1853.         isNull(classFractional) || isNull(classFloating)  ||
  1854.         isNull(classNum)) {
  1855.         ERROR(0) "Prelude does not define numeric classes"
  1856.             EEND;
  1857.     }
  1858.     predNum            = ap(classNum,var);
  1859.     predFractional  = ap(classFractional,var);
  1860.     predIntegral    = ap(classIntegral,var);
  1861.  
  1862.     nameFromInt     = findName(findText("fromInt"));
  1863.     nameFromInteger = findName(findText("fromInteger"));
  1864.     nameFromDouble  = findName(findText("fromDouble"));
  1865.     nameEq            = findName(findText("=="));
  1866.     nameOrdcmp      = findName(findText("ordcmp"));
  1867.     nameShowsPrec   = findName(findText("showsPrec"));
  1868.     nameLe            = findName(findText("<="));
  1869.     nameIndex       = findName(findText("index"));
  1870.     nameInRange     = findName(findText("inRange"));
  1871.     nameRange       = findName(findText("range"));
  1872.     nameMult        = findName(findText("*"));
  1873.     namePlus        = findName(findText("+"));
  1874.     if (isNull(nameFromInt)   || isNull(nameFromDouble) ||
  1875.         isNull(nameEq)        || isNull(nameOrdcmp)     ||
  1876.         isNull(nameShowsPrec) || isNull(nameLe)         ||
  1877.         isNull(nameIndex)     || isNull(nameInRange)    ||
  1878.         isNull(nameRange)      || isNull(nameMult)        ||
  1879.         isNull(namePlus)      || isNull(nameFromInteger)) {
  1880.         ERROR(0) "Prelude does not define standard members"
  1881.             EEND;
  1882.     }
  1883.  
  1884.     /* The following primitives are referred to in derived instances and
  1885.      * hence require types; the following types are a little more general
  1886.      * than we might like, but they are the closest we can get without a
  1887.      * special datatype class.
  1888.      */
  1889.     name(nameConCmp).type
  1890.         = mkPolyType(starToStar,fn(var,fn(var,fn(typeBool,typeBool))));
  1891.     name(nameEnRange).type
  1892.         = mkPolyType(starToStar,fn(boundPair,typeList));
  1893.     name(nameEnIndex).type
  1894.         = mkPolyType(starToStar,fn(boundPair,fn(var,typeInt)));
  1895.     name(nameEnInRng).type
  1896.         = mkPolyType(starToStar,fn(boundPair,fn(var,typeBool)));
  1897.     name(nameEnFrom).type
  1898.         = mkPolyType(starToStar,fn(var,typeList));
  1899.     name(nameEnFrTo).type
  1900.         = name(nameEnFrTh).type
  1901.         = mkPolyType(starToStar,fn(var,fn(var,typeList)));
  1902.  
  1903.     for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
  1904.         addTupInst(classEq,i);
  1905.         addTupInst(classOrd,i);
  1906.         addTupInst(classText,i);
  1907.         addTupInst(classIx,i);
  1908.         addTupInst(classBinary,i);
  1909.     }
  1910.     }
  1911. }
  1912.  
  1913. /*-------------------------------------------------------------------------*/
  1914.