X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftype.c;h=eb2d2d9f4050187ddd5ee6ad8a28b82fec06e00f;hb=9579283cadf4ac68a6f4252244041b5127e16811;hp=bb7d86f38c503dd15f9e75ee3ddfc9f167af30fc;hpb=51c33894862dfd591d71018a70f4ca3914b17f7b;p=ghc-hetmet.git diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index bb7d86f..eb2d2d9 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,17 +9,15 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.19 $ - * $Date: 1999/12/10 15:59:57 $ + * $Revision: 1.34 $ + * $Date: 2000/04/06 14:23:55 $ * ------------------------------------------------------------------------*/ -#include "prelude.h" +#include "hugsbasictypes.h" #include "storage.h" -#include "backend.h" #include "connect.h" -#include "link.h" #include "errors.h" -#include "subst.h" + #include "Assembler.h" /* for AsmCTypes */ /*#define DEBUG_TYPES*/ @@ -28,87 +26,82 @@ /*#define DEBUG_SELS*/ /*#define DEBUG_DEPENDS*/ /*#define DEBUG_DERIVING*/ -/*#define DEBUG_CODE*/ - -Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */ - /* types produce error */ - /* -------------------------------------------------------------------------- * Local function prototypes: * ------------------------------------------------------------------------*/ -static Void local emptyAssumption Args((Void)); -static Void local enterBindings Args((Void)); -static Void local leaveBindings Args((Void)); -static Int local defType Args((Cell)); -static Type local useType Args((Cell)); -static Void local markAssumList Args((List)); -static Cell local findAssum Args((Text)); -static Pair local findInAssumList Args((Text,List)); -static List local intsIntersect Args((List,List)); -static List local genvarAllAss Args((List)); -static List local genvarAnyAss Args((List)); -static Int local newVarsBind Args((Cell)); -static Void local newDefnBind Args((Cell,Type)); - -static Void local enterPendingBtyvs Args((Void)); -static Void local leavePendingBtyvs Args((Void)); -static Cell local patBtyvs Args((Cell)); -static Void local doneBtyvs Args((Int)); -static Void local enterSkolVars Args((Void)); -static Void local leaveSkolVars Args((Int,Type,Int,Int)); - -static Void local typeError Args((Int,Cell,Cell,String,Type,Int)); -static Void local reportTypeError Args((Int,Cell,Cell,String,Type,Type)); -static Void local cantEstablish Args((Int,String,Cell,Type,List)); -static Void local tooGeneral Args((Int,Cell,Type,Type)); - -static Cell local typeExpr Args((Int,Cell)); - -static Cell local typeAp Args((Int,Cell)); -static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool)); -static Void local typeAlt Args((String,Cell,Cell,Type,Int,Int)); -static Int local funcType Args((Int)); -static Void local typeCase Args((Int,Int,Cell)); -static Void local typeComp Args((Int,Type,Cell,List)); -static Cell local typeMonadComp Args((Int,Cell)); -static Void local typeDo Args((Int,Cell)); -static Void local typeConFlds Args((Int,Cell)); -static Void local typeUpdFlds Args((Int,Cell)); +static Void local emptyAssumption ( Void ); +static Void local enterBindings ( Void ); +static Void local leaveBindings ( Void ); +static Int local defType ( Cell ); +static Type local useType ( Cell ); +static Void local markAssumList ( List ); +static Cell local findAssum ( Text ); +static Pair local findInAssumList ( Text,List ); +static List local intsIntersect ( List,List ); +static List local genvarAllAss ( List ); +static List local genvarAnyAss ( List ); +static Int local newVarsBind ( Cell ); +static Void local newDefnBind ( Cell,Type ); + +static Void local enterPendingBtyvs ( Void ); +static Void local leavePendingBtyvs ( Void ); +static Cell local patBtyvs ( Cell ); +static Void local doneBtyvs ( Int ); +static Void local enterSkolVars ( Void ); +static Void local leaveSkolVars ( Int,Type,Int,Int ); + +static Void local typeError ( Int,Cell,Cell,String,Type,Int ); +static Void local reportTypeError ( Int,Cell,Cell,String,Type,Type ); +static Void local cantEstablish ( Int,String,Cell,Type,List ); +static Void local tooGeneral ( Int,Cell,Type,Type ); + +static Cell local typeExpr ( Int,Cell ); + +static Cell local typeAp ( Int,Cell ); +static Type local typeExpected ( Int,String,Cell,Type,Int,Int,Bool ); +static Void local typeAlt ( String,Cell,Cell,Type,Int,Int ); +static Int local funcType ( Int ); +static Void local typeCase ( Int,Int,Cell ); +static Void local typeComp ( Int,Type,Cell,List ); +static Cell local typeMonadComp ( Int,Cell ); +static Void local typeDo ( Int,Cell ); +static Void local typeConFlds ( Int,Cell ); +static Void local typeUpdFlds ( Int,Cell ); #if IPARAM -static Cell local typeWith Args((Int,Cell)); +static Cell local typeWith ( Int,Cell ); #endif -static Cell local typeFreshPat Args((Int,Cell)); +static Cell local typeFreshPat ( Int,Cell ); -static Void local typeBindings Args((List)); -static Void local removeTypeSigs Args((Cell)); +static Void local typeBindings ( List ); +static Void local removeTypeSigs ( Cell ); -static Void local monorestrict Args((List)); -static Void local restrictedBindAss Args((Cell)); -static Void local restrictedAss Args((Int,Cell,Type)); +static Void local monorestrict ( List ); +static Void local restrictedBindAss ( Cell ); +static Void local restrictedAss ( Int,Cell,Type ); -static Void local unrestricted Args((List)); -static List local itbscc Args((List)); -static Void local addEvidParams Args((List,Cell)); +static Void local unrestricted ( List ); +static List local itbscc ( List ); +static Void local addEvidParams ( List,Cell ); -static Void local typeClassDefn Args((Class)); -static Void local typeInstDefn Args((Inst)); -static Void local typeMember Args((String,Name,Cell,List,Cell,Int)); +static Void local typeClassDefn ( Class ); +static Void local typeInstDefn ( Inst ); +static Void local typeMember ( String,Name,Cell,List,Cell,Int ); -static Void local typeBind Args((Cell)); -static Void local typeDefAlt Args((Int,Cell,Pair)); -static Cell local typeRhs Args((Cell)); -static Void local guardedType Args((Int,Cell)); +static Void local typeBind ( Cell ); +static Void local typeDefAlt ( Int,Cell,Pair ); +static Cell local typeRhs ( Cell ); +static Void local guardedType ( Int,Cell ); -static Void local genBind Args((List,Cell)); -static Void local genAss Args((Int,List,Cell,Type)); -static Type local genTest Args((Int,Cell,List,Type,Type,Int)); -static Type local generalize Args((List,Type)); -static Bool local equalTypes Args((Type,Type)); +static Void local genBind ( List,Cell ); +static Void local genAss ( Int,List,Cell,Type ); +static Type local genTest ( Int,Cell,List,Type,Type,Int ); +static Type local generalize ( List,Type ); +static Bool local equalTypes ( Type,Type ); -static Void local typeDefnGroup Args((List)); -static Pair local typeSel Args((Name)); +static Void local typeDefnGroup ( List ); +static Pair local typeSel ( Name ); @@ -151,6 +144,10 @@ static List localEvs; /*::[[(Pred,offset,ev)]] */ static List savedPs; /*::[[(Pred,offset,ev)]] */ static Cell dummyVar; /* Used to put extra tvars into ass*/ +Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */ + /* types produce error */ + + #define saveVarsAss() List saveAssump = hd(varsBounds) #define restoreVarsAss() hd(varsBounds) = saveAssump #define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),hd(varsBounds)) @@ -544,7 +541,7 @@ Type dt, it; { static int tcMode = EXPRESSION; #ifdef DEBUG_TYPES -static Cell local mytypeExpr Args((Int,Cell)); +static Cell local mytypeExpr ( Int,Cell)); static Cell local typeExpr(l,e) Int l; Cell e; { @@ -725,12 +722,10 @@ Cell e; { case LAZYPAT : snd(e) = typeExpr(l,snd(e)); break; -#if NPLUSK case ADDPAT : { Int alpha = newTyvars(1); inferType(typeVarToVar,alpha); return ap(e,assumeEvid(predIntegral,alpha)); } -#endif default : internal("typeExpr"); } @@ -805,7 +800,7 @@ Cell e; { /* requires polymorphism, qualified*/ for (; nonNull(predsAre); predsAre=tl(predsAre)) { evs = cons(assumeEvid(hd(predsAre),typeOff),evs); } - if (!isName(h) || !isCfun(h)) { + /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ { h = applyToArgs(h,rev(evs)); } } @@ -1114,15 +1109,18 @@ Cell e; List qs; { static String boolQual = "boolean qualifier"; static String genQual = "generator"; +#if IPARAM + List svPreds; +#endif STACK_CHECK - if (isNull(qs)) /* no qualifiers left */ - fst(e) = typeExpr(l,fst(e)); - else { + if (isNull(qs)) { /* no qualifiers left */ + spTypeExpr(l,fst(e)); + } else { Cell q = hd(qs); List qs1 = tl(qs); switch (whatIs(q)) { - case BOOLQUAL : check(l,snd(q),NIL,boolQual,typeBool,0); + case BOOLQUAL : spCheck(l,snd(q),NIL,boolQual,typeBool,0); typeComp(l,m,e,qs1); break; @@ -1136,7 +1134,7 @@ List qs; { case FROMQUAL : { Int beta = newTyvars(1); saveVarsAss(); - check(l,snd(snd(q)),NIL,genQual,m,beta); + spCheck(l,snd(snd(q)),NIL,genQual,m,beta); enterSkolVars(); fst(snd(q)) = typeFreshPat(l,patBtyvs(fst(snd(q)))); @@ -1148,7 +1146,7 @@ List qs; { } break; - case DOQUAL : check(l,snd(q),NIL,genQual,m,newTyvars(1)); + case DOQUAL : spCheck(l,snd(q),NIL,genQual,m,newTyvars(1)); typeComp(l,m,e,qs1); break; } @@ -1199,6 +1197,9 @@ Cell e; { Int to; Int tf; Int i; +#if IPARAM + List svPreds; +#endif instantiate(name(c).type); for (; nonNull(predsAre); predsAre=tl(predsAre)) @@ -1217,7 +1218,7 @@ Cell e; { if (isPolyOrQualType(t)) snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE); else { - check(l,snd(hd(fs)),e,conExpr,t,to); + spCheck(l,snd(hd(fs)),e,conExpr,t,to); } } for (i=name(c).arity; i>0; i--) @@ -1236,10 +1237,13 @@ Cell e; { /* bizarre manner for the benefit */ Int alpha = newTyvars(2+n); Int i; List fs1; +#if IPARAM + List svPreds; +#endif /* Calculate type and translation for each expr in the field list */ for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) { - snd(hd(fs1)) = typeExpr(line,snd(hd(fs1))); + spTypeExpr(line,snd(hd(fs1))); bindTv(i,typeIs,typeOff); } @@ -1256,7 +1260,7 @@ Cell e; { /* bizarre manner for the benefit */ ts = rev(ts); /* Type check expression to be updated */ - fst3(snd(e)) = typeExpr(line,fst3(snd(e))); + spTypeExpr(line,fst3(snd(e))); bindTv(alpha,typeIs,typeOff); for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */ @@ -1861,8 +1865,11 @@ Inst in; { /* member functions for instance in*/ Int beta = newKindedVars(inst(in).kinds); List params = makePredAss(inst(in).specifics,beta); Cell d = inventDictVar(); + /* List evids = cons(triple(inst(in).head,mkInt(beta),d), appendOnto(dupList(params),supers)); + */ + List evids = dupList(params); List imps = inst(in).implements; Cell l = mkInt(inst(in).line); @@ -1951,6 +1958,7 @@ Inst in; { /* member functions for instance in*/ /* Invent a GHC-compatible name for the instance decl */ { char buf[FILENAME_MAX+1]; + char buf2[10]; Int i, j; String str; Cell qq = inst(in).head; @@ -1971,12 +1979,15 @@ Inst in; { /* member functions for instance in*/ for (j = 0; i)"), simpleKind(2),2, DATATYPE,NIL);