/* --------------------------------------------------------------------------
* Static Analysis for Hugs
*
- * Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale
- * Haskell Group 1994-99, and is distributed as Open Source software
- * under the Artistic License; see the file "Artistic" that is included
- * in the distribution for details.
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved. It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/09 14:51:10 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/10 15:59:50 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* ------------------------------------------------------------------------*/
static Void local kindError Args((Int,Constr,Constr,String,Kind,Int));
-#if !IGNORE_MODULES
static Void local checkQualImport Args((Pair));
static Void local checkUnqualImport Args((Triple));
static Void local importTycon Args((Module,Tycon));
static Void local importClass Args((Module,Class));
static List local checkExports Args((List));
-#endif
static Void local checkTyconDefn Args((Tycon));
static Void local depConstrs Args((Tycon,List,Cell));
static List local selectCtxt Args((List,List));
static Void local checkSynonyms Args((List));
static List local visitSyn Args((List,Tycon,List));
-#if EVAL_INSTANCES
-static Void local deriveEval Args((List));
-static List local calcEvalContexts Args((Tycon,List,List));
-static Void local checkBanged Args((Name,Kinds,List,Type));
-#endif
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 checkMems2 Args((Class,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));
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));
-#if IGNORE_MODULES
-static Void local duplicateErrorAux Args((Int,Text,String));
-#define duplicateError(l,m,t,k) duplicateErrorAux(l,t,k)
-#else
+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)
-#endif
static Void local checkTypeIn Args((Pair));
/* --------------------------------------------------------------------------
String reloadModule;
#endif
-#if !IGNORE_MODULES
Void startModule(nm) /* switch to a new module */
Cell nm; {
Module m;
if (DOTDOT == snd(entity)) {
imports=dupOnto(tycon(f).defn,imports);
} else {
- imports=checkSubentities(imports,snd(entity),tycon(f).defn,"constructor of type",t);
+ imports=checkSubentities(imports,snd(entity),tycon(f).defn,
+ "constructor of type",t);
}
break;
default:;
if (DOTDOT == snd(entity)) {
return dupOnto(cclass(f).members,imports);
} else {
- return checkSubentities(imports,snd(entity),cclass(f).members,"member of class",t);
+ return checkSubentities(imports,snd(entity),cclass(f).members,
+ "member of class",t);
}
}
}
List es = module(m).exports;
for(; nonNull(es); es=tl(es)) {
Cell e = hd(es);
- if (isName(e))
+ if (isName(e)) {
imports = cons(e,imports);
- else {
+ } else {
Cell c = fst(e);
List subentities = NIL;
imports = cons(c,imports);
switch (tycon(nm).what) {
case SYNONYM:
if (DOTDOT!=parts) {
- ERRMSG(0) "Explicit constructor list given for type synonym \"%s\" in export list of module \"%s\"",
+ ERRMSG(0) "Explicit constructor list given for type synonym"
+ " \"%s\" in export list of module \"%s\"",
identToStr(ident),
textToStr(mt)
EEND;
}
return cons(pair(nm,DOTDOT),exports);
case RESTRICTSYN:
- ERRMSG(0) "Transparent export of restricted type synonym \"%s\" in export list of module \"%s\"",
+ ERRMSG(0) "Transparent export of restricted type synonym"
+ " \"%s\" in export list of module \"%s\"",
identToStr(ident),
textToStr(mt)
EEND;
EEND;
}
}
- return 0; /* NOTREACHED */
+ return exports; /* NOTUSED */
}
static List local checkExports(exports)
#endif
return es;
}
-#endif
+
/* --------------------------------------------------------------------------
* Static analysis of type declarations:
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)
con = ty;
}
- if (nr2>0) /* Add rank 2 annotation */
- type = ap(RANK2,pair(mkInt(nr2),type));
+ if (nr2>0) { /* Add rank 2 annotation */
+ type = ap(RANK2,pair(mkInt(nr2-length(lps)),type));
+ }
if (nonNull(evs)) { /* Add existential annotation */
if (nonNull(derivs)) {
return removeCell(t,syns);
}
-#if EVAL_INSTANCES
-/* --------------------------------------------------------------------------
- * The following code is used in calculating contexts for the automatically
- * derived Eval instances for newtype and restricted type synonyms. This is
- * ugly code, resulting from an ugly feature in the language, and I hope that
- * the feature, and hence the code, will be removed in the not too distant
- * future.
- * ------------------------------------------------------------------------*/
-
-static Void local deriveEval(tcs) /* Derive instances of Eval */
-List tcs; {
- List ts1 = tcs;
- List ts = NIL;
- for (; nonNull(ts1); ts1=tl(ts1)) { /* Build list of rsyns and newtypes*/
- Tycon t = hd(ts1); /* and derive instances for data */
- switch (whatIs(tycon(t).what)) {
- case DATATYPE : addEvalInst(tycon(t).line,t,tycon(t).arity,NIL);
- break;
- case NEWTYPE :
- case RESTRICTSYN : ts = cons(t,ts);
- break;
- }
- }
- emptySubstitution(); /* then derive other instances */
- while (nonNull(ts)) {
- ts = calcEvalContexts(hd(ts),tl(ts),NIL);
- }
- emptySubstitution();
-
- for (; nonNull(tcs); tcs=tl(tcs)) { /* Check any banged components */
- Tycon t = hd(tcs);
- if (whatIs(tycon(t).what)==DATATYPE) {
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- if (isPair(name(c).defn)) {
- Type t = name(c).type;
- List scs = fst(name(c).defn);
- Kinds ks = NIL;
- List ctxt = NIL;
- Int n = 1;
- if (isPolyType(t)) {
- ks = polySigOf(t);
- t = monotypeOf(t);
- }
- if (whatIs(t)==QUAL) {
- ctxt = fst(snd(t));
- t = snd(snd(t));
- }
- for (; nonNull(scs); scs=tl(scs)) {
- Int i = intOf(hd(scs));
- for (; n<i; n++) {
- t = arg(t);
- }
- checkBanged(c,ks,ctxt,arg(fun(t)));
- }
- }
- }
- }
- }
-}
-
-static List local calcEvalContexts(tc,ts,ps)
-Tycon tc; /* Worker code for deriveEval */
-List ts; /* ts = not visited, ps = visiting */
-List ps; {
- Cell ctxt = NIL;
- Int o = newKindedVars(tycon(tc).kind);
- Type t = tycon(tc).defn;
- Int i;
-
- if (whatIs(tycon(tc).what)==NEWTYPE) {
- t = name(hd(t)).type;
- if (isPolyType(t)) {
- t = monotypeOf(t);
- }
- if (whatIs(t)==QUAL) {
- t = snd(snd(t));
- }
- if (whatIs(t)==EXIST) { /* No instance if existentials used*/
- return ts;
- }
- if (whatIs(t)==RANK2) { /* No instance if arg is poly/qual */
- return ts;
- }
- t = arg(fun(t));
- }
-
- clearMarks(); /* Make sure generics are marked */
- for (i=0; i<tycon(tc).arity; i++) { /* in the correct order. */
- copyTyvar(o+i);
- }
-
- for (;;) {
- Type h = getDerefHead(t,o);
- if (isSynonym(h) && argCount>=tycon(h).arity) {
- expandSyn(h,argCount,&t,&o);
- } else if (isOffset(h)) { /* Stop if var at head */
- ctxt = singleton(ap(classEval,copyType(t,o)));
- break;
- } else if (isTuple(h) /* Check for tuples ... */
- || h==tc /* ... direct recursion */
- || cellIsMember(h,ps) /* ... mutual recursion */
- || tycon(h).what==DATATYPE) {/* ... or datatype. */
- break; /* => empty context */
- } else {
- Cell pi = ap(classEval,t);
- Inst in;
-
- if (cellIsMember(h,ts)) { /* Not yet visited? */
- ts = calcEvalContexts(h,removeCell(h,ts),cons(h,ts));
- }
-<<<<<<<<<<<<<< variant A
->>>>>>>>>>>>>> variant B
-
-======= end of combination
- if (nonNull(in=findInstFor(pi,o))) {/* Look for Eval instance */
- List qs = inst(in).specifics;
- Int o1 = typeOff;
- if (isNull(qs)) { /* No context there */
- break; /* => empty context here */
- }
- if (isNull(tl(qs)) && classEval==fun(hd(qs))) {
- t = arg(hd(qs));
- o = o1;
- continue;
- }
- }
- return ts; /* No instance, so give up */
- }
- }
- addEvalInst(tycon(tc).line,tc,tycon(tc).arity,ctxt);
- return ts;
-}
-
-static Void local checkBanged(c,ks,ps,ty)
-Name c; /* Check that banged component of c */
-Kinds ks; /* with type ty is an instance of */
-List ps; /* Eval under the predicates in ps. */
-Type ty; { /* (All types using ks) */
- Cell pi = ap(classEval,ty);
- if (isNull(provePred(ks,ps,pi))) {
- ERRMSG(name(c).line) "Illegal datatype strictness annotation:" ETHEN
- ERRTEXT "\n*** Constructor : " ETHEN ERREXPR(c);
- ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
- ERRTEXT "\n*** Required : " ETHEN ERRPRED(pi);
- ERRTEXT "\n"
- EEND;
- }
-}
-#endif
-
/* --------------------------------------------------------------------------
* Expanding out all type synonyms in a type expression:
* ------------------------------------------------------------------------*/
* 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;
+ cclass(nw).xfds = NIL;
+ 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(vs)) {
+ 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)
+
+/* --------------------------------------------------------------------------
+ * Functional dependencies are inherited from superclasses.
+ * For example, if I've got the following classes:
+ *
+ * class C a b | a -> b
+ * class C [b] a => D a b
+ *
+ * then C will have the dependency ([a], [b]) as expected, and D will inherit
+ * the dependency ([b], [a]) from C.
+ * When doing pairwise improvement, we have to consider not just improving
+ * when we see a pair of Cs or a pair of Ds in the context, but when we've
+ * got a C and a D as well. In this case, we only improve when the
+ * predicate in question matches the type skeleton in the relevant superclass
+ * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying
+ * a and b), but we don't improve the pair (C Int a, D b Int).
+ * To implement functional dependency inheritance, we calculate
+ * the closure of all functional dependencies, and store the result
+ * in an additional field `xfds' (extended functional dependencies).
+ * The `xfds' field is a list of functional dependency lists, annotated
+ * with a list of predicate skeletons constraining when improvement can
+ * happen against this dependency list. For example, the xfds field
+ * for C above would be:
+ * [([C a b], [([a], [b])])]
+ * and the xfds field for D would be:
+ * [([C [b] a, D a b], [([b], [a])])]
+ * Self-improvement (of a C with a C, or a D with a D) is treated as a
+ * special case of an inherited dependency.
+ * ------------------------------------------------------------------------*/
+static List local inheritFundeps ( Class c, Cell pi, Int o )
+{
+ Int alpha = newKindedVars(cclass(c).kinds);
+ List scs = cclass(c).supers;
+ List xfds = NIL;
+ Cell this = NIL;
+ /* better not fail ;-) */
+ if (!matchPred(pi,o,cclass(c).head,alpha))
+ internal("inheritFundeps - predicate failed to match it's own head!");
+ this = copyPred(pi,o);
+ for (; nonNull(scs); scs=tl(scs)) {
+ Class s = getHead(hd(scs));
+ if (isClass(s)) {
+ List sfds = inheritFundeps(s,hd(scs),alpha);
+ for (; nonNull(sfds); sfds=tl(sfds)) {
+ Cell h = hd(sfds);
+ xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds);
+ }
+ }
+ }
+ if (nonNull(cclass(c).fds)) {
+ List fds = NIL, fs = cclass(c).fds;
+ for (; nonNull(fs); fs=tl(fs)) {
+ fds = cons(pair(otvars(this,fst(hd(fs))),
+ otvars(this,snd(hd(fs)))),fds);
+ }
+ xfds = cons(pair(cons(this,NIL),fds),xfds);
+ }
+ return xfds;
+}
+
+static Void local extendFundeps ( Class c )
+{
+ Int alpha;
+ emptySubstitution();
+ alpha = newKindedVars(cclass(c).kinds);
+ cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha);
+
+ /* we can now check for ambiguity */
+ map1Proc(checkMems2,c,fst(cclass(c).members));
+}
+
+
+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 */
h98CheckType(line,"member type",hd(vs),t);
}
+static Void local checkMems2(c,m) /* check member function details */
+Class c;
+Cell m; {
+ Int line = intOf(fst3(m));
+ List vs = snd3(m);
+ Type t = thd3(m);
+}
+
static Void local addMembers(c) /* Add definitions of member funs */
Class c; { /* and other parts of class struct.*/
List ms = fst(cclass(c).members);
List ns = NIL; /* List of names */
Int mno; /* Member function number */
- //printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) );
for (mno=0; mno<cclass(c).numSupers; mno++) {
ns = cons(newDSel(c,mno),ns);
}
*/
mno = cclass(c).numSupers + cclass(c).numMembers;
- cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL);
- implementCfun(cclass(c).dcon,NIL); /* ADR addition */
+ /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */
+ cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL);
+ /* implementCfun(cclass(c).dcon,NIL);
+ Don't manufacture a wrapper fn for dictionary constructors.
+ Applications of dictionary constructors are always saturated,
+ and translate.c:stgExpr() special-cases saturated constructor apps.
+ */
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);
}
EEND;
}
- name(m).line = l;
- name(m).arity = 1;
- name(m).number = mfunNo(no);
- name(m).type = t;
- //printf ( " [%d %d] %s :: ", m, m-NAMEMIN, textToStr ( name(m).text ) );
- //printType(stdout, t );
- //printf ( "\n" );
+ name(m).line = l;
+ name(m).arity = 1;
+ name(m).number = mfunNo(no);
+ name(m).type = t;
return m;
}
Name s;
char buf[16];
- sprintf(buf,"sc%d.%s",no,"%s");
- s = newName(generateText(buf,c),c);
- name(s).line = cclass(c).line;
- name(s).arity = 1;
- name(s).number = DFUNNAME;
+ /* sprintf(buf,"sc%d.%s",no,"%s"); */
+ sprintf(buf,"$p%d%s",no+1,"%s");
+ s = newName(generateText(buf,c),c);
+ name(s).line = cclass(c).line;
+ name(s).arity = 1;
+ name(s).number = DFUNNAME;
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.
* ------------------------------------------------------------------------*/
-static List local 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. */
+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 */
+ if (isNull(ty)) return vs;
switch (whatIs(ty)) {
- case AP : return typeVarsIn(snd(ty),us,
- typeVarsIn(fst(ty),us,vs));
+ case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs);
+ case UNBOXEDTUP: return typeVarsIn(snd(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 AP : return typeVarsIn(snd(ty),us,ws,
+ typeVarsIn(fst(ty),us,ws,vs));
- case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(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 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 POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs);
- case BANG : return typeVarsIn(snd(ty),us,vs);
+ case QUAL : { vs = typeVarsIn(fst(snd(ty)),us,ws,vs);
+ return typeVarsIn(snd(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 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,ws,vs);
+ }
+ return vs;
+ }
+ case TUPLE:
+ case TYCON:
+ case CONIDCELL:
+ case QUALIDENT: return vs;
+
+ default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn");
}
- return vs;
+ assert(0);
}
static List local maybeAppendVar(v,vs) /* append variable to list if not */
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);
+
+ /* this case will lead to a type error --
+ much better than reporting an internal error ;-) */
+ /* 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;
+ 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 xfs = cclass(c).xfds;
+ for (; nonNull(xfs); xfs=tl(xfs)) {
+ List fs = snd(hd(xfs));
+ 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 xfs = cclass(c).xfds;
+ for (; nonNull(xfs); xfs=tl(xfs)) {
+ List fs = snd(hd(xfs));
+ 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);
ERRMSG(line) "Illegal predicate in instance declaration"
EEND;
}
-#if EVAL_INSTANCES
- if (inst(in).c==classEval) {
- ERRMSG(line) "Instances of class \"%s\" are generated automatically",
- textToStr(cclass(inst(in).c).text)
- EEND;
+
+ if (nonNull(cclass(inst(in).c).fds)) {
+ List fds = cclass(inst(in).c).fds;
+ for (; nonNull(fds); fds=tl(fds)) {
+ List as = otvars(inst(in).head, fst(hd(fds)));
+ List bs = otvars(inst(in).head, snd(hd(fds)));
+ List fs = calcFunDeps(inst(in).specifics);
+ as = oclose(fs,as);
+ if (!osubset(bs,as)) {
+ ERRMSG(inst(in).line)
+ "Instance is more general than a dependency allows"
+ ETHEN
+ ERRTEXT "\n*** Instance : "
+ ETHEN ERRPRED(inst(in).head);
+ ERRTEXT "\n*** For class : "
+ ETHEN ERRPRED(cclass(inst(in).c).head);
+ ERRTEXT "\n*** Under dependency : "
+ ETHEN ERRFD(hd(fds));
+ ERRTEXT "\n"
+ EEND;
+ }
+ }
}
-#endif
+
kindInst(in,length(tyvars));
insertInst(in);
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);
addDerInst(0,c,NIL,cts,mkTuple(n),n);
}
-#if EVAL_INSTANCES
-Void addEvalInst(line,t,arity,ctxt) /* Add dummy instance for Eval */
-Int line;
-Cell t;
-Int arity;
-List ctxt; {
- Inst in = newInst();
- Cell head = t;
- Int i;
- for (i=0; i<arity; i++) {
- head = ap(head,mkOffset(i));
- }
- inst(in).line = line;
- inst(in).c = classEval;
- inst(in).head = ap(classEval,head);
- inst(in).specifics = ctxt;
- inst(in).builder = newInstImp(in);
- inst(in).numSpecifics = length(ctxt);
- kindInst(in,arity);
- cclass(classEval).instances
- = appendOnto(cclass(classEval).instances,singleton(in));
-}
-#endif
-
#if TREX
Inst addRecShowInst(c,e) /* Generate instance for ShowRecRow*/
Class c; /* c *must* be ShowRecRow */
List ps = snd(snd(inst(in).specifics));
List spcs = fst(snd(inst(in).specifics));
Int beta = inst(in).numSpecifics;
+ Int its = 1;
+ Int factor = 1+length(ps);
#ifdef DEBUG_DERIVING
Printf("calcInstPreds: ");
while (nonNull(ps)) {
Cell p = hd(ps);
ps = tl(ps);
+ if (its++ >= factor*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)) {
}
-/*-- from STG --*/
/* --------------------------------------------------------------------------
* Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
* They are used to "import" C functions into a module.
* They are usually not written by hand but, rather, generated automatically
- * by GreenCard, IDL compilers or whatever.
+ * by GreenCard, IDL compilers or whatever. We support foreign import
+ * (static) and foreign import dynamic. In the latter case, extName==NIL.
*
* Foreign export declarations generate C wrappers for Hugs functions.
* Hugs only provides "foreign export dynamic" because it's not obvious
* what "foreign export static" would mean in an interactive setting.
* ------------------------------------------------------------------------*/
-Void foreignImport(line,extName,intName,type) /* Handle foreign imports */
+Void foreignImport(line,callconv,extName,intName,type)
+ /* Handle foreign imports */
Cell line;
+Text callconv;
Pair extName;
Cell intName;
Cell type; {
ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
EEND;
}
- name(n).line = l;
- name(n).defn = extName;
- name(n).type = type;
- foreignImports = cons(n,foreignImports);
+ name(n).line = l;
+ name(n).defn = extName;
+ name(n).type = type;
+ name(n).callconv = callconv;
+ foreignImports = cons(n,foreignImports);
}
static Void local checkForeignImport(p) /* Check foreign import */
implementForeignImport(p);
}
-Void foreignExport(line,extName,intName,type)/* Handle foreign exports */
+Void foreignExport(line,callconv,extName,intName,type)
+ /* Handle foreign exports */
Cell line;
+Text callconv;
Cell extName;
Cell intName;
Cell type; {
ERRMSG(l) "Redeclaration of foreign \"%s\"", textToStr(t)
EEND;
}
- name(n).line = l;
- name(n).defn = NIL; /* nothing to say */
- name(n).type = type;
- foreignExports = cons(n,foreignExports);
+ name(n).line = l;
+ name(n).defn = NIL; /* nothing to say */
+ name(n).type = type;
+ name(n).callconv = callconv;
+ foreignExports = cons(n,foreignExports);
}
static Void local checkForeignExport(p) /* Check foreign export */
-
-#if 0
-/*-- from 98 --*/
-/* --------------------------------------------------------------------------
- * Primitive definitions are usually only included in the first script
- * file read - the prelude. A primitive definition associates a variable
- * name with a string (which identifies a built-in primitive) and a type.
- * ------------------------------------------------------------------------*/
-
-Void primDefn(line,prims,type) /* Handle primitive definitions */
-Cell line;
-List prims;
-Cell type; {
- primDefns = cons(triple(line,prims,type),primDefns);
-}
-
-static List local checkPrimDefn(pd) /* Check primitive definition */
-Triple pd; {
- Int line = intOf(fst3(pd));
- List prims = snd3(pd);
- Type type = thd3(pd);
- emptySubstitution();
- type = checkSigType(line,"primitive definition",fst(hd(prims)),type);
- for (; nonNull(prims); prims=tl(prims)) {
- Cell p = hd(prims);
- Bool same = isVar(p);
- Text pt = textOf(same ? p : fst(p));
- String pr = textToStr(textOf(same ? p : snd(p)));
- hd(prims) = addNewPrim(line,pt,pr,type);
- }
- return snd3(pd);
-}
-
-static Name local addNewPrim(l,vn,s,t) /* make binding of variable vn to */
-Int l; /* primitive function referred */
-Text vn; /* to by s, with given type t */
-String s;
-Cell t;{
- Name n = findName(vn);
-
- if (isNull(n)) {
- n = newName(vn,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- duplicateError(l,name(n).mod,vn,"primitive");
- }
-
- addPrim(l,n,s,t);
- return n;
-}
-#endif
-
-
-
-
-
/* --------------------------------------------------------------------------
* Static analysis of patterns:
*
case CONIDCELL :
case CONOPCELL : return checkApPat(line,0,p);
-#if BIGNUMS
- case ZERONUM :
- case POSNUM :
- case NEGNUM :
-#endif
case WILDCARD :
case STRCELL :
case CHARCELL :
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;
}
if (nneg&1) /* for literals */
arg(temp) = mkInt(-intOf(arg(temp)));
}
-#if BIGNUMS
- else if (isBignum(arg(temp))) {
- if (nneg&1)
- arg(temp) = bigNeg(arg(temp));
- }
-#endif
else if (isFloat(arg(temp))) {
if (nneg&1)
arg(temp) = floatNegate(arg(temp));
mapProc(addDepField,bs); /* add extra field for dependents */
for (xs=bs; nonNull(xs); xs=tl(xs)) {
-
- //Printf("\n-----------------------------------------\n" ); print(hd(xs),1000); Printf("\n");
-
emptySubstitution();
depBinding(hd(xs));
soFar((Target)(i++));
break;
#endif
-#if BIGNUMS
- case ZERONUM :
- case POSNUM :
- case NEGNUM :
+#if IPARAM
+ case IPVAR :
#endif
+
case NAME :
case TUPLE :
case STRCELL :
case CHARCELL :
case FLOATCELL :
+ case BIGCELL :
case INTCELL : break;
case COND : depTriple(line,snd(e));
case UPDFLDS : depUpdFlds(line,e);
break;
+#if IPARAM
+ case WITHEXP : depWith(line,e);
+ break;
+#endif
+
case ASPAT : ERRMSG(line) "Illegal `@' in expression"
EEND;
EEND;
#endif
- default : fprintf(stderr,"whatIs(e) == %d\n",whatIs(e));internal("depExpr");
+ default : internal("depExpr");
}
return e;
}
EEND;
}
-#if !IGNORE_MODULES
if (!moduleThisScript(name(n).mod)) {
return n;
}
-#endif
/* Later phases of the system cannot cope if we resolve references
* to unprocessed objects too early. This is the main reason that
* we cannot cope with recursive modules at the moment.
ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
EEND;
}
-#if !IGNORE_MODULES
if (name(n).mod != currentModule) {
return n;
}
-#endif
if (fst(e) == VARIDCELL) {
e = mkVar(qtextOf(e));
} else {
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);
}
+#if EXPLAIN_INSTANCE_RESOLUTION
+Void checkContext(void) { /* 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);
+}
+#endif
+
Void checkDefns() { /* Top level static analysis */
-#if !IGNORE_MODULES
Module thisModule = lastModule();
-#endif
staticAnalysis(RESET);
-#if !IGNORE_MODULES
setCurrModule(thisModule);
/* Resolve module references */
module(thisModule).qualImports);
}
mapProc(checkImportList, unqualImports);
-#endif
- linkPreludeTC(); /* Get prelude tycons and classes */
+ if (!combined) linkPreludeTC(); /* Get prelude tycons and classes */
+
mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
checkSynonyms(tyconDefns); /* check synonym definitions */
mapProc(checkClassDefn,classDefns); /* process class definitions */
mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
+ mapProc(extendFundeps,classDefns); /* finish class definitions */
mapProc(addMembers,classDefns); /* add definitions for member funs */
mapProc(visitClass,classDefns); /* check class hierarchy */
- linkPreludeCM(); /* Get prelude cfuns and mfuns */
+
+ if (!combined) linkPreludeCM(); /* Get prelude cfuns and mfuns */
instDefns = rev(instDefns); /* process instance definitions */
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 */
-#if EVAL_INSTANCES
- deriveEval(tyconDefns); /* Derive instances of Eval */
-#endif
instDefns = appendOnto(instDefns,derivedInsts);
checkDefaultDefns(); /* validate default definitions */
- mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
-#if 0 /* from STG */
- valDefns = eqnsToBindings(valDefns);/* translate value equations */
- map1Proc(opDefined,valDefns,opDefns);/*check all declared ops bound */
-#else /* from 98 */
- valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns, NIL/*primDefns*/ );
- tyconDefns = NIL;
- /* primDefns = NIL; */
-#endif
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
- linkPreludeNames();
+ if (!combined) linkPreludeNames(); /* link names in Prelude */
mapProc(checkForeignImport,foreignImports); /* check foreign imports */
mapProc(checkForeignExport,foreignExports); /* check foreign exports */
foreignImports = NIL;
foreignExports = NIL;
-#if !IGNORE_MODULES
/* Every top-level name has now been created - so we can build the */
/* export list. Note that this has to happen before dependency */
/* analysis so that references to Prelude.foo will be resolved */
/* when compiling the prelude. */
module(thisModule).exports = checkExports(module(thisModule).exports);
-#endif
mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
staticAnalysis(RESET);
}
+
+
+
static Void local addRSsigdecls(pr) /* add sigdecls from TYPE ... IN ..*/
Pair pr; {
List vs = snd(pr); /* get list of variables */
name(n).line = line;
}
-#if IGNORE_MODULES
-static Void local duplicateErrorAux(line,t,kind) /* report duplicate defn */
-Int line;
-Text t;
-String kind; {
- ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
- textToStr(t)
- EEND;
-}
-#else /* !IGNORE_MODULES */
static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
Int line;
Module mod;
EEND;
}
}
-#endif /* !IGNORE_MODULES */
static Void local checkTypeIn(cvs) /* Check that vars in restricted */
Pair cvs; { /* synonym are defined */
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
#endif
break;
- case INSTALL : staticAnalysis(RESET);
+ case POSTPREL: break;
+
+ case PREPREL : staticAnalysis(RESET);
#if TREX
extKind = pair(STAR,pair(ROW,ROW));
#endif
- break;
}
}
projects / ghc-hetmet.git / blobdiff