* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.16 $
- * $Date: 1999/11/23 15:12:06 $
+ * $Revision: 1.30 $
+ * $Date: 2000/03/13 11:37:17 $
* ------------------------------------------------------------------------*/
#include "prelude.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*/
/*#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 );
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))
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; {
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");
}
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;
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))));
}
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;
}
Int to;
Int tf;
Int i;
+#if IPARAM
+ List svPreds;
+#endif
instantiate(name(c).type);
for (; nonNull(predsAre); predsAre=tl(predsAre))
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--)
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);
}
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 */
}
for (; nonNull(mems); mems=tl(mems)) {
- static String deftext = "default_";
+ /* static String deftext = "default_"; */
+ static String deftext = "$dm";
String s = textToStr(name(hd(mems)).text);
Name n;
+ i = j = 0;
for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
buf[i] = deftext[i];
}
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);
locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
name(inst(in).builder).defn /* Register builder imp */
- = singleton(pair(args,ap(LETREC,pair(singleton(locs),
- ap(l,d)))));
+ = singleton(pair(args,ap(LETREC,pair(singleton(locs),
+ ap(l,d)))));
+
+ /* 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;
+ Cell pp = NIL;
+ static String zdftext = "$f";
+
+ while (isAp(qq)) {
+ pp = cons(arg(qq),pp);
+ qq = fun(qq);
+ }
+ // pp is now the fwd list of args(?) to this pred
+
+ i = 0;
+ for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
+ buf[i] = zdftext[j];
+ }
+ str = textToStr(cclass(inst(in).c).text);
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ if (nonNull(pp)) {
+ qq = hd(pp);
+ while (isAp(qq)) qq = fun(qq);
+ switch (whatIs(qq)) {
+ case TYCON: str = textToStr(tycon(qq).text); break;
+ case TUPLE: str = textToStr(ghcTupleText(qq)); break;
+ case OFFSET: sprintf(buf2,"%d",offsetOf(qq));
+ str = buf2;
+ break;
+ default: internal("typeInstDefn: making GHC name"); break;
+ }
+ for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
+ buf[i] = str[j];
+ }
+ }
+
+ buf[i++] = '\0';
+ name(inst(in).builder).text = findText(buf);
+ //fprintf ( stderr, "result = %s\n", buf );
+ }
+
genDefns = cons(inst(in).builder,genDefns);
}
static String guarded = "guarded expression";
static String guard = "guard";
Int line = intOf(fst(gded));
+#if IPARAM
+ List svPreds;
+#endif
gded = snd(gded);
- check(line,fst(gded),NIL,guard,typeBool,0);
- check(line,snd(gded),NIL,guarded,aVar,beta);
+ spCheck(line,fst(gded),NIL,guard,typeBool,0);
+ spCheck(line,snd(gded),NIL,guarded,aVar,beta);
}
Cell rhsExpr(rhs) /* find first expression on a rhs */
* Local function prototypes:
* ------------------------------------------------------------------------*/
-static Type local basicType Args((Char));
+static Type local basicType ( Char );
static Type stateVar = NIL;
assert(length(tvars) == nextVar);
r = mkPolyType(simpleKind(length(tvars)),r);
}
-#if DEBUG_CODE
- if (debugCode) {
- printType(stdout,r); printf("\n");
- }
-#endif
return r;
}
Int what; {
switch (what) {
case RESET : tcMode = EXPRESSION;
-+ daSccs = NIL;
+ daSccs = NIL;
preds = NIL;
pendingBtyvs = NIL;
daSccs = NIL;
mark(typeProgIO);
break;
- case INSTALL : typeChecker(RESET);
- dummyVar = inventVar();
-
- setCurrModule(modulePrelude);
-
- starToStar = simpleKind(1);
-
- typeUnit = addPrimTycon(findText("()"),
- STAR,0,DATATYPE,NIL);
- typeArrow = addPrimTycon(findText("(->)"),
- simpleKind(2),2,
- DATATYPE,NIL);
- typeList = addPrimTycon(findText("[]"),
- starToStar,1,
- DATATYPE,NIL);
-
- arrow = fn(aVar,bVar);
- listof = ap(typeList,aVar);
- boundPair = ap(ap(mkTuple(2),aVar),aVar);
-
- nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
- tycon(typeUnit).defn
- = singleton(nameUnit);
-
- nameNil = addPrimCfun(findText("[]"),0,1,
- mkPolyType(starToStar,
- listof));
- nameCons = addPrimCfun(findText(":"),2,2,
- mkPolyType(starToStar,
- fn(aVar,
- fn(listof,
- listof))));
- name(nameNil).parent =
- name(nameCons).parent = typeList;
-
- name(nameCons).syntax
- = mkSyntax(RIGHT_ASS,5);
-
- tycon(typeList).defn
- = cons(nameNil,cons(nameCons,NIL));
-
- typeVarToVar = fn(aVar,aVar);
+ case POSTPREL:
+
+ if (combined) {
+ setCurrModule(modulePrelude);
+ dummyVar = inventVar();
+ typeUnit = mkTuple(0);
+ arrow = fn(aVar,bVar);
+ listof = ap(typeList,aVar);
+ boundPair = ap(ap(mkTuple(2),aVar),aVar);
+ nameUnit = findQualNameWithoutConsultingExportList
+ (mkQVar(findText("PrelBase"),
+ findText("()")));
+ typeVarToVar = fn(aVar,aVar);
+ }
+ break;
+
+ case PREPREL :
+ typeChecker(RESET);
+
+ if (combined) {
+ Module m = findFakeModule(findText("PrelBase"));
+ setCurrModule(m);
+
+ starToStar = simpleKind(1);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
+
+ listof = ap(typeList,aVar);
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
+
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
+ } else {
+ dummyVar = inventVar();
+
+ setCurrModule(modulePrelude);
+
+ starToStar = simpleKind(1);
+
+ typeUnit = findTycon(findText("()"));
+ assert(nonNull(typeUnit));
+
+ typeArrow = addPrimTycon(findText("(->)"),
+ simpleKind(2),2,
+ DATATYPE,NIL);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
+
+ arrow = fn(aVar,bVar);
+ listof = ap(typeList,aVar);
+ boundPair = ap(ap(mkTuple(2),aVar),aVar);
+
+ nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
+ tycon(typeUnit).defn
+ = singleton(nameUnit);
+
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
+
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
+ typeVarToVar = fn(aVar,aVar);
#if TREX
- typeNoRow = addPrimTycon(findText("EmptyRow"),
- ROW,0,DATATYPE,NIL);
- typeRec = addPrimTycon(findText("Rec"),
- pair(ROW,STAR),1,
- DATATYPE,NIL);
- nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
- ap(typeRec,typeNoRow));
+ typeNoRow = addPrimTycon(findText("EmptyRow"),
+ ROW,0,DATATYPE,NIL);
+ typeRec = addPrimTycon(findText("Rec"),
+ pair(ROW,STAR),1,
+ DATATYPE,NIL);
+ nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
+ ap(typeRec,typeNoRow));
#else
- /* bogus definitions to avoid changing the prelude */
- addPrimCfun(findText("Rec"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
+ /* bogus definitions to avoid changing the prelude */
+ addPrimCfun(findText("Rec"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
#endif
- break;
+ }
+ break;
+
}
}
projects / ghc-hetmet.git / blobdiff