Merging in the various changes between Sep99 Hugs and Nov99 Hugs.
* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/12 17:32:38 $
+ * $Revision: 1.16 $
+ * $Date: 1999/11/17 16:57:38 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Void stringInput Args((String));
extern Void parseScript Args((String,Long));
extern Void parseExp Args((Void));
+#if EXPLAIN_INSTANCE_RESOLUTION
extern Void parseContext Args((Void));
+#endif
extern String readFilename Args((Void));
extern String readLine Args((Void));
extern Syntax defaultSyntax Args((Text));
extern Void primDefn Args((Cell,List,Cell));
extern Void defaultDefn Args((Int,List));
extern Void checkExp Args((Void));
+#if EXPLAIN_INSTANCE_RESOLUTION
+extern Void checkContext Args((Void));
+#endif
extern Void checkDefns Args((Void));
extern Bool h98Pred Args((Bool,Cell));
extern Cell h98Context Args((Bool,List));
extern Void needPrims Args((Int));
extern List calcFunDepsPreds Args((List));
extern Inst findInstFor Args((Cell,Int));
+#if MULTI_INST
+extern List findInstsFor Args((Cell,Int));
+#endif
extern Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds );
#define aVar mkOffset(0) /* Simple skeleton for type var */
* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.20 $
- * $Date: 1999/11/12 17:50:01 $
+ * $Revision: 1.21 $
+ * $Date: 1999/11/17 16:57:38 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
static Void local setLastEdit Args((String,Int));
static Void local failed Args((Void));
static String local strCopy Args((String));
-static Void local browseit Args((Module,String));
+static Void local browseit Args((Module,String,Bool));
static Void local browse Args((Void));
/* --------------------------------------------------------------------------
}
-static Void local browseit(mod,t)
+static Void local browseit(mod,t,all)
Module mod;
-String t; {
+String t;
+Bool all; {
if (nonNull(mod)) {
Cell cs;
- Printf("module %s where\n",textToStr(module(mod).text));
+ if (nonNull(t))
+ Printf("module %s where\n",textToStr(module(mod).text));
for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
Name nm = hd(cs);
- /* only look at things defined in this module */
- if (name(nm).mod == mod) {
+ /* only look at things defined in this module,
+ unless `all' flag is set */
+ if (all || name(nm).mod == mod) {
/* unwanted artifacts, like lambda lifted values,
are in the list of names, but have no types */
if (nonNull(name(nm).type)) {
static Void local browse() { /* browse modules */
Int count = 0; /* or give menu of commands */
String s;
+ Bool all = FALSE;
setCurrModule(findEvalModule());
startNewScript(0); /* for recovery of storage */
- for (; (s=readFilename())!=0; count++) {
- browseit(findModule(findText(s)),s);
- }
+ for (; (s=readFilename())!=0; count++)
+ if (strcmp(s,"all") == 0) {
+ all = TRUE;
+ --count;
+ } else
+ browseit(findModule(findText(s)),s,all);
if (count == 0) {
- whatScripts();
+ browseit(findEvalModule(),NULL,all);
}
}
#if EXPLAIN_INSTANCE_RESOLUTION
static Void local xplain() { /* print type of expression (if any)*/
- Cell type;
Cell d;
Bool sir = showInstRes;
Void setGoal(what, t) /* Set goal for what to be t */
String what;
Target t; {
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
currTarget = (t?t:1);
aiming = TRUE;
if (useDots) {
Void soFar(t) /* Indicate progress towards goal */
Target t; { /* has now reached t */
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
if (useDots) {
Int newPos = (Int)((maxPos * ((long)t))/currTarget);
}
Void done() { /* Goal has now been achieved */
- if (quiet) return;
+ if (quiet)
+ return;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes)
+ return;
+#endif
if (useDots) {
while (maxPos>currPos++)
Putchar('.');
* included in the distribution.
*
* $RCSfile: input.c,v $
- * $Revision: 1.11 $
- * $Date: 1999/11/12 16:38:31 $
+ * $Revision: 1.12 $
+ * $Date: 1999/11/17 16:57:40 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
setLastExpr(inputExpr);
}
+
+#if EXPLAIN_INSTANCE_RESOLUTION
Void parseContext() { /* Read a context to prove */
parseInput(CONTEXT);
}
+#endif
Void parseInterface(nm,len) /* Read a GHC interface file */
String nm;
* included in the distribution.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/10/20 02:16:01 $
+ * $Revision: 1.10 $
+ * $Date: 1999/11/17 16:57:41 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
}
}
return dir;
-#elif HAVE_GETMODULEFILENAME && !DOS
+#elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
/* On Windows, we can find the binary we're running and it's
* conventional to put the libraries in the same place.
*/
if (dir[0] == '\0') { /* GetModuleFileName must have failed */
return HUGSDIR;
}
- if (slash = strrchr(dir,SLASH)) { /* truncate after directory name */
+ slash = strrchr(dir,SLASH);
+ if (slash) { /* truncate after directory name */
*slash = '\0';
}
}
hIn = GetStdHandle(STD_INPUT_HANDLE);
GetConsoleMode(hIn, &mo);
SetConsoleMode(hIn, mo & ~(ENABLE_LINE_INPUT | ENABLE_ECHO_INPUT));
- c = getc(stdin);
+ /*
+ * On Win9x, the first time you change the mode (as above) a
+ * raw '\n' is inserted. Since enter maps to a raw '\r', and we
+ * map this (below) to '\n', we can just ignore all *raw* '\n's.
+ */
+ do {
+ c = getc(stdin);
+ } while (c == '\n');
/* Same as it ever was - revert back state of stdin. */
SetConsoleMode(hIn, mo);
#endif /* USE_REGISTRY */
/* --------------------------------------------------------------------------
+ * Things to do with the argv/argc and the env
+ * ------------------------------------------------------------------------*/
+
+int nh_argc ( void )
+{
+ return prog_argc;
+}
+
+int nh_argvb ( int argno, int offset )
+{
+ return (int)(prog_argv[argno][offset]);
+}
+
+/* --------------------------------------------------------------------------
* Machine dependent control:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.12 $
- * $Date: 1999/10/26 17:27:37 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/17 16:57:42 $
* ------------------------------------------------------------------------*/
%{
static Cell local checkPrec Args((Cell));
static Void local fixDefn Args((Syntax,Cell,Cell,List));
static Cell local buildTuple Args((List));
-static List local checkContext Args((List));
+static List local checkCtxt Args((List));
static Cell local checkPred Args((Cell));
static Pair local checkDo Args((List));
static Cell local checkTyLhs Args((Cell));
context : '(' ')' {$$ = gc2(NIL);}
| btype2 {$$ = gc1(singleton(checkPred($1)));}
| '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
- | '(' btypes2 ')' {$$ = gc3(checkContext(rev($2)));}
+ | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));}
/*#if TREX*/
| lacks {$$ = gc1(singleton($1));}
- | '(' lacks1 ')' {$$ = gc3(checkContext(rev($2)));}
+ | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
;
lacks : varid '\\' varid {
#if TREX
return tup;
}
-static List local checkContext(con) /* validate context */
+static List local checkCtxt(con) /* validate context */
Type con; {
mapOver(checkPred, con);
return con;
* included in the distribution.
*
* $RCSfile: preds.c,v $
- * $Revision: 1.8 $
- * $Date: 1999/10/20 02:16:04 $
+ * $Revision: 1.9 $
+ * $Date: 1999/11/17 16:57:43 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
#if IPARAM
static Cell local findIPEvid Args((Text));
static Void local removeIPEvid Args((Text));
-static Void local matchupIPs Args((List,List));
#endif
static List local makePredAss Args((List,Int));
static List local copyPreds Args((List));
static Cell local qualifyExpr Args((Int,List,Cell));
static Void local overEvid Args((Cell,Cell));
-static Void local cutoffExceeded Args((Cell,Int,Cell,Int,List));
+static Void local cutoffExceeded Args((Cell,Int,List));
static Cell local scFind Args((Cell,Cell,Int,Cell,Int,Int));
static Cell local scEntail Args((List,Cell,Int,Int));
static Cell local entail Args((List,Cell,Int,Int));
Int cutoff = 64; /* Used to limit depth of recursion*/
-static Void local cutoffExceeded(pi,o,pi1,o1,ps)
-Cell pi, pi1; /* Display error msg when cutoff */
-Int o, o1;
+static Void local cutoffExceeded(pi,o,ps)
+Cell pi; /* Display error msg when cutoff */
+Int o;
List ps; {
clearMarks();
ERRMSG(0)
"\n*** The type checker has reached the cutoff limit while trying to\n"
ETHEN ERRTEXT
"*** determine whether:\n*** " ETHEN ERRPRED(copyPred(pi,o));
- ps = (isNull(pi1)) ? copyPreds(ps) : singleton(copyPred(pi1,o1));
+ ps = copyPreds(ps);
ERRTEXT
"\n*** can be deduced from:\n*** " ETHEN ERRCONTEXT(ps);
ERRTEXT
Int d; {
Class h1 = getHead(pi1);
Class h = getHead(pi);
+ Cell ev = NIL;
/* the h==h1 test is just an optimization, and I'm not
sure it will work with IPs, so I'm being conservative
if (/* h==h1 && */ samePred(pi1,o1,pi,o))
return e;
- /* the cclass.level test is also an optimization */
if (isClass(h1) && (!isClass(h) || cclass(h).level<cclass(h1).level)) {
- Int beta = newKindedVars(cclass(h1).kinds);
- List scs = cclass(h1).supers;
- List dsels = cclass(h1).dsels;
- if (!matchPred(pi1,o1,cclass(h1).head,beta))
- internal("scFind");
+ Int beta = newKindedVars(cclass(h1).kinds);
+ List scs = cclass(h1).supers;
+ List dsels = cclass(h1).dsels;
+ List ps = NIL;
+ if (!matchPred(pi1,o1,cclass(h1).head,beta))
+ internal("scFind");
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,pi1,o1,NIL);
+ for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels))
+ ps = cons(triple(hd(scs),mkInt(beta),ap(hd(dsels),e)),ps);
+ ps = rev(ps);
- for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels)) {
- Cell ev = scFind(ap(hd(dsels),e),hd(scs),beta,pi,o,d);
- if (nonNull(ev))
- return ev;
- }
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ int i;
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("scEntail(scFind): ", stdout);
+ printContext(stdout,copyPreds(ps));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(pi, o));
+ fputc('\n', stdout);
+ }
+#endif
+ improve1(0,ps,pi,o);
+ ev = scEntail(ps,pi,o,d);
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes && nonNull(ev)) {
+ int i;
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("scSat.\n", stdout);
+ }
+#endif
+ return ev;
}
-
return NIL;
}
Cell pi;
Int o;
Int d; {
+ if (d++ >= cutoff)
+ cutoffExceeded(pi,o,ps);
+
for (; nonNull(ps); ps=tl(ps)) {
Cell pi1 = hd(ps);
Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o,d);
return NIL;
}
-#if IPARAM
-static Cell local ipEntail(ps,ip,o) /* Find evidence for (ip,o) from ps*/
-List ps;
-Cell ip;
-Int o; {
- Class h = getHead(ip);
- int i;
- for (; nonNull(ps); ps=tl(ps)) {
- Cell pr1 = hd(ps);
- Cell pi1 = fst3(pr1);
- Int o1 = intOf(snd3(pr1));
- Class h1 = getHead(pi1);
- if (isIP(h1)) {
- if (textOf(h1) == textOf(h)) {
- if (unify(arg(pi1),o1,arg(ip),o)) {
- return thd3(pr1);
- } else {
- ERRMSG(0) "Mismatching uses of implicit parameter\n" ETHEN
- ERRPRED(copyPred(pi1,o1));
- ERRTEXT "\n" ETHEN
- ERRPRED(copyPred(ip,o));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- }
- return NIL;
-}
-#endif
/* --------------------------------------------------------------------------
* Now we reach the main entailment routine:
Cell pi; /* tautology, and construction */
Int o;
Int d; {
- Cell ev = scEntail(ps,pi,o,d);
- return nonNull(ev) ? ev :
+ Cell ev = NIL;
+
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ int i;
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("entail: ", stdout);
+ printContext(stdout,copyPreds(ps));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(pi, o));
+ fputc('\n', stdout);
+ }
+#endif
+
+ ev = scEntail(ps,pi,o,d);
+ if (nonNull(ev)) {
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ int i;
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("scSat.\n", stdout);
+ }
+#endif
+ } else {
+ ev =
#if MULTI_INST
- multiInstRes ? inEntails(ps,pi,o,d) :
- inEntail(ps,pi,o,d);
+ multiInstRes ? inEntails(ps,pi,o,d) :
+ inEntail(ps,pi,o,d);
#else
- inEntail(ps,pi,o,d);
+ inEntail(ps,pi,o,d);
#endif
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (nonNull(ev) && showInstRes) {
+ int i;
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("inSat.\n", stdout);
+ }
+#endif
+ }
+ return ev;
}
static Cell local inEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
Cell pi; /* entailment */
Int o;
Int d; {
+ int i;
+ Inst in;
+
+ if (d++ >= cutoff)
+ cutoffExceeded(pi,o,ps);
+
#if TREX
if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
Cell e = fun(pi);
}
else {
#endif
- Inst in = findInstFor(pi,o); /* Class predicates */
+ in = findInstFor(pi,o); /* Class predicates */
if (nonNull(in)) {
Int beta = typeOff;
Cell e = inst(in).builder;
Cell es = inst(in).specifics;
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,NIL,0,ps);
- for (; nonNull(es); es=tl(es)) {
- Cell ev = entail(ps,hd(es),beta,d);
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("try ", stdout);
+ printContext(stdout, es);
+ fputs(" => ", stdout);
+ printPred(stdout, inst(in).head);
+ fputc('\n', stdout);
+ }
+#endif
+ /* would need to lift es to triples, so be lazy, and just
+ use improve1 in the loop */
+ /* improve(0,ps,es); */
+ for (; nonNull(es); es=tl(es)) {
+ Cell ev;
+ improve1(0,ps,hd(es),beta);
+ ev = entail(ps,hd(es),beta,d);
if (nonNull(ev))
e = ap(e,ev);
else
}
return e;
}
+#if EXPLAIN_INSTANCE_RESOLUTION
+ else {
+ if (showInstRes) {
+ for (i = 0; i < d; i++)
+ fputc(' ', stdout);
+ fputs("No instance found for ", stdout);
+ printPred(stdout, copyPred(pi, o));
+ fputc('\n', stdout);
+ }
+ }
+#endif
return NIL;
#if TREX
}
int k = 0;
Cell ins; /* Class predicates */
Inst in, in_;
- Cell pi_;
Cell e_;
+ if (d++ >= cutoff)
+ cutoffExceeded(pi,o,ps);
+
#if TREX
if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
Cell e = fun(pi);
}
else {
#endif
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,NIL,0,ps);
#if EXPLAIN_INSTANCE_RESOLUTION
if (showInstRes) {
- pi_ = copyPred(pi, o);
for (i = 0; i < d; i++)
fputc(' ', stdout);
fputs("inEntails: ", stdout);
- printPred(stdout, pi_);
+ printContext(stdout,copyPreds(ps));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(pi, o));
fputc('\n', stdout);
}
#endif
Int beta = fst(hd(ins));
Cell e = inst(in).builder;
Cell es = inst(in).specifics;
- Cell es_ = es;
#if EXPLAIN_INSTANCE_RESOLUTION
if (showInstRes) {
while (0<n--) {
Cell pi = hd(qs);
- Cell ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)),0);
+ Cell ev = NIL;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ fputs("scSimplify: ", stdout);
+ printContext(stdout,copyPreds(tl(qs)));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
+ fputc('\n', stdout);
+ }
+#endif
+ ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)),0);
if (nonNull(ev)) {
overEvid(thd3(pi),ev); /* Overwrite dict var with evidence*/
qs = tl(qs); /* ... and discard predicate */
List ins = NIL;
if (multiInstRes) {
ins = findInstsFor(pi,o);
- in = nonNull(ins) && isNull(tl(ins)) ? hd(ins) : NIL;
+ in = nonNull(ins) && isNull(tl(ins)) ? snd(hd(ins)) : NIL;
} else
#endif
in = findInstFor(pi,o);
* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.16 $
- * $Date: 1999/11/12 17:32:43 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/17 16:57:44 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Void local checkClassDefn Args((Class));
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));
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");
/* Check for trivial dependency
*/
- if (isNull(snd(fd))) {
+ if (isNull(vs)) {
ERRMSG(cclass(c).line) "Functional dependency is trivial"
EEND;
}
tcDeps = NIL;
}
+
+/* --------------------------------------------------------------------------
+ * 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(c,pi,o)
+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(c)
+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;
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);
else
return cons(t,vs);
- case OFFSET : internal("zonkTyvarsIn");
+ /* this case will lead to a type error --
+ much better than reporting an internal error ;-) */
+ /* case OFFSET : internal("zonkTyvarsIn"); */
default : return vs;
}
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);
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);
- }
+ 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)) {
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);
+ 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
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"
staticAnalysis(RESET);
}
+#if EXPLAIN_INSTANCE_RESOLUTION
Void checkContext(void) { /* Top level static check on Expr */
List vs, qs;
leaveScope();
staticAnalysis(RESET);
}
+#endif
Void checkDefns() { /* Top level static analysis */
Module thisModule = lastModule();
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 */
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.16 $
- * $Date: 1999/11/16 17:38:56 $
+ * $Revision: 1.17 $
+ * $Date: 1999/11/17 16:57:46 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
cclass(classHw).kinds = NIL;
cclass(classHw).head = NIL;
cclass(classHw).fds = NIL;
+ cclass(classHw).xfds = NIL;
cclass(classHw).dcon = NIL;
cclass(classHw).supers = NIL;
cclass(classHw).dsels = NIL;
mark(cclass(i).head);
mark(cclass(i).kinds);
mark(cclass(i).fds);
+ mark(cclass(i).xfds);
mark(cclass(i).dsels);
mark(cclass(i).supers);
mark(cclass(i).members);
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.12 $
- * $Date: 1999/11/12 17:32:47 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/17 16:57:48 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
Int arity; /* Number of arguments */
Kinds kinds; /* Kinds of constructors in class */
List fds; /* Functional Dependencies */
+ List xfds; /* Xpanded Functional Dependencies */
Cell head; /* Head of class */
Name dcon; /* Dictionary constructor function */
List supers; /* :: [Pred] */
* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.7 $
- * $Date: 1999/10/16 02:17:27 $
+ * $Revision: 1.8 $
+ * $Date: 1999/11/17 16:57:49 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Pair local copyNoMark Args((Cell,Int));
static Type local dropRank1Body Args((Type,Int,Int));
static Type local liftRank1Body Args((Type,Int));
+static Bool local matchTypeAbove Args((Type,Int,Type,Int,Int));
static Bool local varToVarBind Args((Tyvar *,Tyvar *));
static Bool local varToTypeBind Args((Tyvar *,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));
+static Bool local instImprove Args((Int,Class,Cell,Int));
+static Bool local pairImprove Args((Int,Class,Cell,Int,Cell,Int,Int));
#if IPARAM
static Bool local ipImprove Args((Int,Cell,Int,Cell,Int));
#endif
}
#if MULTI_INST
-Cell findInstsFor(pi,o) /* Find matching instance for pred */
+List 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*/
Cell pi = fst3(hd(ps1));
Int o = intOf(snd3(hd(ps1)));
Cell c = getHead(pi);
- if ((isClass(c) && nonNull(cclass(c).fds)) || isIP(c)) {
+ if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
improved |= improveAgainst(line,sps,pi,o);
if (!isIP(c))
- improved |= instImprove(line,pi,o);
+ improved |= instImprove(line,c,pi,o);
improved |= improveAgainst(line,tl(ps1),pi,o);
}
}
} while (improved);
}
+Void improve1(line,sps,pi,o) /* Improve a single predicate */
+Int line;
+List sps;
+Cell pi;
+Int o; {
+ Bool improved;
+ Cell c = getHead(pi);
+ do {
+ improved = FALSE;
+ if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
+ improved |= improveAgainst(line,sps,pi,o);
+ if (!isIP(c))
+ improved |= instImprove(line,c,pi,o);
+ }
+ } while (improved);
+}
+
Bool improveAgainst(line,ps,pi,o)
Int line;
List 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);
+ /* it would be nice to optimize for the common case
+ where h == h1 */
+ if (isClass(h) && isClass(h1)) {
+ improved |= pairImprove(line,h,pi,o,pi1,o1,numTyvars);
+ if (h != h1)
+ improved |= pairImprove(line,h1,pi1,o1,pi,o,numTyvars);
+ }
#if IPARAM
else if (isIP(h1) && textOf(h1) == textOf(h))
improved |= ipImprove(line,pi,o,pi1,o1);
return improved;
}
+Bool instImprove(line,c,pi,o)
+Int line;
+Class c;
+Cell pi;
+Int o; {
+ Bool improved = FALSE;
+ List ins = cclass(c).instances;
+ for (; nonNull(ins); ins=tl(ins)) {
+ Cell in = hd(ins);
+ Int alpha = newKindedVars(inst(in).kinds);
+ improved |= pairImprove(line,c,pi,o,inst(in).head,alpha,alpha);
+ }
+ return improved;
+}
+
#if IPARAM
Bool ipImprove(line,pi,o,pi1,o1)
Int line;
}
#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 */
+Bool pairImprove(line,c,pi1,o1,pi2,o2,above) /* Look for improvement of (pi1,o1)*/
+Int line; /* against (pi2,o2) */
+Class c;
Cell pi1;
Int o1;
-Cell pi;
-Int o; {
+Cell pi2;
+Int o2;
+Int above; {
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;
- }
+ List xfds = cclass(c).xfds;
+ for (; nonNull(xfds); xfds=tl(xfds)) {
+ Cell xfd = hd(xfds);
+ Cell hs = fst(xfd);
+ Int alpha;
+ for (; nonNull(hs); hs=tl(hs)) {
+ Cell h = hd(hs);
+ Class d = getHead(h);
+ alpha = newKindedVars(cclass(d).kinds);
+ if (matchPred(pi2,o2,h,alpha))
+ break;
+ numTyvars = alpha;
}
- }
- 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;
+ if (nonNull(hs)) {
+ List fds = snd(xfd);
for (; nonNull(fds); fds=tl(fds)) {
- Int beta = newKindedVars(inst(in).kinds);
- Bool same = TRUE;
List as = fst(hd(fds));
+ Bool same = TRUE;
for (; same && nonNull(as); as=tl(as)) {
Int n = offsetOf(hd(as));
- same &= matchType(nthArg(n,pi),o,
- nthArg(n,inst(in).head),beta);
+ same &= matchTypeAbove(nthArg(n,pi1),o1,
+ mkOffset(n),alpha,above);
}
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);
+ Int n = offsetOf(hd(as));
+ Type t1 = nthArg(n,pi1);
+ Type t2 = mkOffset(n);
+ if (!matchTypeAbove(t1,o1,t2,alpha,above)) {
+ same &= unify(t1,o1,t2,alpha);
improved = TRUE;
}
}
if (!same) {
ERRMSG(line)
- "Constraint is not consistent with declared instance"
+ "Constraints are not consistent with functional dependency"
ETHEN
ERRTEXT "\n*** Constraint : "
- ETHEN ERRPRED(copyPred(pi,o));
- ERRTEXT "\n*** Instance : "
- ETHEN ERRPRED(inst(in).head);
+ ETHEN ERRPRED(copyPred(pi1,o1));
+ ERRTEXT "\n*** And constraint : "
+ ETHEN ERRPRED(copyPred(pi2,o2));
ERRTEXT "\n*** For class : "
ETHEN ERRPRED(cclass(c).head);
- ERRTEXT "\n*** Under dependency : "
+ ERRTEXT "\n*** Break dependency : "
ETHEN ERRFD(hd(fds));
ERRTEXT "\n"
EEND;
}
- } else {
- numTyvars = beta;
}
}
+ numTyvars = alpha;
}
}
return improved;
return result;
}
+static Bool local matchTypeAbove(t1,o1,t,o,a) /* match, allowing only vars */
+Type t1; /* allocated since `a' to be bound */
+Int o1; /* this is deeply hacky, since it */
+Type t; /* relies on careful use of the */
+Int o; /* substitution stack */
+Int a; {
+ Bool result;
+ bindOnlyAbove(a);
+ result = unify(t1,o1,t,o);
+ unrestrictBind();
+ return result;
+}
+
/* --------------------------------------------------------------------------
* Unify kind expressions:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: subst.h,v $
- * $Revision: 1.5 $
- * $Date: 1999/10/16 02:17:27 $
+ * $Revision: 1.6 $
+ * $Date: 1999/11/17 16:57:50 $
* ------------------------------------------------------------------------*/
typedef struct { /* Each type variable contains: */
extern Inst findInstFor Args((Cell,Int));
extern Void improve Args((Int,List,List));
+extern Void improve1 Args((Int,List,Cell,Int));
extern Bool sameSchemes Args((Type,Type));
extern Bool sameType Args((Type,Int,Type,Int));
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.12 $
- * $Date: 1999/11/16 17:39:00 $
+ * $Revision: 1.13 $
+ * $Date: 1999/11/17 16:57:50 $
* ------------------------------------------------------------------------*/
#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 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 defs = cclass(c).defaults;
List dsels = cclass(c).dsels;
Cell pat = cclass(c).dcon;
- Cell args = NIL;
Int width = cclass(c).numSupers + cclass(c).numMembers;
char buf[FILENAME_MAX+1];
Int i = 0;
for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
Cell pi = hd(ps);
- Cell ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
- if (isNull(ev))
+ Cell ev = NIL;
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ fputs("scEntail: ", stdout);
+ printContext(stdout,copyPreds(params));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
+ fputc('\n', stdout);
+ }
+#endif
+ ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
+ if (isNull(ev)) {
+#if EXPLAIN_INSTANCE_RESOLUTION
+ if (showInstRes) {
+ fputs("inEntail: ", stdout);
+ printContext(stdout,copyPreds(evids));
+ fputs(" ||- ", stdout);
+ printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
+ fputc('\n', stdout);
+ }
+#endif
ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
+ }
if (isNull(ev)) {
clearMarks();
ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
#define MAJOR_RELEASE 0
#if MAJOR_RELEASE
-#define HUGS_VERSION "October 1999 "
+#define HUGS_VERSION "November 1999 "
#else
-#define HUGS_VERSION "STGHugs-991115"
+#define HUGS_VERSION "STGHugs-991117"
#endif
projects / ghc-hetmet.git / commitdiff