* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/15 23:52:00 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/16 02:17:30 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Int defaultLine; /* line in which default defs occur*/
extern List evalDefaults; /* defaults for evaluator */
extern Cell inputExpr; /* evaluator input expression */
+extern Cell inputContext; /* evaluator input expression */
extern Addr inputCode; /* Code for compiled input expr */
extern Int whnfArgs; /* number of args of term in whnf */
#if DEBUG_CODE
extern Bool debugCode; /* TRUE => print G-code to screen */
#endif
+#if DEBUG_SHOWSC
+extern Bool debugSC; /* TRUE => print SC to screen */
+extern Void printSc Args((FILE*, Text, Int, Cell));
+#endif
extern Bool kindExpert; /* TRUE => display kind errors in */
/* full detail */
extern Bool allowOverlap; /* TRUE => allow overlapping insts */
extern Type fullExpand Args((Type));
extern Bool isAmbiguous Args((Type));
extern Void ambigError Args((Int,String,Cell,Type));
-extern Void classDefn Args((Int,Cell,Cell));
+extern Void classDefn Args((Int,Cell,List,List));
extern Void instDefn Args((Int,Cell,Cell));
extern Void addTupInst Args((Class,Int));
#if TREX
extern Inst addRecShowInst Args((Class,Ext));
extern Inst addRecEqInst Args((Class,Ext));
#endif
+extern List oclose Args((List,List));
+extern List zonkTyvarsIn Args((Type,List));
+extern Type zonkTyvar Args((Int));
+extern Type zonkType Args((Type,Int));
extern Void primDefn Args((Cell,List,Cell));
extern Void defaultDefn Args((Int,List));
extern Void checkExp Args((Void));
extern Void gcRecovered Args((Int));
extern Void gcCStack Args((Void));
extern Void needPrims Args((Int));
+extern List calcFunDepsPreds Args((List));
+extern Inst findInstFor Args((Cell,Int));
extern Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds );
#define aVar mkOffset(0) /* Simple skeleton for type var */
extern Void interface Args((Int));
-extern List typeVarsIn Args((Cell,List,List));
-
extern Void getFileSize Args((String, Long *));
extern Void loadInterface Args((String,Long));
* included in the distribution.
*
* $RCSfile: errors.h,v $
- * $Revision: 1.4 $
- * $Date: 1999/10/15 21:41:05 $
+ * $Revision: 1.5 $
+ * $Date: 1999/10/16 02:17:28 $
* ------------------------------------------------------------------------*/
extern Void internal Args((String)) HUGS_noreturn;
#define ERRPRED(pi) Hilite(); printPred(errorStream,pi); Lolite()
#define ERRKIND(k) Hilite(); printKind(errorStream,k); Lolite()
#define ERRKINDS(ks) Hilite(); printKinds(errorStream,ks); Lolite()
+#define ERRFD(fd) Hilite(); printFD(errorStream,fd); Lolite()
extern Void errHead Args((Int)); /* in main.c */
extern Void errFail Args((Void)) HUGS_noreturn;
extern Void printPred Args((FILE *,Cell));
extern Void printKind Args((FILE *,Kind));
extern Void printKinds Args((FILE *,Kinds));
+extern Void printFD Args((FILE *,Pair));
/*-------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: output.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/10/15 21:40:53 $
+ * $Revision: 1.7 $
+ * $Date: 1999/10/16 02:17:28 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
putKinds(ks);
}
+Void printFD(fp,fd) /* print functional dependency */
+FILE* fp;
+Pair fd; {
+ List us;
+ outputStream = fp;
+ for (us=fst(fd); nonNull(us); us=tl(us)) {
+ putTyVar(offsetOf(hd(us)));
+ if (nonNull(tl(us))) {
+ putChr(' ');
+ }
+ }
+ putStr(" -> ");
+ for (us=snd(fd); nonNull(us); us=tl(us)) {
+ putTyVar(offsetOf(hd(us)));
+ if (nonNull(tl(us))) {
+ putChr(' ');
+ }
+ }
+}
+
/*-------------------------------------------------------------------------*/
* in the distribution for details.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 23:52:01 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/16 02:17:29 $
* ------------------------------------------------------------------------*/
%{
/*- Class declarations: ---------------------------------------------------*/
-topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3); sp-=3;}
+topDecl : TCLASS crule wherePart {classDefn(intOf($1),$2,$3,NIL); sp-=3;}
| TINSTANCE irule wherePart {instDefn(intOf($1),$2,$3); sp-=3;}
| DEFAULT '(' dtypes ')' {defaultDefn(intOf($1),$3); sp-=4;}
| TCLASS error {syntaxError("class declaration");}
* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/15 21:40:55 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/16 02:17:30 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Type local instantiateSyn Args((Type,Type));
static Void local checkClassDefn Args((Class));
-static Void local depPredExp Args((Int,List,Cell));
+static Cell local depPredExp Args((Int,List,Cell));
static Void local checkMems Args((Class,List,Cell));
static Void local addMembers Args((Class));
static Name local newMember Args((Int,Int,Cell,Type,Class));
static Name local newDSel Args((Class,Int));
-static Name local newDBuild Args((Class));
static Text local generateText Args((String,Class));
static Int local visitClass Args((Class));
static Name local memberName Args((Class,Text));
static List local numInsert Args((Int,Cell,List));
+static List local typeVarsIn Args((Cell,List,List,List));
static List local maybeAppendVar Args((Cell,List));
static Type local checkSigType Args((Int,String,Cell,Type));
+static Void local checkOptQuantVars Args((Int,List,List));
static Type local depTopType Args((Int,List,Type));
static Type local depCompType Args((Int,List,Type));
static Type local depTypeExp Args((Int,List,Type));
static Type local depTypeVar Args((Int,List,Text));
static List local checkQuantVars Args((Int,List,List,Cell));
+static List local otvars Args((Cell,List));
+static Bool local osubset Args((List,List));
static Void local kindConstr Args((Int,Int,Int,Constr));
static Kind local kindAtom Args((Int,Constr));
static Void local kindPred Args((Int,Int,Int,Cell));
static Void local initDerInst Args((Inst));
static Void local calcInstPreds Args((Inst));
static Void local maybeAddPred Args((Cell,Int,Int,List));
+static List local calcFunDeps Args((List));
static Cell local copyAdj Args((Cell,Int,Int));
static Void local tidyDerInst Args((Inst));
+static List local otvarsZonk Args((Cell,List,Int));
static Void local addDerivImp Args((Inst));
static Void local depConFlds Args((Int,Cell,Bool));
static Void local depUpdFlds Args((Int,Cell));
static List local depFields Args((Int,Cell,List,Bool));
+#if IPARAM
+static Void local depWith Args((Int,Cell));
+static List local depDwFlds Args((Int,Cell,List));
+#endif
#if TREX
static Cell local depRecord Args((Int,Cell));
#endif
static Void local addRSsigdecls Args((Pair));
static Void local allNoPrevDef Args((Cell));
static Void local noPrevDef Args((Int,Cell));
+static Bool local odiff Args((List,List));
+
static Void local duplicateErrorAux Args((Int,Module,Text,String));
#define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
static Void local checkTypeIn Args((Pair));
EEND;
}
}
- return 0; /* NOTREACHED */
+ return exports; /* NOTUSED */
}
static List local checkExports(exports)
for (i=0; i<tycon(t).arity; ++i) /* build representation for tycon */
lhs = ap(lhs,mkOffset(i)); /* applied to full comp. of args */
- if (whatIs(cs)==QUAL) { /* allow for possible context */
+ if (isQualType(cs)) { /* allow for possible context */
ctxt = fst(snd(cs));
cs = snd(snd(cs));
- map2Proc(depPredExp,line,tyvars,ctxt);
+ map2Over(depPredExp,line,tyvars,ctxt);
h98CheckCtxt(line,"context",TRUE,ctxt,NIL);
}
sig = checkQuantVars(line,evs,sig,con);
}
- if (whatIs(con)==QUAL) { /* Local predicates */
+ if (isQualType(con)) { /* Local predicates */
List us;
lps = fst(snd(con));
- for (us = typeVarsIn(lps,NIL,NIL); nonNull(us); us=tl(us))
+ for (us = typeVarsIn(lps,NIL,NIL,NIL); nonNull(us); us=tl(us))
if (!varIsMember(textOf(hd(us)),evs)) {
ERRMSG(line)
"Variable \"%s\" in constraint is not locally bound",
textToStr(textOf(hd(us)))
EEND;
}
- map2Proc(depPredExp,line,sig,lps);
+ map2Over(depPredExp,line,sig,lps);
con = snd(snd(con));
arity = length(lps);
}
Type ty = fun(con);
Type cmp = arg(con);
fun(con) = typeArrow;
- if (isPolyType(cmp)) {
+ if (isPolyOrQualType(cmp)) {
if (nonNull(derivs)) {
ERRMSG(line) "Cannot derive instances for types" ETHEN
- ERRTEXT " with polymorphic components"
+ ERRTEXT " with polymorphic or qualified components"
EEND;
}
if (nr2==0)
* stages of static analysis.
* ------------------------------------------------------------------------*/
-Void classDefn(line,head,ms) /* process new class definition */
-Int line; /* definition line number */
-Cell head; /* class header :: ([Supers],Class) */
-List ms; { /* class definition body */
+Void classDefn(line,head,ms,fds) /* process new class definition */
+Int line; /* definition line number */
+Cell head; /* class header :: ([Supers],Class) */
+List ms; /* class definition body */
+List fds; { /* functional dependencies */
Text ct = textOf(getHead(snd(head)));
Int arity = argCount;
if (nonNull(findClass(ct))) {
- ERRMSG(line) "Repeated definition of class \"%s\"",
- textToStr(ct)
- EEND;
+ ERRMSG(line) "Repeated definition of class \"%s\"",
+ textToStr(ct)
+ EEND;
} else if (nonNull(findTycon(ct))) {
- ERRMSG(line) "\"%s\" used as both class and type constructor",
- textToStr(ct)
- EEND;
+ ERRMSG(line) "\"%s\" used as both class and type constructor",
+ textToStr(ct)
+ EEND;
} else {
- Class nw = newClass(ct);
- cclass(nw).line = line;
- cclass(nw).arity = arity;
- cclass(nw).head = snd(head);
- cclass(nw).supers = fst(head);
- cclass(nw).members = ms;
- cclass(nw).level = 0;
- classDefns = cons(nw,classDefns);
- if (arity!=1)
- h98DoesntSupport(line,"multiple parameter classes");
+ Class nw = newClass(ct);
+ cclass(nw).line = line;
+ cclass(nw).arity = arity;
+ cclass(nw).head = snd(head);
+ cclass(nw).supers = fst(head);
+ cclass(nw).members = ms;
+ cclass(nw).level = 0;
+ cclass(nw).fds = fds;
+ classDefns = cons(nw,classDefns);
+ if (arity!=1)
+ h98DoesntSupport(line,"multiple parameter classes");
}
}
tyvars = cons(arg(temp),tyvars);
}
- for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
- arg(temp) = mkOffset(args);
+ for (fs=cclass(c).fds; nonNull(fs); fs=tl(fs)) {
+ Pair fd = hd(fs);
+ List vs = snd(fd);
+
+ /* Check for trivial dependency
+ */
+ if (isNull(snd(fd))) {
+ ERRMSG(cclass(c).line) "Functional dependency is trivial"
+ EEND;
+ }
+
+ /* Check for duplicated vars on right hand side, and for vars on
+ * right that also appear on the left:
+ */
+ for (vs=snd(fd); nonNull(vs); vs=tl(vs)) {
+ if (varIsMember(textOf(hd(vs)),fst(fd))) {
+ ERRMSG(cclass(c).line)
+ "Trivial dependency for variable \"%s\"",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ if (varIsMember(textOf(hd(vs)),tl(vs))) {
+ ERRMSG(cclass(c).line)
+ "Repeated variable \"%s\" in functional dependency",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
+ }
+
+ /* Check for duplicated vars on left hand side:
+ */
+ for (vs=fst(fd); nonNull(vs); vs=tl(vs)) {
+ if (varIsMember(textOf(hd(vs)),tl(vs))) {
+ ERRMSG(cclass(c).line)
+ "Repeated variable \"%s\" in functional dependency",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
+ }
+ }
+
+ if (cclass(c).arity==0) {
+ cclass(c).head = c;
+ } else {
+ Int args = cclass(c).arity - 1;
+ for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
+ arg(temp) = mkOffset(args);
+ }
+ arg(temp) = mkOffset(0);
+ fun(temp) = c;
}
- arg(temp) = mkOffset(0);
- fun(temp) = c;
- tcDeps = NIL; /* find dependents */
- map2Proc(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
+ tcDeps = NIL; /* find dependents */
+ map2Over(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL);
cclass(c).numSupers = length(cclass(c).supers);
cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/
tcDeps = NIL;
}
-static Void local depPredExp(line,tyvars,pred)
+static Cell local depPredExp(line,tyvars,pred)
Int line;
List tyvars;
Cell pred; {
- Int args = 1; /* parser guarantees >=1 args */
- Cell h = fun(pred);
+ Int args = 0;
+ Cell prev = NIL;
+ Cell h = pred;
for (; isAp(h); args++) {
- arg(pred) = depTypeExp(line,tyvars,arg(pred));
- pred = h;
- h = fun(pred);
+ arg(h) = depTypeExp(line,tyvars,arg(h));
+ prev = h;
+ h = fun(h);
+ }
+
+ if (args==0) {
+ h98DoesntSupport(line,"tag classes");
+ } else if (args!=1) {
+ h98DoesntSupport(line,"multiple parameter classes");
}
- arg(pred) = depTypeExp(line,tyvars,arg(pred));
- if (args!=1)
- h98DoesntSupport(line,"multiple parameter classes");
if (isQCon(h)) { /* standard class constraint */
Class c = findQualClass(h);
ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
EEND;
}
- fun(pred) = c;
+ if (isNull(prev)) {
+ pred = c;
+ } else {
+ fun(prev) = c;
+ }
if (args!=cclass(c).arity) {
ERRMSG(line) "Wrong number of arguments for class \"%s\"",
textToStr(cclass(c).text)
}
}
#endif
- else { /* check for other kinds of pred */
- internal("depPredExp"); /* ... but there aren't any! */
+ else
+#if IPARAM
+ if (whatIs(h) != IPCELL)
+#endif
+ {
+ internal("depPredExp");
}
+ return pred;
}
static Void local checkMems(c,tyvars,m) /* check member function details */
Type t = thd3(m);
List sig = NIL;
List tvs = NIL;
+ List xtvs = NIL;
+
+ if (isPolyType(t)) {
+ xtvs = fst(snd(t));
+ t = monotypeOf(t);
+ }
+
- tyvars = typeVarsIn(t,NIL,tyvars);/* Look for extra type vars. */
+ tyvars = typeVarsIn(t,NIL,xtvs,tyvars);
+ /* Look for extra type vars. */
+ checkOptQuantVars(line,xtvs,tyvars);
- if (whatIs(t)==QUAL) { /* Overloaded member signatures? */
- map2Proc(depPredExp,line,tyvars,fst(snd(t)));
+ if (isQualType(t)) { /* Overloaded member signatures? */
+ map2Over(depPredExp,line,tyvars,fst(snd(t)));
} else {
t = ap(QUAL,pair(NIL,t));
}
for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify */
sig = ap(NIL,sig);
}
- t = mkPolyType(sig,t);
+ if (nonNull(sig)) {
+ t = mkPolyType(sig,t);
+ }
thd3(m) = t; /* Save type */
take(cclass(c).arity,tyvars); /* Delete extra type vars */
if (mno==1) { /* Single entry dicts use newtype */
name(cclass(c).dcon).defn = nameId;
- name(hd(cclass(c).members)).number = mfunNo(0);
+ if (nonNull(cclass(c).members)) {
+ name(hd(cclass(c).members)).number = mfunNo(0);
+ }
}
- cclass(c).dbuild = newDBuild(c);
cclass(c).defaults = classBindings("class",c,cclass(c).defaults);
}
return s;
}
-static Name local newDBuild(c) /* Make definition for builder */
-Class c; {
- Name b = newName(generateText("class.%s",c),c);
- name(b).line = cclass(c).line;
- name(b).arity = cclass(c).numSupers+1;
- return b;
-}
-
#define MAX_GEN 128
static Text local generateText(sk,c) /* We need to generate names for */
* occur in the type expression when read from left to right.
* ------------------------------------------------------------------------*/
-List typeVarsIn(ty,us,vs) /* Calculate list of type variables*/
-Cell ty; /* used in type expression, reading*/
-List us; /* from left to right ignoring any */
-List vs; { /* listed in us. */
+static List local typeVarsIn(ty,us,ws,vs)/*Calculate list of type variables*/
+Cell ty; /* used in type expression, reading*/
+List us; /* from left to right ignoring any */
+List ws; /* listed in us. */
+List vs; { /* ws = explicitly quantified vars */
switch (whatIs(ty)) {
- case AP : return typeVarsIn(snd(ty),us,
- typeVarsIn(fst(ty),us,vs));
+ case AP : return typeVarsIn(snd(ty),us,ws,
+ typeVarsIn(fst(ty),us,ws,vs));
- case VARIDCELL :
- case VAROPCELL : if (nonNull(findBtyvs(textOf(ty)))
- || varIsMember(textOf(ty),us)) {
- return vs;
- } else {
- return maybeAppendVar(ty,vs);
- }
+ case VARIDCELL :
+ case VAROPCELL : if ((nonNull(findBtyvs(textOf(ty)))
+ && !varIsMember(textOf(ty),ws))
+ || varIsMember(textOf(ty),us)) {
+ return vs;
+ } else {
+ return maybeAppendVar(ty,vs);
+ }
- case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),vs);
+ case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs);
- case QUAL : { List qs = fst(snd(ty));
- for (; nonNull(qs); qs=tl(qs)) {
- vs = typeVarsIn(hd(qs),us,vs);
- }
- return typeVarsIn(snd(snd(ty)),us,vs);
- }
+ case QUAL : { vs = typeVarsIn(fst(snd(ty)),us,ws,vs);
+ return typeVarsIn(snd(snd(ty)),us,ws,vs);
+ }
- case BANG : return typeVarsIn(snd(ty),us,vs);
+ case BANG : return typeVarsIn(snd(ty),us,ws,vs);
- case LABC : { List fs = snd(snd(ty));
- for (; nonNull(fs); fs=tl(fs)) {
- vs = typeVarsIn(snd(hd(fs)),us,vs);
- }
- return vs;
- }
+ case LABC : { List fs = snd(snd(ty));
+ for (; nonNull(fs); fs=tl(fs)) {
+ vs = typeVarsIn(snd(hd(fs)),us,ws,vs);
+ }
+ return vs;
+ }
}
return vs;
}
String where; /* explicit type signature */
Cell e;
Type type; {
- List tvs = typeVarsIn(type,NIL,NIL);
- Int n = length(tvs);
- List sunk = unkindTypes;
+ List tvs = NIL;
+ List sunk = NIL;
+ List xtvs = NIL;
+
+ if (isPolyType(type)) {
+ xtvs = fst(snd(type));
+ type = monotypeOf(type);
+ }
+ tvs = typeVarsIn(type,NIL,xtvs,NIL);
+ sunk = unkindTypes;
+ checkOptQuantVars(line,xtvs,tvs);
- if (whatIs(type)==QUAL) {
- map2Proc(depPredExp,line,tvs,fst(snd(type)));
- snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
+ if (isQualType(type)) {
+ map2Over(depPredExp,line,tvs,fst(snd(type)));
+ snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
if (isAmbiguous(type)) {
ambigError(line,where,e,type);
type = depTopType(line,tvs,type);
}
- if (n>0) {
- if (n>=NUM_OFFSETS) {
+ if (nonNull(tvs)) {
+ if (length(tvs)>=NUM_OFFSETS) {
ERRMSG(line) "Too many type variables in %s\n", where
EEND;
} else {
return type;
}
+static Void local checkOptQuantVars(line,xtvs,tvs)
+Int line;
+List xtvs; /* Explicitly quantified vars */
+List tvs; { /* Implicitly quantified vars */
+ if (nonNull(xtvs)) {
+ List vs = tvs;
+ for (; nonNull(vs); vs=tl(vs)) {
+ if (!varIsMember(textOf(hd(vs)),xtvs)) {
+ ERRMSG(line) "Quantifier does not mention type variable \"%s\"",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ }
+ for (vs=xtvs; nonNull(vs); vs=tl(vs)) {
+ if (!varIsMember(textOf(hd(vs)),tvs)) {
+ ERRMSG(line) "Quantified type variable \"%s\" is not used",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ if (varIsMember(textOf(hd(vs)),tl(vs))) {
+ ERRMSG(line) "Quantified type variable \"%s\" is repeated",
+ textToStr(textOf(hd(vs)))
+ EEND;
+ }
+ }
+ }
+}
+
static Type local depTopType(l,tvs,t) /* Check top-level of type sig */
Int l;
List tvs;
Int i = 1;
for (; getHead(t1)==typeArrow && argCount==2; ++i) {
arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
- if (isPolyType(arg(fun(t1)))) {
+ if (isPolyOrQualType(arg(fun(t1)))) {
nr2 = i;
}
prev = t1;
Int l;
List tvs;
Type t; {
- if (isPolyType(t)) {
- Int ntvs = length(tvs);
- List nfr = NIL;
- if (isPolyType(t)) {
- List vs = fst(snd(t));
- t = monotypeOf(t);
- tvs = checkQuantVars(l,vs,tvs,t);
- nfr = replicate(length(vs),NIL);
- }
- if (whatIs(t)==QUAL) {
- map2Proc(depPredExp,l,tvs,fst(snd(t)));
- snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
- if (isAmbiguous(t)) {
- ambigError(l,"type component",NIL,t);
- }
- } else {
- t = depTypeExp(l,tvs,t);
- }
- if (isNull(nfr)) {
- return t;
- }
- take(ntvs,tvs);
- return mkPolyType(nfr,t);
- } else {
- return depTypeExp(l,tvs,t);
+ Int ntvs = length(tvs);
+ List nfr = NIL;
+ if (isPolyType(t)) {
+ List vs = fst(snd(t));
+ t = monotypeOf(t);
+ tvs = checkQuantVars(l,vs,tvs,t);
+ nfr = replicate(length(vs),NIL);
+ }
+ if (isQualType(t)) {
+ map2Over(depPredExp,l,tvs,fst(snd(t)));
+ snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
+ if (isAmbiguous(t)) {
+ ambigError(l,"type component",NIL,t);
}
+ } else {
+ t = depTypeExp(l,tvs,t);
+ }
+ if (isNull(nfr)) {
+ return t;
+ }
+ take(ntvs,tvs);
+ return mkPolyType(nfr,t);
}
static Type local depTypeExp(line,tyvars,type)
Int line;
List tyvars;
Text tv; {
- Int offset = 0;
- Cell vt = findBtyvs(tv);
+ Int offset = 0;
+ Int found = (-1);
- if (nonNull(vt)) {
- return fst(vt);
+ for (; nonNull(tyvars); offset++) {
+ if (tv==textOf(hd(tyvars))) {
+ found = offset;
+ }
+ tyvars = tl(tyvars);
}
- for (; nonNull(tyvars) && tv!=textOf(hd(tyvars)); offset++) {
- tyvars = tl(tyvars);
- }
- if (isNull(tyvars)) {
- ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
- EEND;
+ if (found<0) {
+ Cell vt = findBtyvs(tv);
+ if (nonNull(vt)) {
+ return fst(vt);
+ }
+ ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
+ EEND;
}
- return mkOffset(offset);
+ return mkOffset(found);
}
static List local checkQuantVars(line,vs,tvs,body)
List tvs; /* variables already in scope */
Cell body; { /* type/constr for scope of vars */
if (nonNull(vs)) {
- List bvs = typeVarsIn(body,NIL,NIL);
+ List bvs = typeVarsIn(body,NIL,NIL,NIL);
List us = vs;
for (; nonNull(us); us=tl(us)) {
Text u = textOf(hd(us));
textToStr(u)
EEND;
}
+#if 0
if (varIsMember(u,tvs)) {
ERRMSG(line) "Local quantifier for %s hides an outer use",
textToStr(u)
EEND;
}
+#endif
if (!varIsMember(u,bvs)) {
ERRMSG(line) "Locally quantified variable %s is not used",
textToStr(u)
}
}
-Bool isAmbiguous(type) /* Determine whether type is */
-Type type; { /* ambiguous */
+List zonkTyvarsIn(t,vs)
+Type t;
+List vs; {
+ switch (whatIs(t)) {
+ case AP : return zonkTyvarsIn(fun(t),
+ zonkTyvarsIn(arg(t),vs));
+
+ case INTCELL : if (cellIsMember(t,vs))
+ return vs;
+ else
+ return cons(t,vs);
+
+ case OFFSET : internal("zonkTyvarsIn");
+
+ default : return vs;
+ }
+}
+
+static List local otvars(pi,os) /* os is a list of offsets that */
+Cell pi; /* refer to the arguments of pi; */
+List os; { /* find list of offsets in those */
+ List us = NIL; /* positions */
+ for (; nonNull(os); os=tl(os)) {
+ us = offsetTyvarsIn(nthArg(offsetOf(hd(os)),pi),us);
+ }
+ return us;
+}
+
+static List local otvarsZonk(pi,os,o) /* same as above, but zonks */
+Cell pi;
+List os; {
+ List us = NIL;
+ List vs = NIL;
+ for (; nonNull(os); os=tl(os)) {
+ Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o);
+ us = zonkTyvarsIn(t,us);
+ }
+ return us;
+}
+
+static Bool local odiff(us,vs)
+List us, vs; {
+ while (nonNull(us) && cellIsMember(hd(us),vs)) {
+ us = tl(us);
+ }
+ return us;
+}
+
+static Bool local osubset(us,vs) /* Determine whether us is subset */
+List us, vs; { /* of vs */
+ while (nonNull(us) && cellIsMember(hd(us),vs)) {
+ us = tl(us);
+ }
+ return isNull(us);
+}
+
+List oclose(fds,vs) /* Compute closure of vs wrt to fds*/
+List fds;
+List vs; {
+ Bool changed = TRUE;
+ while (changed) {
+ List fds1 = NIL;
+ changed = FALSE;
+ while (nonNull(fds)) {
+ Cell fd = hd(fds);
+ List next = tl(fds);
+ if (osubset(fst(fd),vs)) { /* Test if fd applies */
+ List os = snd(fd);
+ for (; nonNull(os); os=tl(os)) {
+ if (!cellIsMember(hd(os),vs)) {
+ vs = cons(hd(os),vs);
+ changed = TRUE;
+ }
+ }
+ } else { /* Didn't apply this time, so keep */
+ tl(fds) = fds1;
+ fds1 = fds;
+ }
+ fds = next;
+ }
+ fds = fds1;
+ }
+ return vs;
+}
+
+Bool isAmbiguous(type) /* Determine whether type is */
+Type type; { /* ambiguous */
if (isPolyType(type)) {
- type = monotypeOf(type);
+ type = monotypeOf(type);
}
- if (whatIs(type)==QUAL) { /* only qualified types can be */
- List tvps = offsetTyvarsIn(fst(snd(type)),NIL); /* ambiguous */
- List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
- while (nonNull(tvps) && cellIsMember(hd(tvps),tvts)) {
- tvps = tl(tvps);
- }
- return nonNull(tvps);
+ if (isQualType(type)) { /* only qualified types can be */
+ List ps = fst(snd(type)); /* ambiguous */
+ List tvps = offsetTyvarsIn(ps,NIL);
+ List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
+ List fds = calcFunDeps(ps);
+
+ tvts = oclose(fds,tvts); /* Close tvts under fds */
+ return !osubset(tvps,tvts);
}
return FALSE;
}
+List calcFunDeps(ps)
+List ps; {
+ List fds = NIL;
+ for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
+ Cell pi = hd(ps);
+ Cell c = getHead(pi);
+ if (isClass(c)) {
+ List fs = cclass(c).fds;
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvars(pi,fst(hd(fs))),
+ otvars(pi,snd(hd(fs)))),fds);
+ }
+ }
+#if IPARAM
+ else if (isIP(c)) {
+ fds = cons(pair(NIL,offsetTyvarsIn(arg(pi),NIL)),fds);
+ }
+#endif
+ }
+ return fds;
+}
+
+List calcFunDepsPreds(ps)
+List ps; {
+ List fds = NIL;
+ for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
+ Cell pi3 = hd(ps);
+ Cell pi = fst3(pi3);
+ Cell c = getHead(pi);
+ Int o = intOf(snd3(pi3));
+ if (isClass(c)) {
+ List fs = cclass(c).fds;
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
+ otvarsZonk(pi,snd(hd(fs)),o)),fds);
+ }
+ }
+#if IPARAM
+ else if (isIP(c)) {
+ fds = cons(pair(NIL,zonkTyvarsIn(arg(pi),NIL)),fds);
+ }
+#endif
+ }
+ return fds;
+}
+
Void ambigError(line,where,e,type) /* produce error message for */
Int line; /* ambiguity */
String where;
Int m;
Cell pi; {
#if TREX
- if (isExt(fun(pi))) {
+ if (isAp(pi) && isExt(fun(pi))) {
static String lackspred = "lacks predicate";
checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
return;
}
#endif
+#if IPARAM
+ if (isAp(pi) && whatIs(fun(pi)) == IPCELL) {
+ static String ippred = "iparam predicate";
+ checkKind(l,alpha,m,arg(pi),NIL,ippred,STAR,0);
+ return;
+ }
+#endif
{ static String predicate = "class constraint";
Class c = getHead(pi);
List as = getArgs(pi);
Int n = cclass(c).arity;
Int beta = newKindvars(n);
cclass(c).kinds = NIL;
- do {
+ while (n>0) {
n--;
cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
- } while (n>0);
+ }
}
}
switch (whatIs(tycon(c).what)) {
case NEWTYPE :
case DATATYPE : { List cs = tycon(c).defn;
- if (whatIs(cs)==QUAL) {
+ if (isQualType(cs)) {
map3Proc(kindPred,line,beta,m,
fst(snd(cs)));
tycon(c).defn = cs = snd(snd(cs));
static Void local checkInstDefn(in) /* Validate instance declaration */
Inst in; {
Int line = inst(in).line;
- List tyvars = typeVarsIn(inst(in).head,NIL,NIL);
+ List tyvars = typeVarsIn(inst(in).head,NIL,NIL,NIL);
+ List tvps = NIL, tvts = NIL;
+ List fds = NIL;
if (haskell98) { /* Check for `simple' type */
List tvs = NIL;
}
}
- depPredExp(line,tyvars,inst(in).head);
+ /* add in the tyvars from the `specifics' so that we don't
+ prematurely complain about undefined tyvars */
+ tyvars = typeVarsIn(inst(in).specifics,NIL,NIL,tyvars);
+ inst(in).head = depPredExp(line,tyvars,inst(in).head);
if (haskell98) {
Type h = getHead(arg(inst(in).head));
}
}
- map2Proc(depPredExp,line,tyvars,inst(in).specifics);
+ map2Over(depPredExp,line,tyvars,inst(in).specifics);
+
+ /* OK, now we start over, and test for ambiguity */
+ tvts = offsetTyvarsIn(inst(in).head,NIL);
+ tvps = offsetTyvarsIn(inst(in).specifics,NIL);
+ fds = calcFunDeps(inst(in).specifics);
+ tvts = oclose(fds,tvts);
+ tvts = odiff(tvps,tvts);
+ if (!isNull(tvts)) {
+ ERRMSG(line) "Undefined type variable \"%s\"",
+ textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars)))
+ EEND;
+ }
+
h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL);
inst(in).numSpecifics = length(inst(in).specifics);
inst(in).c = getHead(inst(in).head);
List ins = cclass(c).instances;
List prev = NIL;
+ if (nonNull(cclass(c).fds)) { /* Check for conflicts with fds */
+ List ins1 = cclass(c).instances;
+ for (; nonNull(ins1); ins1=tl(ins1)) {
+ List fds = cclass(c).fds;
+ substitution(RESET);
+ for (; nonNull(fds); fds=tl(fds)) {
+ Int alpha = newKindedVars(inst(in).kinds);
+ Int beta = newKindedVars(inst(hd(ins1)).kinds);
+ List as = fst(hd(fds));
+ Bool same = TRUE;
+ for (; same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ same &= unify(nthArg(n,inst(in).head),alpha,
+ nthArg(n,inst(hd(ins1)).head),beta);
+ }
+ if (isNull(as) && same) {
+ for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ same &= sameType(nthArg(n,inst(in).head),alpha,
+ nthArg(n,inst(hd(ins1)).head),beta);
+ }
+ if (!same) {
+ ERRMSG(inst(in).line)
+ "Instances are not consistent with dependencies"
+ ETHEN
+ ERRTEXT "\n*** This instance : "
+ ETHEN ERRPRED(inst(in).head);
+ ERRTEXT "\n*** Conflicts with : "
+ ETHEN ERRPRED(inst(hd(ins)).head);
+ ERRTEXT "\n*** For class : "
+ ETHEN ERRPRED(cclass(c).head);
+ ERRTEXT "\n*** Under dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+ }
+ }
+
+
substitution(RESET);
while (nonNull(ins)) { /* Look for overlap w/ other insts */
Int alpha = newKindedVars(inst(in).kinds);
continue;
}
}
+#if MULTI_INST
+ if (multiInstRes && nonNull(inst(in).specifics)) {
+ break;
+ } else {
+#endif
ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
textToStr(cclass(c).text)
ETHEN
ERRTEXT "\n"
EEND;
}
+#if MULTI_INST
+ }
+#endif
prev = ins; /* No overlap detected, so move on */
ins = tl(ins); /* to next instance */
}
List ts; /* and named class ct */
Cell ct; {
Int line = tycon(t).line;
- Class c = findClass(textOf(ct));
+ Class c = findQualClass(ct);
if (isNull(c)) {
ERRMSG(line) "Unknown class \"%s\" in derived instance",
- textToStr(textOf(ct))
+ identToStr(ct)
EEND;
}
addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
List ps = snd(snd(inst(in).specifics));
List spcs = fst(snd(inst(in).specifics));
Int beta = inst(in).numSpecifics;
+ Int its = 1;
#ifdef DEBUG_DERIVING
Printf("calcInstPreds: ");
while (nonNull(ps)) {
Cell p = hd(ps);
ps = tl(ps);
+ if (its++ >= cutoff) {
+ Cell bpi = inst(in).head;
+ Cell pi = copyPred(fun(p),intOf(snd(p)));
+ ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
+ ERRTEXT " after %d iterations.", its-1 ETHEN
+ ERRTEXT
+ "\n*** This may indicate that the problem is undecidable. However,\n"
+ ETHEN ERRTEXT
+ "*** you may still try to increase the cutoff limit using the -c\n"
+ ETHEN ERRTEXT
+ "*** option and then try again. (The current setting is -c%d)\n",
+ cutoff
+ EEND;
+ }
if (isInt(fst(p))) { /* Delayed substitution? */
List qs = snd(p);
for (; nonNull(hd(qs)); qs=tl(qs)) {
String wh;
Cell e;
Type t; {
- List tvs = typeVarsIn(t,NIL,NIL);
+ List tvs = typeVarsIn(t,NIL,NIL,NIL);
h98DoesntSupport(l,"pattern type annotations");
for (; nonNull(tvs); tvs=tl(tvs)) {
Int beta = newKindvars(1);
hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars));
}
t = checkSigType(l,"pattern type",e,t);
- if (isPolyType(t) || whatIs(t)==QUAL || whatIs(t)==RANK2) {
+ if (isPolyOrQualType(t) || whatIs(t)==RANK2) {
ERRMSG(l) "Illegal syntax in %s type annotation", wh
EEND;
}
break;
#endif
+#if IPARAM
+ case IPVAR :
+#endif
+
case NAME :
case TUPLE :
case STRCELL :
case UPDFLDS : depUpdFlds(line,e);
break;
+#if IPARAM
+ case WITHEXP : depWith(line,e);
+ break;
+#endif
+
case ASPAT : ERRMSG(line) "Illegal `@' in expression"
EEND;
if (isPolyType(t)) { /* Find tycon that c belongs to */
t = monotypeOf(t);
}
- if (whatIs(t)==QUAL) {
+ if (isQualType(t)) {
t = snd(snd(t));
}
if (whatIs(t)==CDICTS) {
return cs;
}
+#if IPARAM
+static Void local depWith(line,e) /* check with using fields */
+Int line;
+Cell e; {
+ fst(snd(e)) = depExpr(line,fst(snd(e)));
+ snd(snd(e)) = depDwFlds(line,e,snd(snd(e)));
+}
+
+static List local depDwFlds(l,e,fs)/* check field binding list */
+Int l;
+Cell e;
+List fs;
+{
+ Cell c = fs;
+ for (; nonNull(c); c=tl(c)) { /* for each field binding */
+ snd(hd(c)) = depExpr(l,snd(hd(c)));
+ }
+ return fs;
+}
+#endif
+
#if TREX
static Cell local depRecord(line,e) /* find dependents of record and */
Int line; /* sort fields into approp. order */
staticAnalysis(RESET);
}
+Void checkContext() { /* Top level static check on Expr */
+ List vs, qs;
+
+ staticAnalysis(RESET);
+ clearScope(); /* Analyse expression in the scope */
+ withinScope(NIL); /* of no local bindings */
+ qs = inputContext;
+ for (vs = NIL; nonNull(qs); qs=tl(qs)) {
+ vs = typeVarsIn(hd(qs),NIL,NIL,vs);
+ }
+ map2Proc(depPredExp,0,vs,inputContext);
+ leaveScope();
+ staticAnalysis(RESET);
+}
+
Void checkDefns() { /* Top level static analysis */
Module thisModule = lastModule();
staticAnalysis(RESET);
mapProc(checkInstDefn,instDefns);
setCurrModule(thisModule);
+ mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
+ valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns,/*primDefns*/NIL);
+ mapProc(allNoPrevDef,valDefns); /* check against previous defns */
mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
deriveContexts(derivedInsts); /* Calculate derived inst contexts */
instDefns = appendOnto(instDefns,derivedInsts);
checkDefaultDefns(); /* validate default definitions */
- mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
- valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns, NIL/*primDefns*/ );
- tyconDefns = NIL;
-
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
linkPreludeNames();
staticAnalysis(RESET);
}
+
+
+
static Void local addRSsigdecls(pr) /* add sigdecls from TYPE ... IN ..*/
Pair pr; {
List vs = snd(pr); /* get list of variables */
Type ty = t;
if (isPolyType(t))
t = monotypeOf(t);
- if (whatIs(t)==QUAL) {
+ if (isQualType(t)) {
Cell pi = h98Context(TRUE,fst(snd(t)));
if (nonNull(pi)) {
ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/10/15 21:40:57 $
+ * $Revision: 1.11 $
+ * $Date: 1999/10/16 02:17:32 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
return (t<0 || t>=NUM_TEXT);
}
+#define MAX_FIXLIT 100
+Text fixLitText(t) /* fix literal text that might include \ */
+Text t; {
+ String s = textToStr(t);
+ char p[MAX_FIXLIT];
+ Int i;
+ for(i = 0;i < MAX_FIXLIT-2 && *s;s++) {
+ p[i++] = *s;
+ if (*s == '\\') {
+ p[i++] = '\\';
+ }
+ }
+ if (i < MAX_FIXLIT-2) {
+ p[i] = 0;
+ } else {
+ ERRMSG(0) "storage space exhausted for internal literal string"
+ EEND;
+ }
+ return (findText(p));
+}
+#undef MAX_FIXLIT
+
static Int local hash(s) /* Simple hash function on strings */
String s; {
int v, j = 3;
cclass(classHw).supers = NIL;
cclass(classHw).dsels = NIL;
cclass(classHw).members = NIL;
- cclass(classHw).dbuild = NIL;
cclass(classHw).defaults = NIL;
cclass(classHw).instances = NIL;
classes=cons(classHw,classes);
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 21:40:58 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/16 02:17:25 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* qualified or unqualified.
*/
extern String identToStr Args((Cell));
+extern Text fixLitText Args((Text));
extern Syntax identSyntax Args((Cell));
extern Syntax defaultSyntax Args((Text));
* ------------------------------------------------------------------------*/
#define TAGMIN 1 /* Box and constructor cell tag values */
-#define BCSTAG 20 /* Box=TAGMIN..BCSTAG-1 */
+#define BCSTAG 30 /* Box=TAGMIN..BCSTAG-1 */
#define isTag(c) (TAGMIN<=(c) && (c)<SPECMIN) /* Tag cell values */
#define isBoxTag(c) (TAGMIN<=(c) && (c)<BCSTAG) /* Box cell tag values */
#define isConTag(c) (BCSTAG<=(c) && (c)<SPECMIN) /* Constr cell tag values*/
#define BIGCELL 16 /* Integer literal: snd :: Text */
#if PTR_ON_HEAP
#define PTRCELL 17 /* C Heap Pointer snd :: Ptr */
-#define CPTRCELL 18 /* Native code pointer snd :: Ptr */
+#if IPARAM
+#define IPCELL 19 /* Imp Param Cell: snd :: Text */
+#define IPVAR 20 /* ?x: snd :: Text */
+#endif
+#define CPTRCELL 21 /* Native code pointer snd :: Ptr */
#endif
#if TREX
-#define EXTCOPY 19 /* Copy of an Ext: snd :: Text */
+#define EXTCOPY 22 /* Copy of an Ext: snd :: Text */
#endif
//#define textOf(c) ((Text)(snd(c))) /* c :: (VAR|CON)(ID|OP) */
#define mkDictVar(t) ap(DICTVAR,t)
#define inventDictVar() mkDictVar(inventDictText())
#define mkStr(t) ap(STRCELL,t)
+#if IPARAM
+#define mkIParam(c) ap(IPCELL,snd(c))
+#define isIP(p) (whatIs(p) == IPCELL)
+#define ipMatch(pi, t) (isIP(fun(pi)) && textOf(fun(pi)) == t)
+#define ipVar(pi) textOf(fun(pi))
+#else
+#define isIP(p) FALSE
+#endif
extern Bool isVar Args((Cell));
extern Bool isCon Args((Cell));
extern Bool isQVar Args((Cell));
* element is a special cell will be treated as an application node.
* ------------------------------------------------------------------------*/
-#define LETREC 20 /* LETREC snd :: ([Decl],Exp) */
-#define COND 21 /* COND snd :: (Exp,Exp,Exp) */
-#define LAMBDA 22 /* LAMBDA snd :: Alt */
-#define FINLIST 23 /* FINLIST snd :: [Exp] */
-#define DOCOMP 24 /* DOCOMP snd :: (Exp,[Qual]) */
-#define BANG 25 /* BANG snd :: Type */
-#define COMP 26 /* COMP snd :: (Exp,[Qual]) */
-#define ASPAT 27 /* ASPAT snd :: (Var,Exp) */
-#define ESIGN 28 /* ESIGN snd :: (Exp,Type) */
-#define RSIGN 29 /* RSIGN snd :: (Rhs,Type) */
-#define CASE 30 /* CASE snd :: (Exp,[Alt]) */
-#define NUMCASE 31 /* NUMCASE snd :: (Exp,Disc,Rhs) */
-#define FATBAR 32 /* FATBAR snd :: (Exp,Exp) */
-#define LAZYPAT 33 /* LAZYPAT snd :: Exp */
-#define DERIVE 35 /* DERIVE snd :: Cell */
+#define LETREC 30 /* LETREC snd :: ([Decl],Exp) */
+#define COND 31 /* COND snd :: (Exp,Exp,Exp) */
+#define LAMBDA 32 /* LAMBDA snd :: Alt */
+#define FINLIST 33 /* FINLIST snd :: [Exp] */
+#define DOCOMP 34 /* DOCOMP snd :: (Exp,[Qual]) */
+#define BANG 35 /* BANG snd :: Type */
+#define COMP 36 /* COMP snd :: (Exp,[Qual]) */
+#define ASPAT 37 /* ASPAT snd :: (Var,Exp) */
+#define ESIGN 38 /* ESIGN snd :: (Exp,Type) */
+#define RSIGN 39 /* RSIGN snd :: (Rhs,Type) */
+#define CASE 40 /* CASE snd :: (Exp,[Alt]) */
+#define NUMCASE 41 /* NUMCASE snd :: (Exp,Disc,Rhs) */
+#define FATBAR 42 /* FATBAR snd :: (Exp,Exp) */
+#define LAZYPAT 43 /* LAZYPAT snd :: Exp */
+#define DERIVE 45 /* DERIVE snd :: Cell */
#if BREAK_FLOATS
-#define FLOATCELL 36 /* FLOATCELL snd :: (Int,Int) */
+#define FLOATCELL 46 /* FLOATCELL snd :: (Int,Int) */
#endif
-#define BOOLQUAL 39 /* BOOLQUAL snd :: Exp */
-#define QWHERE 40 /* QWHERE snd :: [Decl] */
-#define FROMQUAL 41 /* FROMQUAL snd :: (Exp,Exp) */
-#define DOQUAL 42 /* DOQUAL snd :: Exp */
-#define MONADCOMP 43 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
+#define BOOLQUAL 49 /* BOOLQUAL snd :: Exp */
+#define QWHERE 50 /* QWHERE snd :: [Decl] */
+#define FROMQUAL 51 /* FROMQUAL snd :: (Exp,Exp) */
+#define DOQUAL 52 /* DOQUAL snd :: Exp */
+#define MONADCOMP 53 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
-#define GUARDED 44 /* GUARDED snd :: [guarded exprs] */
+#define GUARDED 54 /* GUARDED snd :: [guarded exprs] */
-#define ARRAY 45 /* Array snd :: (Bounds,[Values]) */
-#define MUTVAR 46 /* Mutvar snd :: Cell */
+#define ARRAY 55 /* Array snd :: (Bounds,[Values]) */
+#define MUTVAR 56 /* Mutvar snd :: Cell */
#if INTERNAL_PRIMS
-#define HUGSOBJECT 47 /* HUGSOBJECT snd :: Cell */
+#define HUGSOBJECT 57 /* HUGSOBJECT snd :: Cell */
+#endif
+
+#if IPARAM
+#define WITHEXP 58 /* WITHEXP snd :: [(Var,Exp)] */
#endif
-#define POLYTYPE 50 /* POLYTYPE snd :: (Kind,Type) */
-#define QUAL 51 /* QUAL snd :: ([Classes],Type) */
-#define RANK2 52 /* RANK2 snd :: (Int,Type) */
-#define EXIST 53 /* EXIST snd :: (Int,Type) */
-#define POLYREC 54 /* POLYREC snd :: (Int,Type) */
-#define BIGLAM 55 /* BIGLAM snd :: (vars,patterns) */
-#define CDICTS 56 /* CDICTS snd :: ([Pred],Type) */
-
-#define LABC 60 /* LABC snd :: (con,[(Vars,Type)]) */
-#define CONFLDS 61 /* CONFLDS snd :: (con,[Field]) */
-#define UPDFLDS 62 /* UPDFLDS snd :: (Exp,[con],[Field]) */
+
+#define POLYTYPE 60 /* POLYTYPE snd :: (Kind,Type) */
+#define QUAL 61 /* QUAL snd :: ([Classes],Type) */
+#define RANK2 62 /* RANK2 snd :: (Int,Type) */
+#define EXIST 63 /* EXIST snd :: (Int,Type) */
+#define POLYREC 64 /* POLYREC snd :: (Int,Type) */
+#define BIGLAM 65 /* BIGLAM snd :: (vars,patterns) */
+#define CDICTS 66 /* CDICTS snd :: ([Pred],Type) */
+
+#define LABC 67 /* LABC snd :: (con,[(Vars,Type)]) */
+#define CONFLDS 68 /* CONFLDS snd :: (con,[Field]) */
+#define UPDFLDS 69 /* UPDFLDS snd :: (Exp,[con],[Field]) */
#if TREX
-#define RECORD 63 /* RECORD snd :: [Val] */
-#define EXTCASE 64 /* EXTCASE snd :: (Exp,Disc,Rhs) */
-#define RECSEL 65 /* RECSEL snd :: Ext */
+#define RECORD 70 /* RECORD snd :: [Val] */
+#define EXTCASE 71 /* EXTCASE snd :: (Exp,Disc,Rhs) */
+#define RECSEL 72 /* RECSEL snd :: Ext */
#endif
-#define IMPDEPS 68 /* IMPDEPS snd :: [Binding] */
+#define IMPDEPS 73 /* IMPDEPS snd :: [Binding] */
-#define QUALIDENT 70 /* Qualified identifier snd :: (Id,Id) */
-#define HIDDEN 71 /* hiding import list snd :: [Entity] */
-#define MODULEENT 72 /* module in export list snd :: con */
+#define QUALIDENT 74 /* Qualified identifier snd :: (Id,Id) */
+#define HIDDEN 75 /* hiding import list snd :: [Entity] */
+#define MODULEENT 76 /* module in export list snd :: con */
-#define INFIX 80 /* INFIX snd :: (see tidyInfix) */
-#define ONLY 81 /* ONLY snd :: Exp */
-#define NEG 82 /* NEG snd :: Exp */
+#define INFIX 77 /* INFIX snd :: (see tidyInfix) */
+#define ONLY 78 /* ONLY snd :: Exp */
+#define NEG 79 /* NEG snd :: Exp */
/* Used when parsing GHC interface files */
-#define DICTAP 85 /* DICTTYPE snd :: (QClassId,[Type]) */
+#define DICTAP 80 /* DICTTYPE snd :: (QClassId,[Type]) */
#if SIZEOF_INTP != SIZEOF_INT
-#define PTRCELL 90 /* C Heap Pointer snd :: (Int,Int) */
+#define PTRCELL 81 /* C Heap Pointer snd :: (Int,Int) */
#endif
#define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
extern Tycon addPrimTycon Args((Text,Kind,Int,Cell,Cell));
#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
+#define isQualType(t) (isPair(t) && fst(t)==QUAL)
#define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
#define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
+#define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
#define polySigOf(t) fst(snd(t))
#define monotypeOf(t) snd(snd(t))
Int level; /* Level in class hierarchy */
Int arity; /* Number of arguments */
Kinds kinds; /* Kinds of constructors in class */
+ List fds; /* Functional Dependencies */
Cell head; /* Head of class */
Name dcon; /* Dictionary constructor function */
List supers; /* :: [Pred] */
List dsels; /* Superclass dictionary selectors */
List members; /* :: [Name] */
Int numMembers; /* length(members) */
- Name dbuild; /* Default dictionary builder */
List defaults; /* :: [Name] */
List instances; /* :: [Inst] */
};
extern Void hugsStackOverflow Args((Void));
+#if SYMANTEC_C
+#include <Memory.h>
+#define STACK_HEADROOM 16384
+#define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \
+ internal("Macintosh function parameter stack overflow.");
+#else
+#define STACK_CHECK
+#endif
+
/* --------------------------------------------------------------------------
* Script file control:
* The implementation of script file storage is hidden.
* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/10/15 21:40:59 $
+ * $Revision: 1.7 $
+ * $Date: 1999/10/16 02:17:27 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Kind local makeSimpleKind Args((Int));
static Kind local makeVarKind Args((Int));
static Void local expandSyn1 Args((Tycon, Type *, Int *));
+static List local listTyvar Args((Int,List));
+static List local listTyvars Args((Type,Int,List));
+static Cell local dupTyvar Args((Int,List));
+static Cell local dupTyvars Args((Cell,Int,List));
+static Pair local copyNoMark Args((Cell,Int));
static Type local dropRank1Body Args((Type,Int,Int));
static Type local liftRank1Body Args((Type,Int));
static Int local remover Args((Text,Type,Int));
static Int local tailVar Args((Type,Int));
#endif
+
+static Bool local pairImprove Args((Int,Class,Cell,Int,Cell,Int));
+static Bool local instImprove Args((Int,Cell,Int));
+static Bool local improveAgainst Args((Int,List,Cell,Int));
+#if IPARAM
+static Bool local ipImprove Args((Int,Cell,Int,Cell,Int));
+#endif
+
static Bool local kvarToVarBind Args((Tyvar *,Tyvar *));
static Bool local kvarToTypeBind Args((Tyvar *,Type,Int));
typeFree++;
}
- if (whatIs(typeIs)==QUAL) { /* Qualified type? */
+ if (isQualType(typeIs)) { /* Qualified type? */
predsAre = fst(snd(typeIs));
typeIs = snd(snd(typeIs));
}
Void markType(t,o) /* mark fixed vars in type (t,o) */
Type t;
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case POLYTYPE :
case QUAL :
Type copyType(t,o) /* calculate most general form of */
Type t; /* type expression (t,o) */
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case AP : { Type l = copyType(fst(t),o);/* ensure correct */
Type r = copyType(snd(t),o);/* eval. order */
return pi;
}
+Type zonkTyvar(vn) /* flatten type by chasing all references */
+Int vn; { /* and collapsing OFFSETS to absolute indexes */
+ Tyvar *tyv = tyvar(vn);
+
+ if (tyv->bound)
+ return zonkType(tyv->bound,tyv->offs);
+ else
+ return mkInt(vn);
+}
+
+Type zonkType(t,o) /* flatten type by chasing all references */
+Type t; /* and collapsing OFFSETS to absolute indexes */
+Int o; {
+ STACK_CHECK
+ switch (whatIs(t)) {
+ case AP : { Type l = zonkType(fst(t),o);/* ensure correct */
+ Type r = zonkType(snd(t),o);/* eval. order */
+ return ap(l,r);
+ }
+ case OFFSET : return zonkTyvar(o+offsetOf(t));
+ case INTCELL : return zonkTyvar(intOf(t));
+ }
+
+ return t;
+}
+
#ifdef DEBUG_TYPES
Type debugTyvar(vn) /* expand type structure in full */
Int vn; { /* detail */
Type debugType(t,o)
Type t;
Int o; {
+ STACK_CHECK
switch (whatIs(t)) {
case AP : { Type l = debugType(fst(t),o);
Type r = debugType(snd(t),o);
return t;
}
+List debugContext(ps)
+List ps; {
+ Cell p;
+ List qs = NIL;
+ for (; nonNull(ps); ps=tl(ps)) {
+ p = debugPred(fst3(hd(ps)),intOf(snd3(hd(ps))));
+ qs = cons(p,qs);
+ }
+ return rev(qs);
+}
+
+Cell debugPred(pi,o)
+Cell pi;
+Int o; {
+ if (isAp(pi)) {
+ return pair(debugPred(fun(pi),o),debugType(arg(pi),o));
+ }
+ return pi;
+}
#endif /*DEBUG_TYPES*/
Kind copyKindvar(vn) /* build kind attatched to variable*/
}
/* --------------------------------------------------------------------------
+ * Copy type expression from substitution without marking:
+ * ------------------------------------------------------------------------*/
+
+static List local listTyvar(vn,ns)
+Int vn;
+List ns; {
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv)) {
+ return listTyvars(tyv->bound,tyv->offs,ns);
+ } else if (!intIsMember(vn,ns)) {
+ ns = cons(mkInt(vn),ns);
+ }
+ return ns;
+}
+
+static List local listTyvars(t,o,ns)
+Cell t;
+Int o;
+List ns; {
+ switch (whatIs(t)) {
+ case AP : return listTyvars(fst(t),o,
+ listTyvars(snd(t),o,
+ ns));
+ case OFFSET : return listTyvar(o+offsetOf(t),ns);
+ case INTCELL : return listTyvar(intOf(t),ns);
+ default : break;
+ }
+ return ns;
+}
+
+static Cell local dupTyvar(vn,ns)
+Int vn;
+List ns; {
+ Tyvar *tyv = tyvar(vn);
+
+ if (isBound(tyv)) {
+ return dupTyvars(tyv->bound,tyv->offs,ns);
+ } else {
+ Int i = 0;
+ for (; nonNull(ns) && vn!=intOf(hd(ns)); ns=tl(ns)) {
+ i++;
+ }
+ return mkOffset(i);
+ }
+}
+
+static Cell local dupTyvars(t,o,ns)
+Cell t;
+Int o;
+List ns; {
+ switch (whatIs(t)) {
+ case AP : { Type l = dupTyvars(fst(t),o,ns);
+ Type r = dupTyvars(snd(t),o,ns);
+ return ap(l,r);
+ }
+ case OFFSET : return dupTyvar(o+offsetOf(t),ns);
+ case INTCELL : return dupTyvar(intOf(t),ns);
+ }
+ return t;
+}
+
+static Cell local copyNoMark(t,o) /* Copy a type or predicate without*/
+Cell t; /* changing marks */
+Int o; {
+ List ns = listTyvars(t,o,NIL);
+ Cell result = pair(ns,dupTyvars(t,o,ns));
+ for (; nonNull(ns); ns=tl(ns)) {
+ hd(ns) = tyvar(intOf(hd(ns)))->kind;
+ }
+ return result;
+}
+
+/* --------------------------------------------------------------------------
* Droping and lifting of type schemes that appear in rank 2 position:
* ------------------------------------------------------------------------*/
Int o; {
Tyvar *tyv;
+ STACK_CHECK
for (;;) {
deRef(tyv,t,o);
if (tyv) /* type variable */
Int o1,o2; {
Tyvar *tyv1, *tyv2;
+ STACK_CHECK
deRef(tyv1,t1,o1);
deRef(tyv2,t2,o2);
Bool typeMatches(type,mt) /* test if type matches monotype mt*/
Type type, mt; { /* imported from STG Hugs */
Bool result;
- if (isPolyType(type) || whatIs(type)==QUAL)
+ if (isPolyOrQualType(type))
return FALSE;
emptySubstitution();
noBind();
for (; isAp(pi1); pi1=fun(pi1), pi=fun(pi))
if (!unify(arg(pi1),o1,arg(pi),o))
return FALSE;
+#if IPARAM
+ if (isIP(pi1) && isIP(pi))
+ return textOf(pi1)==textOf(pi);
+ else
+#endif
return pi1==pi;
}
Int o; { /* match is found, then tyvars from*/
Class c = getHead(pi); /* typeOff have been initialized to*/
List ins; /* allow direct use of specifics. */
+ Cell kspi = NIL;
if (!isClass(c))
return NIL;
typeOff = beta;
return in;
}
- else
- numTyvars = beta;
+ else {
+ numTyvars = beta;
+ if (allowOverlap) {
+ Int alpha = newKindedVars(inst(in).kinds);
+ if (isNull(kspi)) {
+ kspi = copyNoMark(pi,o);
+ }
+ beta = newKindedVars(fst(kspi));
+ if (matchPred(inst(in).head,alpha,snd(kspi),beta)) {
+ numTyvars = alpha;
+ return NIL;
+ }
+ numTyvars = alpha;
+ }
+ }
}
unrestrictBind();
return NIL;
}
+#if MULTI_INST
+Cell findInstsFor(pi,o) /* Find matching instance for pred */
+Cell pi; /* (pi,o), or otherwise NIL. If a */
+Int o; { /* match is found, then tyvars from*/
+ Class c = getHead(pi); /* typeOff have been initialized to*/
+ List ins; /* allow direct use of specifics. */
+ List res = NIL;
+
+ if (!isClass(c))
+ return NIL;
+
+ for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins)) {
+ Inst in = hd(ins);
+ Int beta = newKindedVars(inst(in).kinds);
+ if (matchPred(pi,o,inst(in).head,beta)) {
+ res = cons (pair (beta, in), res);
+ continue;
+ }
+ else
+ numTyvars = beta;
+ }
+ if (res == NIL) {
+ unrestrictBind();
+ }
+
+ return rev(res);
+}
+#endif
+
+/* --------------------------------------------------------------------------
+ * Improvement:
+ * ------------------------------------------------------------------------*/
+
+Void improve(line,sps,ps) /* Improve a list of predicates */
+Int line;
+List sps;
+List ps; {
+ Bool improved;
+ List ps1;
+ do {
+ improved = FALSE;
+ for (ps1=ps; nonNull(ps1); ps1=tl(ps1)) {
+ Cell pi = fst3(hd(ps1));
+ Int o = intOf(snd3(hd(ps1)));
+ Cell c = getHead(pi);
+ if ((isClass(c) && nonNull(cclass(c).fds)) || isIP(c)) {
+ improved |= improveAgainst(line,sps,pi,o);
+ if (!isIP(c))
+ improved |= instImprove(line,pi,o);
+ improved |= improveAgainst(line,tl(ps1),pi,o);
+ }
+ }
+ } while (improved);
+}
+
+Bool improveAgainst(line,ps,pi,o)
+Int line;
+List ps;
+Cell pi;
+Int o; {
+ Bool improved = FALSE;
+ Cell h = getHead(pi);
+ for (; nonNull(ps); ps=tl(ps)) {
+ Cell pr = hd(ps);
+ Cell pi1 = fst3(pr);
+ Int o1 = intOf(snd3(pr));
+ Cell h1 = getHead(pi1);
+ if (isClass(h1) && h==h1)
+ improved |= pairImprove(line,h,pi,o,pi1,o1);
+#if IPARAM
+ else if (isIP(h1) && textOf(h1) == textOf(h))
+ improved |= ipImprove(line,pi,o,pi1,o1);
+#endif
+ }
+ return improved;
+}
+
+#if IPARAM
+Bool ipImprove(line,pi,o,pi1,o1)
+Int line;
+Cell pi;
+Int o;
+Cell pi1;
+Int o1; {
+ Type t = arg(pi);
+ Type t1 = arg(pi1);
+ if (!sameType(t,o,t1,o1)) {
+ if (!unify(t,o,t1,o1)) {
+ ERRMSG(line) "Mismatching uses of implicit parameter\n"
+ ETHEN
+ ERRTEXT "\n*** "
+ ETHEN ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n*** "
+ ETHEN ERRPRED(copyPred(pi,o));
+ ERRTEXT "\n"
+ EEND;
+ }
+ return TRUE;
+ }
+ return FALSE;
+}
+#endif
+
+Bool pairImprove(line,c,pi1,o1,pi,o) /* Look for improvement of (pi1,o1)*/
+Int line; /* against (pi,o), assuming that */
+Class c; /* both pi and pi1 are for class c */
+Cell pi1;
+Int o1;
+Cell pi;
+Int o; {
+ Bool improved = FALSE;
+ List fds = cclass(c).fds;
+ for (; nonNull(fds); fds=tl(fds)) {
+ List as = fst(hd(fds));
+ Bool same = TRUE;
+ for (; same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ same &= sameType(nthArg(n,pi1),o1,nthArg(n,pi),o);
+ }
+ if (isNull(as) && same) {
+ for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ Type t1 = nthArg(n,pi1);
+ Type t = nthArg(n,pi);
+ if (!sameType(t1,o1,t,o)) {
+ same &= unify(t1,o1,t,o);
+ improved = TRUE;
+ }
+ }
+ if (!same) {
+ ERRMSG(line)
+ "Constraints are not consistent with functional dependency"
+ ETHEN
+ ERRTEXT "\n*** Constraint : "
+ ETHEN ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n*** And constraint : "
+ ETHEN ERRPRED(copyPred(pi,o));
+ ERRTEXT "\n*** For class : "
+ ETHEN ERRPRED(cclass(c).head);
+ ERRTEXT "\n*** Break dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
+ }
+ return improved;
+}
+
+Bool instImprove(line,pi,o) /* Look for improvement of (pi,o) */
+Int line; /* returning TRUE if an improvement*/
+Cell pi; /* was made, and FALSE otherwise */
+Int o; {
+ Bool improved = FALSE;
+ Cell c = getHead(pi);
+ if (isClass(c) && nonNull(cclass(c).fds)) {
+ List ins = cclass(c).instances;
+ for (; nonNull(ins); ins=tl(ins)) {
+ Cell in = hd(ins);
+ List fds = cclass(c).fds;
+ for (; nonNull(fds); fds=tl(fds)) {
+ Int beta = newKindedVars(inst(in).kinds);
+ Bool same = TRUE;
+ List as = fst(hd(fds));
+ for (; same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ same &= matchType(nthArg(n,pi),o,
+ nthArg(n,inst(in).head),beta);
+ }
+ if (isNull(as) && same) {
+ for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
+ Int n = offsetOf(hd(as));
+ Type tp = nthArg(n,pi);
+ Type ti = nthArg(n,inst(in).head);
+ if (!matchType(tp,o,ti,beta)) {
+ same &= unify(tp,o,ti,beta);
+ improved = TRUE;
+ }
+ }
+ if (!same) {
+ ERRMSG(line)
+ "Constraint is not consistent with declared instance"
+ ETHEN
+ ERRTEXT "\n*** Constraint : "
+ ETHEN ERRPRED(copyPred(pi,o));
+ ERRTEXT "\n*** Instance : "
+ ETHEN ERRPRED(inst(in).head);
+ ERRTEXT "\n*** For class : "
+ ETHEN ERRPRED(cclass(c).head);
+ ERRTEXT "\n*** Under dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ } else {
+ numTyvars = beta;
+ }
+ }
+ }
+ }
+ return improved;
+}
+
/* --------------------------------------------------------------------------
* Compare type schemes:
* ------------------------------------------------------------------------*/
for (; nr2>0; nr2--) { /* Deal with rank 2 arguments */
Type t = arg(fun(s));
Type t1 = arg(fun(s1));
- b = isPolyType(t);
- b1 = isPolyType(t1);
+ b = isPolyOrQualType(t);
+ b1 = isPolyOrQualType(t1);
if (b || b1) {
if (b && b1) {
t = dropRank1(t,o,m);
return FALSE;
}
else {
- noBind();
- b = unify(t,o,t1,o);
- unrestrictBind();
- if (!b)
+ if (!sameType(t,o,t1,o)) {
return FALSE;
+ }
}
+
s = arg(s);
s1 = arg(s1);
}
- noBind(); /* Ensure body types are the same */
- b = unify(s,o,s1,o);
+ return sameType(s,o,s1,o); /* Ensure body types are the same */
+}
+
+Bool sameType(t1,o1,t,o) /* Test to see if types are */
+Type t1; /* the same, with no binding of */
+Int o1; /* the variables in either one. */
+Cell t; /* Assumes types are kind correct */
+Int o; { /* with the same kind. */
+ Bool result;
+ noBind();
+ result = unify(t1,o1,t,o);
+ unrestrictBind();
+ return result;
+}
+
+Bool matchType(t1,o1,t,o) /* One way match type (t1,o1) */
+Type t1; /* against (t,o), allowing only */
+Int o1; /* vars in 2nd type to be bound. */
+Type t; /* Assumes types are kind correct */
+Int o; { /* and that no vars have been */
+ Bool result; /* alloc'd since o. */
+ bindOnlyAbove(o);
+ result = unify(t1,o1,t,o);
unrestrictBind();
- return b;
+ return result;
}
/* --------------------------------------------------------------------------
* included in the distribution.
*
* $RCSfile: subst.h,v $
- * $Revision: 1.4 $
- * $Date: 1999/10/15 21:41:00 $
+ * $Revision: 1.5 $
+ * $Date: 1999/10/16 02:17:27 $
* ------------------------------------------------------------------------*/
typedef struct { /* Each type variable contains: */
extern Bool unifyPred Args((Cell,Int,Cell,Int));
extern Inst findInstFor Args((Cell,Int));
-extern Bool sameSchemes Args((Type,Type));
+extern Void improve Args((Int,List,List));
+
+extern Bool sameSchemes Args((Type,Type));
+extern Bool sameType Args((Type,Int,Type,Int));
+extern Bool matchType Args((Type,Int,Type,Int));
/*-------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/15 21:41:01 $
+ * $Revision: 1.10 $
+ * $Date: 1999/10/16 02:17:26 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Cell local typeAp Args((Int,Cell));
static Type local typeExpected Args((Int,String,Cell,Type,Int,Int,Bool));
+static Type local typeExpected2 Args((Int,String,Cell,Type,Int,Int));
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 typeDo Args((Int,Cell));
static Void local typeConFlds Args((Int,Cell));
static Void local typeUpdFlds Args((Int,Cell));
+#if IPARAM
+static Cell local typeWith Args((Int,Cell));
+#endif
static Cell local typeFreshPat Args((Int,Cell));
static Void local typeBindings Args((List));
tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
sks = tl(sks);
} while (nonNull(sks));
+ normPreds(l);
sps = elimPredsUsing(hd(localEvs),sps);
preds = revOnto(preds,sps);
}
typeError(l,e,in,where,t,o);
#define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
#define inferType(t,o) typeIs=t; typeOff=o
+#if IPARAM
+#define spTypeExpr(l,e) svPreds = preds; preds = NIL; e = typeExpr(l,e); preds = revOnto(preds,svPreds);
+#define spCheck(l,e,in,where,t,o) svPreds = preds; preds = NIL; check(l,e,in,where,t,o); preds = revOnto(preds,svPreds);
+#else
+#define spTypeExpr(l,e) e = typeExpr(l,e);
+#define spCheck(l,e,in,where,t,o) check(l,e,in,where,t,o);
+#endif
static Void local cantEstablish(line,wh,e,t,ps)
Int line; /* Complain when declared preds */
static int number = 0;
Cell retv;
int mynumber = number++;
+ List ps;
+ STACK_CHECK
Printf("%d) to check: ",mynumber);
printExp(stdout,e);
Putchar('\n');
retv = mytypeExpr(l,e);
Printf("%d) result: ",mynumber);
printType(stdout,debugType(typeIs,typeOff));
+ Printf("\n%d) preds: ",mynumber);
+ printContext(stdout,debugContext(preds));
Putchar('\n');
return retv;
}
static String aspat = "as (@) pattern";
static String typeSig = "type annotation";
static String lambda = "lambda expression";
+#if IPARAM
+ List svPreds;
+#endif
switch (whatIs(e)) {
case AP :
case NAME :
case VAROPCELL :
- case VARIDCELL : return typeAp(l,e);
+ case VARIDCELL :
+#if IPARAM
+ case IPVAR :
+#endif
+ return typeAp(l,e);
case TUPLE : typeTuple(e);
break;
case UPDFLDS : typeUpdFlds(l,e);
break;
+#if IPARAM
+ case WITHEXP : return typeWith(l,e);
+#endif
+
case COND : { Int beta = newTyvars(1);
check(l,fst3(snd(e)),e,cond,typeBool,0);
- check(l,snd3(snd(e)),e,cond,aVar,beta);
- check(l,thd3(snd(e)),e,cond,aVar,beta);
+ spCheck(l,snd3(snd(e)),e,cond,aVar,beta);
+ spCheck(l,thd3(snd(e)),e,cond,aVar,beta);
tyvarType(beta);
}
break;
case LETREC : enterBindings();
enterSkolVars();
mapProc(typeBindings,fst(snd(e)));
- snd(snd(e)) = typeExpr(l,snd(snd(e)));
+ spTypeExpr(l,snd(snd(e)));
leaveBindings();
leaveSkolVars(l,typeIs,typeOff,0);
break;
case FINLIST : { Int beta = newTyvars(1);
List xs;
for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
- check(l,hd(xs),e,list,aVar,beta);
+ spCheck(l,hd(xs),e,list,aVar,beta);
}
inferType(listof,beta);
}
Cell p = NIL;
Cell a = e;
Int i;
+#if IPARAM
+ List svPreds;
+#endif
switch (whatIs(h)) {
case NAME : typeIs = name(h).type;
}
break;
+#if IPARAM
+ case IPVAR : { Text t = textOf(h);
+ Int alpha = newTyvars(1);
+ Cell ip = pair(ap(IPCELL,t),aVar);
+ Cell ev = assumeEvid(ip,alpha);
+ typeIs = mkInt(alpha);
+ h = ap(h,ev);
+ }
+ break;
+#endif
+
default : h = typeExpr(l,h);
break;
}
for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
Type expect = dropRank1(arg(fun(body)),alpha,m);
- if (isPolyType(expect)) {
+ if (isPolyOrQualType(expect)) {
if (tcMode==EXPRESSION) /* poly/qual type in expr */
hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
}
}
else { /* Not a poly/qual type */
- check(l,hd(as),e,app,expect,alpha);
+ spCheck(l,hd(as),e,app,expect,alpha);
}
h = ap(h,hd(as)); /* Save checked argument */
}
Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
shouldBe(l,h,e,app,aVar,beta);
for (i=n; i>0; --i) { /* check e_i::t_i for each i */
- check(l,arg(a),e,app,aVar,beta+2*i-1);
+ spCheck(l,arg(a),e,app,aVar,beta+2*i-1);
p = a;
a = fun(a);
}
preds = NIL;
check(l,e,NIL,wh,t,o);
+ improve(l,ps,preds);
clearMarks();
mapProc(markAssumList,defnBounds);
mapProc(markPred,savePreds);
markBtyvs();
- for (i=0; i<n; i++)
- markTyvar(alpha+i);
+ if (n > 0) { /* mark alpha thru alpha+n-1, plus any */
+ /* type vars that are functionally */
+ List us = NIL, vs = NIL; /* dependent on them */
+ List fds = calcFunDepsPreds(preds);
+ for (i=0; i<n; i++) {
+ Type t1 = zonkTyvar(alpha+i);
+ us = zonkTyvarsIn(t1,us);
+ }
+ vs = oclose(fds,us);
+ for (; nonNull(vs); vs=tl(vs))
+ markTyvar(intOf(hd(vs)));
+ }
+ normPreds(l);
savePreds = elimPredsUsing(ps,savePreds);
if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
savePreds = elimPredsUsing(ps,savePreds);
while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
Type ta = arg(fun(t));
- if (isPolyType(ta)) {
+ if (isPolyOrQualType(ta)) {
if (hd(ps)!=WILDCARD) {
if (!isVar(hd(ps))) {
ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
static String boolQual = "boolean qualifier";
static String genQual = "generator";
+ STACK_CHECK
if (isNull(qs)) /* no qualifiers left */
fst(e) = typeExpr(l,fst(e));
else {
tyvar(beta)->kind = starToStar;
#if !MONAD_COMPS
bindTv(beta,typeList,0);
+ m = nameListMonad;
#endif
typeComp(l,mon,snd(e),snd(snd(e)));
for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
;
t = dropRank1(arg(fun(t)),to,tf);
- if (isPolyType(t))
+ 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);
/* (typeIs,typeOff) still carry the result type when we exit the loop */
}
+#if IPARAM
+static Cell local typeWith(line,e) /* Type check a with */
+Int line;
+Cell e; {
+ static String update = "with";
+ List fs = snd(snd(e)); /* List of field specifications */
+ List ts = NIL; /* List of types for fields */
+ Int n = length(fs);
+ Int alpha = newTyvars(2+n);
+ Int i;
+ List fs1;
+ Cell tIs;
+ Cell tOff;
+ List dpreds = NIL, dp;
+ Cell bs = NIL;
+
+ /* Type check expression to be updated */
+ fst(snd(e)) = typeExpr(line,fst(snd(e)));
+ bindTv(alpha,typeIs,typeOff);
+ tIs = typeIs;
+ tOff = typeOff;
+ /* elim duplicate uses of imp params */
+ preds = scSimplify(preds);
+ /* extract preds that we're going to bind */
+ for (fs1=fs; nonNull(fs1); fs1=tl(fs1)) {
+ Text t = textOf(fst(hd(fs1)));
+ Cell p = findIPEvid(t);
+ dpreds = cons(p, dpreds);
+ if (nonNull(p)) {
+ removeIPEvid(t);
+ } else {
+ /* maybe give a warning message here... */
+ }
+ }
+ dpreds = rev(dpreds);
+
+ /* Calculate type and translation for each expr in the field list */
+ for (fs1=fs, dp=dpreds, i=alpha+2; nonNull(fs1); fs1=tl(fs1), dp=tl(dp), i++) {
+ static String with = "with";
+ Cell ev = hd(dp);
+ snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
+ bindTv(i,typeIs,typeOff);
+ if (nonNull(ev)) {
+ shouldBe(line,fst(hd(fs1)),e,with,snd(fst3(ev)),intOf(snd3(ev)));
+ bs = cons(cons(pair(thd3(ev), cons(triple(NIL, mkInt(line), snd(hd(fs1))), NIL)), NIL), bs);
+ }
+ }
+ typeIs = tIs;
+ typeOff = tOff;
+ return (ap(LETREC,pair(bs,fst(snd(e)))));
+}
+#endif
+
static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
Int l; /* fresh type variables to each var */
Cell p; { /* bound in the pattern */
preds = NIL; /* Type check the bindings */
mapProc(restrictedBindAss,bs);
mapProc(typeBind,bs);
+ improve(line,NIL,preds);
normPreds(line);
elimTauts();
preds = revOnto(preds,savePreds);
preds = NIL;
mapProc(typeBind,hd(imps));
+ improve(line,NIL,preds);
clearMarks();
mapProc(markAssumList,tl(defnBounds));
enterPendingBtyvs();
for (; nonNull(alts); alts=tl(alts))
typeAlt(extbind,fst(b),hd(alts),t,o,m);
+ improve(line,ps,preds);
leavePendingBtyvs();
if (nonNull(ps)) /* Add dict params, if necessary */
mapProc(markPred,savePreds);
markBtyvs();
+ normPreds(line);
savePreds = elimPredsUsing(ps,savePreds);
if (nonNull(preds)) {
List vs = NIL;
Int i = 0;
for (; i<m; ++i)
vs = cons(mkInt(o+i),vs);
- if (resolveDefs(vs))
+ if (resolveDefs(vs)) {
savePreds = elimPredsUsing(ps,savePreds);
+ }
if (nonNull(preds)) {
clearMarks();
reducePreds();
* ------------------------------------------------------------------------*/
static Void local typeClassDefn(c) /* Type check implementations of */
-Class c; { /* defaults for class c */
+Class c; { /* defaults for class c */
/* ----------------------------------------------------------------------
- * Generate code for default dictionary builder function:
- *
- * class.C sc1 ... scn d = let v1 ... = ...
- * vm ... = ...
- * in Make.C sc1 ... scn v1 ... vm
- *
- * where sci are superclass dictionary parameters, vj are implementations
- * for member functions, either taken from defaults, or using "error" to
- * produce a suitable error message. (Additional line number values must
- * be added at appropriate places but, for clarity, these are not shown
- * above.)
+ * Generate code for default dictionary builder functions:
* --------------------------------------------------------------------*/
Int beta = newKindedVars(cclass(c).kinds);
- List params = makePredAss(cclass(c).supers,beta);
- Cell body = cclass(c).dcon;
- Cell pat = body;
+ Cell d = inventDictVar();
+ List dparam = singleton(triple(cclass(c).head,mkInt(beta),d));
List mems = cclass(c).members;
List defs = cclass(c).defaults;
List dsels = cclass(c).dsels;
- Cell d = inventDictVar();
- List args = NIL;
- List locs = NIL;
- Cell l = mkInt(cclass(c).line);
- List ps;
+ Cell pat = cclass(c).dcon;
+ Cell args = NIL;
+ Int width = cclass(c).numSupers + cclass(c).numMembers;
+ char buf[FILENAME_MAX+1];
+ Int i = 0;
+ Int j = 0;
- for (ps=params; nonNull(ps); ps=tl(ps)) {
- Cell v = thd3(hd(ps));
- body = ap(body,v);
- pat = ap(pat,inventVar());
- args = cons(v,args);
+ if (isNull(defs) && nonNull(mems)) {
+ defs = cclass(c).defaults = cons(NIL,NIL);
}
- args = revOnto(args,singleton(d));
- params = appendOnto(params,
- singleton(triple(cclass(c).head,mkInt(beta),d)));
for (; nonNull(mems); mems=tl(mems)) {
- Cell v = inventVar(); /* Pick a name for component */
- Cell imp = NIL;
-
- if (nonNull(defs)) { /* Look for default implementation */
- imp = hd(defs);
- defs = tl(defs);
- }
-
- if (isNull(imp)) { /* Generate undefined member msg */
- static String header = "Undefined member: ";
- String name = textToStr(name(hd(mems)).text);
- char msg[FILENAME_MAX+1];
- Int i;
- Int j;
-
- for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
- msg[i] = header[i];
- for (j=0; (i+j)<FILENAME_MAX && name[j]!='\0'; j++)
- msg[i+j] = name[j];
- msg[i+j] = '\0';
-
- imp = pair(v,singleton(pair(NIL,ap(l,ap(nameError,
- mkStr(findText(msg)))))));
- }
- else { /* Use default implementation */
- fst(imp) = v;
- typeMember("default member binding",
- hd(mems),
- snd(imp),
- params,
- cclass(c).head,
- beta);
- }
-
- locs = cons(imp,locs);
- body = ap(body,v);
- pat = ap(pat,v);
+ static String deftext = "default_";
+ String s = textToStr(name(hd(mems)).text);
+ Name n;
+ for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
+ buf[i] = deftext[i];
+ }
+ for(; (i+j)<FILENAME_MAX && s[j]!='\0'; j++) {
+ buf[i+j] = s[j];
+ }
+ buf[i+j] = '\0';
+ n = newName(findText(buf),c);
+
+ if (isNull(hd(defs))) { /* No default definition */
+ static String header = "Undefined member: ";
+ for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
+ buf[i] = header[i];
+ for (j=0; (i+j)<FILENAME_MAX && s[j]!='\0'; j++)
+ buf[i+j] = s[j];
+ buf[i+j] = '\0';
+ name(n).line = cclass(c).line;
+ name(n).arity = 1;
+ name(n).defn = singleton(pair(singleton(d),
+ ap(mkInt(cclass(c).line),
+ ap(nameError,
+ mkStr(fixLitText(
+ findText(buf)))))));
+ } else { /* User supplied default defn */
+ List alts = snd(hd(defs));
+ Int line = rhsLine(snd(hd(alts)));
+
+ typeMember("default member binding",
+ hd(mems),
+ alts,
+ dparam,
+ cclass(c).head,
+ beta);
+
+ name(n).line = line;
+ name(n).arity = 1+length(fst(hd(alts)));
+ name(n).defn = alts;
+
+ for (; nonNull(alts); alts=tl(alts)) {
+ fst(hd(alts)) = cons(d,fst(hd(alts)));
+ }
+ }
+
+ hd(defs) = n;
+ genDefns = cons(n,genDefns);
+ if (isNull(tl(defs)) && nonNull(tl(mems))) {
+ tl(defs) = cons(NIL,NIL);
+ }
+ defs = tl(defs);
}
- body = ap(l,body);
- if (nonNull(locs))
- body = ap(LETREC,pair(singleton(locs),body));
- name(cclass(c).dbuild).defn
- = singleton(pair(args,body));
-
- name(cclass(c).dbuild).inlineMe = TRUE;
- genDefns = cons(cclass(c).dbuild,genDefns);
- cclass(c).defaults = NIL;
/* ----------------------------------------------------------------------
* Generate code for superclass and member function selectors:
* --------------------------------------------------------------------*/
- args = getArgs(pat);
- pat = singleton(pat);
- for (; nonNull(dsels); dsels=tl(dsels)) {
- name(hd(dsels)).defn = singleton(pair(pat,ap(l,hd(args))));
+ for (i=0; i<width; i++) {
+ pat = ap(pat,inventVar());
+ }
+ pat = singleton(pat);
+ for (i=0; nonNull(dsels); dsels=tl(dsels)) {
+ name(hd(dsels)).defn = singleton(pair(pat,
+ ap(mkInt(cclass(c).line),
+ nthArg(i++,hd(pat)))));
name(hd(dsels)).inlineMe = TRUE;
- args = tl(args);
- genDefns = cons(hd(dsels),genDefns);
+ genDefns = cons(hd(dsels),genDefns);
}
for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
- name(hd(mems)).defn = singleton(pair(pat,ap(mkInt(name(hd(mems)).line),
- hd(args))));
- args = tl(args);
- genDefns = cons(hd(mems),genDefns);
+ name(hd(mems)).defn = singleton(pair(pat,
+ ap(mkInt(name(hd(mems)).line),
+ nthArg(i++,hd(pat)))));
+ genDefns = cons(hd(mems),genDefns);
}
}
* .
* .
* scm = ...
- * d = f (class.C sc1 ... scm d)
- * omit if the / f (Make.C sc1' ... scm' v1' ... vk')
- * instance decl { = let vj ... = ...
- * has no imps \ in Make.C sc1' ... scm' ... vj ...
+ * vj ... = ...
+ * d = Make.C sc1 ... scm v1 ... vk
* in d
*
- * where sci are superclass dictionaries, d and f are new names, vj
+ * where sci are superclass dictionaries, d is a new name, vj
* is a newly generated name corresponding to the implementation of a
* member function. (Additional line number values must be added at
* appropriate places but, for clarity, these are not shown above.)
+ * If no implementation of a particular vj is available, then we use
+ * the default implementation, partially applied to d.
* --------------------------------------------------------------------*/
Int alpha = newKindedVars(cclass(inst(in).c).kinds);
List imps = inst(in).implements;
Cell l = mkInt(inst(in).line);
- Cell dictDef = cclass(inst(in).c).dbuild;
+ Cell dictDef = cclass(inst(in).c).dcon;
+ List mems = cclass(inst(in).c).members;
+ List defs = cclass(inst(in).c).defaults;
List args = NIL;
List locs = NIL;
List ps;
locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
dictDef = ap(dictDef,thd3(pi));
}
- dictDef = ap(dictDef,d);
-
- if (isNull(imps)) /* No implementations */
- locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
- else { /* Implementations supplied*/
- List mems = cclass(inst(in).c).members;
- Cell f = inventVar();
- Cell pat = cclass(inst(in).c).dcon;
- Cell res = pat;
- List locs1 = NIL;
-
- locs = cons(pair(d,singleton(pair(NIL,ap(l,ap(f,dictDef))))),
- locs);
-
- for (ps=supers; nonNull(ps); ps=tl(ps)){/* Add param for each sc */
- Cell v = inventVar();
- pat = ap(pat,v);
- res = ap(res,v);
- }
-
- for (; nonNull(mems); mems=tl(mems)) { /* For each member: */
- Cell v = inventVar();
- Cell imp = NIL;
-
- if (nonNull(imps)) { /* Look for implementation */
- imp = hd(imps);
- imps = tl(imps);
- }
-
- if (isNull(imp)) { /* If none, f will copy */
- pat = ap(pat,v); /* its argument unchanged */
- res = ap(res,v);
- }
- else { /* Otherwise, add the impl */
- pat = ap(pat,WILDCARD); /* to f as a local defn */
- res = ap(res,v);
- typeMember("instance member binding",
- hd(mems),
- snd(imp),
- evids,
- inst(in).head,
- beta);
- locs1 = cons(pair(v,snd(imp)),locs1);
- }
- }
- res = ap(l,res);
- if (nonNull(locs1)) /* Build the body of f */
- res = ap(LETREC,pair(singleton(locs1),res));
- pat = singleton(pat); /* And the arglist for f */
- locs = cons(pair(f,singleton(pair(pat,res))),locs);
- }
- d = ap(l,d);
-
- name(inst(in).builder).defn /* Register builder imp */
- = singleton(pair(args,ap(LETREC,pair(singleton(locs),d))));
+ for (; nonNull(defs); defs=tl(defs)) {
+ Cell imp = NIL;
+ if (nonNull(imps)) {
+ imp = hd(imps);
+ imps = tl(imps);
+ }
+ if (isNull(imp)) {
+ dictDef = ap(dictDef,ap(hd(defs),d));
+ } else {
+ Cell v = inventVar();
+ dictDef = ap(dictDef,v);
+ typeMember("instance member binding",
+ hd(mems),
+ snd(imp),
+ evids,
+ inst(in).head,
+ beta);
+ locs = cons(pair(v,snd(imp)),locs);
+ }
+ mems = tl(mems);
+ }
+ 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)))));
name(inst(in).builder).inlineMe = TRUE;
name(inst(in).builder).isDBuilder = TRUE;
genDefns = cons(inst(in).builder,genDefns);
typeAlt(wh,mem,hd(alts),t,o,m);
qualify(tl(ps),hd(alts)); /* Add any extra dict params */
}
+ improve(line,evids,preds);
leavePendingBtyvs();
evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
evids);
clearMarks();
+ normPreds(line);
qs = elimPredsUsing(evids,NIL);
if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
qs = elimPredsUsing(evids,qs);
#endif
if (!sameSchemes(t,rt))
tooGeneral(line,mem,rt,t);
- if (nonNull(preds))
- cantEstablish(line,wh,mem,t,ps);
+ if (nonNull(preds)) {
+ preds = scSimplify(preds);
+ cantEstablish(line,wh,mem,t,ps);
+ }
}
/* --------------------------------------------------------------------------
Cell rhsExpr(rhs) /* find first expression on a rhs */
Cell rhs; {
+ STACK_CHECK
switch (whatIs(rhs)) {
case GUARDED : return snd(snd(hd(snd(rhs))));
case LETREC : return rhsExpr(snd(snd(rhs)));
Int rhsLine(rhs) /* find line number associated with */
Cell rhs; { /* a right hand side */
+ STACK_CHECK
switch (whatIs(rhs)) {
case GUARDED : return intOf(fst(hd(snd(rhs))));
case LETREC : return rhsLine(snd(snd(rhs)));
static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
Type t1, t2; {
-
+ STACK_CHECK
et: if (whatIs(t1)!=whatIs(t2))
return FALSE;
type = typeIs;
beta = typeOff;
clearMarks();
+ improve(0,NIL,preds);
normPreds(0);
elimTauts();
preds = scSimplify(preds);
Int what; {
switch (what) {
case RESET : tcMode = EXPRESSION;
++ daSccs = NIL;
preds = NIL;
pendingBtyvs = NIL;
daSccs = NIL;
emptyAssumption();
break;
- case MARK : mark(daSccs);
- mark(defnBounds);
+ case MARK : mark(defnBounds);
mark(varsBounds);
mark(depends);
mark(pendingBtyvs);
mark(localEvs);
mark(savedPs);
mark(dummyVar);
+ mark(daSccs);
mark(preds);
mark(stdDefaults);
mark(arrow);
projects / ghc-hetmet.git / commitdiff