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