* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.17 $
- * $Date: 1999/11/17 16:57:44 $
+ * $Revision: 1.29 $
+ * $Date: 2000/03/10 20:03:36 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "storage.h"
-#include "backend.h"
#include "connect.h"
-#include "link.h"
#include "errors.h"
-#include "subst.h"
/* --------------------------------------------------------------------------
* local function prototypes:
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 List local checkImportEntity Args((List,Module,Bool,Cell));
+static List local resolveImportList Args((Module,Cell,Bool));
static Void local checkImportList Args((Pair));
static Void local importEntity Args((Module,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 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));
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)) {
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;
}
/* 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)) {
+ List privileged;
+ imports = resolveImportList(m, DOTDOT, FALSE);
+ privileged = resolveImportList(m, snd(impList),TRUE);
+ imports = dupOnto(privileged,imports);
} 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);
* 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; {
+static List local inheritFundeps ( Class c, Cell pi, Int o )
+{
Int alpha = newKindedVars(cclass(c).kinds);
List scs = cclass(c).supers;
List xfds = NIL;
return xfds;
}
-static Void local extendFundeps(c)
-Class c; {
+static Void local extendFundeps ( Class c )
+{
Int alpha;
emptySubstitution();
alpha = newKindedVars(cclass(c).kinds);
*/
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;
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 */
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
* 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);
}
}
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) linkPrimitiveNames(); /* link primitive names */
mapProc(checkForeignImport,foreignImports); /* check foreign imports */
mapProc(checkForeignExport,foreignExports); /* check foreign exports */
#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