X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Ftype.c;h=9ce98030dfe2837396986d36be65a759788193c4;hb=1211c4e59dd9c4f5e7b027649a1e3c6eb459f5e1;hp=fec44e1f15a3aacbcb7f8064190443ac7fa01e40;hpb=8e01a7198ab0e0d15621af77cb9d5f38f25577b5;p=ghc-hetmet.git diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index fec44e1..9ce9803 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,17 +9,16 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.24 $ - * $Date: 2000/03/06 08:38:05 $ + * $Revision: 1.36 $ + * $Date: 2000/05/26 17:42:18 $ * ------------------------------------------------------------------------*/ -#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 "Rts.h" /* to make StgPtr visible in Assembler.h */ #include "Assembler.h" /* for AsmCTypes */ /*#define DEBUG_TYPES*/ @@ -28,87 +27,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 +145,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 +542,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 +723,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 +801,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)); } } @@ -1139,6 +1135,7 @@ List qs; { case FROMQUAL : { Int beta = newTyvars(1); saveVarsAss(); + enterPendingBtyvs(); spCheck(l,snd(snd(q)),NIL,genQual,m,beta); enterSkolVars(); fst(snd(q)) @@ -1146,7 +1143,7 @@ List qs; { shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta); typeComp(l,m,e,qs1); restoreVarsAss(); - doneBtyvs(l); + leavePendingBtyvs(); leaveSkolVars(l,typeIs,typeOff,0); } break; @@ -1963,6 +1960,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; @@ -1983,12 +1981,15 @@ Inst in; { /* member functions for instance in*/ for (j = 0; i