1 /* -*- mode: hugs-c; -*- */
2 /* --------------------------------------------------------------------------
3 * type.c: Copyright (c) Mark P Jones 1991-1998. All rights reserved.
4 * See NOTICE for details and conditions of use etc...
5 * Hugs version 1.3c, March 1998
7 * This is the Hugs type checker
8 * ------------------------------------------------------------------------*/
15 #include "hugs.h" /* for target */
16 #include "pat.h" /* for failFree */
21 #include "Assembler.h" /* for AsmCTypes */
23 /*#define DEBUG_TYPES*/
24 /*#define DEBUG_KINDS*/
25 /*#define DEBUG_DEFAULTS*/
26 /*#define DEBUG_SELS*/
27 /*#define DEBUG_CODE*/
28 /*#define DEBUG_DEPENDS*/
29 /*#define DEBUG_DERIVING*/
31 Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
32 /* types produce error */
34 /* --------------------------------------------------------------------------
35 * Local function prototypes:
36 * ------------------------------------------------------------------------*/
38 static Void local emptyAssumption Args((Void));
39 static Void local enterBindings Args((Void));
40 static Void local leaveBindings Args((Void));
41 static Int local defType Args((Cell));
42 static Type local useType Args((Cell));
43 static Void local markAssumList Args((List));
44 static Cell local findAssum Args((Text));
45 static Pair local findInAssumList Args((Text,List));
46 static List local intsIntersect Args((List,List));
47 static List local genvarAllAss Args((List));
48 static List local genvarAnyAss Args((List));
49 static Int local newVarsBind Args((Cell));
50 static Void local newDefnBind Args((Cell,Type));
52 static Void local enterPendingBtyvs Args((Void));
53 static Void local leavePendingBtyvs Args((Void));
54 static Cell local patBtyvs Args((Cell));
55 static Void local doneBtyvs Args((Int));
57 static Void local typeError Args((Int,Cell,Cell,String,Type,Int));
58 static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type));
59 static Void local cantEstablish Args((Int,String,Cell,Type,List));
60 static Void local tooGeneral Args((Int,Cell,Type,Type));
62 static Cell local typeExpr Args((Int,Cell));
64 static Cell local typeAp Args((Int,Cell));
65 static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
66 static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int));
67 static Int local funcType Args((Int));
68 static Void local typeCase Args((Int,Int,Cell));
69 static Void local typeComp Args((Int,Type,Cell,List));
70 static Void local typeDo Args((Int,Cell));
71 static Cell local compZero Args((List,Int));
72 static Void local typeConFlds Args((Int,Cell));
73 static Void local typeUpdFlds Args((Int,Cell));
74 static Cell local typeFreshPat Args((Int,Cell));
76 static Void local typeBindings Args((List));
77 static Void local removeTypeSigs Args((Cell));
79 static Void local monorestrict Args((List));
80 static Void local restrictedBindAss Args((Cell));
81 static Void local restrictedAss Args((Int,Cell,Type));
83 static Void local unrestricted Args((List));
84 static List local itbscc Args((List));
85 static Void local addEvidParams Args((List,Cell));
87 static Void local typeClassDefn Args((Class));
88 static Void local typeInstDefn Args((Inst));
89 static Void local typeMember Args((String,Name,Cell,List,Cell,Int));
91 static Void local typeBind Args((Cell));
92 static Void local typeDefAlt Args((Int,Cell,Pair));
93 static Cell local typeRhs Args((Cell));
94 static Void local guardedType Args((Int,Cell));
96 static Void local genBind Args((List,Cell));
97 static Void local genAss Args((Int,List,Cell,Type));
98 static Type local genTest Args((Int,Cell,List,Type,Type,Int));
99 static Type local generalize Args((List,Type));
100 static Bool local equalTypes Args((Type,Type));
102 static Void local typeDefnGroup Args((List));
103 static Pair local typeSel Args((Name));
105 /* --------------------------------------------------------------------------
106 * Frequently used type skeletons:
107 * ------------------------------------------------------------------------*/
109 static Type arrow; /* mkOffset(0) -> mkOffset(1) */
110 static Type boundPair; /* (mkOffset(0),mkOffset(0)) */
111 static Type listof; /* [ mkOffset(0) ] */
112 static Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
114 static Cell predNum; /* Num (mkOffset(0)) */
115 static Cell predFractional; /* Fractional (mkOffset(0)) */
116 static Cell predIntegral; /* Integral (mkOffset(0)) */
117 static Kind starToStar; /* Type -> Type */
118 static Cell predMonad; /* Monad (mkOffset(0)) */
119 static Cell predMonad0; /* Monad0 (mkOffset(0)) */
121 /* --------------------------------------------------------------------------
124 * A basic typing statement is a pair (Var,Type) and an assumption contains
125 * an ordered list of basic typing statements in which the type for a given
126 * variable is given by the most recently added assumption about that var.
128 * In practice, the assumption set is split between a pair of lists, one
129 * holding assumptions for vars defined in bindings, the other for vars
130 * defined in patterns/binding parameters etc. The reason for this
131 * separation is that vars defined in bindings may be overloaded (with the
132 * overloading being unknown until the whole binding is typed), whereas the
133 * vars defined in patterns have no overloading. A form of dependency
134 * analysis (at least as far as calculating dependents within the same group
135 * of value bindings) is required to implement this. Where it is known that
136 * no overloaded values are defined in a binding (i.e., when the `dreaded
137 * monomorphism restriction' strikes), the list used to record dependents
138 * is flagged with a NODEPENDS tag to avoid gathering dependents at that
141 * To interleave between vars for bindings and vars for patterns, we use
142 * a list of lists of typing statements for each. These lists are always
143 * the same length. The implementation here is very similar to that of the
144 * dependency analysis used in the static analysis component of this system.
146 * To deal with polymorphic recursion, variables defined in bindings can be
147 * assigned types of the form (POLYREC,(def,use)), where def is a type
148 * variable for the type of the defining occurence, and use is a type
149 * scheme for (recursive) calls/uses of the variable.
150 * ------------------------------------------------------------------------*/
152 static List defnBounds; /*::[[(Var,Type)]] possibly ovrlded*/
153 static List varsBounds; /*::[[(Var,Type)]] not overloaded */
154 static List depends; /*::[?[Var]] dependents/NODEPENDS */
155 static List skolVars; /*::[[Var]] skolem vars */
156 static Cell dummyVar; /* Used to put extra tvars into ass*/
158 #define saveVarsAss() List saveAssump = hd(varsBounds)
159 #define restoreVarsAss() hd(varsBounds) = saveAssump
160 #define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),hd(varsBounds))
161 #define findTopBinding(v) findInAssumList(textOf(v),hd(defnBounds))
163 static Void local emptyAssumption() { /* set empty type assumption */
170 static Void local enterBindings() { /* Add new level to assumption sets */
171 defnBounds = cons(NIL,defnBounds);
172 varsBounds = cons(NIL,varsBounds);
173 depends = cons(NIL,depends);
176 static Void local leaveBindings() { /* Drop one level of assumptions */
177 defnBounds = tl(defnBounds);
178 varsBounds = tl(varsBounds);
179 depends = tl(depends);
182 static Int local defType(a) /* Return type for defining occ. */
183 Cell a; { /* of a var from assumption pair */
184 return (isPair(a) && fst(a)==POLYREC) ? fst(snd(a)) : a;
187 static Type local useType(a) /* Return type for use of a var */
188 Cell a; { /* defined in an assumption */
189 return (isPair(a) && fst(a)==POLYREC) ? snd(snd(a)) : a;
192 static Void local markAssumList(as) /* Mark all types in assumption set*/
193 List as; { /* :: [(Var, Type)] */
194 for (; nonNull(as); as=tl(as)) { /* No need to mark generic types; */
195 Type t = defType(snd(hd(as))); /* the only free variables in those*/
196 if (!isPolyType(t)) /* must have been free earlier too */
201 static Cell local findAssum(t) /* Find most recent assumption about*/
202 Text t; { /* variable named t, if any */
203 List defnBounds1 = defnBounds; /* return translated variable, with */
204 List varsBounds1 = varsBounds; /* type in typeIs */
205 List depends1 = depends;
207 while (nonNull(defnBounds1)) {
208 Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
214 ass = findInAssumList(t,hd(defnBounds1)); /* search defnBounds */
219 if (hd(depends1)!=NODEPENDS && /* save dependent? */
220 isNull(v=varIsMember(t,hd(depends1))))
221 /* N.B. make new copy of variable and store this on list of*/
222 /* dependents, and in the assumption so that all uses of */
223 /* the variable will be at the same node, if we need to */
224 /* overwrite the call of a function with a translation... */
225 hd(depends1) = cons(v=mkVar(t),hd(depends1));
230 defnBounds1 = tl(defnBounds1); /* look in next level*/
231 varsBounds1 = tl(varsBounds1); /* of assumption set */
232 depends1 = tl(depends1);
237 static Pair local findInAssumList(t,as)/* Search for assumption for var */
238 Text t; /* named t in list of assumptions as*/
240 for (; nonNull(as); as=tl(as))
241 if (textOf(fst(hd(as)))==t)
246 static List local intsIntersect(as,bs) /* calculate intersection of lists */
247 List as, bs; { /* of integers (as sets) */
248 List ts = NIL; /* destructively modifies as */
250 if (intIsMember(intOf(hd(as)),bs)) {
261 static List local genvarAllAss(as) /* calculate generic vars that are */
262 List as; { /* in every type in assumptions as */
263 List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
264 for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
265 vs = intsIntersect(vs,genvarTyvar(intOf(defType(snd(hd(as)))),NIL));
269 static List local genvarAnyAss(as) /* calculate generic vars that are */
270 List as; { /* in any type in assumptions as */
271 List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
272 for (as=tl(as); nonNull(as); as=tl(as))
273 vs = genvarTyvar(intOf(defType(snd(hd(as)))),vs);
277 static Int local newVarsBind(v) /* make new assump for pattern var */
279 Int beta = newTyvars(1);
280 addVarAssump(v,mkInt(beta));
282 printf("variable, assume ");
284 printf(" :: _%d\n",beta);
289 static Void local newDefnBind(v,type) /* make new assump for defn var */
290 Cell v; /* and set type if given (nonNull) */
292 Int beta = newTyvars(1);
293 Cell ta = mkInt(beta);
295 if (nonNull(type) && isPolyType(type))
296 ta = pair(POLYREC,pair(ta,type));
297 hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
299 printf("definition, assume ");
301 printf(" :: _%d\n",beta);
303 bindTv(beta,typeIs,typeOff); /* Bind beta to new type skeleton */
306 /* --------------------------------------------------------------------------
307 * Bound and skolemized type variables:
308 * ------------------------------------------------------------------------*/
310 static List pendingBtyvs = NIL;
312 static Void local enterPendingBtyvs() {
314 pendingBtyvs = cons(NIL,pendingBtyvs);
317 static Void local leavePendingBtyvs() {
318 List pts = hd(pendingBtyvs);
319 pendingBtyvs = tl(pendingBtyvs);
320 for (; nonNull(pts); pts=tl(pts)) {
321 Int line = intOf(fst(hd(pts)));
322 List vs = snd(hd(pts));
325 for (; nonNull(vs); vs=tl(vs)) {
326 Cell v = fst(hd(vs));
327 Cell t = copyTyvar(intOf(snd(hd(vs))));
329 ERRMSG(line) "Type annotation uses variable " ETHEN ERREXPR(v);
330 ERRTEXT " where a more specific type " ETHEN ERRTYPE(t);
331 ERRTEXT " was inferred"
334 else if (offsetOf(t)!=i) {
335 List us = snd(hd(pts));
338 internal("leavePendingBtyvs");
341 ERRMSG(line) "Type annotation uses distinct variables " ETHEN
342 ERREXPR(v); ERRTEXT " and " ETHEN ERREXPR(fst(hd(us)));
343 ERRTEXT " where a single variable was inferred"
353 static Cell local patBtyvs(p) /* Strip bound type vars from pat */
355 if (whatIs(p)==BIGLAM) {
356 List bts = hd(btyvars) = fst(snd(p));
357 for (p=snd(snd(p)); nonNull(bts); bts=tl(bts)) {
358 Int beta = newTyvars(1);
359 tyvar(beta)->kind = snd(hd(bts));
360 snd(hd(bts)) = mkInt(beta);
363 skolVars = cons(NIL,skolVars);
367 static Void local doneBtyvs(l)
369 if (nonNull(hd(btyvars))) { /* Save bound tyvars */
370 hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
374 if (nonNull(hd(skolVars))) { /* Check that Skolem vars do not */
375 List vs; /* escape their scope */
377 clearMarks(); /* Look for occurences in the */
378 markType(typeIs,typeOff); /* result type */
380 for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
381 Int vn = intOf(fst(hd(vs)));
382 if (tyvar(vn)->offs == FIXED_TYVAR) {
383 Cell tv = copyTyvar(vn);
384 Type t = copyType(typeIs,typeOff);
385 ERRMSG(l) "Existentially quantified variable in result type"
387 ERRTEXT "\nvariable : " ETHEN ERRTYPE(tv);
388 ERRTEXT "\nfrom pattern : " ETHEN ERREXPR(snd(hd(vs)));
389 ERRTEXT "\nresult type : " ETHEN ERRTYPE(t);
395 markBtyvs(); /* Now check assumptions */
396 mapProc(markAssumList,defnBounds);
397 mapProc(markAssumList,varsBounds);
399 for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
400 Int vn = intOf(fst(hd(vs)));
401 if (tyvar(vn)->offs == FIXED_TYVAR) {
402 ERRMSG(l) "Existentially quantified variable from pattern "
403 ETHEN ERREXPR(snd(hd(vs)));
404 ERRTEXT " appears in enclosing assumptions" /*so there!*/
409 skolVars = tl(skolVars);
412 /* --------------------------------------------------------------------------
414 * ------------------------------------------------------------------------*/
418 /* --------------------------------------------------------------------------
420 * ------------------------------------------------------------------------*/
422 static Void local typeError(l,e,in,wh,t,o)
423 Int l; /* line number near type error */
424 String wh; /* place in which error occurs */
425 Cell e; /* source of error */
426 Cell in; /* context if any (NIL if not) */
427 Type t; /* should be of type (t,o) */
428 Int o; { /* type inferred is (typeIs,typeOff) */
430 clearMarks(); /* types printed here are monotypes */
431 /* use marking to give sensible names*/
433 { List vs = genericVars;
434 for (; nonNull(vs); vs=tl(vs)) {
435 Int v = intOf(hd(vs));
436 printf("%c :: ", ('a'+tyvar(v)->offs));
437 printKind(stdout,tyvar(v)->kind);
443 reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
446 static Void local reportTypeError(l,e,in,wh,inft,expt)
447 Int l; /* Error printing part of typeError*/
451 ERRMSG(l) "Type error in %s", wh ETHEN
453 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(in);
455 ERRTEXT "\n*** Term : " ETHEN ERREXPR(e);
456 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(inft);
457 ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(expt);
459 ERRTEXT "\n*** Because : %s", unifyFails ETHEN
465 #define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
466 typeError(l,e,in,where,t,o);
467 #define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
468 #define inferType(t,o) typeIs=t; typeOff=o
470 static Void local cantEstablish(line,wh,e,t,ps)
471 Int line; /* Complain when declared preds */
472 String wh; /* are not sufficient to discharge */
473 Cell e; /* or defer the inferred context. */
476 ERRMSG(line) "Cannot justify constraints in %s", wh ETHEN
477 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
478 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(t);
479 ERRTEXT "\n*** Given context : " ETHEN ERRCONTEXT(ps);
480 ERRTEXT "\n*** Constraints : " ETHEN ERRCONTEXT(copyPreds(preds));
485 static Void local tooGeneral(l,e,dt,it) /* explicit type sig. too general */
489 ERRMSG(l) "Inferred type is not general enough" ETHEN
490 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
491 ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(dt);
492 ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(it);
497 /* --------------------------------------------------------------------------
498 * Typing of expressions:
499 * ------------------------------------------------------------------------*/
501 #define EXPRESSION 0 /* type checking expression */
502 #define NEW_PATTERN 1 /* pattern, introducing new vars */
503 #define OLD_PATTERN 2 /* pattern, involving bound vars */
504 static int tcMode = EXPRESSION;
507 static Cell local mytypeExpr Args((Int,Cell));
508 static Cell local typeExpr(l,e)
511 static int number = 0;
513 int mynumber = number++;
514 printf("%d) to check: ",mynumber);
517 retv = mytypeExpr(l,e);
518 printf("%d) result: ",mynumber);
519 printType(stdout,debugType(typeIs,typeOff));
523 static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
525 static Cell local typeExpr(l,e) /* Determine type of expr/pattern */
529 static String cond = "conditional";
530 static String list = "list";
531 static String discr = "case discriminant";
532 static String aspat = "as (@) pattern";
533 static String typeSig = "type annotation";
534 static String lambda = "lambda expression";
538 /* The following cases can occur in either pattern or expr. mode */
543 case VARIDCELL : return typeAp(l,e);
545 case TUPLE : typeTuple(e);
548 #if OVERLOADED_CONSTANTS
549 case BIGCELL : { Int alpha = newTyvars(1);
550 inferType(aVar,alpha);
551 return ap2(nameFromInteger,
552 assumeEvid(predNum,alpha),
556 case INTCELL : { Int alpha = newTyvars(1);
557 inferType(aVar,alpha);
558 return ap2(nameFromInt,
559 assumeEvid(predNum,alpha),
563 case FLOATCELL : { Int alpha = newTyvars(1);
564 inferType(aVar,alpha);
565 return ap2(nameFromDouble,
566 assumeEvid(predFractional,alpha),
570 case BIGCELL : inferType(typeBignum,0);
572 case INTCELL : inferType(typeInt,0);
574 case FLOATCELL : inferType(typeFloat,0);
578 case STRCELL : inferType(typeString,0);
581 case CHARCELL : inferType(typeChar,0);
584 case CONFLDS : typeConFlds(l,e);
587 case ESIGN : snd(snd(e)) = localizeBtyvs(snd(snd(e)));
588 return typeExpected(l,typeSig,
589 fst(snd(e)),snd(snd(e)),
593 case EXT : { Int beta = newTyvars(2);
594 Cell pi = ap(e,aVar);
595 Type t = fn(mkOffset(0),
596 fn(ap(typeRec,mkOffset(1)),
597 ap(typeRec,ap2(e,mkOffset(0),
599 tyvar(beta+1)->kind = ROW;
601 return ap(e,assumeEvid(pi,beta+1));
605 /* The following cases can only occur in expr mode */
607 case UPDFLDS : typeUpdFlds(l,e);
610 case COND : { Int beta = newTyvars(1);
611 check(l,fst3(snd(e)),e,cond,typeBool,0);
612 check(l,snd3(snd(e)),e,cond,aVar,beta);
613 check(l,thd3(snd(e)),e,cond,aVar,beta);
618 case LETREC : enterBindings();
619 mapProc(typeBindings,fst(snd(e)));
620 snd(snd(e)) = typeExpr(l,snd(snd(e)));
624 case FINLIST : { Int beta = newTyvars(1);
626 for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
627 check(l,hd(xs),e,list,aVar,beta);
629 inferType(listof,beta);
633 case DOCOMP : typeDo(l,e);
636 case COMP : { Int beta = newTyvars(1);
637 typeComp(l,listof,snd(e),snd(snd(e)));
638 bindTv(beta,typeIs,typeOff);
639 inferType(listof,beta);
643 case CASE : { Int beta = newTyvars(2); /* discr result */
644 check(l,fst(snd(e)),NIL,discr,aVar,beta);
645 map2Proc(typeCase,l,beta,snd(snd(e)));
650 case LAMBDA : { Int beta = newTyvars(1);
652 typeAlt(lambda,e,snd(e),aVar,beta,1);
659 case RECSEL : { Int beta = newTyvars(2);
660 Cell pi = ap(snd(e),aVar);
661 Type t = fn(ap(typeRec,
662 ap2(snd(e),mkOffset(0),
664 tyvar(beta+1)->kind = ROW;
666 return ap(e,assumeEvid(pi,beta+1));
670 /* The remaining cases can only occur in pattern mode: */
672 case WILDCARD : inferType(aVar,newTyvars(1));
675 case ASPAT : { Int beta = newTyvars(1);
676 snd(snd(e)) = typeExpr(l,snd(snd(e)));
677 bindTv(beta,typeIs,typeOff);
678 check(l,fst(snd(e)),e,aspat,aVar,beta);
683 case LAZYPAT : snd(e) = typeExpr(l,snd(e));
687 case ADDPAT : { Int alpha = newTyvars(1);
688 inferType(typeVarToVar,alpha);
689 return ap(e,assumeEvid(predIntegral,alpha));
693 default : internal("typeExpr");
699 /* --------------------------------------------------------------------------
700 * Typing rules for particular special forms:
701 * ------------------------------------------------------------------------*/
703 static Cell local typeAp(l,e) /* Type check application, which */
704 Int l; /* may be headed with a variable */
705 Cell e; { /* requires polymorphism, qualified*/
706 static String app = "application"; /* types, and possible rank2 args. */
714 case NAME : typeIs = name(h).type;
718 case VARIDCELL : if (tcMode==NEW_PATTERN) {
719 inferType(aVar,newVarsBind(e));
722 Cell v = findAssum(textOf(h));
725 typeIs = (tcMode==OLD_PATTERN)
730 h = findName(textOf(h));
733 typeIs = name(h).type;
738 default : h = typeExpr(l,h);
745 instantiate(typeIs); /* Deal with polymorphism ... */
746 if (nonNull(predsAre)) { /* ... and with qualified types. */
748 for (; nonNull(predsAre); predsAre=tl(predsAre))
749 evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
750 if (!isName(h) || !isCfun(h))
751 h = applyToArgs(h,rev(evs));
754 if (whatIs(typeIs)==EXIST) { /* Deal with existential arguments */
755 Int n = intOf(fst(snd(typeIs)));
756 typeIs = snd(snd(typeIs));
757 if (!isCfun(h) || n>typeFree)
759 else if (tcMode!=EXPRESSION) {
760 Int alpha = typeOff + typeFree;
762 bindTv(alpha-n,SKOLEM,0);
763 hd(skolVars) = cons(pair(mkInt(alpha-n),e),hd(skolVars));
768 if (whatIs(typeIs)==RANK2) { /* Deal with rank 2 arguments */
771 Int nr2 = intOf(fst(snd(typeIs)));
772 Type body = snd(snd(typeIs));
776 if (n<nr2) { /* Must have enough arguments */
777 ERRMSG(l) "Use of " ETHEN ERREXPR(h);
779 ERRTEXT " in " ETHEN ERREXPR(e);
781 ERRTEXT " requires at least %d argument%s\n",
782 nr2, (nr2==1 ? "" : "s")
786 for (i=nr2; i<n; ++i) /* Find rank two arguments */
789 for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
790 Type expect = dropRank1(arg(fun(body)),alpha,m);
791 if (isPolyType(expect)) {
792 if (tcMode==EXPRESSION) /* poly/qual type in expr */
793 hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
794 else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
795 if (!isVar(hd(as))) {
796 ERRMSG(l) "Argument " ETHEN ERREXPR(arg(as));
797 ERRTEXT " in pattern " ETHEN ERREXPR(e);
798 ERRTEXT " where a variable is required\n"
801 if (tcMode==NEW_PATTERN) { /* Pattern match */
804 addVarAssump(dummyVar,mkInt(alpha+i));
807 addVarAssump(hd(as),expect);
809 else { /* Pattern binding */
810 Text t = textOf(hd(as));
811 Cell a = findInAssumList(t,hd(defnBounds));
815 if (nonNull(predsAre)) {
816 ERRMSG(l) "Cannot use pattern binding for " ETHEN
818 ERRTEXT " as a component with a qualified type\n"
821 shouldBe(l,hd(as),e,app,aVar,intOf(defType(snd(a))));
825 else { /* Not a poly/qual type */
826 check(l,hd(as),e,app,expect,alpha);
828 h = ap(h,hd(as)); /* Save checked argument */
830 inferType(body,alpha);
834 if (n>0) { /* Deal with remaining args */
835 Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
836 shouldBe(l,h,e,app,aVar,beta);
837 for (i=n; i>0; --i) { /* check e_i::t_i for each i */
838 check(l,arg(a),e,app,aVar,beta+2*i-1);
842 tyvarType(beta+2*n); /* Inferred type is r_n+1 */
845 if (isNull(p)) /* Replace head with translation */
853 static Cell local typeExpected(l,wh,e,reqd,alpha,n,addEvid)
854 Int l; /* Type check expression e in wh */
855 String wh; /* at line l, expecting type reqd, */
856 Cell e; /* and treating vars alpha through */
857 Type reqd; /* (alpha+n-1) as fixed. */
860 Bool addEvid; { /* TRUE => add \ev -> ... */
861 List savePreds = preds;
872 ps = makePredAss(predsAre,o);
875 check(l,e,NIL,wh,t,o);
878 mapProc(markAssumList,defnBounds);
879 mapProc(markAssumList,varsBounds);
880 mapProc(markPred,savePreds);
886 savePreds = elimPredsUsing(ps,savePreds);
887 if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
888 savePreds = elimPredsUsing(ps,savePreds);
889 if (nonNull(preds)) {
890 Type ty = copyType(t,o);
891 List qs = copyPreds(ps);
892 cantEstablish(l,wh,e,ty,qs);
897 if (copyTyvar(o+i)!=mkOffset(i)) {
898 List qs = copyPreds(ps);
899 Type it = copyType(t,o);
900 tooGeneral(l,e,reqd,generalize(qs,it));
904 e = qualifyExpr(l,ps,e);
908 preds = revOnto(ps,savePreds);
914 static Void local typeAlt(wh,e,a,t,o,m) /* Type check abstraction (Alt) */
915 String wh; /* a = ( [p1, ..., pn], rhs ) */
922 List ps = fst(a) = patBtyvs(fst(a));
924 Int l = rhsLine(snd(a));
930 if (whatIs(t)==RANK2) {
931 if (n<(nr2=intOf(fst(snd(t))))) {
932 ERRMSG(l) "Definition requires at least %d parameters on lhs",
939 while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
940 Type ta = arg(fun(t));
941 if (isPolyType(ta)) {
942 if (hd(ps)!=WILDCARD) {
943 if (!isVar(hd(ps))) {
944 ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
945 ERRTEXT " used where a variable or wildcard is required\n"
951 addVarAssump(dummyVar,mkInt(o+i));
954 addVarAssump(hd(ps),ta);
958 hd(ps) = typeFreshPat(l,hd(ps));
959 shouldBe(l,hd(ps),NIL,wh,ta,o);
968 snd(a) = typeRhs(snd(a));
970 Int beta = funcType(n);
973 hd(ps) = typeFreshPat(l,hd(ps));
974 bindTv(beta+2*i+1,typeIs,typeOff);
977 snd(a) = typeRhs(snd(a));
978 bindTv(beta+2*n,typeIs,typeOff);
982 if (!unify(typeIs,typeOff,t,o)) {
985 req = liftRank2(origt,o,m);
986 liftRank2Args(as,o,m);
987 got = ap(RANK2,pair(mkInt(nr2),revOnto(as,copyType(typeIs,typeOff))));
988 reportTypeError(l,e,NIL,wh,got,req);
995 static Int local funcType(n) /*return skeleton for function type*/
996 Int n; { /*with n arguments, taking the form*/
997 Int beta = newTyvars(2*n+1); /* r1 t1 r2 t2 ... rn tn rn+1 */
998 Int i; /* with r_i := t_i -> r_i+1 */
1000 bindTv(beta+2*i,arrow,beta+2*i+1);
1004 static Void local typeCase(l,beta,c) /* type check case: pat -> rhs */
1005 Int l; /* (case given by c == (pat,rhs)) */
1006 Int beta; /* need: pat :: (var,beta) */
1007 Cell c; { /* rhs :: (var,beta+1) */
1008 static String casePat = "case pattern";
1009 static String caseExpr = "case expression";
1013 fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
1014 shouldBe(l,fst(c),NIL,casePat,aVar,beta);
1015 snd(c) = typeRhs(snd(c));
1016 shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,aVar,beta+1);
1022 static Void local typeComp(l,m,e,qs) /* type check comprehension */
1024 Type m; /* monad (mkOffset(0)) */
1027 static String boolQual = "boolean qualifier";
1028 static String genQual = "generator";
1030 if (isNull(qs)) /* no qualifiers left */
1031 fst(e) = typeExpr(l,fst(e));
1035 switch (whatIs(q)) {
1036 case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
1037 typeComp(l,m,e,qs1);
1040 case QWHERE : enterBindings();
1041 mapProc(typeBindings,snd(q));
1042 typeComp(l,m,e,qs1);
1046 case FROMQUAL : { Int beta = newTyvars(1);
1048 check(l,snd(snd(q)),NIL,genQual,m,beta);
1050 = typeFreshPat(l,patBtyvs(fst(snd(q))));
1051 shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
1052 typeComp(l,m,e,qs1);
1058 case DOQUAL : check(l,snd(q),NIL,genQual,m,newTyvars(1));
1059 typeComp(l,m,e,qs1);
1065 static Void local typeDo(l,e) /* type check do-notation */
1068 static String finGen = "final generator";
1069 Int alpha = newTyvars(1);
1070 Int beta = newTyvars(1);
1071 Cell mon = ap(mkInt(beta),aVar);
1072 Cell m = assumeEvid(predMonad,beta);
1073 tyvar(beta)->kind = starToStar;
1075 typeComp(l,mon,snd(e),snd(snd(e)));
1076 shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
1077 snd(e) = pair(pair(m,compZero(snd(snd(e)),beta)),snd(e));
1080 static Cell local compZero(qs,beta) /* return evidence for Monad0 beta */
1081 List qs; /* if needed for qualifiers qs */
1083 for (; nonNull(qs); qs=tl(qs))
1084 switch (whatIs(hd(qs))) {
1085 case FROMQUAL : if (failFree(fst(snd(hd(qs)))))
1087 /* intentional fall-thru */
1088 case BOOLQUAL : return assumeEvid(predMonad0,beta);
1093 static Void local typeConFlds(l,e) /* Type check a construction */
1096 static String conExpr = "value construction";
1097 Name c = fst(snd(e));
1098 List fs = snd(snd(e));
1104 instantiate(name(c).type);
1105 for (; nonNull(predsAre); predsAre=tl(predsAre))
1106 assumeEvid(hd(predsAre),typeOff);
1107 if (whatIs(typeIs)==RANK2)
1108 typeIs = snd(snd(typeIs));
1113 for (; nonNull(fs); fs=tl(fs)) {
1115 for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
1117 t = dropRank1(arg(fun(t)),to,tf);
1119 snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
1121 check(l,snd(hd(fs)),e,conExpr,t,to);
1124 for (i=name(c).arity; i>0; i--)
1129 static Void local typeUpdFlds(line,e) /* Type check an update */
1130 Int line; /* (Written in what might seem a */
1131 Cell e; { /* bizarre manner for the benefit */
1132 static String update = "update"; /* of as yet unreleased extensions)*/
1133 List cs = snd3(snd(e)); /* List of constructors */
1134 List fs = thd3(snd(e)); /* List of field specifications */
1135 List ts = NIL; /* List of types for fields */
1137 Int alpha = newTyvars(2+n);
1141 /* Calculate type and translation for each expr in the field list */
1142 for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1143 snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
1144 bindTv(i,typeIs,typeOff);
1148 mapProc(markAssumList,defnBounds);
1149 mapProc(markAssumList,varsBounds);
1150 mapProc(markPred,preds);
1153 for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1155 ts = cons(generalize(NIL,copyTyvar(i)),ts);
1159 /* Type check expression to be updated */
1160 fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
1161 bindTv(alpha,typeIs,typeOff);
1163 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */
1165 List ta = replicate(name(c).arity,NIL);
1169 tcMode = NEW_PATTERN; /* Domain type */
1170 instantiate(name(c).type);
1171 tcMode = EXPRESSION;
1174 for (; nonNull(predsAre); predsAre=tl(predsAre))
1175 assumeEvid(hd(predsAre),typeOff);
1177 if (whatIs(typeIs)==RANK2) {
1178 ERRMSG(line) "Sorry, record update syntax cannot currently be used for datatypes with polymorphic components"
1182 instantiate(name(c).type); /* Range type */
1185 for (; nonNull(predsAre); predsAre=tl(predsAre))
1186 assumeEvid(hd(predsAre),typeOff);
1188 for (fs1=fs, i=1; nonNull(fs1); fs1=tl(fs1), i++) {
1189 Int n = sfunPos(fst(hd(fs1)),c);
1196 for (; nonNull(ta); ta=tl(ta)) { /* For each cfun arg */
1197 if (nonNull(hd(ta))) { /* Field to updated? */
1198 Int n = intOf(hd(ta));
1201 for (; n-- > 1; f=tl(f), t=tl(t))
1206 shouldBe(line,snd(f),e,update,arg(fun(tr)),or);
1207 } /* Unmentioned component */
1208 else if (!unify(arg(fun(td)),od,arg(fun(tr)),or))
1209 internal("typeUpdFlds");
1215 inferType(td,od); /* Check domain type */
1216 shouldBe(line,fst3(snd(e)),e,update,aVar,alpha);
1217 inferType(tr,or); /* Check range type */
1218 shouldBe(line,e,NIL,update,aVar,alpha+1);
1220 /* (typeIs,typeOff) still carry the result type when we exit the loop */
1223 static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
1224 Int l; /* fresh type variables to each var */
1225 Cell p; { /* bound in the pattern */
1226 tcMode = NEW_PATTERN;
1228 tcMode = EXPRESSION;
1232 /* --------------------------------------------------------------------------
1233 * Type check group of bindings:
1234 * ------------------------------------------------------------------------*/
1236 static Void local typeBindings(bs) /* type check a binding group */
1238 Bool usesPatBindings = FALSE; /* TRUE => pattern binding in bs */
1239 Bool usesUntypedVar = FALSE; /* TRUE => var bind w/o type decl */
1242 /* The following loop is used to determine whether the monomorphism */
1243 /* restriction should be applied. It could be written marginally more */
1244 /* efficiently by using breaks, but clarity is more important here ... */
1246 for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) { /* Analyse binding group */
1249 usesPatBindings = TRUE;
1250 else if (isNull(fst(hd(snd(snd(b))))) /* no arguments */
1251 && whatIs(fst(snd(b)))==IMPDEPS) /* implicitly typed*/
1252 usesUntypedVar = TRUE;
1255 if (usesPatBindings || usesUntypedVar)
1260 mapProc(removeTypeSigs,bs); /* Remove binding type info */
1261 hd(varsBounds) = revOnto(hd(defnBounds), /* transfer completed assmps*/
1262 hd(varsBounds)); /* out of defnBounds */
1263 hd(defnBounds) = NIL;
1267 static Void local removeTypeSigs(b) /* Remove type info from a binding */
1269 snd(b) = snd(snd(b));
1272 /* --------------------------------------------------------------------------
1273 * Type check a restricted binding group:
1274 * ------------------------------------------------------------------------*/
1276 static Void local monorestrict(bs) /* Type restricted binding group */
1278 List savePreds = preds;
1279 Int line = isVar(fst(hd(bs))) ? rhsLine(snd(hd(snd(snd(hd(bs))))))
1280 : rhsLine(snd(snd(snd(hd(bs)))));
1281 hd(defnBounds) = NIL;
1282 hd(depends) = NODEPENDS; /* No need for dependents here */
1284 preds = NIL; /* Type check the bindings */
1285 mapProc(restrictedBindAss,bs);
1286 mapProc(typeBind,bs);
1289 preds = revOnto(preds,savePreds);
1291 clearMarks(); /* Mark fixed variables */
1292 mapProc(markAssumList,tl(defnBounds));
1293 mapProc(markAssumList,tl(varsBounds));
1294 mapProc(markPred,preds);
1297 if (isNull(tl(defnBounds))) { /* Top-level may need defaulting */
1299 if (nonNull(preds) && resolveDefs(genvarAnyAss(hd(defnBounds))))
1304 if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
1307 if (nonNull(preds)) { /* Look for unresolved overloading */
1308 Cell v = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
1309 Cell ass = findInAssumList(textOf(v),hd(varsBounds));
1310 preds = scSimplify(preds);
1312 ERRMSG(line) "Unresolved top-level overloading" ETHEN
1313 ERRTEXT "\n*** Binding : %s", textToStr(textOf(v))
1316 ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(snd(ass));
1318 ERRTEXT "\n*** Outstanding context : " ETHEN
1319 ERRCONTEXT(copyPreds(preds));
1325 map1Proc(genBind,NIL,bs); /* Generalize types of def'd vars */
1328 static Void local restrictedBindAss(b) /* Make assums for vars in binding */
1329 Cell b; { /* gp with restricted overloading */
1331 if (isVar(fst(b))) { /* function-binding? */
1332 Cell t = fst(snd(b));
1333 if (whatIs(t)==IMPDEPS) /* Discard implicitly typed deps */
1334 fst(snd(b)) = t = NIL; /* in a restricted binding group. */
1335 fst(snd(b)) = localizeBtyvs(t);
1336 restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
1338 else { /* pattern-binding? */
1340 List ts = fst(snd(b));
1341 Int line = rhsLine(snd(snd(snd(b))));
1343 for (; nonNull(vs); vs=tl(vs))
1345 restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
1349 restrictedAss(line,hd(vs),NIL);
1353 static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
1354 Int l; /* is t (if nonNull) in restricted */
1355 Cell v; /* binding group */
1358 if (nonNull(predsAre)) {
1359 ERRMSG(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
1361 ERRTEXT " not permitted in restricted binding"
1366 /* --------------------------------------------------------------------------
1367 * Unrestricted binding group:
1368 * ------------------------------------------------------------------------*/
1370 static Void local unrestricted(bs) /* Type unrestricted binding group */
1372 List savePreds = preds;
1373 List imps = NIL; /* Implicitly typed bindings */
1374 List exps = NIL; /* Explicitly typed bindings */
1377 /* ----------------------------------------------------------------------
1378 * STEP 1: Separate implicitly typed bindings from explicitly typed
1379 * bindings and do a dependency analyis, where f depends on g iff f
1380 * is implicitly typed and involves a call to g.
1381 * --------------------------------------------------------------------*/
1383 for (; nonNull(bs); bs=tl(bs)) {
1385 if (whatIs(fst(snd(b)))==IMPDEPS)
1386 imps = cons(b,imps); /* N.B. New lists are built to */
1387 else /* avoid breaking the original */
1388 exps = cons(b,exps); /* list structure for bs. */
1391 for (bs=imps; nonNull(bs); bs=tl(bs)) {
1392 Cell b = hd(bs); /* Restrict implicitly typed dep */
1393 List ds = snd(fst(snd(b))); /* lists to bindings in imps */
1395 while (nonNull(ds)) {
1397 if (cellIsMember(hd(ds),imps)) {
1405 imps = itbscc(imps); /* Dependency analysis on imps */
1406 for (bs=imps; nonNull(bs); bs=tl(bs))
1407 for (bs1=hd(bs); nonNull(bs1); bs1=tl(bs1))
1408 fst(snd(hd(bs1))) = NIL; /* reset imps type fields */
1410 #ifdef DEBUG_DEPENDS
1411 printf("Binding group:");
1412 for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
1414 for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
1415 printf(" %s",textToStr(textOf(fst(hd(bs)))));
1418 if (nonNull(exps)) {
1420 for (bs=exps; nonNull(bs); bs=tl(bs))
1421 printf(" %s",textToStr(textOf(fst(hd(bs)))));
1427 /* ----------------------------------------------------------------------
1428 * STEP 2: Add type assumptions about any explicitly typed variable.
1429 * --------------------------------------------------------------------*/
1431 for (bs=exps; nonNull(bs); bs=tl(bs)) {
1432 fst(snd(hd(bs))) = localizeBtyvs(fst(snd(hd(bs))));
1433 hd(varsBounds) = cons(pair(fst(hd(bs)),fst(snd(hd(bs)))),
1437 /* ----------------------------------------------------------------------
1438 * STEP 3: Calculate types for each group of implicitly typed bindings.
1439 * --------------------------------------------------------------------*/
1441 for (; nonNull(imps); imps=tl(imps)) {
1442 Cell b = hd(hd(imps));
1443 Int line = isVar(fst(b)) ? rhsLine(snd(hd(snd(snd(b)))))
1444 : rhsLine(snd(snd(snd(b))));
1445 hd(defnBounds) = NIL;
1447 for (bs1=hd(imps); nonNull(bs1); bs1=tl(bs1))
1448 newDefnBind(fst(hd(bs1)),NIL);
1451 mapProc(typeBind,hd(imps));
1454 mapProc(markAssumList,tl(defnBounds));
1455 mapProc(markAssumList,tl(varsBounds));
1456 mapProc(markPred,savePreds);
1460 savePreds = elimOuterPreds(savePreds);
1461 if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds))))
1462 savePreds = elimOuterPreds(savePreds);
1464 map1Proc(genBind,preds,hd(imps));
1465 if (nonNull(preds)) {
1466 map1Proc(addEvidParams,preds,hd(depends));
1467 map1Proc(qualifyBinding,preds,hd(imps));
1470 hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
1473 /* ----------------------------------------------------------------------
1474 * STEP 4: Now infer a type for each explicitly typed variable and
1475 * check for compatibility with the declared type.
1476 * --------------------------------------------------------------------*/
1478 for (; nonNull(exps); exps=tl(exps)) {
1479 static String extbind = "explicitly typed binding";
1481 List alts = snd(snd(b));
1482 Int line = rhsLine(snd(hd(alts)));
1488 hd(defnBounds) = NIL;
1489 hd(depends) = NODEPENDS;
1492 instantiate(fst(snd(b)));
1495 t = dropRank2(typeIs,o,m);
1496 ps = makePredAss(predsAre,o);
1498 enterPendingBtyvs();
1499 for (; nonNull(alts); alts=tl(alts))
1500 typeAlt(extbind,fst(b),hd(alts),t,o,m);
1501 leavePendingBtyvs();
1503 if (nonNull(ps)) /* Add dict params, if necessary */
1504 qualifyBinding(ps,b);
1507 mapProc(markAssumList,tl(defnBounds));
1508 mapProc(markAssumList,tl(varsBounds));
1509 mapProc(markPred,savePreds);
1512 savePreds = elimPredsUsing(ps,savePreds);
1513 if (nonNull(preds)) {
1517 vs = cons(mkInt(o+i),vs);
1518 if (resolveDefs(vs))
1519 savePreds = elimPredsUsing(ps,savePreds);
1520 if (nonNull(preds)) {
1523 if (nonNull(preds) && resolveDefs(vs))
1524 savePreds = elimPredsUsing(ps,savePreds);
1528 resetGenerics(); /* Make sure we're general enough */
1530 t = generalize(ps,liftRank2(t,o,m));
1531 if (!sameSchemes(t,fst(snd(b))))
1532 tooGeneral(line,fst(b),fst(snd(b)),t);
1534 if (nonNull(preds)) /* Check context was strong enough */
1535 cantEstablish(line,extbind,fst(b),t,ps);
1538 preds = savePreds; /* Restore predicates */
1539 hd(defnBounds) = NIL;
1542 #define SCC itbscc /* scc for implicitly typed binds */
1543 #define LOWLINK itblowlink
1544 #define DEPENDS(t) fst(snd(t))
1545 #define SETDEPENDS(c,v) fst(snd(c))=v
1552 static Void local addEvidParams(qs,v) /* overwrite VARID/OPCELL v with */
1553 List qs; /* application of variable to evid. */
1554 Cell v; { /* parameters given by qs */
1559 internal("addEvidParams");
1561 for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
1562 nv = ap(nv,thd3(hd(qs)));
1564 snd(v) = thd3(hd(qs));
1568 /* --------------------------------------------------------------------------
1569 * Type check bodies of class and instance declarations:
1570 * ------------------------------------------------------------------------*/
1572 static Void local typeClassDefn(c) /* Type check implementations of */
1573 Class c; { /* defaults for class c */
1575 /* ----------------------------------------------------------------------
1576 * Generate code for default dictionary builder function:
1578 * class.C sc1 ... scn d = let v1 ... = ...
1580 * in Make.C sc1 ... scn v1 ... vm
1582 * where sci are superclass dictionary parameters, vj are implementations
1583 * for member functions, either taken from defaults, or using "error" to
1584 * produce a suitable error message. (Additional line number values must
1585 * be added at appropriate places but, for clarity, these are not shown
1587 * --------------------------------------------------------------------*/
1589 Int beta = newKindedVars(cclass(c).kinds);
1590 List params = makePredAss(cclass(c).supers,beta);
1591 Cell body = cclass(c).dcon;
1593 List mems = cclass(c).members;
1594 List defs = cclass(c).defaults;
1595 List dsels = cclass(c).dsels;
1596 Cell d = inventDictVar();
1599 Cell l = mkInt(cclass(c).line);
1602 for (ps=params; nonNull(ps); ps=tl(ps)) {
1603 Cell v = thd3(hd(ps));
1605 pat = ap(pat,inventVar());
1606 args = cons(v,args);
1608 args = revOnto(args,singleton(d));
1609 params = appendOnto(params,
1610 singleton(triple(cclass(c).head,mkInt(beta),d)));
1612 for (; nonNull(mems); mems=tl(mems)) {
1613 Cell v = inventVar(); /* Pick a name for component */
1616 if (nonNull(defs)) { /* Look for default implementation */
1621 if (isNull(imp)) { /* Generate undefined member msg */
1622 static String header = "Undefined member: ";
1623 String name = textToStr(name(hd(mems)).text);
1624 char msg[FILENAME_MAX+1];
1628 for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
1630 for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
1634 imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
1635 mkStr(findText(msg)))))));
1637 else { /* Use default implementation */
1639 typeMember("default member binding",
1647 locs = cons(imp,locs);
1653 body = ap(LETREC,pair(singleton(locs),body));
1654 name(cclass(c).dbuild).defn
1655 = singleton(pair(args,body));
1656 genDefns = cons(cclass(c).dbuild,genDefns);
1657 cclass(c).defaults = NIL;
1659 /* ----------------------------------------------------------------------
1660 * Generate code for superclass and member function selectors:
1661 * --------------------------------------------------------------------*/
1663 args = getArgs(pat);
1664 pat = singleton(pat);
1665 for (; nonNull(dsels); dsels=tl(dsels)) {
1666 name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
1668 genDefns = cons(hd(dsels),genDefns);
1670 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
1671 name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
1674 genDefns = cons(hd(mems),genDefns);
1678 static Void local typeInstDefn(in) /* Type check implementations of */
1679 Inst in; { /* member functions for instance in*/
1681 /* ----------------------------------------------------------------------
1682 * Generate code for instance specific dictionary builder function:
1684 * inst.maker d1 ... dn = let sc1 = ...
1689 * d = f (class.C sc1 ... scm d)
1690 * omit if the / f (Make.C sc1' ... scm' v1' ... vk')
1691 * instance decl { = let vj ... = ...
1692 * has no imps \ in Make.C sc1' ... scm' ... vj ...
1695 * where sci are superclass dictionaries, d and f are new names, vj
1696 * is a newly generated name corresponding to the implementation of a
1697 * member function. (Additional line number values must be added at
1698 * appropriate places but, for clarity, these are not shown above.)
1699 * --------------------------------------------------------------------*/
1701 Int alpha = newKindedVars(cclass(inst(in).c).kinds);
1702 List supers = makePredAss(cclass(inst(in).c).supers,alpha);
1703 Int beta = newKindedVars(inst(in).kinds);
1704 List params = makePredAss(inst(in).specifics,beta);
1705 Cell d = inventDictVar();
1706 List evids = cons(triple(inst(in).head,mkInt(beta),d),
1707 appendOnto(dupList(params),supers));
1709 List imps = inst(in).implements;
1710 Cell l = mkInt(inst(in).line);
1711 Cell dictDef = cclass(inst(in).c).dbuild;
1716 if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
1717 internal("typeInstDefn");
1719 for (ps=params; nonNull(ps); ps=tl(ps)) /* Build arglist */
1720 args = cons(thd3(hd(ps)),args);
1723 for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
1725 Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)));
1727 ev = inEntail(evids,fst3(pi),intOf(snd3(pi)));
1730 ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
1731 ERRTEXT "\n*** Instance : " ETHEN
1732 ERRPRED(copyPred(inst(in).head,beta));
1733 ERRTEXT "\n*** Context supplied : " ETHEN
1734 ERRCONTEXT(copyPreds(params));
1735 ERRTEXT "\n*** Required superclass : " ETHEN
1736 ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
1740 locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
1741 dictDef = ap(dictDef,thd3(pi));
1743 dictDef = ap(dictDef,d);
1745 if (isNull(imps)) /* No implementations */
1746 locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
1747 else { /* Implementations supplied*/
1748 List mems = cclass(inst(in).c).members;
1749 Cell f = inventVar();
1750 Cell pat = cclass(inst(in).c).dcon;
1754 locs = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
1757 for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc */
1758 Cell v = inventVar();
1763 for (; nonNull(mems); mems=tl(mems)) { /* For each member: */
1764 Cell v = inventVar();
1767 if (nonNull(imps)) { /* Look for implementation */
1772 if (isNull(imp)) { /* If none, f will copy */
1773 pat = ap(pat,v); /* its argument unchanged */
1776 else { /* Otherwise, add the impl */
1777 pat = ap(pat,WILDCARD); /* to f as a local defn */
1779 typeMember("instance member binding",
1785 locs1 = cons(pair(v,snd(imp)),locs1);
1789 if (nonNull(locs1)) /* Build the body of f */
1790 res = ap(LETREC,pair(singleton(locs1),res));
1791 pat = singleton(pat); /* And the arglist for f */
1792 locs = cons(pair(f,singleton(pair(pat,res))),locs);
1796 name(inst(in).builder).defn /* Register builder imp */
1797 = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
1798 genDefns = cons(inst(in).builder,genDefns);
1801 static Void local typeMember(wh,mem,alts,evids,head,beta)
1802 String wh; /* Type check alternatives alts of */
1803 Name mem; /* member mem for inst type head */
1804 Cell alts; /* at offset beta using predicate */
1805 List evids; /* assignment evids */
1808 Int line = rhsLine(snd(hd(alts)));
1817 printf("Type check member: ");
1818 printExp(stdout,mem);
1820 printType(stdout,name(mem).type);
1821 printf("\nfor the instance: ");
1822 printPred(stdout,head);
1826 instantiate(name(mem).type); /* Find required type */
1829 t = dropRank2(typeIs,o,m);
1830 ps = makePredAss(predsAre,o);
1831 if (!unifyPred(hd(predsAre),typeOff,head,beta))
1832 internal("typeMember1");
1835 rt = generalize(qs,liftRank2(t,o,m));
1838 printf("Required type is: ");
1839 printType(stdout,rt);
1843 hd(defnBounds) = NIL; /* Type check each alternative */
1844 hd(depends) = NODEPENDS;
1845 enterPendingBtyvs();
1846 for (preds=NIL; nonNull(alts); alts=tl(alts)) {
1847 typeAlt(wh,mem,hd(alts),t,o,m);
1848 qualify(tl(ps),hd(alts)); /* Add any extra dict params */
1850 leavePendingBtyvs();
1852 evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
1855 qs = elimPredsUsing(evids,NIL);
1856 if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
1857 qs = elimPredsUsing(evids,qs);
1860 "Implementation of %s requires extra context",
1861 textToStr(name(mem).text) ETHEN
1862 ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(rt);
1863 ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
1868 resetGenerics(); /* Make sure we're general enough */
1870 t = generalize(ps,liftRank2(t,o,m));
1872 printf("Inferred type is: ");
1873 printType(stdout,t);
1876 if (!sameSchemes(t,rt))
1877 tooGeneral(line,mem,rt,t);
1879 cantEstablish(line,wh,mem,t,ps);
1882 /* --------------------------------------------------------------------------
1883 * Type check bodies of bindings:
1884 * ------------------------------------------------------------------------*/
1886 static Void local typeBind(b) /* Type check binding */
1888 if (isVar(fst(b))) { /* function binding */
1889 Cell ass = findTopBinding(fst(b));
1893 internal("typeBind");
1895 beta = intOf(defType(snd(ass)));
1896 enterPendingBtyvs();
1897 map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
1898 leavePendingBtyvs();
1900 else { /* pattern binding */
1901 static String lhsPat = "lhs pattern";
1902 static String rhs = "right hand side";
1903 Int beta = newTyvars(1);
1904 Pair pb = snd(snd(b));
1905 Int l = rhsLine(snd(pb));
1907 tcMode = OLD_PATTERN;
1908 check(l,fst(pb),NIL,lhsPat,aVar,beta);
1909 tcMode = EXPRESSION;
1910 snd(pb) = typeRhs(snd(pb));
1911 shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
1915 static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding */
1919 static String valDef = "function binding";
1920 typeAlt(valDef,v,a,aVar,beta,0);
1923 static Cell local typeRhs(e) /* check type of rhs of definition */
1925 switch (whatIs(e)) {
1926 case GUARDED : { Int beta = newTyvars(1);
1927 map1Proc(guardedType,beta,snd(e));
1932 case LETREC : enterBindings();
1933 mapProc(typeBindings,fst(snd(e)));
1934 snd(snd(e)) = typeRhs(snd(snd(e)));
1938 default : snd(e) = typeExpr(intOf(fst(e)),snd(e));
1944 static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
1945 Int beta; /* should have gd :: Bool, */
1946 Cell gded; { /* ex :: (var,beta) */
1947 static String guarded = "guarded expression";
1948 static String guard = "guard";
1949 Int line = intOf(fst(gded));
1952 check(line,fst(gded),NIL,guard,typeBool,0);
1953 check(line,snd(gded),NIL,guarded,aVar,beta);
1956 Cell rhsExpr(rhs) /* find first expression on a rhs */
1958 switch (whatIs(rhs)) {
1959 case GUARDED : return snd(snd(hd(snd(rhs))));
1960 case LETREC : return rhsExpr(snd(snd(rhs)));
1961 default : return snd(rhs);
1965 Int rhsLine(rhs) /* find line number associated with */
1966 Cell rhs; { /* a right hand side */
1967 switch (whatIs(rhs)) {
1968 case GUARDED : return intOf(fst(hd(snd(rhs))));
1969 case LETREC : return rhsLine(snd(snd(rhs)));
1970 default : return intOf(fst(rhs));
1974 /* --------------------------------------------------------------------------
1975 * Calculate generalization of types and compare with declared type schemes:
1976 * ------------------------------------------------------------------------*/
1978 static Void local genBind(ps,b) /* Generalize the type of each var */
1979 List ps; /* defined in binding b, qualifying*/
1980 Cell b; { /* each with the predicates in ps. */
1982 Cell t = fst(snd(b));
1985 genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
1987 Int line = rhsLine(snd(snd(snd(b))));
1988 for (; nonNull(v); v=tl(v)) {
1994 genAss(line,ps,hd(v),ty);
1999 static Void local genAss(l,ps,v,dt) /* Calculate inferred type of v and*/
2000 Int l; /* compare with declared type, dt, */
2001 List ps; /* if given & check for ambiguity. */
2004 Cell ass = findTopBinding(v);
2009 snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
2014 printType(stdout,snd(ass));
2019 static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred */
2020 Int l; /* type (t,o) with context ps */
2021 Cell v; /* against declared type dt for v. */
2026 Type bt = NIL; /* Body of inferred type */
2027 Type it = NIL; /* Full inferred type */
2029 resetGenerics(); /* Calculate Haskell typing */
2032 it = generalize(ps,bt);
2034 if (nonNull(dt)) { /* If a declared type was given, */
2035 instantiate(dt); /* check body for match. */
2036 if (!equalTypes(typeIs,bt))
2037 tooGeneral(l,v,dt,it);
2039 else if (nonNull(ps)) /* Otherwise test for ambiguity in */
2040 if (isAmbiguous(it)) /* inferred type. */
2041 ambigError(l,"inferred type",v,it);
2046 static Type local generalize(qs,t) /* calculate generalization of t */
2047 List qs; /* having already marked fixed vars*/
2048 Type t; { /* with qualifying preds qs */
2050 t = ap(QUAL,pair(qs,t));
2051 if (nonNull(genericVars)) {
2053 List vs = genericVars;
2054 for (; nonNull(vs); vs=tl(vs)) {
2055 Tyvar *tyv = tyvar(intOf(hd(vs)));
2056 Kind ka = tyv->kind;
2059 t = mkPolyType(k,t);
2061 printf("Generalized type: ");
2062 printType(stdout,t);
2064 printKind(stdout,k);
2071 static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
2074 et: if (whatIs(t1)!=whatIs(t2))
2077 switch (whatIs(t1)) {
2083 case TUPLE : return t1==t2;
2085 case INTCELL : return intOf(t1)!=intOf(t2);
2087 case AP : if (equalTypes(fun(t1),fun(t2))) {
2094 default : internal("equalTypes");
2097 return TRUE;/*NOTREACHED*/
2100 /* --------------------------------------------------------------------------
2101 * Entry points to type checker:
2102 * ------------------------------------------------------------------------*/
2104 Type typeCheckExp(useDefs) /* Type check top level expression */
2105 Bool useDefs; { /* using defaults if reqd */
2111 emptySubstitution();
2113 inputExpr = typeExpr(0,inputExpr);
2119 preds = scSimplify(preds);
2120 if (useDefs && nonNull(preds)) {
2123 if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
2127 ctxt = copyPreds(preds);
2128 type = generalize(ctxt,copyType(type,beta));
2129 inputExpr = qualifyExpr(0,preds,inputExpr);
2131 emptySubstitution();
2135 Void typeCheckDefns() { /* Type check top level bindings */
2136 Target t = length(selDefns) + length(valDefns) +
2137 length(instDefns) + length(classDefns);
2142 emptySubstitution();
2144 setGoal("Type checking",t);
2146 for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
2147 mapOver(typeSel,hd(gs));
2150 for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
2151 typeDefnGroup(hd(gs));
2155 for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
2156 emptySubstitution();
2157 typeClassDefn(hd(gs));
2160 for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
2161 emptySubstitution();
2162 typeInstDefn(hd(gs));
2167 emptySubstitution();
2171 static Void local typeDefnGroup(bs) /* type check group of value defns */
2172 List bs; { /* (one top level scc) */
2175 emptySubstitution();
2176 hd(defnBounds) = NIL;
2179 typeBindings(bs); /* find types for vars in bindings */
2181 if (nonNull(preds)) {
2182 Cell v = fst(hd(hd(varsBounds)));
2183 Name n = findName(textOf(v));
2184 Int l = nonNull(n) ? name(n).line : 0;
2185 preds = scSimplify(preds);
2186 ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
2187 ERRCONTEXT(copyPreds(preds));
2188 ERRTEXT " required for definition of " ETHEN
2189 ERREXPR(nonNull(n)?n:v);
2194 for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
2195 Cell a = hd(as); /* add infered types to environment*/
2196 Name n = findName(textOf(fst(a)));
2198 internal("typeDefnGroup");
2199 name(n).type = snd(a);
2201 hd(varsBounds) = NIL;
2204 static Pair local typeSel(s) /* Calculate a suitable type for a */
2205 Name s; { /* particular selector, s. */
2206 List cns = name(s).defn;
2207 Int line = name(s).line;
2208 Type dom = NIL; /* Inferred domain */
2209 Type rng = NIL; /* Inferred range */
2210 Cell nv = inventVar();
2216 printf("Selector %s, cns=",textToStr(name(s).text));
2217 printExp(stdout,cns);
2221 emptySubstitution();
2224 for (; nonNull(cns); cns=tl(cns)) {
2225 Name c = fst(hd(cns));
2226 Int n = intOf(snd(hd(cns)));
2227 Int a = name(c).arity;
2234 instantiate(name(c).type); /* Instantiate constructor type */
2237 for (; nonNull(predsAre); predsAre=tl(predsAre))
2238 assumeEvid(hd(predsAre),o1);
2240 if (whatIs(typeIs)==RANK2) /* Skip rank2 annotation, if any */
2241 typeIs = snd(snd(typeIs));
2242 for (; --n>0; a--) { /* Get range */
2243 pat = ap(pat,WILDCARD);
2244 typeIs = arg(typeIs);
2246 rng1 = dropRank1(arg(fun(typeIs)),o1,m1);
2248 typeIs = arg(typeIs);
2249 while (--a>0) { /* And then look for domain */
2250 pat = ap(pat,WILDCARD);
2251 typeIs = arg(typeIs);
2255 if (isNull(dom)) { /* Save first domain type and then */
2256 dom = dom1; /* unify with subsequent domains to*/
2257 o = o1; /* match up preds and range types */
2260 else if (!unify(dom1,o1,dom,o))
2261 internal("typeSel1");
2263 if (isNull(rng)) /* Compare component types */
2265 else if (!sameSchemes(rng1,rng)) {
2267 rng = liftRank1(rng,o,m);
2268 rng1 = liftRank1(rng1,o1,m1);
2269 ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
2270 textToStr(name(s).text) ETHEN
2271 ERRTEXT "\n*** Field type : " ETHEN ERRTYPE(rng1);
2272 ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(rng);
2276 alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
2280 if (isNull(dom) || isNull(rng)) /* Should have been initialized by */
2281 internal("typeSel2"); /* now, assuming length cns >= 1. */
2283 clearMarks(); /* No fixed variables here */
2284 preds = scSimplify(preds); /* Simplify context */
2285 dom = copyType(dom,o); /* Calculate domain type */
2287 rng = copyType(typeIs,typeOff);
2288 if (nonNull(predsAre)) {
2289 List ps = makePredAss(predsAre,typeOff);
2291 for (; nonNull(alts1); alts1=tl(alts1)) {
2294 for (; nonNull(qs); qs=tl(qs))
2295 body = ap(body,thd3(hd(qs)));
2296 snd(snd(hd(alts1))) = body;
2298 preds = appendOnto(preds,ps);
2300 name(s).type = generalize(copyPreds(preds),fn(dom,rng));
2301 name(s).arity = 1 + length(preds);
2302 map1Proc(qualify,preds,alts);
2305 printf("Inferred arity = %d, type = ",name(s).arity);
2306 printType(stdout,name(s).type);
2310 return pair(s,alts);
2313 /* --------------------------------------------------------------------------
2314 * Local function prototypes:
2315 * ------------------------------------------------------------------------*/
2317 static Type local basicType Args((Char));
2319 /* --------------------------------------------------------------------------
2321 * ------------------------------------------------------------------------*/
2323 List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
2324 Type t; /* to list vs */
2326 switch (whatIs(t)) {
2327 case AP : return offsetTyvarsIn(fun(t),
2328 offsetTyvarsIn(arg(t),vs));
2330 case OFFSET : if (cellIsMember(t,vs)) {
2335 case QUAL : return offsetTyvarsIn(snd(t),vs);
2337 case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
2338 /* slightly inaccurate, but won't matter here */
2341 case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
2343 default : return vs;
2347 static Type stateVar = NIL;
2348 static Type alphaVar = NIL;
2349 static Type betaVar = NIL;
2350 static Int nextVar = 0;
2352 static Void clearTyVars( void )
2360 static Type mkStateVar( void )
2362 if (isNull(stateVar)) {
2363 stateVar = mkOffset(nextVar++);
2368 static Type mkAlphaVar( void )
2370 if (isNull(alphaVar)) {
2371 alphaVar = mkOffset(nextVar++);
2376 static Type mkBetaVar( void )
2378 if (isNull(betaVar)) {
2379 betaVar = mkOffset(nextVar++);
2384 static Type local basicType(k)
2391 #ifdef PROVIDE_INT64
2395 #ifdef PROVIDE_INTEGER
2411 #ifdef PROVIDE_ARRAY
2412 case ARR_REP: return ap(typePrimArray,mkAlphaVar());
2413 case BARR_REP: return typePrimByteArray;
2414 case REF_REP: return ap2(typeRef,mkStateVar(),mkAlphaVar());
2415 case MUTARR_REP: return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
2416 case MUTBARR_REP: return ap(typePrimMutableByteArray,mkStateVar());
2418 #ifdef PROVIDE_STABLE
2420 return ap(typeStable,mkAlphaVar());
2424 return ap(typeWeak,mkAlphaVar());
2426 return ap(typeIO,typeUnit);
2428 #ifdef PROVIDE_FOREIGN
2432 #ifdef PROVIDE_CONCURRENT
2434 return typeThreadId;
2436 return ap(typeMVar,mkAlphaVar());
2441 return fn(typeException,mkAlphaVar());
2443 return typeException;
2445 return mkAlphaVar(); /* polymorphic */
2447 return mkBetaVar(); /* polymorphic */
2449 printf("Kind: '%c'\n",k);
2450 internal("basicType");
2454 /* Generate type of primop based on list of arg types and result types:
2456 * eg primType "II" "II" = Int -> Int -> (Int,Int)
2459 Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
2463 List tvars = NIL; /* for polymorphic types */
2468 /* build result types */
2469 for(; *r_kinds; ++r_kinds) {
2470 rs = cons(basicType(*r_kinds),rs);
2472 /* Construct tuple of results */
2473 if (length(rs) == 0) {
2475 } else if (length(rs) == 1) {
2478 r = mkTuple(length(rs));
2479 for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
2483 /* Construct list of arguments */
2484 for(; *a_kinds; ++a_kinds) {
2485 as = cons(basicType(*a_kinds),as);
2487 /* Apply any monad magic */
2488 if (monad == MONAD_IO) {
2490 } else if (monad == MONAD_ST) {
2491 r = ap2(typeST,mkStateVar(),r);
2493 /* glue it all together */
2494 for(; nonNull(as); as=tl(as)) {
2497 tvars = offsetTyvarsIn(r,NIL);
2498 if (nonNull(tvars)) {
2499 assert(length(tvars) == nextVar);
2500 r = mkPolyType(simpleKind(length(tvars)),r);
2504 printType(stdout,r); printf("\n");
2510 /* forall a1 .. am. TC a1 ... am -> Int */
2511 Type conToTagType(t)
2516 for (i=0; i<tycon(t).arity; ++i) {
2517 Offset tv = mkOffset(i);
2519 tvars = cons(tv,tvars);
2521 ty = fn(ty,typeInt);
2522 if (nonNull(tvars)) {
2523 ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2528 /* forall a1 .. am. Int -> TC a1 ... am */
2529 Type tagToConType(t)
2534 for (i=0; i<tycon(t).arity; ++i) {
2535 Offset tv = mkOffset(i);
2537 tvars = cons(tv,tvars);
2539 ty = fn(typeInt,ty);
2540 if (nonNull(tvars)) {
2541 ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2546 /* --------------------------------------------------------------------------
2547 * Type checker control:
2548 * ------------------------------------------------------------------------*/
2552 arrow = fn(aVar,mkOffset(1));
2553 listof = ap(typeList,aVar);
2554 predNum = ap(classNum,aVar);
2555 predFractional = ap(classFractional,aVar);
2556 predIntegral = ap(classIntegral,aVar);
2557 predMonad = ap(classMonad,aVar);
2558 predMonad0 = ap(classMonad0,aVar);
2561 Void typeChecker(what)
2564 case RESET : tcMode = EXPRESSION;
2570 case MARK : mark(defnBounds);
2583 mark(predFractional);
2590 case INSTALL : typeChecker(RESET);
2591 dummyVar = inventVar();
2592 starToStar = simpleKind(1);
2593 typeVarToVar = fn(aVar,aVar);
2598 /*-------------------------------------------------------------------------*/