* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/10/26 17:27:45 $
+ * $Revision: 1.33 $
+ * $Date: 2000/03/31 04:13:27 $
* ------------------------------------------------------------------------*/
-#include "prelude.h"
+#include "hugsbasictypes.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
-#include "link.h"
#include "errors.h"
-#include "subst.h"
/* --------------------------------------------------------------------------
* local function prototypes:
* ------------------------------------------------------------------------*/
-static Void local kindError Args((Int,Constr,Constr,String,Kind,Int));
-static Void local checkQualImport Args((Pair));
-static Void local checkUnqualImport Args((Triple));
-
-static Name local lookupName Args((Text,List));
-static List local checkSubentities Args((List,List,List,String,Text));
-static List local checkExportTycon Args((List,Text,Cell,Tycon));
-static List local checkExportClass Args((List,Text,Cell,Class));
-static List local checkExport Args((List,Text,Cell));
-static List local checkImportEntity Args((List,Module,Cell));
-static List local resolveImportList Args((Module,Cell));
-static Void local checkImportList Args((Pair));
-
-static Void local importEntity Args((Module,Cell));
-static Void local importName Args((Module,Name));
-static Void local importTycon Args((Module,Tycon));
-static Void local importClass Args((Module,Class));
-static List local checkExports Args((List));
-
-static Void local checkTyconDefn Args((Tycon));
-static Void local depConstrs Args((Tycon,List,Cell));
-static List local addSels Args((Int,Name,List,List));
-static List local selectCtxt Args((List,List));
-static Void local checkSynonyms Args((List));
-static List local visitSyn Args((List,Tycon,List));
-static Type local instantiateSyn Args((Type,Type));
-
-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 addMembers Args((Class));
-static Name local newMember Args((Int,Int,Cell,Type,Class));
-static Name local newDSel Args((Class,Int));
-static Text local generateText Args((String,Class));
-static Int local visitClass Args((Class));
-
-static List local classBindings Args((String,Class,List));
-static Name local memberName Args((Class,Text));
-static List local numInsert Args((Int,Cell,List));
-
- 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 kindType Args((Int,String,Type));
-static Void local fixKinds Args((Void));
-
-static Void local kindTCGroup Args((List));
-static Void local initTCKind Args((Cell));
-static Void local kindTC Args((Cell));
-static Void local genTC Args((Cell));
-
-static Void local checkInstDefn Args((Inst));
-static Void local insertInst Args((Inst));
-static Bool local instCompare Args((Inst,Inst));
-static Name local newInstImp Args((Inst));
-static Void local kindInst Args((Inst,Int));
-static Void local checkDerive Args((Tycon,List,List,Cell));
-static Void local addDerInst Args((Int,Class,List,List,Type,Int));
-static Void local deriveContexts Args((List));
-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 checkDefaultDefns Args((Void));
-
-static Void local checkForeignImport Args((Name));
-static Void local checkForeignExport Args((Name));
-
-static Cell local tidyInfix Args((Int,Cell));
-static Pair local attachFixity Args((Int,Cell));
-static Syntax local lookupSyntax Args((Text));
-
-static Cell local checkPat Args((Int,Cell));
-static Cell local checkMaybeCnkPat Args((Int,Cell));
-static Cell local checkApPat Args((Int,Int,Cell));
-static Void local addToPatVars Args((Int,Cell));
-static Name local conDefined Args((Int,Cell));
-static Void local checkIsCfun Args((Int,Name));
-static Void local checkCfunArgs Args((Int,Cell,Int));
-static Cell local checkPatType Args((Int,String,Cell,Type));
-static Cell local applyBtyvs Args((Cell));
-static Cell local bindPat Args((Int,Cell));
-static Void local bindPats Args((Int,List));
-
-static List local extractSigdecls Args((List));
-static List local extractFixdecls Args((List));
-static List local extractBindings Args((List));
-static List local getPatVars Args((Int,Cell,List));
-static List local addPatVar Args((Int,Cell,List));
-static List local eqnsToBindings Args((List,List,List,List));
-static Void local notDefined Args((Int,List,Cell));
-static Cell local findBinding Args((Text,List));
-static Cell local getAttr Args((List,Cell));
-static Void local addSigdecl Args((List,Cell));
-static Void local addFixdecl Args((List,List,List,List,Triple));
-static Void local dupFixity Args((Int,Text));
-static Void local missFixity Args((Int,Text));
-
-static List local dependencyAnal Args((List));
-static List local topDependAnal Args((List));
-static Void local addDepField Args((Cell));
-static Void local remDepField Args((List));
-static Void local remDepField1 Args((Cell));
-static Void local clearScope Args((Void));
-static Void local withinScope Args((List));
-static Void local leaveScope Args((Void));
-static Void local saveSyntax Args((Cell,Cell));
-
-static Void local depBinding Args((Cell));
-static Void local depDefaults Args((Class));
-static Void local depInsts Args((Inst));
-static Void local depClassBindings Args((List));
-static Void local depAlt Args((Cell));
-static Void local depRhs Args((Cell));
-static Void local depGuard Args((Cell));
-static Cell local depExpr Args((Int,Cell));
-static Void local depPair Args((Int,Cell));
-static Void local depTriple Args((Int,Cell));
-static Void local depComp Args((Int,Cell,List));
-static Void local depCaseAlt Args((Int,Cell));
-static Cell local depVar Args((Int,Cell));
-static Cell local depQVar Args((Int,Cell));
-static Void local depConFlds Args((Int,Cell,Bool));
-static Void local depUpdFlds Args((Int,Cell));
-static List local depFields Args((Int,Cell,List,Bool));
+static Void local kindError ( Int,Constr,Constr,String,Kind,Int );
+static Void local checkQualImport ( Pair );
+static Void local checkUnqualImport ( Triple );
+
+static Name local lookupName ( Text,List );
+static List local checkSubentities ( List,List,List,String,Text );
+static List local checkExportTycon ( List,Text,Cell,Tycon );
+static List local checkExportClass ( List,Text,Cell,Class );
+static List local checkExport ( List,Text,Cell );
+static List local checkImportEntity ( List,Module,Bool,Cell );
+static List local resolveImportList ( Module,Cell,Bool );
+static Void local checkImportList ( Pair );
+
+static Void local importEntity ( Module,Cell );
+static Void local importName ( Module,Name );
+static Void local importTycon ( Module,Tycon );
+static Void local importClass ( Module,Class );
+static List local checkExports ( List, Module );
+
+static Void local checkTyconDefn ( Tycon );
+static Void local depConstrs ( Tycon,List,Cell );
+static List local addSels ( Int,Name,List,List );
+static List local selectCtxt ( List,List );
+static Void local checkSynonyms ( List );
+static List local visitSyn ( List,Tycon,List );
+static Type local instantiateSyn ( Type,Type );
+
+static Void local checkClassDefn ( Class );
+static Cell local depPredExp ( Int,List,Cell );
+static Void local checkMems ( Class,List,Cell );
+static Void local checkMems2 ( Class,Cell );
+static Void local addMembers ( Class );
+static Name local newMember ( Int,Int,Cell,Type,Class );
+static Text local generateText ( String,Class );
+
+static List local classBindings ( String,Class,List );
+static Name local memberName ( Class,Text );
+static List local numInsert ( Int,Cell,List );
+
+static List local maybeAppendVar ( Cell,List );
+
+static Type local checkSigType ( Int,String,Cell,Type );
+static Void local checkOptQuantVars ( Int,List,List );
+static Type local depTopType ( Int,List,Type );
+static Type local depCompType ( Int,List,Type );
+static Type local depTypeExp ( Int,List,Type );
+static Type local depTypeVar ( Int,List,Text );
+static List local checkQuantVars ( Int,List,List,Cell );
+static List local otvars ( Cell,List );
+static Bool local osubset ( List,List );
+static Void local kindConstr ( Int,Int,Int,Constr );
+static Kind local kindAtom ( Int,Constr );
+static Void local kindPred ( Int,Int,Int,Cell );
+static Void local kindType ( Int,String,Type );
+static Void local fixKinds ( Void );
+
+static Void local kindTCGroup ( List );
+static Void local initTCKind ( Cell );
+static Void local kindTC ( Cell );
+static Void local genTC ( Cell );
+
+static Void local checkInstDefn ( Inst );
+static Void local insertInst ( Inst );
+static Bool local instCompare ( Inst,Inst );
+static Name local newInstImp ( Inst );
+static Void local kindInst ( Inst,Int );
+static Void local checkDerive ( Tycon,List,List,Cell );
+static Void local addDerInst ( Int,Class,List,List,Type,Int );
+static Void local deriveContexts ( List );
+static Void local initDerInst ( Inst );
+static Void local calcInstPreds ( Inst );
+static Void local maybeAddPred ( Cell,Int,Int,List );
+static List local calcFunDeps ( List );
+static Cell local copyAdj ( Cell,Int,Int );
+static Void local tidyDerInst ( Inst );
+static List local otvarsZonk ( Cell,List,Int );
+
+static Void local addDerivImp ( Inst );
+
+static Void local checkDefaultDefns ( Void );
+
+static Void local checkForeignImport ( Name );
+static Void local checkForeignExport ( Name );
+
+static Cell local tidyInfix ( Int,Cell );
+static Pair local attachFixity ( Int,Cell );
+static Syntax local lookupSyntax ( Text );
+
+static Cell local checkPat ( Int,Cell );
+static Cell local checkMaybeCnkPat ( Int,Cell );
+static Cell local checkApPat ( Int,Int,Cell );
+static Void local addToPatVars ( Int,Cell );
+static Name local conDefined ( Int,Cell );
+static Void local checkIsCfun ( Int,Name );
+static Void local checkCfunArgs ( Int,Cell,Int );
+static Cell local checkPatType ( Int,String,Cell,Type );
+static Cell local applyBtyvs ( Cell );
+static Cell local bindPat ( Int,Cell );
+static Void local bindPats ( Int,List );
+
+static List local extractSigdecls ( List );
+static List local extractFixdecls ( List );
+static List local extractBindings ( List );
+static List local getPatVars ( Int,Cell,List );
+static List local addPatVar ( Int,Cell,List );
+static List local eqnsToBindings ( List,List,List,List );
+static Void local notDefined ( Int,List,Cell );
+static Cell local findBinding ( Text,List );
+static Cell local getAttr ( List,Cell );
+static Void local addSigdecl ( List,Cell );
+static Void local addFixdecl ( List,List,List,List,Triple );
+static Void local dupFixity ( Int,Text );
+static Void local missFixity ( Int,Text );
+
+static List local dependencyAnal ( List );
+static List local topDependAnal ( List );
+static Void local addDepField ( Cell );
+static Void local remDepField ( List );
+static Void local remDepField1 ( Cell );
+static Void local clearScope ( Void );
+static Void local withinScope ( List );
+static Void local leaveScope ( Void );
+static Void local saveSyntax ( Cell,Cell );
+
+static Void local depBinding ( Cell );
+static Void local depDefaults ( Class );
+static Void local depInsts ( Inst );
+static Void local depClassBindings ( List );
+static Void local depAlt ( Cell );
+static Void local depRhs ( Cell );
+static Void local depGuard ( Cell );
+static Cell local depExpr ( Int,Cell );
+static Void local depPair ( Int,Cell );
+static Void local depTriple ( Int,Cell );
+static Void local depComp ( Int,Cell,List );
+static Void local depCaseAlt ( Int,Cell );
+static Cell local depVar ( Int,Cell );
+static Cell local depQVar ( Int,Cell );
+static Void local depConFlds ( Int,Cell,Bool );
+static Void local depUpdFlds ( Int,Cell );
+static List local depFields ( Int,Cell,List,Bool );
#if IPARAM
-static Void local depWith Args((Int,Cell));
-static List local depDwFlds Args((Int,Cell,List));
+static Void local depWith ( Int,Cell );
+static List local depDwFlds ( Int,Cell,List );
#endif
#if TREX
-static Cell local depRecord Args((Int,Cell));
+static Cell local depRecord ( Int,Cell );
#endif
-static List local tcscc Args((List,List));
-static List local bscc Args((List));
+static List local tcscc ( List,List );
+static List local bscc ( List );
-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 addRSsigdecls ( Pair );
+static Void local allNoPrevDef ( Cell );
+static Void local noPrevDef ( Int,Cell );
+static Bool local odiff ( List,List );
-static Void local duplicateErrorAux Args((Int,Module,Text,String));
+static Void local duplicateErrorAux ( Int,Module,Text,String );
#define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
-static Void local checkTypeIn Args((Pair));
+static Void local checkTypeIn ( Pair );
/* --------------------------------------------------------------------------
* The code in this file is arranged in roughly the following order:
* Static analysis of modules:
* ------------------------------------------------------------------------*/
-#if HSCRIPT
-String reloadModule;
-#endif
-
-Void startModule(nm) /* switch to a new module */
-Cell nm; {
- Module m;
- if (!isCon(nm)) internal("startModule");
- if (isNull(m = findModule(textOf(nm))))
- m = newModule(textOf(nm));
- else if (!isPreludeScript()) {
- /* You're allowed to break the rules in the Prelude! */
-#if HSCRIPT
- reloadModule = textToStr(textOf(nm));
-#endif
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(textOf(nm))
- EEND;
- }
+Void startModule ( Module m ) /* switch to a new module */
+{
+ if (isNull(m)) internal("startModule");
setCurrModule(m);
}
return imports;
}
-static List local checkImportEntity(imports,exporter,entity)
+static List local checkImportEntity(imports,exporter,priv,entity)
List imports; /* Accumulated list of things to import */
Module exporter;
-Cell entity; { /* Entry from import list */
+Bool priv;
+Cell entity; { /* Entry from import list */
List oldImports = imports;
Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
- List es = module(exporter).exports;
+ List es = NIL;
+ if (priv) {
+ es = module(exporter).names;
+ es = dupOnto(module(exporter).tycons,es);
+ es = dupOnto(module(exporter).classes,es);
+ } else {
+ es = module(exporter).exports;
+ }
+
for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es); /* :: Entity | (Entity, NIL|DOTDOT) */
+ Cell e = hd(es); /* :: Entity
+ | (Entity, NIL|DOTDOT)
+ | tycon
+ | class
+ */
if (isPair(e)) {
Cell f = fst(e);
if (isTycon(f)) {
case NEWTYPE:
case DATATYPE:
if (DOTDOT == snd(entity)) {
- imports=dupOnto(tycon(f).defn,imports);
+ 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);
}
}
}
if (isIdent(entity) && name(e).text == t) {
imports = cons(e,imports);
}
+ } else if (isTycon(e) && priv) {
+ if (tycon(e).text == t) {
+ imports = cons(e,imports);
+ return dupOnto(tycon(e).defn,imports);
+ }
+ } else if (isClass(e) && priv) {
+ if (cclass(e).text == t) {
+ imports = cons(e,imports);
+ return dupOnto(cclass(e).members,imports);
+ }
+ } else if (whatIs(e) == TUPLE && priv) {
+ // do nothing
} else {
internal("checkImportEntity3");
}
return imports;
}
-static List local resolveImportList(m,impList)
+static List local resolveImportList(m,impList,priv)
Module m; /* exporting module */
-Cell impList; {
+Cell impList;
+Bool priv; {
List imports = NIL;
if (DOTDOT == impList) {
List es = module(m).exports;
}
}
} else {
- map1Accum(checkImportEntity,imports,m,impList);
+ map2Accum(checkImportEntity,imports,m,priv,impList);
}
return imports;
}
List imports = NIL; /* entities we want to import */
List hidden = NIL; /* entities we want to hide */
- if (moduleThisScript(m)) {
- ERRMSG(0) "Module \"%s\" recursively imports itself",
- textToStr(module(m).text)
- EEND;
- }
if (isPair(impList) && HIDDEN == fst(impList)) {
/* Somewhat inefficient - but obviously correct:
* imports = importsOf("module Foo") `setDifference` hidden;
*/
- hidden = resolveImportList(m, snd(impList));
- imports = resolveImportList(m, DOTDOT);
+ hidden = resolveImportList(m, snd(impList),FALSE);
+ imports = resolveImportList(m, DOTDOT,FALSE);
+ } else if (isPair(impList) && STAR == fst(impList)) {
+ // Previously, I was forcing an import Prelude,
+ // but this precluded doing things like
+ // import Prelude hiding ( catch)
+ // so, for now, you need to put an explicit
+ // import Prelude if you use import privileged.
+ imports = resolveImportList(m, snd(impList),TRUE);
} else {
- imports = resolveImportList(m, impList);
+ imports = resolveImportList(m, impList,FALSE);
}
+
for(; nonNull(imports); imports=tl(imports)) {
Cell e = hd(imports);
if (!cellIsMember(e,hidden))
switch (whatIs(e)) {
case NAME : importName(source,e);
break;
+ case TUPLE:
case TYCON : importTycon(source,e);
break;
case CLASS : importClass(source,e);
Name n; {
Name clash = addName(n);
if (nonNull(clash) && clash!=n) {
- ERRMSG(0) "Entity \"%s\" imported from module \"%s\" already defined in module \"%s\"",
+ ERRMSG(0) "Entity \"%s\" imported from module \"%s\""
+ " already defined in module \"%s\"",
textToStr(name(n).text),
textToStr(module(source).text),
textToStr(module(name(clash).mod).text)
return exports; /* NOTUSED */
}
-static List local checkExports(exports)
-List exports; {
- Module m = lastModule();
+static List local checkExports ( List exports, Module thisModule )
+{
+ Module m = thisModule;
Text mt = module(m).text;
List es = NIL;
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)) {
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 ( 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;
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);
*/
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(m).arity = 1;
name(m).number = mfunNo(no);
name(m).type = t;
- name(m).inlineMe = TRUE;
return m;
}
-static Name local newDSel(c,no) /* Make definition for dict selectr*/
+Name newDSel(c,no) /* Make definition for dict selectr*/
Class c;
Int no; {
Name s;
char buf[16];
- sprintf(buf,"sc%d.%s",no,"%s");
+ /* 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;
return findText(buffer);
}
-static Int local visitClass(c) /* visit class defn to check that */
+ Int visitClass(c) /* visit class defn to check that */
Class c; { /* class hierarchy is acyclic */
#if TREX
if (isExt(c)) { /* special case for lacks preds */
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 DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs);
+ case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs);
+
case AP : return typeVarsIn(snd(ty),us,ws,
typeVarsIn(fst(ty),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 */
}
if (nonNull(tvs)) {
- if (length(tvs)>=NUM_OFFSETS) {
+ if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) {
ERRMSG(line) "Too many type variables in %s\n", where
EEND;
} else {
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
ERRMSG(line) "Illegal predicate in instance declaration"
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;
+ }
+ }
+ }
+
kindInst(in,length(tyvars));
insertInst(in);
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++ >= cutoff) {
+ 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
return copyAdj(tyv->bound,tyv->offs,beta);
}
vn -= beta;
- if (vn<0 || vn>=NUM_OFFSETS) {
+ if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) {
internal("copyAdj");
}
return mkOffset(vn);
* 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
static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with */
Int l; /* the possibility of n+k pattern */
Cell p; {
-#if NPLUSK
Cell h = getHead(p);
if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */
arg(p) = checkPat(l,v);
return p;
}
-#endif
return checkApPat(l,0,p);
}
static Cell local depExpr(line,e) /* find dependents of expression */
Int line;
Cell e; {
- // Printf( "\n\n"); print(e,100); Printf("\n");
+ //Printf( "\n\n"); print(e,100); Printf("\n");
//printExp(stdout,e);
switch (whatIs(e)) {
EEND;
}
+#if 0
+ what is this for??
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.
staticAnalysis(RESET);
}
-Void checkContext() { /* Top level static check on Expr */
+#if EXPLAIN_INSTANCE_RESOLUTION
+Void checkContext(void) { /* Top level static check on Expr */
List vs, qs;
staticAnalysis(RESET);
leaveScope();
staticAnalysis(RESET);
}
+#endif
+
+Void checkDefns ( Module thisModule ) { /* Top level static analysis */
-Void checkDefns() { /* Top level static analysis */
- Module thisModule = lastModule();
staticAnalysis(RESET);
setCurrModule(thisModule);
/* Every module (including the Prelude) implicitly contains
* "import qualified Prelude"
*/
- module(thisModule).qualImports=cons(pair(mkCon(textPrelude),modulePrelude),
- module(thisModule).qualImports);
+ module(thisModule).qualImports
+ =cons(pair(mkCon(textPrelude),modulePrelude),
+ module(thisModule).qualImports);
}
mapProc(checkImportList, unqualImports);
- linkPreludeTC(); /* Get prelude tycons and classes */
+ /* Note: there's a lot of side-effecting going on here, so
+ don't monkey about with the order of operations here unless
+ you know what you are doing */
+ 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(visitClass,classDefns); /* check class hierarchy */
+ mapProc(extendFundeps,classDefns); /* finish class definitions */
+ /* (convenient if we do this after */
+ /* calling `visitClass' so that we */
+ /* know the class hierarchy is */
+ /* acyclic) */
+
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);
mapProc(allNoPrevDef,valDefns); /* check against previous defns */
- linkPreludeNames();
+ if (!combined) linkPrimNames(); /* link primitive names */
mapProc(checkForeignImport,foreignImports); /* check foreign imports */
mapProc(checkForeignExport,foreignExports); /* check foreign exports */
/* 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);
+ module(thisModule).exports
+ = checkExports ( module(thisModule).exports, thisModule );
mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
#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