2 /* --------------------------------------------------------------------------
3 * This is the Hugs type checker
5 * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
6 * Yale Haskell Group, and the Oregon Graduate Institute of Science and
7 * Technology, 1994-1999, All rights reserved. It is distributed as
8 * free software under the license in the file "License", which is
9 * included in the distribution.
11 * $RCSfile: type.c,v $
13 * $Date: 2000/02/03 13:55:22 $
14 * ------------------------------------------------------------------------*/
23 #include "Assembler.h" /* for AsmCTypes */
25 /*#define DEBUG_TYPES*/
26 /*#define DEBUG_KINDS*/
27 /*#define DEBUG_DEFAULTS*/
28 /*#define DEBUG_SELS*/
29 /*#define DEBUG_DEPENDS*/
30 /*#define DEBUG_DERIVING*/
31 /*#define DEBUG_CODE*/
33 Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
34 /* types produce error */
37 /* --------------------------------------------------------------------------
38 * Local function prototypes:
39 * ------------------------------------------------------------------------*/
41 static Void local emptyAssumption Args((Void));
42 static Void local enterBindings Args((Void));
43 static Void local leaveBindings Args((Void));
44 static Int local defType Args((Cell));
45 static Type local useType Args((Cell));
46 static Void local markAssumList Args((List));
47 static Cell local findAssum Args((Text));
48 static Pair local findInAssumList Args((Text,List));
49 static List local intsIntersect Args((List,List));
50 static List local genvarAllAss Args((List));
51 static List local genvarAnyAss Args((List));
52 static Int local newVarsBind Args((Cell));
53 static Void local newDefnBind Args((Cell,Type));
55 static Void local enterPendingBtyvs Args((Void));
56 static Void local leavePendingBtyvs Args((Void));
57 static Cell local patBtyvs Args((Cell));
58 static Void local doneBtyvs Args((Int));
59 static Void local enterSkolVars Args((Void));
60 static Void local leaveSkolVars Args((Int,Type,Int,Int));
62 static Void local typeError Args((Int,Cell,Cell,String,Type,Int));
63 static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type));
64 static Void local cantEstablish Args((Int,String,Cell,Type,List));
65 static Void local tooGeneral Args((Int,Cell,Type,Type));
67 static Cell local typeExpr Args((Int,Cell));
69 static Cell local typeAp Args((Int,Cell));
70 static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
71 static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int));
72 static Int local funcType Args((Int));
73 static Void local typeCase Args((Int,Int,Cell));
74 static Void local typeComp Args((Int,Type,Cell,List));
75 static Cell local typeMonadComp Args((Int,Cell));
76 static Void local typeDo Args((Int,Cell));
77 static Void local typeConFlds Args((Int,Cell));
78 static Void local typeUpdFlds Args((Int,Cell));
80 static Cell local typeWith Args((Int,Cell));
82 static Cell local typeFreshPat Args((Int,Cell));
84 static Void local typeBindings Args((List));
85 static Void local removeTypeSigs Args((Cell));
87 static Void local monorestrict Args((List));
88 static Void local restrictedBindAss Args((Cell));
89 static Void local restrictedAss Args((Int,Cell,Type));
91 static Void local unrestricted Args((List));
92 static List local itbscc Args((List));
93 static Void local addEvidParams Args((List,Cell));
95 static Void local typeClassDefn Args((Class));
96 static Void local typeInstDefn Args((Inst));
97 static Void local typeMember Args((String,Name,Cell,List,Cell,Int));
99 static Void local typeBind Args((Cell));
100 static Void local typeDefAlt Args((Int,Cell,Pair));
101 static Cell local typeRhs Args((Cell));
102 static Void local guardedType Args((Int,Cell));
104 static Void local genBind Args((List,Cell));
105 static Void local genAss Args((Int,List,Cell,Type));
106 static Type local genTest Args((Int,Cell,List,Type,Type,Int));
107 static Type local generalize Args((List,Type));
108 static Bool local equalTypes Args((Type,Type));
110 static Void local typeDefnGroup Args((List));
111 static Pair local typeSel Args((Name));
115 /* --------------------------------------------------------------------------
118 * A basic typing statement is a pair (Var,Type) and an assumption contains
119 * an ordered list of basic typing statements in which the type for a given
120 * variable is given by the most recently added assumption about that var.
122 * In practice, the assumption set is split between a pair of lists, one
123 * holding assumptions for vars defined in bindings, the other for vars
124 * defined in patterns/binding parameters etc. The reason for this
125 * separation is that vars defined in bindings may be overloaded (with the
126 * overloading being unknown until the whole binding is typed), whereas the
127 * vars defined in patterns have no overloading. A form of dependency
128 * analysis (at least as far as calculating dependents within the same group
129 * of value bindings) is required to implement this. Where it is known that
130 * no overloaded values are defined in a binding (i.e., when the `dreaded
131 * monomorphism restriction' strikes), the list used to record dependents
132 * is flagged with a NODEPENDS tag to avoid gathering dependents at that
135 * To interleave between vars for bindings and vars for patterns, we use
136 * a list of lists of typing statements for each. These lists are always
137 * the same length. The implementation here is very similar to that of the
138 * dependency analysis used in the static analysis component of this system.
140 * To deal with polymorphic recursion, variables defined in bindings can be
141 * assigned types of the form (POLYREC,(def,use)), where def is a type
142 * variable for the type of the defining occurence, and use is a type
143 * scheme for (recursive) calls/uses of the variable.
144 * ------------------------------------------------------------------------*/
146 static List defnBounds; /*::[[(Var,Type)]] possibly ovrlded*/
147 static List varsBounds; /*::[[(Var,Type)]] not overloaded */
148 static List depends; /*::[?[Var]] dependents/NODEPENDS */
149 static List skolVars; /*::[[Var]] skolem vars */
150 static List localEvs; /*::[[(Pred,offset,ev)]] */
151 static List savedPs; /*::[[(Pred,offset,ev)]] */
152 static Cell dummyVar; /* Used to put extra tvars into ass*/
154 #define saveVarsAss() List saveAssump = hd(varsBounds)
155 #define restoreVarsAss() hd(varsBounds) = saveAssump
156 #define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),hd(varsBounds))
157 #define findTopBinding(v) findInAssumList(textOf(v),hd(defnBounds))
159 static Void local emptyAssumption() { /* set empty type assumption */
168 static Void local enterBindings() { /* Add new level to assumption sets */
169 defnBounds = cons(NIL,defnBounds);
170 varsBounds = cons(NIL,varsBounds);
171 depends = cons(NIL,depends);
174 static Void local leaveBindings() { /* Drop one level of assumptions */
175 defnBounds = tl(defnBounds);
176 varsBounds = tl(varsBounds);
177 depends = tl(depends);
180 static Int local defType(a) /* Return type for defining occ. */
181 Cell a; { /* of a var from assumption pair */
182 return (isPair(a) && fst(a)==POLYREC) ? fst(snd(a)) : a;
185 static Type local useType(a) /* Return type for use of a var */
186 Cell a; { /* defined in an assumption */
187 return (isPair(a) && fst(a)==POLYREC) ? snd(snd(a)) : a;
190 static Void local markAssumList(as) /* Mark all types in assumption set*/
191 List as; { /* :: [(Var, Type)] */
192 for (; nonNull(as); as=tl(as)) { /* No need to mark generic types; */
193 Type t = defType(snd(hd(as))); /* the only free variables in those*/
194 if (!isPolyType(t)) /* must have been free earlier too */
199 static Cell local findAssum(t) /* Find most recent assumption about*/
200 Text t; { /* variable named t, if any */
201 List defnBounds1 = defnBounds; /* return translated variable, with */
202 List varsBounds1 = varsBounds; /* type in typeIs */
203 List depends1 = depends;
205 while (nonNull(defnBounds1)) {
206 Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
212 ass = findInAssumList(t,hd(defnBounds1)); /* search defnBounds */
217 if (hd(depends1)!=NODEPENDS && /* save dependent? */
218 isNull(v=varIsMember(t,hd(depends1))))
219 /* N.B. make new copy of variable and store this on list of*/
220 /* dependents, and in the assumption so that all uses of */
221 /* the variable will be at the same node, if we need to */
222 /* overwrite the call of a function with a translation... */
223 hd(depends1) = cons(v=mkVar(t),hd(depends1));
228 defnBounds1 = tl(defnBounds1); /* look in next level*/
229 varsBounds1 = tl(varsBounds1); /* of assumption set */
230 depends1 = tl(depends1);
235 static Pair local findInAssumList(t,as)/* Search for assumption for var */
236 Text t; /* named t in list of assumptions as*/
238 for (; nonNull(as); as=tl(as))
239 if (textOf(fst(hd(as)))==t)
244 static List local intsIntersect(as,bs) /* calculate intersection of lists */
245 List as, bs; { /* of integers (as sets) */
246 List ts = NIL; /* destructively modifies as */
248 if (intIsMember(intOf(hd(as)),bs)) {
259 static List local genvarAllAss(as) /* calculate generic vars that are */
260 List as; { /* in every type in assumptions as */
261 List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
262 for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
263 vs = intsIntersect(vs,genvarTyvar(intOf(defType(snd(hd(as)))),NIL));
267 static List local genvarAnyAss(as) /* calculate generic vars that are */
268 List as; { /* in any type in assumptions as */
269 List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
270 for (as=tl(as); nonNull(as); as=tl(as))
271 vs = genvarTyvar(intOf(defType(snd(hd(as)))),vs);
275 static Int local newVarsBind(v) /* make new assump for pattern var */
277 Int beta = newTyvars(1);
278 addVarAssump(v,mkInt(beta));
280 Printf("variable, assume ");
282 Printf(" :: _%d\n",beta);
287 static Void local newDefnBind(v,type) /* make new assump for defn var */
288 Cell v; /* and set type if given (nonNull) */
290 Int beta = newTyvars(1);
291 Cell ta = mkInt(beta);
293 if (nonNull(type) && isPolyType(type))
294 ta = pair(POLYREC,pair(ta,type));
295 hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
297 Printf("definition, assume ");
299 Printf(" :: _%d\n",beta);
301 bindTv(beta,typeIs,typeOff); /* Bind beta to new type skeleton */
304 /* --------------------------------------------------------------------------
306 * ------------------------------------------------------------------------*/
310 /* --------------------------------------------------------------------------
311 * Bound and skolemized type variables:
312 * ------------------------------------------------------------------------*/
314 static List pendingBtyvs = NIL;
316 static Void local enterPendingBtyvs() {
318 pendingBtyvs = cons(NIL,pendingBtyvs);
321 static Void local leavePendingBtyvs() {
322 List pts = hd(pendingBtyvs);
323 pendingBtyvs = tl(pendingBtyvs);
324 for (; nonNull(pts); pts=tl(pts)) {
325 Int line = intOf(fst(hd(pts)));
326 List vs = snd(hd(pts));
329 for (; nonNull(vs); vs=tl(vs)) {
330 Cell v = fst(hd(vs));
331 Cell t = copyTyvar(intOf(snd(hd(vs))));
333 ERRMSG(line) "Type annotation uses variable " ETHEN ERREXPR(v);
334 ERRTEXT " where a more specific type " ETHEN ERRTYPE(t);
335 ERRTEXT " was inferred"
338 else if (offsetOf(t)!=i) {
339 List us = snd(hd(pts));
342 internal("leavePendingBtyvs");
345 ERRMSG(line) "Type annotation uses distinct variables " ETHEN
346 ERREXPR(v); ERRTEXT " and " ETHEN ERREXPR(fst(hd(us)));
347 ERRTEXT " where a single variable was inferred"
357 static Cell local patBtyvs(p) /* Strip bound type vars from pat */
359 if (whatIs(p)==BIGLAM) {
360 List bts = hd(btyvars) = fst(snd(p));
361 for (p=snd(snd(p)); nonNull(bts); bts=tl(bts)) {
362 Int beta = newTyvars(1);
363 tyvar(beta)->kind = snd(hd(bts));
364 snd(hd(bts)) = mkInt(beta);
370 static Void local doneBtyvs(l)
372 if (nonNull(hd(btyvars))) { /* Save bound tyvars */
373 hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
378 static Void local enterSkolVars() {
379 skolVars = cons(NIL,skolVars);
380 localEvs = cons(NIL,localEvs);
381 savedPs = cons(preds,savedPs);
385 static Void local leaveSkolVars(l,t,o,m)
390 if (nonNull(hd(localEvs))) { /* Check for local predicates */
391 List sks = hd(skolVars);
394 internal("leaveSkolVars");
396 markAllVars(); /* Mark all variables in current */
397 do { /* substitution, then unmark sks. */
398 tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
400 } while (nonNull(sks));
402 sps = elimPredsUsing(hd(localEvs),sps);
403 preds = revOnto(preds,sps);
406 if (nonNull(hd(skolVars))) { /* Check that Skolem vars do not */
407 List vs; /* escape their scope */
410 clearMarks(); /* Look for occurences in the */
411 for (; i<m; i++) /* inferred type */
415 for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
416 Int vn = intOf(fst(hd(vs)));
417 if (tyvar(vn)->offs == FIXED_TYVAR) {
418 Cell tv = copyTyvar(vn);
419 Type ty = liftRank2(t,o,m);
420 ERRMSG(l) "Existentially quantified variable in inferred type"
422 ERRTEXT "\n*** Variable : " ETHEN ERRTYPE(tv);
423 ERRTEXT "\n*** From pattern : " ETHEN ERREXPR(snd(hd(vs)));
424 ERRTEXT "\n*** Result type : " ETHEN ERRTYPE(ty);
430 markBtyvs(); /* Now check assumptions */
431 mapProc(markAssumList,defnBounds);
432 mapProc(markAssumList,varsBounds);
434 for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
435 Int vn = intOf(fst(hd(vs)));
436 if (tyvar(vn)->offs == FIXED_TYVAR) {
438 "Existentially quantified variable escapes from pattern "
439 ETHEN ERREXPR(snd(hd(vs)));
445 localEvs = tl(localEvs);
446 skolVars = tl(skolVars);
447 preds = revOnto(preds,hd(savedPs));
448 savedPs = tl(savedPs);
451 /* --------------------------------------------------------------------------
453 * ------------------------------------------------------------------------*/
455 static Void local typeError(l,e,in,wh,t,o)
456 Int l; /* line number near type error */
457 String wh; /* place in which error occurs */
458 Cell e; /* source of error */
459 Cell in; /* context if any (NIL if not) */
460 Type t; /* should be of type (t,o) */
461 Int o; { /* type inferred is (typeIs,typeOff) */
463 clearMarks(); /* types printed here are monotypes */
464 /* use marking to give sensible names*/
466 { List vs = genericVars;
467 for (; nonNull(vs); vs=tl(vs)) {
468 Int v = intOf(hd(vs));
469 Printf("%c :: ", ('a'+tyvar(v)->offs));
470 printKind(stdout,tyvar(v)->kind);
476 reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
479 static Void local reportTypeError(l,e,in,wh,inft,expt)
480 Int l; /* Error printing part of typeError*/
484 ERRMSG(l) "Type error in %s", wh ETHEN
486 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(in);
488 ERRTEXT "\n*** Term : " ETHEN ERREXPR(e);
489 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(inft);
490 ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(expt);
492 ERRTEXT "\n*** Because : %s", unifyFails ETHEN
498 #define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
499 typeError(l,e,in,where,t,o);
500 #define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
501 #define inferType(t,o) typeIs=t; typeOff=o
503 #define spTypeExpr(l,e) svPreds = preds; preds = NIL; e = typeExpr(l,e); preds = revOnto(preds,svPreds);
504 #define spCheck(l,e,in,where,t,o) svPreds = preds; preds = NIL; check(l,e,in,where,t,o); preds = revOnto(preds,svPreds);
506 #define spTypeExpr(l,e) e = typeExpr(l,e);
507 #define spCheck(l,e,in,where,t,o) check(l,e,in,where,t,o);
510 static Void local cantEstablish(line,wh,e,t,ps)
511 Int line; /* Complain when declared preds */
512 String wh; /* are not sufficient to discharge */
513 Cell e; /* or defer the inferred context. */
516 ERRMSG(line) "Cannot justify constraints in %s", wh ETHEN
517 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
518 ERRTEXT "\n*** Type : " ETHEN ERRTYPE(t);
519 ERRTEXT "\n*** Given context : " ETHEN ERRCONTEXT(ps);
520 ERRTEXT "\n*** Constraints : " ETHEN ERRCONTEXT(copyPreds(preds));
525 static Void local tooGeneral(l,e,dt,it) /* explicit type sig. too general */
529 ERRMSG(l) "Inferred type is not general enough" ETHEN
530 ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
531 ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(dt);
532 ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(it);
537 /* --------------------------------------------------------------------------
538 * Typing of expressions:
539 * ------------------------------------------------------------------------*/
541 #define EXPRESSION 0 /* type checking expression */
542 #define NEW_PATTERN 1 /* pattern, introducing new vars */
543 #define OLD_PATTERN 2 /* pattern, involving bound vars */
544 static int tcMode = EXPRESSION;
547 static Cell local mytypeExpr Args((Int,Cell));
548 static Cell local typeExpr(l,e)
551 static int number = 0;
553 int mynumber = number++;
556 Printf("%d) to check: ",mynumber);
559 retv = mytypeExpr(l,e);
560 Printf("%d) result: ",mynumber);
561 printType(stdout,debugType(typeIs,typeOff));
562 Printf("\n%d) preds: ",mynumber);
563 printContext(stdout,debugContext(preds));
567 static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
569 static Cell local typeExpr(l,e) /* Determine type of expr/pattern */
573 static String cond = "conditional";
574 static String list = "list";
575 static String discr = "case discriminant";
576 static String aspat = "as (@) pattern";
577 static String typeSig = "type annotation";
578 static String lambda = "lambda expression";
585 /* The following cases can occur in either pattern or expr. mode */
596 case TUPLE : typeTuple(e);
599 case BIGCELL : { Int alpha = newTyvars(1);
600 inferType(aVar,alpha);
601 return ap(ap(nameFromInteger,
602 assumeEvid(predNum,alpha)),
606 case INTCELL : { Int alpha = newTyvars(1);
607 inferType(aVar,alpha);
608 return ap(ap(nameFromInt,
609 assumeEvid(predNum,alpha)),
613 case FLOATCELL : { Int alpha = newTyvars(1);
614 inferType(aVar,alpha);
615 return ap(ap(nameFromDouble,
616 assumeEvid(predFractional,alpha)),
620 case STRCELL : inferType(typeString,0);
623 case CHARCELL : inferType(typeChar,0);
626 case CONFLDS : typeConFlds(l,e);
629 case ESIGN : snd(snd(e)) = localizeBtyvs(snd(snd(e)));
630 return typeExpected(l,typeSig,
631 fst(snd(e)),snd(snd(e)),
635 case EXT : { Int beta = newTyvars(2);
636 Cell pi = ap(e,aVar);
639 ap(typeRec,ap(ap(e,aVar),bVar))));
640 tyvar(beta+1)->kind = ROW;
642 return ap(e,assumeEvid(pi,beta+1));
646 /* The following cases can only occur in expr mode */
648 case UPDFLDS : typeUpdFlds(l,e);
652 case WITHEXP : return typeWith(l,e);
655 case COND : { Int beta = newTyvars(1);
656 check(l,fst3(snd(e)),e,cond,typeBool,0);
657 spCheck(l,snd3(snd(e)),e,cond,aVar,beta);
658 spCheck(l,thd3(snd(e)),e,cond,aVar,beta);
663 case LETREC : enterBindings();
665 mapProc(typeBindings,fst(snd(e)));
666 spTypeExpr(l,snd(snd(e)));
668 leaveSkolVars(l,typeIs,typeOff,0);
671 case FINLIST : { Int beta = newTyvars(1);
673 for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
674 spCheck(l,hd(xs),e,list,aVar,beta);
676 inferType(listof,beta);
680 case DOCOMP : typeDo(l,e);
683 case COMP : return typeMonadComp(l,e);
685 case CASE : { Int beta = newTyvars(2); /* discr result */
686 check(l,fst(snd(e)),NIL,discr,aVar,beta);
687 map2Proc(typeCase,l,beta,snd(snd(e)));
692 case LAMBDA : { Int beta = newTyvars(1);
694 typeAlt(lambda,e,snd(e),aVar,beta,1);
701 case RECSEL : { Int beta = newTyvars(2);
702 Cell pi = ap(snd(e),aVar);
703 Type t = fn(ap(typeRec,
706 tyvar(beta+1)->kind = ROW;
708 return ap(e,assumeEvid(pi,beta+1));
712 /* The remaining cases can only occur in pattern mode: */
714 case WILDCARD : inferType(aVar,newTyvars(1));
717 case ASPAT : { Int beta = newTyvars(1);
718 snd(snd(e)) = typeExpr(l,snd(snd(e)));
719 bindTv(beta,typeIs,typeOff);
720 check(l,fst(snd(e)),e,aspat,aVar,beta);
725 case LAZYPAT : snd(e) = typeExpr(l,snd(e));
729 case ADDPAT : { Int alpha = newTyvars(1);
730 inferType(typeVarToVar,alpha);
731 return ap(e,assumeEvid(predIntegral,alpha));
735 default : internal("typeExpr");
741 /* --------------------------------------------------------------------------
742 * Typing rules for particular special forms:
743 * ------------------------------------------------------------------------*/
745 static Cell local typeAp(l,e) /* Type check application, which */
746 Int l; /* may be headed with a variable */
747 Cell e; { /* requires polymorphism, qualified*/
748 static String app = "application"; /* types, and possible rank2 args. */
759 case NAME : typeIs = name(h).type;
763 case VARIDCELL : if (tcMode==NEW_PATTERN) {
764 inferType(aVar,newVarsBind(e));
767 Cell v = findAssum(textOf(h));
770 typeIs = (tcMode==OLD_PATTERN)
775 h = findName(textOf(h));
778 typeIs = name(h).type;
784 case IPVAR : { Text t = textOf(h);
785 Int alpha = newTyvars(1);
786 Cell ip = pair(ap(IPCELL,t),aVar);
787 Cell ev = assumeEvid(ip,alpha);
788 typeIs = mkInt(alpha);
794 default : h = typeExpr(l,h);
798 if (isNull(typeIs)) {
802 instantiate(typeIs); /* Deal with polymorphism ... */
803 if (nonNull(predsAre)) { /* ... and with qualified types. */
805 for (; nonNull(predsAre); predsAre=tl(predsAre)) {
806 evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
808 if (!isName(h) || !isCfun(h)) {
809 h = applyToArgs(h,rev(evs));
813 if (whatIs(typeIs)==CDICTS) { /* Deal with local dictionaries */
814 List evs = makePredAss(fst(snd(typeIs)),typeOff);
816 typeIs = snd(snd(typeIs));
817 for (; nonNull(ps); ps=tl(ps)) {
818 h = ap(h,thd3(hd(ps)));
820 if (tcMode==EXPRESSION) {
821 preds = revOnto(evs,preds);
823 hd(localEvs) = revOnto(evs,hd(localEvs));
827 if (whatIs(typeIs)==EXIST) { /* Deal with existential arguments */
828 Int n = intOf(fst(snd(typeIs)));
829 typeIs = snd(snd(typeIs));
830 if (!isCfun(getHead(h)) || n>typeFree) {
832 } else if (tcMode!=EXPRESSION) {
833 Int alpha = typeOff + typeFree;
835 bindTv(alpha-n,SKOLEM,0);
836 hd(skolVars) = cons(pair(mkInt(alpha-n),e),hd(skolVars));
841 if (whatIs(typeIs)==RANK2) { /* Deal with rank 2 arguments */
844 Int nr2 = intOf(fst(snd(typeIs)));
845 Type body = snd(snd(typeIs));
849 if (n<nr2) { /* Must have enough arguments */
850 ERRMSG(l) "Use of " ETHEN ERREXPR(h);
852 ERRTEXT " in " ETHEN ERREXPR(e);
854 ERRTEXT " requires at least %d argument%s\n",
855 nr2, (nr2==1 ? "" : "s")
859 for (i=nr2; i<n; ++i) /* Find rank two arguments */
862 for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
863 Type expect = dropRank1(arg(fun(body)),alpha,m);
864 if (isPolyOrQualType(expect)) {
865 if (tcMode==EXPRESSION) /* poly/qual type in expr */
866 hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
867 else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
868 if (!isVar(hd(as))) {
869 ERRMSG(l) "Argument " ETHEN ERREXPR(arg(as));
870 ERRTEXT " in pattern " ETHEN ERREXPR(e);
871 ERRTEXT " where a variable is required\n"
874 if (tcMode==NEW_PATTERN) { /* Pattern match */
877 addVarAssump(dummyVar,mkInt(alpha+i));
880 addVarAssump(hd(as),expect);
882 else { /* Pattern binding */
883 Text t = textOf(hd(as));
884 Cell a = findInAssumList(t,hd(defnBounds));
888 if (nonNull(predsAre)) {
889 ERRMSG(l) "Cannot use pattern binding for " ETHEN
891 ERRTEXT " as a component with a qualified type\n"
894 shouldBe(l,hd(as),e,app,aVar,intOf(defType(snd(a))));
898 else { /* Not a poly/qual type */
899 spCheck(l,hd(as),e,app,expect,alpha);
901 h = ap(h,hd(as)); /* Save checked argument */
903 inferType(body,alpha);
907 if (n>0) { /* Deal with remaining args */
908 Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
909 shouldBe(l,h,e,app,aVar,beta);
910 for (i=n; i>0; --i) { /* check e_i::t_i for each i */
911 spCheck(l,arg(a),e,app,aVar,beta+2*i-1);
915 tyvarType(beta+2*n); /* Inferred type is r_n+1 */
918 if (isNull(p)) /* Replace head with translation */
926 static Cell local typeExpected(l,wh,e,reqd,alpha,n,addEvid)
927 Int l; /* Type check expression e in wh */
928 String wh; /* at line l, expecting type reqd, */
929 Cell e; /* and treating vars alpha through */
930 Type reqd; /* (alpha+n-1) as fixed. */
933 Bool addEvid; { /* TRUE => add \ev -> ... */
934 List savePreds = preds;
945 ps = makePredAss(predsAre,o);
948 check(l,e,NIL,wh,t,o);
952 mapProc(markAssumList,defnBounds);
953 mapProc(markAssumList,varsBounds);
954 mapProc(markPred,savePreds);
957 if (n > 0) { /* mark alpha thru alpha+n-1, plus any */
958 /* type vars that are functionally */
959 List us = NIL, vs = NIL; /* dependent on them */
960 List fds = calcFunDepsPreds(preds);
961 for (i=0; i<n; i++) {
962 Type t1 = zonkTyvar(alpha+i);
963 us = zonkTyvarsIn(t1,us);
966 for (; nonNull(vs); vs=tl(vs))
967 markTyvar(intOf(hd(vs)));
971 savePreds = elimPredsUsing(ps,savePreds);
972 if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
973 savePreds = elimPredsUsing(ps,savePreds);
974 if (nonNull(preds)) {
975 Type ty = copyType(t,o);
976 List qs = copyPreds(ps);
977 cantEstablish(l,wh,e,ty,qs);
982 if (copyTyvar(o+i)!=mkOffset(i)) {
983 List qs = copyPreds(ps);
984 Type it = copyType(t,o);
985 tooGeneral(l,e,reqd,generalize(qs,it));
989 e = qualifyExpr(l,ps,e);
993 preds = revOnto(ps,savePreds);
999 static Void local typeAlt(wh,e,a,t,o,m) /* Type check abstraction (Alt) */
1000 String wh; /* a = ( [p1, ..., pn], rhs ) */
1007 List ps = fst(a) = patBtyvs(fst(a));
1009 Int l = rhsLine(snd(a));
1016 if (whatIs(t)==RANK2) {
1017 if (n<(nr2=intOf(fst(snd(t))))) {
1018 ERRMSG(l) "Definition requires at least %d parameters on lhs",
1025 while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
1026 Type ta = arg(fun(t));
1027 if (isPolyOrQualType(ta)) {
1028 if (hd(ps)!=WILDCARD) {
1029 if (!isVar(hd(ps))) {
1030 ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
1031 ERRTEXT " used where a variable or wildcard is required\n"
1034 if (m>0 && !added) {
1037 addVarAssump(dummyVar,mkInt(o+i));
1040 addVarAssump(hd(ps),ta);
1044 hd(ps) = typeFreshPat(l,hd(ps));
1045 shouldBe(l,hd(ps),NIL,wh,ta,o);
1054 snd(a) = typeRhs(snd(a));
1056 Int beta = funcType(n);
1059 hd(ps) = typeFreshPat(l,hd(ps));
1060 bindTv(beta+2*i+1,typeIs,typeOff);
1063 snd(a) = typeRhs(snd(a));
1064 bindTv(beta+2*n,typeIs,typeOff);
1068 if (!unify(typeIs,typeOff,t,o)) {
1071 req = liftRank2(origt,o,m);
1072 liftRank2Args(as,o,m);
1073 got = ap(RANK2,pair(mkInt(nr2),revOnto(as,copyType(typeIs,typeOff))));
1074 reportTypeError(l,e,NIL,wh,got,req);
1079 leaveSkolVars(l,origt,o,m);
1082 static Int local funcType(n) /*return skeleton for function type*/
1083 Int n; { /*with n arguments, taking the form*/
1084 Int beta = newTyvars(2*n+1); /* r1 t1 r2 t2 ... rn tn rn+1 */
1085 Int i; /* with r_i := t_i -> r_i+1 */
1087 bindTv(beta+2*i,arrow,beta+2*i+1);
1091 static Void local typeCase(l,beta,c) /* type check case: pat -> rhs */
1092 Int l; /* (case given by c == (pat,rhs)) */
1093 Int beta; /* need: pat :: (var,beta) */
1094 Cell c; { /* rhs :: (var,beta+1) */
1095 static String casePat = "case pattern";
1096 static String caseExpr = "case expression";
1100 fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
1101 shouldBe(l,fst(c),NIL,casePat,aVar,beta);
1102 snd(c) = typeRhs(snd(c));
1103 shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,aVar,beta+1);
1107 leaveSkolVars(l,typeIs,typeOff,0);
1110 static Void local typeComp(l,m,e,qs) /* type check comprehension */
1112 Type m; /* monad (mkOffset(0)) */
1115 static String boolQual = "boolean qualifier";
1116 static String genQual = "generator";
1119 if (isNull(qs)) /* no qualifiers left */
1120 fst(e) = typeExpr(l,fst(e));
1124 switch (whatIs(q)) {
1125 case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0);
1126 typeComp(l,m,e,qs1);
1129 case QWHERE : enterBindings();
1131 mapProc(typeBindings,snd(q));
1132 typeComp(l,m,e,qs1);
1134 leaveSkolVars(l,typeIs,typeOff,0);
1137 case FROMQUAL : { Int beta = newTyvars(1);
1139 check(l,snd(snd(q)),NIL,genQual,m,beta);
1142 = typeFreshPat(l,patBtyvs(fst(snd(q))));
1143 shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
1144 typeComp(l,m,e,qs1);
1147 leaveSkolVars(l,typeIs,typeOff,0);
1151 case DOQUAL : check(l,snd(q),NIL,genQual,m,newTyvars(1));
1152 typeComp(l,m,e,qs1);
1158 static Cell local typeMonadComp(l,e) /* type check monad comprehension */
1161 Int alpha = newTyvars(1);
1162 Int beta = newTyvars(1);
1163 Cell mon = ap(mkInt(beta),aVar);
1164 Cell m = assumeEvid(predMonad,beta);
1165 tyvar(beta)->kind = starToStar;
1167 bindTv(beta,typeList,0);
1171 typeComp(l,mon,snd(e),snd(snd(e)));
1172 bindTv(alpha,typeIs,typeOff);
1173 inferType(mon,alpha);
1174 return ap(MONADCOMP,pair(m,snd(e)));
1177 static Void local typeDo(l,e) /* type check do-notation */
1180 static String finGen = "final generator";
1181 Int alpha = newTyvars(1);
1182 Int beta = newTyvars(1);
1183 Cell mon = ap(mkInt(beta),aVar);
1184 Cell m = assumeEvid(predMonad,beta);
1185 tyvar(beta)->kind = starToStar;
1187 typeComp(l,mon,snd(e),snd(snd(e)));
1188 shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
1189 snd(e) = pair(m,snd(e));
1192 static Void local typeConFlds(l,e) /* Type check a construction */
1195 static String conExpr = "value construction";
1196 Name c = fst(snd(e));
1197 List fs = snd(snd(e));
1203 instantiate(name(c).type);
1204 for (; nonNull(predsAre); predsAre=tl(predsAre))
1205 assumeEvid(hd(predsAre),typeOff);
1206 if (whatIs(typeIs)==RANK2)
1207 typeIs = snd(snd(typeIs));
1212 for (; nonNull(fs); fs=tl(fs)) {
1214 for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
1216 t = dropRank1(arg(fun(t)),to,tf);
1217 if (isPolyOrQualType(t))
1218 snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
1220 check(l,snd(hd(fs)),e,conExpr,t,to);
1223 for (i=name(c).arity; i>0; i--)
1228 static Void local typeUpdFlds(line,e) /* Type check an update */
1229 Int line; /* (Written in what might seem a */
1230 Cell e; { /* bizarre manner for the benefit */
1231 static String update = "update"; /* of as yet unreleased extensions)*/
1232 List cs = snd3(snd(e)); /* List of constructors */
1233 List fs = thd3(snd(e)); /* List of field specifications */
1234 List ts = NIL; /* List of types for fields */
1236 Int alpha = newTyvars(2+n);
1240 /* Calculate type and translation for each expr in the field list */
1241 for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1242 snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
1243 bindTv(i,typeIs,typeOff);
1247 mapProc(markAssumList,defnBounds);
1248 mapProc(markAssumList,varsBounds);
1249 mapProc(markPred,preds);
1252 for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
1254 ts = cons(generalize(NIL,copyTyvar(i)),ts);
1258 /* Type check expression to be updated */
1259 fst3(snd(e)) = typeExpr(line,fst3(snd(e)));
1260 bindTv(alpha,typeIs,typeOff);
1262 for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */
1264 List ta = replicate(name(c).arity,NIL);
1268 tcMode = NEW_PATTERN; /* Domain type */
1269 instantiate(name(c).type);
1270 tcMode = EXPRESSION;
1273 for (; nonNull(predsAre); predsAre=tl(predsAre))
1274 assumeEvid(hd(predsAre),typeOff);
1276 if (whatIs(typeIs)==RANK2) {
1277 ERRMSG(line) "Sorry, record update syntax cannot currently be "
1278 "used for datatypes with polymorphic components"
1282 instantiate(name(c).type); /* Range type */
1285 for (; nonNull(predsAre); predsAre=tl(predsAre))
1286 assumeEvid(hd(predsAre),typeOff);
1288 for (fs1=fs, i=1; nonNull(fs1); fs1=tl(fs1), i++) {
1289 Int n = sfunPos(fst(hd(fs1)),c);
1296 for (; nonNull(ta); ta=tl(ta)) { /* For each cfun arg */
1297 if (nonNull(hd(ta))) { /* Field to updated? */
1298 Int n = intOf(hd(ta));
1301 for (; n-- > 1; f=tl(f), t=tl(t))
1306 shouldBe(line,snd(f),e,update,arg(fun(tr)),or);
1307 } /* Unmentioned component */
1308 else if (!unify(arg(fun(td)),od,arg(fun(tr)),or))
1309 internal("typeUpdFlds");
1315 inferType(td,od); /* Check domain type */
1316 shouldBe(line,fst3(snd(e)),e,update,aVar,alpha);
1317 inferType(tr,or); /* Check range type */
1318 shouldBe(line,e,NIL,update,aVar,alpha+1);
1320 /* (typeIs,typeOff) still carry the result type when we exit the loop */
1324 static Cell local typeWith(line,e) /* Type check a with */
1327 List fs = snd(snd(e)); /* List of field specifications */
1329 Int alpha = newTyvars(2+n);
1334 List dpreds = NIL, dp;
1337 /* Type check expression to be updated */
1338 fst(snd(e)) = typeExpr(line,fst(snd(e)));
1339 bindTv(alpha,typeIs,typeOff);
1342 /* elim duplicate uses of imp params */
1343 preds = scSimplify(preds);
1344 /* extract preds that we're going to bind */
1345 for (fs1=fs; nonNull(fs1); fs1=tl(fs1)) {
1346 Text t = textOf(fst(hd(fs1)));
1347 Cell p = findIPEvid(t);
1348 dpreds = cons(p, dpreds);
1352 /* maybe give a warning message here... */
1355 dpreds = rev(dpreds);
1357 /* Calculate type and translation for each expr in the field list */
1358 for (fs1=fs, dp=dpreds, i=alpha+2; nonNull(fs1); fs1=tl(fs1), dp=tl(dp), i++) {
1359 static String with = "with";
1361 snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
1362 bindTv(i,typeIs,typeOff);
1364 shouldBe(line,fst(hd(fs1)),e,with,snd(fst3(ev)),intOf(snd3(ev)));
1365 bs = cons(cons(pair(thd3(ev), cons(triple(NIL, mkInt(line), snd(hd(fs1))), NIL)), NIL), bs);
1370 return (ap(LETREC,pair(bs,fst(snd(e)))));
1374 static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
1375 Int l; /* fresh type variables to each var */
1376 Cell p; { /* bound in the pattern */
1377 tcMode = NEW_PATTERN;
1379 tcMode = EXPRESSION;
1383 /* --------------------------------------------------------------------------
1384 * Type check group of bindings:
1385 * ------------------------------------------------------------------------*/
1387 static Void local typeBindings(bs) /* type check a binding group */
1389 Bool usesPatBindings = FALSE; /* TRUE => pattern binding in bs */
1390 Bool usesUntypedVar = FALSE; /* TRUE => var bind w/o type decl */
1393 /* The following loop is used to determine whether the monomorphism */
1394 /* restriction should be applied. It could be written marginally more */
1395 /* efficiently by using breaks, but clarity is more important here ... */
1397 for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) { /* Analyse binding group */
1400 usesPatBindings = TRUE;
1401 else if (isNull(fst(hd(snd(snd(b))))) /* no arguments */
1402 && whatIs(fst(snd(b)))==IMPDEPS) /* implicitly typed*/
1403 usesUntypedVar = TRUE;
1406 if (usesPatBindings || usesUntypedVar)
1411 mapProc(removeTypeSigs,bs); /* Remove binding type info */
1412 hd(varsBounds) = revOnto(hd(defnBounds), /* transfer completed assmps*/
1413 hd(varsBounds)); /* out of defnBounds */
1414 hd(defnBounds) = NIL;
1418 static Void local removeTypeSigs(b) /* Remove type info from a binding */
1420 snd(b) = snd(snd(b));
1423 /* --------------------------------------------------------------------------
1424 * Type check a restricted binding group:
1425 * ------------------------------------------------------------------------*/
1427 static Void local monorestrict(bs) /* Type restricted binding group */
1429 List savePreds = preds;
1430 Int line = isVar(fst(hd(bs))) ? rhsLine(snd(hd(snd(snd(hd(bs))))))
1431 : rhsLine(snd(snd(snd(hd(bs)))));
1432 hd(defnBounds) = NIL;
1433 hd(depends) = NODEPENDS; /* No need for dependents here */
1435 preds = NIL; /* Type check the bindings */
1436 mapProc(restrictedBindAss,bs);
1437 mapProc(typeBind,bs);
1438 improve(line,NIL,preds);
1441 preds = revOnto(preds,savePreds);
1443 clearMarks(); /* Mark fixed variables */
1444 mapProc(markAssumList,tl(defnBounds));
1445 mapProc(markAssumList,tl(varsBounds));
1446 mapProc(markPred,preds);
1449 if (isNull(tl(defnBounds))) { /* Top-level may need defaulting */
1451 if (nonNull(preds) && resolveDefs(genvarAnyAss(hd(defnBounds))))
1456 if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
1459 if (nonNull(preds)) { /* Look for unresolved overloading */
1460 Cell v = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
1461 Cell ass = findInAssumList(textOf(v),hd(varsBounds));
1462 preds = scSimplify(preds);
1464 ERRMSG(line) "Unresolved top-level overloading" ETHEN
1465 ERRTEXT "\n*** Binding : %s", textToStr(textOf(v))
1468 ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(snd(ass));
1470 ERRTEXT "\n*** Outstanding context : " ETHEN
1471 ERRCONTEXT(copyPreds(preds));
1477 map1Proc(genBind,NIL,bs); /* Generalize types of def'd vars */
1480 static Void local restrictedBindAss(b) /* Make assums for vars in binding */
1481 Cell b; { /* gp with restricted overloading */
1483 if (isVar(fst(b))) { /* function-binding? */
1484 Cell t = fst(snd(b));
1485 if (whatIs(t)==IMPDEPS) { /* Discard implicitly typed deps */
1486 fst(snd(b)) = t = NIL; /* in a restricted binding group. */
1488 fst(snd(b)) = localizeBtyvs(t);
1489 restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
1490 } else { /* pattern-binding? */
1492 List ts = fst(snd(b));
1493 Int line = rhsLine(snd(snd(snd(b))));
1495 for (; nonNull(vs); vs=tl(vs)) {
1497 restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
1500 restrictedAss(line,hd(vs),NIL);
1506 static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
1507 Int l; /* is t (if nonNull) in restricted */
1508 Cell v; /* binding group */
1511 if (nonNull(predsAre)) {
1512 ERRMSG(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
1514 ERRTEXT " not permitted in restricted binding"
1519 /* --------------------------------------------------------------------------
1520 * Unrestricted binding group:
1521 * ------------------------------------------------------------------------*/
1523 static Void local unrestricted(bs) /* Type unrestricted binding group */
1525 List savePreds = preds;
1526 List imps = NIL; /* Implicitly typed bindings */
1527 List exps = NIL; /* Explicitly typed bindings */
1530 /* ----------------------------------------------------------------------
1531 * STEP 1: Separate implicitly typed bindings from explicitly typed
1532 * bindings and do a dependency analyis, where f depends on g iff f
1533 * is implicitly typed and involves a call to g.
1534 * --------------------------------------------------------------------*/
1536 for (; nonNull(bs); bs=tl(bs)) {
1538 if (whatIs(fst(snd(b)))==IMPDEPS)
1539 imps = cons(b,imps); /* N.B. New lists are built to */
1540 else /* avoid breaking the original */
1541 exps = cons(b,exps); /* list structure for bs. */
1544 for (bs=imps; nonNull(bs); bs=tl(bs)) {
1545 Cell b = hd(bs); /* Restrict implicitly typed dep */
1546 List ds = snd(fst(snd(b))); /* lists to bindings in imps */
1548 while (nonNull(ds)) {
1550 if (cellIsMember(hd(ds),imps)) {
1558 imps = itbscc(imps); /* Dependency analysis on imps */
1559 for (bs=imps; nonNull(bs); bs=tl(bs))
1560 for (bs1=hd(bs); nonNull(bs1); bs1=tl(bs1))
1561 fst(snd(hd(bs1))) = NIL; /* reset imps type fields */
1563 #ifdef DEBUG_DEPENDS
1564 Printf("Binding group:");
1565 for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
1567 for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
1568 Printf(" %s",textToStr(textOf(fst(hd(bs)))));
1571 if (nonNull(exps)) {
1573 for (bs=exps; nonNull(bs); bs=tl(bs))
1574 Printf(" %s",textToStr(textOf(fst(hd(bs)))));
1580 /* ----------------------------------------------------------------------
1581 * STEP 2: Add type assumptions about any explicitly typed variable.
1582 * --------------------------------------------------------------------*/
1584 for (bs=exps; nonNull(bs); bs=tl(bs)) {
1585 fst(snd(hd(bs))) = localizeBtyvs(fst(snd(hd(bs))));
1586 hd(varsBounds) = cons(pair(fst(hd(bs)),fst(snd(hd(bs)))),
1590 /* ----------------------------------------------------------------------
1591 * STEP 3: Calculate types for each group of implicitly typed bindings.
1592 * --------------------------------------------------------------------*/
1594 for (; nonNull(imps); imps=tl(imps)) {
1595 Cell b = hd(hd(imps));
1596 Int line = isVar(fst(b)) ? rhsLine(snd(hd(snd(snd(b)))))
1597 : rhsLine(snd(snd(snd(b))));
1598 hd(defnBounds) = NIL;
1600 for (bs1=hd(imps); nonNull(bs1); bs1=tl(bs1))
1601 newDefnBind(fst(hd(bs1)),NIL);
1604 mapProc(typeBind,hd(imps));
1605 improve(line,NIL,preds);
1608 mapProc(markAssumList,tl(defnBounds));
1609 mapProc(markAssumList,tl(varsBounds));
1610 mapProc(markPred,savePreds);
1614 savePreds = elimOuterPreds(savePreds);
1615 if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds)))) {
1616 savePreds = elimOuterPreds(savePreds);
1619 map1Proc(genBind,preds,hd(imps));
1620 if (nonNull(preds)) {
1621 map1Proc(addEvidParams,preds,hd(depends));
1622 map1Proc(qualifyBinding,preds,hd(imps));
1625 h98CheckType(line,"inferred type",
1626 fst(hd(hd(defnBounds))),snd(hd(hd(defnBounds))));
1627 hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
1630 /* ----------------------------------------------------------------------
1631 * STEP 4: Now infer a type for each explicitly typed variable and
1632 * check for compatibility with the declared type.
1633 * --------------------------------------------------------------------*/
1635 for (; nonNull(exps); exps=tl(exps)) {
1636 static String extbind = "explicitly typed binding";
1638 List alts = snd(snd(b));
1639 Int line = rhsLine(snd(hd(alts)));
1645 hd(defnBounds) = NIL;
1646 hd(depends) = NODEPENDS;
1649 instantiate(fst(snd(b)));
1652 t = dropRank2(typeIs,o,m);
1653 ps = makePredAss(predsAre,o);
1655 enterPendingBtyvs();
1656 for (; nonNull(alts); alts=tl(alts))
1657 typeAlt(extbind,fst(b),hd(alts),t,o,m);
1658 improve(line,ps,preds);
1659 leavePendingBtyvs();
1661 if (nonNull(ps)) /* Add dict params, if necessary */
1662 qualifyBinding(ps,b);
1665 mapProc(markAssumList,tl(defnBounds));
1666 mapProc(markAssumList,tl(varsBounds));
1667 mapProc(markPred,savePreds);
1671 savePreds = elimPredsUsing(ps,savePreds);
1672 if (nonNull(preds)) {
1676 vs = cons(mkInt(o+i),vs);
1677 if (resolveDefs(vs)) {
1678 savePreds = elimPredsUsing(ps,savePreds);
1680 if (nonNull(preds)) {
1683 if (nonNull(preds) && resolveDefs(vs))
1684 savePreds = elimPredsUsing(ps,savePreds);
1688 resetGenerics(); /* Make sure we're general enough */
1690 t = generalize(ps,liftRank2(t,o,m));
1692 if (!sameSchemes(t,fst(snd(b))))
1693 tooGeneral(line,fst(b),fst(snd(b)),t);
1694 h98CheckType(line,"inferred type",fst(b),t);
1696 if (nonNull(preds)) /* Check context was strong enough */
1697 cantEstablish(line,extbind,fst(b),t,ps);
1700 preds = savePreds; /* Restore predicates */
1701 hd(defnBounds) = NIL;
1704 #define SCC itbscc /* scc for implicitly typed binds */
1705 #define LOWLINK itblowlink
1706 #define DEPENDS(t) fst(snd(t))
1707 #define SETDEPENDS(c,v) fst(snd(c))=v
1714 static Void local addEvidParams(qs,v) /* overwrite VARID/OPCELL v with */
1715 List qs; /* application of variable to evid. */
1716 Cell v; { /* parameters given by qs */
1721 internal("addEvidParams");
1723 for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
1724 nv = ap(nv,thd3(hd(qs)));
1726 snd(v) = thd3(hd(qs));
1730 /* --------------------------------------------------------------------------
1731 * Type check bodies of class and instance declarations:
1732 * ------------------------------------------------------------------------*/
1734 static Void local typeClassDefn(c) /* Type check implementations of */
1735 Class c; { /* defaults for class c */
1737 /* ----------------------------------------------------------------------
1738 * Generate code for default dictionary builder functions:
1739 * --------------------------------------------------------------------*/
1741 Int beta = newKindedVars(cclass(c).kinds);
1742 Cell d = inventDictVar();
1743 List dparam = singleton(triple(cclass(c).head,mkInt(beta),d));
1744 List mems = cclass(c).members;
1745 List defs = cclass(c).defaults;
1746 List dsels = cclass(c).dsels;
1747 Cell pat = cclass(c).dcon;
1748 Int width = cclass(c).numSupers + cclass(c).numMembers;
1749 char buf[FILENAME_MAX+1];
1753 if (isNull(defs) && nonNull(mems)) {
1754 defs = cclass(c).defaults = cons(NIL,NIL);
1757 for (; nonNull(mems); mems=tl(mems)) {
1758 /* static String deftext = "default_"; */
1759 static String deftext = "$dm";
1760 String s = textToStr(name(hd(mems)).text);
1763 for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
1764 buf[i] = deftext[i];
1766 for(; (i+j)<FILENAME_MAX && s[j]!='\0'; j++) {
1770 n = newName(findText(buf),c);
1772 if (isNull(hd(defs))) { /* No default definition */
1773 static String header = "Undefined member: ";
1774 for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
1776 for (j=0; (i+j)<FILENAME_MAX && s[j]!='\0'; j++)
1779 name(n).line = cclass(c).line;
1781 name(n).defn = singleton(pair(singleton(d),
1782 ap(mkInt(cclass(c).line),
1785 findText(buf)))))));
1786 } else { /* User supplied default defn */
1787 List alts = snd(hd(defs));
1788 Int line = rhsLine(snd(hd(alts)));
1790 typeMember("default member binding",
1797 name(n).line = line;
1798 name(n).arity = 1+length(fst(hd(alts)));
1799 name(n).defn = alts;
1801 for (; nonNull(alts); alts=tl(alts)) {
1802 fst(hd(alts)) = cons(d,fst(hd(alts)));
1807 genDefns = cons(n,genDefns);
1808 if (isNull(tl(defs)) && nonNull(tl(mems))) {
1809 tl(defs) = cons(NIL,NIL);
1814 /* ----------------------------------------------------------------------
1815 * Generate code for superclass and member function selectors:
1816 * --------------------------------------------------------------------*/
1818 for (i=0; i<width; i++) {
1819 pat = ap(pat,inventVar());
1821 pat = singleton(pat);
1822 for (i=0; nonNull(dsels); dsels=tl(dsels)) {
1823 name(hd(dsels)).defn = singleton(pair(pat,
1824 ap(mkInt(cclass(c).line),
1825 nthArg(i++,hd(pat)))));
1826 genDefns = cons(hd(dsels),genDefns);
1828 for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
1829 name(hd(mems)).defn = singleton(pair(pat,
1830 ap(mkInt(name(hd(mems)).line),
1831 nthArg(i++,hd(pat)))));
1832 genDefns = cons(hd(mems),genDefns);
1836 static Void local typeInstDefn(in) /* Type check implementations of */
1837 Inst in; { /* member functions for instance in*/
1839 /* ----------------------------------------------------------------------
1840 * Generate code for instance specific dictionary builder function:
1842 * inst.maker d1 ... dn = let sc1 = ...
1848 * d = Make.C sc1 ... scm v1 ... vk
1851 * where sci are superclass dictionaries, d is a new name, vj
1852 * is a newly generated name corresponding to the implementation of a
1853 * member function. (Additional line number values must be added at
1854 * appropriate places but, for clarity, these are not shown above.)
1855 * If no implementation of a particular vj is available, then we use
1856 * the default implementation, partially applied to d.
1857 * --------------------------------------------------------------------*/
1859 Int alpha = newKindedVars(cclass(inst(in).c).kinds);
1860 List supers = makePredAss(cclass(inst(in).c).supers,alpha);
1861 Int beta = newKindedVars(inst(in).kinds);
1862 List params = makePredAss(inst(in).specifics,beta);
1863 Cell d = inventDictVar();
1864 List evids = cons(triple(inst(in).head,mkInt(beta),d),
1865 appendOnto(dupList(params),supers));
1867 List imps = inst(in).implements;
1868 Cell l = mkInt(inst(in).line);
1869 Cell dictDef = cclass(inst(in).c).dcon;
1870 List mems = cclass(inst(in).c).members;
1871 List defs = cclass(inst(in).c).defaults;
1876 if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
1877 internal("typeInstDefn");
1879 for (ps=params; nonNull(ps); ps=tl(ps)) /* Build arglist */
1880 args = cons(thd3(hd(ps)),args);
1883 for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
1886 #if EXPLAIN_INSTANCE_RESOLUTION
1888 fputs("scEntail: ", stdout);
1889 printContext(stdout,copyPreds(params));
1890 fputs(" ||- ", stdout);
1891 printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
1892 fputc('\n', stdout);
1895 ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
1897 #if EXPLAIN_INSTANCE_RESOLUTION
1899 fputs("inEntail: ", stdout);
1900 printContext(stdout,copyPreds(evids));
1901 fputs(" ||- ", stdout);
1902 printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
1903 fputc('\n', stdout);
1906 ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
1910 ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
1911 ERRTEXT "\n*** Instance : " ETHEN
1912 ERRPRED(copyPred(inst(in).head,beta));
1913 ERRTEXT "\n*** Context supplied : " ETHEN
1914 ERRCONTEXT(copyPreds(params));
1915 ERRTEXT "\n*** Required superclass : " ETHEN
1916 ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
1920 locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
1921 dictDef = ap(dictDef,thd3(pi));
1924 for (; nonNull(defs); defs=tl(defs)) {
1926 if (nonNull(imps)) {
1931 dictDef = ap(dictDef,ap(hd(defs),d));
1933 Cell v = inventVar();
1934 dictDef = ap(dictDef,v);
1935 typeMember("instance member binding",
1941 locs = cons(pair(v,snd(imp)),locs);
1945 locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
1947 name(inst(in).builder).defn /* Register builder imp */
1948 = singleton(pair(args,ap(LETREC,pair(singleton(locs),
1951 /* Invent a GHC-compatible name for the instance decl */
1953 char buf[FILENAME_MAX+1];
1956 Cell qq = inst(in).head;
1958 static String zdftext = "$f";
1961 pp = cons(arg(qq),pp);
1964 // pp is now the fwd list of args(?) to this pred
1967 for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
1968 buf[i] = zdftext[j];
1970 str = textToStr(cclass(inst(in).c).text);
1971 for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
1974 for (; nonNull(pp); pp=tl(pp)) {
1976 while (isAp(qq)) qq = fun(qq);
1977 switch (whatIs(qq)) {
1978 case TYCON: str = textToStr(tycon(qq).text); break;
1979 case TUPLE: str = textToStr(ghcTupleText(qq)); break;
1980 default: internal("typeInstDefn: making GHC name"); break;
1982 for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
1988 name(inst(in).builder).text = findText(buf);
1989 //fprintf ( stderr, "result = %s\n", buf );
1992 genDefns = cons(inst(in).builder,genDefns);
1995 static Void local typeMember(wh,mem,alts,evids,head,beta)
1996 String wh; /* Type check alternatives alts of */
1997 Name mem; /* member mem for inst type head */
1998 Cell alts; /* at offset beta using predicate */
1999 List evids; /* assignment evids */
2002 Int line = rhsLine(snd(hd(alts)));
2011 Printf("\nType check member: ");
2012 printExp(stdout,mem);
2014 printType(stdout,name(mem).type);
2015 Printf("\n for the instance: ");
2016 printPred(stdout,head);
2020 instantiate(name(mem).type); /* Find required type */
2023 t = dropRank2(typeIs,o,m);
2024 ps = makePredAss(predsAre,o);
2025 if (!unifyPred(hd(predsAre),typeOff,head,beta))
2026 internal("typeMember1");
2029 rt = generalize(qs,liftRank2(t,o,m));
2032 Printf("Required type is: ");
2033 printType(stdout,rt);
2037 hd(defnBounds) = NIL; /* Type check each alternative */
2038 hd(depends) = NODEPENDS;
2039 enterPendingBtyvs();
2040 for (preds=NIL; nonNull(alts); alts=tl(alts)) {
2041 typeAlt(wh,mem,hd(alts),t,o,m);
2042 qualify(tl(ps),hd(alts)); /* Add any extra dict params */
2044 improve(line,evids,preds);
2045 leavePendingBtyvs();
2047 evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
2051 qs = elimPredsUsing(evids,NIL);
2052 if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
2053 qs = elimPredsUsing(evids,qs);
2056 "Implementation of %s requires extra context",
2057 textToStr(name(mem).text) ETHEN
2058 ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(rt);
2059 ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
2064 resetGenerics(); /* Make sure we're general enough */
2066 t = generalize(ps,liftRank2(t,o,m));
2068 Printf(" Inferred type is: ");
2069 printType(stdout,t);
2072 if (!sameSchemes(t,rt))
2073 tooGeneral(line,mem,rt,t);
2074 if (nonNull(preds)) {
2075 preds = scSimplify(preds);
2076 cantEstablish(line,wh,mem,t,ps);
2080 /* --------------------------------------------------------------------------
2081 * Type check bodies of bindings:
2082 * ------------------------------------------------------------------------*/
2084 static Void local typeBind(b) /* Type check binding */
2086 if (isVar(fst(b))) { /* function binding */
2087 Cell ass = findTopBinding(fst(b));
2091 internal("typeBind");
2093 beta = intOf(defType(snd(ass)));
2094 enterPendingBtyvs();
2095 map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
2096 leavePendingBtyvs();
2098 else { /* pattern binding */
2099 static String lhsPat = "lhs pattern";
2100 static String rhs = "right hand side";
2101 Int beta = newTyvars(1);
2102 Pair pb = snd(snd(b));
2103 Int l = rhsLine(snd(pb));
2105 tcMode = OLD_PATTERN;
2106 enterPendingBtyvs();
2107 fst(pb) = patBtyvs(fst(pb));
2108 check(l,fst(pb),NIL,lhsPat,aVar,beta);
2109 tcMode = EXPRESSION;
2110 snd(pb) = typeRhs(snd(pb));
2111 shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
2113 leavePendingBtyvs();
2117 static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding */
2121 static String valDef = "function binding";
2122 typeAlt(valDef,v,a,aVar,beta,0);
2125 static Cell local typeRhs(e) /* check type of rhs of definition */
2127 switch (whatIs(e)) {
2128 case GUARDED : { Int beta = newTyvars(1);
2129 map1Proc(guardedType,beta,snd(e));
2134 case LETREC : enterBindings();
2136 mapProc(typeBindings,fst(snd(e)));
2137 snd(snd(e)) = typeRhs(snd(snd(e)));
2139 leaveSkolVars(rhsLine(snd(snd(e))),typeIs,typeOff,0);
2142 case RSIGN : fst(snd(e)) = typeRhs(fst(snd(e)));
2143 shouldBe(rhsLine(fst(snd(e))),
2144 rhsExpr(fst(snd(e))),NIL,
2149 default : snd(e) = typeExpr(intOf(fst(e)),snd(e));
2155 static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
2156 Int beta; /* should have gd :: Bool, */
2157 Cell gded; { /* ex :: (var,beta) */
2158 static String guarded = "guarded expression";
2159 static String guard = "guard";
2160 Int line = intOf(fst(gded));
2163 check(line,fst(gded),NIL,guard,typeBool,0);
2164 check(line,snd(gded),NIL,guarded,aVar,beta);
2167 Cell rhsExpr(rhs) /* find first expression on a rhs */
2170 switch (whatIs(rhs)) {
2171 case GUARDED : return snd(snd(hd(snd(rhs))));
2172 case LETREC : return rhsExpr(snd(snd(rhs)));
2173 case RSIGN : return rhsExpr(fst(snd(rhs)));
2174 default : return snd(rhs);
2178 Int rhsLine(rhs) /* find line number associated with */
2179 Cell rhs; { /* a right hand side */
2181 switch (whatIs(rhs)) {
2182 case GUARDED : return intOf(fst(hd(snd(rhs))));
2183 case LETREC : return rhsLine(snd(snd(rhs)));
2184 case RSIGN : return rhsLine(fst(snd(rhs)));
2185 default : return intOf(fst(rhs));
2189 /* --------------------------------------------------------------------------
2190 * Calculate generalization of types and compare with declared type schemes:
2191 * ------------------------------------------------------------------------*/
2193 static Void local genBind(ps,b) /* Generalize the type of each var */
2194 List ps; /* defined in binding b, qualifying*/
2195 Cell b; { /* each with the predicates in ps. */
2197 Cell t = fst(snd(b));
2200 genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
2202 Int line = rhsLine(snd(snd(snd(b))));
2203 for (; nonNull(v); v=tl(v)) {
2209 genAss(line,ps,hd(v),ty);
2214 static Void local genAss(l,ps,v,dt) /* Calculate inferred type of v and*/
2215 Int l; /* compare with declared type, dt, */
2216 List ps; /* if given & check for ambiguity. */
2219 Cell ass = findTopBinding(v);
2224 snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
2229 printType(stdout,snd(ass));
2234 static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred */
2235 Int l; /* type (t,o) with context ps */
2236 Cell v; /* against declared type dt for v. */
2241 Type bt = NIL; /* Body of inferred type */
2242 Type it = NIL; /* Full inferred type */
2244 resetGenerics(); /* Calculate Haskell typing */
2247 it = generalize(ps,bt);
2249 if (nonNull(dt)) { /* If a declared type was given, */
2250 instantiate(dt); /* check body for match. */
2251 if (!equalTypes(typeIs,bt))
2252 tooGeneral(l,v,dt,it);
2254 else if (nonNull(ps)) /* Otherwise test for ambiguity in */
2255 if (isAmbiguous(it)) /* inferred type. */
2256 ambigError(l,"inferred type",v,it);
2261 static Type local generalize(qs,t) /* calculate generalization of t */
2262 List qs; /* having already marked fixed vars*/
2263 Type t; { /* with qualifying preds qs */
2265 t = ap(QUAL,pair(qs,t));
2266 if (nonNull(genericVars)) {
2268 List vs = genericVars;
2269 for (; nonNull(vs); vs=tl(vs)) {
2270 Tyvar *tyv = tyvar(intOf(hd(vs)));
2271 Kind ka = tyv->kind;
2274 t = mkPolyType(k,t);
2276 Printf("Generalized type: ");
2277 printType(stdout,t);
2279 printKind(stdout,k);
2286 static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
2289 et: if (whatIs(t1)!=whatIs(t2))
2292 switch (whatIs(t1)) {
2298 case TUPLE : return t1==t2;
2300 case INTCELL : return intOf(t1)!=intOf(t2);
2302 case AP : if (equalTypes(fun(t1),fun(t2))) {
2309 default : internal("equalTypes");
2312 return TRUE;/*NOTREACHED*/
2315 /* --------------------------------------------------------------------------
2316 * Entry points to type checker:
2317 * ------------------------------------------------------------------------*/
2319 Type typeCheckExp(useDefs) /* Type check top level expression */
2320 Bool useDefs; { /* using defaults if reqd */
2326 emptySubstitution();
2328 inputExpr = typeExpr(0,inputExpr);
2332 improve(0,NIL,preds);
2335 preds = scSimplify(preds);
2336 if (useDefs && nonNull(preds)) {
2339 if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
2343 ctxt = copyPreds(preds);
2344 type = generalize(ctxt,copyType(type,beta));
2345 inputExpr = qualifyExpr(0,preds,inputExpr);
2346 h98CheckType(0,"inferred type",inputExpr,type);
2348 emptySubstitution();
2352 Void typeCheckDefns() { /* Type check top level bindings */
2353 Target t = length(selDefns) + length(valDefns) +
2354 length(instDefns) + length(classDefns);
2359 emptySubstitution();
2362 setGoal("Type checking",t);
2364 for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
2365 mapOver(typeSel,hd(gs));
2368 for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
2369 typeDefnGroup(hd(gs));
2373 for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
2374 emptySubstitution();
2375 typeClassDefn(hd(gs));
2378 for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
2379 emptySubstitution();
2380 typeInstDefn(hd(gs));
2385 emptySubstitution();
2389 static Void local typeDefnGroup(bs) /* type check group of value defns */
2390 List bs; { /* (one top level scc) */
2393 emptySubstitution();
2394 hd(defnBounds) = NIL;
2397 typeBindings(bs); /* find types for vars in bindings */
2399 if (nonNull(preds)) {
2400 Cell v = fst(hd(hd(varsBounds)));
2401 Name n = findName(textOf(v));
2402 Int l = nonNull(n) ? name(n).line : 0;
2403 preds = scSimplify(preds);
2404 ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
2405 ERRCONTEXT(copyPreds(preds));
2406 ERRTEXT " required for definition of " ETHEN
2407 ERREXPR(nonNull(n)?n:v);
2412 if (nonNull(hd(skolVars))) {
2414 Name n = findName(isVar(fst(b)) ? textOf(fst(b)) : textOf(hd(fst(b))));
2415 Int l = nonNull(n) ? name(n).line : 0;
2416 leaveSkolVars(l,typeUnit,0,0);
2420 for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
2421 Cell a = hd(as); /* add infered types to environment*/
2422 Name n = findName(textOf(fst(a)));
2424 internal("typeDefnGroup");
2425 name(n).type = snd(a);
2427 hd(varsBounds) = NIL;
2430 static Pair local typeSel(s) /* Calculate a suitable type for a */
2431 Name s; { /* particular selector, s. */
2432 List cns = name(s).defn;
2433 Int line = name(s).line;
2434 Type dom = NIL; /* Inferred domain */
2435 Type rng = NIL; /* Inferred range */
2436 Cell nv = inventVar();
2438 Int o = 0; /* bogus init to keep gcc -O happy */
2439 Int m = 0; /* bogus init to keep gcc -O happy */
2442 Printf("Selector %s, cns=",textToStr(name(s).text));
2443 printExp(stdout,cns);
2447 emptySubstitution();
2450 for (; nonNull(cns); cns=tl(cns)) {
2451 Name c = fst(hd(cns));
2452 Int n = intOf(snd(hd(cns)));
2453 Int a = name(c).arity;
2460 instantiate(name(c).type); /* Instantiate constructor type */
2463 for (; nonNull(predsAre); predsAre=tl(predsAre))
2464 assumeEvid(hd(predsAre),o1);
2466 if (whatIs(typeIs)==RANK2) /* Skip rank2 annotation, if any */
2467 typeIs = snd(snd(typeIs));
2468 for (; --n>0; a--) { /* Get range */
2469 pat = ap(pat,WILDCARD);
2470 typeIs = arg(typeIs);
2472 rng1 = dropRank1(arg(fun(typeIs)),o1,m1);
2474 typeIs = arg(typeIs);
2475 while (--a>0) { /* And then look for domain */
2476 pat = ap(pat,WILDCARD);
2477 typeIs = arg(typeIs);
2481 if (isNull(dom)) { /* Save first domain type and then */
2482 dom = dom1; /* unify with subsequent domains to*/
2483 o = o1; /* match up preds and range types */
2486 else if (!unify(dom1,o1,dom,o))
2487 internal("typeSel1");
2489 if (isNull(rng)) /* Compare component types */
2491 else if (!sameSchemes(rng1,rng)) {
2493 rng = liftRank1(rng,o,m);
2494 rng1 = liftRank1(rng1,o1,m1);
2495 ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
2496 textToStr(name(s).text) ETHEN
2497 ERRTEXT "\n*** Field type : " ETHEN ERRTYPE(rng1);
2498 ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(rng);
2502 alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
2506 if (isNull(dom) || isNull(rng)) /* Should have been initialized by */
2507 internal("typeSel2"); /* now, assuming length cns >= 1. */
2509 clearMarks(); /* No fixed variables here */
2510 preds = scSimplify(preds); /* Simplify context */
2511 dom = copyType(dom,o); /* Calculate domain type */
2513 rng = copyType(typeIs,typeOff);
2514 if (nonNull(predsAre)) {
2515 List ps = makePredAss(predsAre,typeOff);
2517 for (; nonNull(alts1); alts1=tl(alts1)) {
2520 for (; nonNull(qs); qs=tl(qs))
2521 body = ap(body,thd3(hd(qs)));
2522 snd(snd(hd(alts1))) = body;
2524 preds = appendOnto(preds,ps);
2526 name(s).type = generalize(copyPreds(preds),fn(dom,rng));
2527 name(s).arity = 1 + length(preds);
2528 map1Proc(qualify,preds,alts);
2531 Printf("Inferred arity = %d, type = ",name(s).arity);
2532 printType(stdout,name(s).type);
2536 return pair(s,alts);
2540 /* --------------------------------------------------------------------------
2541 * Local function prototypes:
2542 * ------------------------------------------------------------------------*/
2544 static Type local basicType Args((Char));
2547 static Type stateVar = NIL;
2548 static Type alphaVar = NIL;
2549 static Type betaVar = NIL;
2550 static Type gammaVar = NIL;
2551 static Type deltaVar = NIL;
2552 static Int nextVar = 0;
2554 static Void clearTyVars( void )
2564 static Type mkStateVar( void )
2566 if (isNull(stateVar)) {
2567 stateVar = mkOffset(nextVar++);
2572 static Type mkAlphaVar( void )
2574 if (isNull(alphaVar)) {
2575 alphaVar = mkOffset(nextVar++);
2580 static Type mkBetaVar( void )
2582 if (isNull(betaVar)) {
2583 betaVar = mkOffset(nextVar++);
2588 static Type mkGammaVar( void )
2590 if (isNull(gammaVar)) {
2591 gammaVar = mkOffset(nextVar++);
2596 static Type mkDeltaVar( void )
2598 if (isNull(deltaVar)) {
2599 deltaVar = mkOffset(nextVar++);
2604 static Type local basicType(k)
2622 return ap(typePrimArray,mkAlphaVar());
2624 return typePrimByteArray;
2626 return ap2(typeRef,mkStateVar(),mkAlphaVar());
2628 return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
2630 return ap(typePrimMutableByteArray,mkStateVar());
2632 return ap(typeStable,mkAlphaVar());
2635 return ap(typeWeak,mkAlphaVar());
2637 return ap(typeIO,typeUnit);
2639 #ifdef PROVIDE_FOREIGN
2644 return typeThreadId;
2646 return ap(typeMVar,mkAlphaVar());
2650 return fn(typeException,mkAlphaVar());
2652 return typeException;
2654 return mkAlphaVar(); /* polymorphic */
2656 return mkBetaVar(); /* polymorphic */
2658 return mkGammaVar(); /* polymorphic */
2660 return mkDeltaVar(); /* polymorphic */
2662 printf("Kind: '%c'\n",k);
2663 internal("basicType");
2665 assert(0); return 0; /* NOTREACHED */
2668 /* Generate type of primop based on list of arg types and result types:
2670 * eg primType "II" "II" = Int -> Int -> (Int,Int)
2673 Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
2677 List tvars = NIL; /* for polymorphic types */
2682 /* build result types */
2683 for(; *r_kinds; ++r_kinds) {
2684 rs = cons(basicType(*r_kinds),rs);
2686 /* Construct tuple of results */
2687 if (length(rs) == 0) {
2689 } else if (length(rs) == 1) {
2692 r = mkTuple(length(rs));
2693 for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
2697 /* Construct list of arguments */
2698 for(; *a_kinds; ++a_kinds) {
2699 as = cons(basicType(*a_kinds),as);
2701 /* Apply any monad magic */
2702 if (monad == MONAD_IO) {
2704 } else if (monad == MONAD_ST) {
2705 r = ap2(typeST,mkStateVar(),r);
2707 /* glue it all together */
2708 for(; nonNull(as); as=tl(as)) {
2711 tvars = offsetTyvarsIn(r,NIL);
2712 if (nonNull(tvars)) {
2713 assert(length(tvars) == nextVar);
2714 r = mkPolyType(simpleKind(length(tvars)),r);
2718 printType(stdout,r); printf("\n");
2724 /* forall a1 .. am. TC a1 ... am -> Int */
2725 Type conToTagType(t)
2730 for (i=0; i<tycon(t).arity; ++i) {
2731 Offset tv = mkOffset(i);
2733 tvars = cons(tv,tvars);
2735 ty = fn(ty,typeInt);
2736 if (nonNull(tvars)) {
2737 ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2742 /* forall a1 .. am. Int -> TC a1 ... am */
2743 Type tagToConType(t)
2748 for (i=0; i<tycon(t).arity; ++i) {
2749 Offset tv = mkOffset(i);
2751 tvars = cons(tv,tvars);
2753 ty = fn(typeInt,ty);
2754 if (nonNull(tvars)) {
2755 ty = mkPolyType(simpleKind(tycon(t).arity),ty);
2760 /* --------------------------------------------------------------------------
2761 * Type checker control:
2762 * ------------------------------------------------------------------------*/
2764 Void typeChecker(what)
2767 case RESET : tcMode = EXPRESSION;
2775 case MARK : mark(defnBounds);
2791 mark(predFractional);
2801 setCurrModule(modulePrelude);
2802 dummyVar = inventVar();
2803 typeUnit = mkTuple(0);
2804 arrow = fn(aVar,bVar);
2805 listof = ap(typeList,aVar);
2806 boundPair = ap(ap(mkTuple(2),aVar),aVar);
2807 nameUnit = findQualNameWithoutConsultingExportList
2808 (mkQVar(findText("PrelBase"),
2810 typeVarToVar = fn(aVar,aVar);
2818 Module m = findFakeModule(findText("PrelBase"));
2821 starToStar = simpleKind(1);
2822 typeList = addPrimTycon(findText("[]"),
2826 listof = ap(typeList,aVar);
2827 nameNil = addPrimCfun(findText("[]"),0,1,
2828 mkPolyType(starToStar,
2830 nameCons = addPrimCfun(findText(":"),2,2,
2831 mkPolyType(starToStar,
2835 name(nameNil).parent =
2836 name(nameCons).parent = typeList;
2838 name(nameCons).syntax
2839 = mkSyntax(RIGHT_ASS,5);
2841 tycon(typeList).defn
2842 = cons(nameNil,cons(nameCons,NIL));
2845 dummyVar = inventVar();
2847 setCurrModule(modulePrelude);
2849 starToStar = simpleKind(1);
2851 typeUnit = findTycon(findText("()"));
2852 assert(nonNull(typeUnit));
2854 typeArrow = addPrimTycon(findText("(->)"),
2857 typeList = addPrimTycon(findText("[]"),
2861 arrow = fn(aVar,bVar);
2862 listof = ap(typeList,aVar);
2863 boundPair = ap(ap(mkTuple(2),aVar),aVar);
2865 nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
2866 tycon(typeUnit).defn
2867 = singleton(nameUnit);
2869 nameNil = addPrimCfun(findText("[]"),0,1,
2870 mkPolyType(starToStar,
2872 nameCons = addPrimCfun(findText(":"),2,2,
2873 mkPolyType(starToStar,
2877 name(nameNil).parent =
2878 name(nameCons).parent = typeList;
2880 name(nameCons).syntax
2881 = mkSyntax(RIGHT_ASS,5);
2883 tycon(typeList).defn
2884 = cons(nameNil,cons(nameCons,NIL));
2886 typeVarToVar = fn(aVar,aVar);
2888 typeNoRow = addPrimTycon(findText("EmptyRow"),
2889 ROW,0,DATATYPE,NIL);
2890 typeRec = addPrimTycon(findText("Rec"),
2893 nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
2894 ap(typeRec,typeNoRow));
2896 /* bogus definitions to avoid changing the prelude */
2897 addPrimCfun(findText("Rec"), 0,0,typeUnit);
2898 addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
2899 addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
2907 /*-------------------------------------------------------------------------*/