home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / type.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-06  |  62.8 KB  |  1,304 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.     tk implementation i*/
  892. String wh;                     /* of member m at instance t  */
  893. Name   m;                     /* where ar = sig of vars in t*/
  894. Name   i;
  895. Cell   pi;
  896. Kind   ar; {
  897.     Int  line = rhsLine(snd(hd(name(i).defn)));
  898.     Int  alpha, beta;
  899.     Type rt = NIL;                /* required type       */
  900.     Type it = NIL;                /* inferred type       */
  901.     List evid;                    /* evidence assignment       */
  902.     List qs;                    /* predicate list       */
  903.  
  904.     emptySubstitution();
  905.     hd(defnBounds) = NIL;
  906.     hd(depends)    = NODEPENDS;
  907.     preds       = NIL;
  908.  
  909.     alpha = newTyvars(1);            /* record expected type       */
  910.     beta  = newKindedVars(ar);
  911.     instantiate(name(m).type);
  912.     bindTv(alpha,typeIs,typeOff);
  913.     if (isNull(predsAre) || !oneWayMatches(hd(predsAre),typeOff,pi,beta))
  914.     internal("typeMember1");
  915.     evid = singleton(triple(hd(predsAre),mkInt(typeOff),dictVar));
  916.  
  917.     resetGenericsFrom(0);            /* Set required type, rt   */
  918.     qs = copyPreds(evid);
  919.     rt = generalise(qs,copyTyvar(alpha));
  920.  
  921.     map2Proc(typeDefAlt,alpha,m,name(i).defn);    /* Type each alt in defn   */
  922.  
  923.     clearMarks();
  924.     if (nonNull(elimConstPreds(line,wh,m,NIL)))    /* need to resolve constant*/
  925.     internal("typeMember2");        /* overloading - shouldn't */
  926.                         /* be any locally constant */
  927.                         /* overloading at all!       */
  928.  
  929.     explicitProve(line,wh,m,evid,preds);    /* resolve remaining preds */
  930.  
  931.     resetGenericsFrom(0);            /* Determine inferred type */
  932.     qs = copyPreds(evid);
  933.     it = generalise(qs,copyTyvar(alpha));
  934.  
  935.     if (!equalSchemes(rt,it))            /* check inferred type ok  */
  936.     tooGeneral(line,m,rt,it);
  937.  
  938.     map1Proc(qualify,evid,name(i).defn);    /* add dictionary parameter*/
  939.  
  940.     overDefns = cons(i,overDefns);
  941. }
  942.  
  943. /* --------------------------------------------------------------------------
  944.  * Type check bodies of bindings:
  945.  * ------------------------------------------------------------------------*/
  946.  
  947. static Void local typeBind(b)           /* Type check binding           */
  948. Cell b; {
  949.     if (isVar(fst(b))) {                   /* function binding */
  950.     Cell ass = findTopBinding(fst(b));
  951.     Int  beta;
  952.  
  953.     if (isNull(ass) || !isInt(snd(ass)))
  954.         internal("typeBind");
  955.  
  956.     beta = intOf(snd(ass));
  957.     map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
  958.     }
  959.     else {                           /* pattern binding  */
  960.     static String lhsPat = "lhs pattern";
  961.     static String rhs    = "right hand side";
  962.     Int  beta         = newTyvars(1);
  963.     Pair pb             = snd(snd(b));
  964.     Int  l             = rhsLine(snd(pb));
  965.  
  966.     check(l,fst(pb),NIL,lhsPat,var,beta);
  967.     snd(pb) = typeRhs(snd(pb));
  968.     shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,var,beta);
  969.     }
  970. }
  971.  
  972. static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding  */
  973. Int  beta;
  974. Cell v;
  975. Pair a; {
  976.     static String valDef = "function binding";
  977.     Int l         = rhsLine(snd(a));
  978.     typeAlt(a);
  979.     shouldBe(l,v,NIL,valDef,var,beta);
  980. }
  981.  
  982. static Cell local typeRhs(e)           /* check type of rhs of definition  */
  983. Cell e; {
  984.     switch (whatIs(e)) {
  985.     case GUARDED : {   Int beta = newTyvars(1);
  986.                map1Proc(guardedType,beta,snd(e));
  987.                tyvarType(beta);
  988.                }
  989.                break;
  990.  
  991.     case LETREC  : enterBindings();
  992.                mapProc(typeBindings,fst(snd(e)));
  993.                snd(snd(e)) = typeRhs(snd(snd(e)));
  994.                leaveBindings();
  995.                break;
  996.  
  997.     default      : snd(e) = typeExpr(intOf(fst(e)),snd(e));
  998.                break;
  999.     }
  1000.     return e;
  1001. }
  1002.  
  1003. static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
  1004. Int  beta;                   /* should have gd :: Bool,       */
  1005. Cell gded; {                   /*          ex :: (var,beta)       */
  1006.     static String guarded = "guarded expression";
  1007.     static String guard   = "guard";
  1008.     Int line = intOf(fst(gded));
  1009.  
  1010.     gded     = snd(gded);
  1011.     check(line,fst(gded),NIL,guard,typeBool,0);
  1012.     check(line,snd(gded),NIL,guarded,var,beta);
  1013. }
  1014.  
  1015. Cell rhsExpr(rhs)               /* find first expression on a rhs   */
  1016. Cell rhs; {
  1017.  
  1018.     STACK_CHECK;            /* KH */
  1019.  
  1020.     switch (whatIs(rhs)) {
  1021.     case GUARDED : return snd(snd(hd(snd(rhs))));
  1022.     case LETREC  : return rhsExpr(snd(snd(rhs)));
  1023.     default      : return snd(rhs);
  1024.     }
  1025. }
  1026.  
  1027. Int rhsLine(rhs)               /* find line number associated with */
  1028. Cell rhs; {                   /* a right hand side           */
  1029.  
  1030.  = hd(as);        /* add infered types to environment*/
  1031.     Name n = findName(textOf(fst(a)));
  1032.  
  1033.     if (isNull(n))
  1034.         internal("typeDefnGroup");
  1035.     if (catchAmbigs && isAmbiguous(snd(a)))
  1036.         ambigError(name(n).line,"inferred type",n,snd(a));
  1037.     name(n).type = snd(a);
  1038.     }
  1039.     hd(varsBounds) = NIL;
  1040. }
  1041.  
  1042. /* --------------------------------------------------------------------------
  1043.  * Type checker control:
  1044.  * ------------------------------------------------------------------------*/
  1045.  
  1046. Void typeChecker(what)
  1047. Int what; {
  1048.     Int  i;
  1049.  
  1050.     switch (what) {
  1051.     case RESET   : patternMode = FALSE;
  1052.                matchMode   = FALSE;
  1053.                predProve   = NIL;
  1054.                instPred       = NIL;
  1055.                instExpr       = NIL;
  1056.                unkindTypes = NIL;
  1057.                emptySubstitution();
  1058.                emptyAssumption();
  1059.                preds       = NIL;
  1060.                break;
  1061.  
  1062.     case MARK    : for (i=0; i<MAXTUPCON; ++i)
  1063.                mark(tupleConTypes[i]);
  1064.                for (i=0; i<MAXKINDFUN; ++i) {
  1065.                mark(simpleKindCache[i]);
  1066.                mark(varKindCache[i]);
  1067.                }
  1068.                for (i=0; i<numTyvars; ++i)
  1069.                mark(tyvars[i].bound);
  1070.                mark(typeIs);
  1071.                mark(predsAre);
  1072.                mark(defnBounds);
  1073.                mark(varsBounds);
  1074.                mark(depends);
  1075.                mark(preds);
  1076.                mark(dictVar);
  1077.                mark(predProve);
  1078.                mark(instPred);
  1079.                mark(instExpr);
  1080.                mark(unkindTypes);
  1081.                mark(genericVars);
  1082.                mark(arrow);
  1083.                mark(typeList);
  1084.                mark(typeIntToInt);
  1085.                mark(predNum);
  1086.                mark(predMonad);
  1087.                mark(predMonad0);
  1088.                mark(starToStar);
  1089.                mark(monadSig);
  1090. #ifdef LAMBDAVAR
  1091.                mark(typeProg);
  1092. #endif
  1093. #ifdef LAMBDANU
  1094.                mark(typeLnProg);
  1095. #endif
  1096. #if MAC
  1097.                mark(typeIO);
  1098.                mark(typeState);
  1099. #endif
  1100.  
  1101.                break;
  1102.  
  1103.     case INSTALL : typeChecker(RESET);
  1104.  
  1105.                for (i=0; i<MAXTUPCON; ++i)
  1106.                tupleConTypes[i] = NIL;
  1107.                for (i=0; i<MAXKINDFUN; ++i) {
  1108.                simpleKindCache[i] = NIL;
  1109.                varKindCache[i]    = NIL;
  1110.                }
  1111.  
  1112.                dictVar      = inventDictVar();
  1113.  
  1114.                var        = mkOffset(0);
  1115.                arrow        = fn(var,mkOffset(1));
  1116.                starToStar   = simpleKind(1);
  1117.  
  1118.                typeList     = ap(LIST,var);
  1119.                nameNil        = addPrimCfun("[]",0,0,
  1120.                            mkPolyType(starToStar,
  1121.                                   typeList));
  1122.                nameCons     = addPrimCfun(":",2,1,
  1123.                            mkPolyType(starToStar,
  1124.                                   fn(var,
  1125.                                   fn(typeList,
  1126.                                  typeList))));
  1127.  
  1128.                typeUnit     = UNIT;
  1129.  
  1130.                typeBool     = addPrimTycon("Bool",STAR,DATATYPE,NIL);
  1131.                nameFalse    = addPrimCfun("False",0,0,typeBool);
  1132.                nameTrue     = addPrimCfun("True",0,1,typeBool);
  1133.                        tycon(typeBool).defn
  1134.                     = cons(nameFalse,cons(nameTrue,NIL));
  1135.  
  1136.                typeInt        = addPrimTycon("Int",STAR,DATATYPE,NIL);
  1137.                typeFloat    = addPrimTycon("Float",STAR,DATATYPE,NIL);
  1138.  
  1139.                typeChar     = addPrimTycon("Char",STAR,DATATYPE,NIL);
  1140.                typeString   = addPrimTycon("String",STAR,SYNONYM,
  1141.                             ap(LIST,typeChar));
  1142.                typeIntToInt = ap(ap(ARROW,typeInt),typeInt);
  1143. #if MAC
  1144.                /* Abstract type for the system state token */
  1145.                typeState =    addPrimTycon("IOState",STAR,DATATYPE,NIL);
  1146.  
  1147.                /* The basic IO monad type */
  1148.                typeIO =       addPrimTycon("IO",starToStar,DATATYPE,NIL);
  1149.  
  1150.                /* IO :: forall a. (IOState -> (a,IOState)) -> IO a */
  1151.                nameIO =       addPrimCfun("IO",1,0,
  1152.                     mkPolyType(starToStar,
  1153.                        fn(
  1154.                            fn(typeState,
  1155.                               ap(ap(mkTuple(2),var),
  1156.                                  typeState)),
  1157.                             ap(typeIO,var)
  1158.                           )));
  1159.                tycon(typeIO).arity = 1;
  1160. #endif
  1161.  
  1162. #ifdef LAMBDAVAR
  1163.                typeProc     = addPrimTycon("Proc",starToStar,
  1164.                            DATATYPE,NIL);
  1165.                typeProg        = ap(typeProc,UNIT);
  1166.                typeVar        = addPrimTycon("Var",starToStar,
  1167.                            DATATYPE,NIL);
  1168.                nameVar      = addPrimCfun("_LambdaVar",1,0,
  1169.                           mkPolyType(starToStar,
  1170.                                  fn(var,
  1171.                                 ap(typeVar,
  1172.                                    var))));
  1173. #endif
  1174.  
  1175. #ifdef LAMBDANU
  1176.                typeCmd      = addPrimTycon("Cmd",simpleKind(2),
  1177.                            DATATYPE,NIL);
  1178.                typeLnProg   = mkPolyType(starToStar,
  1179.                          ap(ap(typeCmd,var),UNIT));
  1180.                typeTag        = addPrimTycon("Tag",starToStar,
  1181.                            DATATYPE,NIL);
  1182.                nameTag      = addPrimCfun("_LambdaNu",1,0,
  1183.                           mkPolyType(starToStar,
  1184.                                  fn(var,
  1185.                                 ap(typeTag,
  1186.                                    var))));
  1187. #endif
  1188.  
  1189.                        initIOtypes();
  1190.  
  1191.                nameFromInt  = NIL;
  1192.                classNum        = NIL;
  1193.                predNum        = NIL;
  1194.                classMonad   = NIL;
  1195.                predMonad    = NIL;
  1196.                classMonad0  = NIL;
  1197.                predMonad0   = NIL;
  1198.                monadSig        = NIL;
  1199.  
  1200.                break;
  1201.  
  1202.     case PRELUDE : classNum    = findClass(findText("Num"));
  1203.                nameFromInt = findName(findText("fromInteger"));
  1204.                if (nonNull(classNum) && nonNull(nameFromInt))
  1205.                predNum = ap(classNum,var);
  1206.  
  1207.                classMonad  = findClass(findText("Monad"));
  1208.                classMonad0 = findClass(findText("Monad0"));
  1209.                nameResult  = findName(findText("result"));
  1210.                nameBind       = findName(findText("bind"));
  1211.                nameZero    = findName(findText("zero"));
  1212.                if (nonNull(classMonad)  &&
  1213.                nonNull(classMonad0) &&
  1214.                nonNull(nameResult)  &&
  1215.                nonNull(nameBind)    &&
  1216.                nonNull(nameZero)) {
  1217.                predMonad  = ap(classMonad,var);
  1218.                predMonad0 = ap(classMonad0,var);
  1219.                monadSig   = singleton(starToStar);
  1220.                }
  1221.                else {
  1222.                nameResult  = NIL;
  1223.                nameBind    = NIL;
  1224.                nameZero    = NIL;
  1225.                classMonad  = NIL;
  1226.                predMonad   = NIL;
  1227.                classMonad0 = NIL;
  1228.                predMonad0  = NIL;
  1229.                monadSig    = NIL;
  1230.                }
  1231.                break;
  1232.     }
  1233. }
  1234.  
  1235. #if MPW        /* Reinitialise Predefined types -- KH */
  1236.  
  1237. #define ResetName(n)    if (nonNull(n)) name(n).defn   = PREDEFINED;
  1238. #define ResetClass(c)    if (nonNull(c)) class(c).head   = PREDEFINED;
  1239.  
  1240. InitPredefTypes()
  1241. {
  1242.   ResetName(nameFromInt);
  1243.   ResetName(nameResult);
  1244.   ResetName(nameBind);
  1245.   ResetName(nameZero);
  1246.   
  1247.   ResetClass(classNum);
  1248.   ResetClass(classMonad);
  1249.   ResetClass(classMonad0);
  1250.  
  1251. /*  initIOtypes();*/
  1252. }
  1253. #endif
  1254.  
  1255. static Void local initIOtypes() {    /* initialise I/O types and cfuns   */
  1256.     Type req        = addPrimTycon("Request",STAR,DATATYPE,NIL);
  1257.     Type rsp        = addPrimTycon("Response",STAR,DATATYPE,NIL);
  1258.     Type ioe        = addPrimTycon("IOError",STAR,DATATYPE,NIL);
  1259.     Type si        = fn(typeString, ioe);
  1260.     Type sreq        = fn(typeString, req);
  1261.     Type ssreq        = fn(typeString, sreq);
  1262.  
  1263.     nameReadFile    = addPrimCfun("ReadFile",   1, 0, sreq);
  1264.     nameWriteFile   = addPrimCfun("WriteFile",  2, 1, ssreq);
  1265.     nameAppendFile  = addPrimCfun("AppendFile", 2, 2, ssreq);
  1266.     nameReadChan    = addPrimCfun("ReadChan",   1, 3, sreq);
  1267.     nameAppendChan  = addPrimCfun("AppendChan", 2, 4, ssreq);
  1268.     nameEcho        = addPrimCfun("Echo",       1, 5, fn(typeBool,req));
  1269.     nameGetArgs     = addPrimCfun("GetArgs",    0, 6, req);
  1270.     nameGetProgName = addPrimCfun("GetProgName",0, 7, req);
  1271.     nameGetEnv      = addPrimCfun("GetEnv",     1, 8, sreq);
  1272. #if MAC
  1273.     nameImperate    = addPrimCfun("Imperate",   1, 9, fn(ap(typeIO,typeUnit),req));
  1274. #endif
  1275.  
  1276.     /*
  1277.        MPW C seems to choke on this without the temp definitions,
  1278.        giving bizarre syntax errors.
  1279.        I suspect the macros are just nested too deeply!  KH
  1280.     */
  1281.     {
  1282. #if MAC
  1283.       Cell temp0 =  cons(nameImperate,NIL);
  1284. #else
  1285.       Cell temp0 =  NIL;
  1286. #endif
  1287.       Cell temp1 =  cons(nameGetArgs,cons(nameGetProgName,
  1288.              cons(nameGetEnv,temp0)));
  1289.       Cell temp2 =  cons(nameReadFile,cons(nameWriteFile,
  1290.              cons(nameAppendFile,cons(nameReadChan,
  1291.               cons(nameAppendChan,cons(nameEcho,temp1))))));
  1292.  
  1293.       tycon(req).defn =  temp2;
  1294.     }
  1295.  
  1296.     nameSuccess     = addPrimCfun("Success",0,0,rsp);
  1297.     nameStr        = addPrimCfun("Str",    1,1,fn(typeString,rsp));
  1298.     nameFailure     = addPrimCfun("Failure",1,2,fn(ioe,rsp));
  1299.     nameStrList     = addPrimCfun("StrList",1,3,fn(ap(LIST,typeString),rsp));
  1300.     tycon(rsp).defn = cons(nameSuccess,cons(nameStr,
  1301.                cons(nameFailure,cons(nameStrList,NIL))));
  1302.  
  1303.     nameWriteError  = addPrimCfun("WriteError", 1, 0, si);
  1304.     nameReadError   = addPrimCf