* included in the distribution.
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.13 $
- * $Date: 1999/12/06 16:25:23 $
+ * $Revision: 1.14 $
+ * $Date: 1999/12/10 15:59:41 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
itblNames[nItblNames++] = textToStr(name(con).text);
} else
if (isTuple(con)) {
- char cc[20];
- sprintf(cc, "Tuple%d", tupleOf(con) );
itblNames[nItblNames++] = vv;
- itblNames[nItblNames++] = cc;
+ itblNames[nItblNames++] = textToStr(ghcTupleText(con));
} else
assert ( /* cant identify constructor name */ 0 );
setPos(v,asmAllocCONSTR(bco, vv));
Void codegen(what)
Int what; {
switch (what) {
- case INSTALL:
- /* deliberate fall though */
- case RESET:
- break;
- case MARK:
- break;
+ case PREPREL:
+ case RESET:
+ case MARK:
+ case POSTPREL:
+ break;
}
liftControl(what);
}
* included in the distribution.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.15 $
- * $Date: 1999/11/22 16:00:21 $
+ * $Revision: 1.16 $
+ * $Date: 1999/12/10 15:59:42 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Target i = 0;
List binds = NIL;
- /* a nasty hack. But I don't know an easier way to make */
- /* these things appear. */
- if (lastModule() == modulePrelude) {
- implementCfun ( nameCons, NIL );
- implementCfun ( nameNil, NIL );
- implementCfun ( nameUnit, NIL );
- }
-
{
List vss;
List vs;
Void compiler(what)
Int what; {
switch (what) {
- case INSTALL :
+ case PREPREL :
case RESET : freeVars = NIL;
freeFuns = NIL;
freeBegin = mkOffset(0);
- //extraVars = NIL;
- //numExtraVars = 0;
- //localOffset = 0;
- //localArity = 0;
break;
case MARK : mark(freeVars);
mark(freeFuns);
- //mark(extraVars);
break;
+
+ case POSTPREL: break;
}
}
* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.20 $
- * $Date: 1999/12/03 17:56:04 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/10 15:59:43 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* ------------------------------------------------------------------------*/
extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
+extern Bool combined; /* TRUE => combined operation */
extern Module modulePrelude;
/* --------------------------------------------------------------------------
extern Void everybody Args((Int));
-#define RESET 1 /* reset subsystem */
-#define MARK 2 /* mark parts of graph in use by subsystem */
-#define INSTALL 3 /* install subsystem (executed once only) */
-#define EXIT 4 /* Take action immediately before exit() */
-#define BREAK 5 /* Take action after program break */
-#define GCDONE 6 /* Restore subsystem invariantss after GC */
+
+#define RESET 1 /* reset subsystem */
+#define MARK 2 /* mark parts of graph in use by subsystem */
+#define PREPREL 3 /* do startup actions before Prelude loading */
+#define POSTPREL 4 /* do startup actions after Prelude loading */
+#define EXIT 5 /* Take action immediately before exit() */
+#define BREAK 6 /* Take action after program break */
+#define GCDONE 7 /* Restore subsystem invariantss after GC */
+
+/* PREPREL was formerly called INSTALL. POSTPREL doesn't have an analogy
+ in the old Hugs.
+*/
+
typedef long Target;
extern Void setGoal Args((String, Target));
extern Void getFileSize Args((String, Long *));
-extern Void loadInterface Args((String,Long));
+extern ZPair readInterface Args((String,Long));
+extern Void processInterfaces Args((Void));
-extern Void openGHCIface Args((Text));
-extern Void loadSharedLib Args((String));
-extern Void addGHCImports Args((Int,Text,List));
-extern Void addGHCExports Args((Cell,List));
-extern Void addGHCVar Args((Int,Text,Type));
-extern Void addGHCSynonym Args((Int,Cell,List,Type));
-extern Void addGHCDataDecl Args((Int,List,Cell,List,List));
-extern Void addGHCNewType Args((Int,List,Cell,List,Cell));
-extern Void addGHCClass Args((Int,List,Cell,List,List));
-extern Void addGHCInstance Args((Int,List,Pair,Text));
-extern Void finishInterfaces Args((Void));
+extern List /* of ZTriple(I_INTERFACE,
+ Text--name of obj file,
+ Int--size of obj file) */
+ ifaces_outstanding;
-extern Void hi_o_namesFromSrcName Args((String,String*,String* oName));
-extern Void parseInterface Args((String,Long));
-
-
-#define SMALL_INLINE_SIZE 9
+extern Void hi_o_namesFromSrcName Args((String,String*,String* oName));
+extern Cell parseInterface Args((String,Long));
-// nasty hack, but seems an easy to convey the object name
-// and size to openGHCIface
-char nameObj[FILENAME_MAX+1];
-int sizeObj;
* included in the distribution.
*
* $RCSfile: derive.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/12/01 10:22:53 $
+ * $Revision: 1.11 $
+ * $Date: 1999/12/10 15:59:43 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Void deriveControl(what)
Int what; {
switch (what) {
- case INSTALL :
- /* deliberate fall through */
+ case PREPREL :
case RESET :
diVars = NIL;
diNum = 0;
mark(diVars);
mark(cfunSfuns);
break;
+
+ case POSTPREL: break;
}
}
* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.29 $
- * $Date: 1999/12/06 16:25:24 $
+ * $Revision: 1.30 $
+ * $Date: 1999/12/10 15:59:44 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
String hugsEdit = 0; /* String for editor command */
String hugsPath = 0; /* String for file search path */
+ List ifaces_outstanding = NIL;
+
#if REDIRECT_OUTPUT
static Bool disableOutput = FALSE; /* redirect output to buffer? */
#endif
Printf("Standalone mode: Restart with command line +c for combined mode\n\n" );
}
- everybody(INSTALL);
+ everybody(PREPREL);
+
evalModule = findText(""); /* evaluate wrt last module by default */
if (proj) {
if (namesUpto>1) {
// setLastEdit(name,0);
- nameObj[0] = 0;
strcpy(name, scriptInfo[stacknum].path);
strcat(name, scriptInfo[stacknum].modName);
if (scriptInfo[stacknum].fromSource)
scriptFile = name;
if (scriptInfo[stacknum].fromSource) {
- if (lastWasObject) finishInterfaces();
+ if (lastWasObject) processInterfaces();
lastWasObject = FALSE;
Printf("Reading script \"%s\":\n",name);
needsImports = FALSE;
typeCheckDefns();
compileDefns();
} else {
+ Cell iface;
+ List imports;
+ ZTriple iface_info;
+ char nameObj[FILENAME_MAX+1];
+ Int sizeObj;
+
Printf("Reading iface \"%s\":\n", name);
scriptFile = name;
needsImports = FALSE;
strcat(nameObj, DLL_ENDING);
sizeObj = scriptInfo[stacknum].oSize;
- loadInterface(name,len);
+ iface = readInterface(name,len);
+ imports = zsnd(iface); iface = zfst(iface);
+
+ if (nonNull(imports)) chase(imports);
scriptFile = 0;
lastWasObject = TRUE;
+
+ iface_info = ztriple(iface, findText(nameObj), mkInt(sizeObj) );
+ ifaces_outstanding = cons(iface_info,ifaces_outstanding);
+
if (needsImports) return FALSE;
}
scriptFile = 0;
- preludeLoaded = TRUE;
+
+ if (strcmp(scriptInfo[stacknum].modName, "Prelude")==0) {
+ preludeLoaded = TRUE;
+ everybody(POSTPREL);
+ }
return TRUE;
}
//numScripts = 0;
while (numScripts < namesUpto) {
-ppSmStack ( "readscripts-loop2" );
+ ppSmStack ( "readscripts-loop2" );
if (scriptInfo[numScripts].fromSource) {
nextNumScripts = NUM_SCRIPTS; //bogus initialisation
if (addScript(numScripts)) {
numScripts++;
-assert(nextNumScripts==NUM_SCRIPTS);
+ assert(nextNumScripts==NUM_SCRIPTS);
}
else
dropScriptsFrom(numScripts-1);
nextNumScripts = NUM_SCRIPTS;
if (addScript(numScripts)) {
numScripts++;
-assert(nextNumScripts==NUM_SCRIPTS);
+ assert(nextNumScripts==NUM_SCRIPTS);
} else {
//while (!scriptInfo[numScripts].fromSource && numScripts > 0)
// numScripts--;
//if (scriptInfo[numScripts].fromSource)
// numScripts++;
numScripts = nextNumScripts;
-assert(nextNumScripts<NUM_SCRIPTS);
+ assert(nextNumScripts<NUM_SCRIPTS);
}
}
}
-if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
+ if (numScripts==namesUpto) ppSmStack( "readscripts-final") ;
}
- finishInterfaces();
+ processInterfaces();
{ Int m = namesUpto-1;
Text mtext = findText(scriptInfo[m].modName);
Void everybody(what) /* send command `what' to each component of*/
Int what; { /* system to respond as appropriate ... */
+fprintf ( stderr, "EVERYBODY %d\n", what );
machdep(what); /* The order of calling each component is */
- storage(what); /* important for the INSTALL command */
+ storage(what); /* important for the PREPREL command */
substitution(what);
input(what);
translateControl(what);
* included in the distribution.
*
* $RCSfile: input.c,v $
- * $Revision: 1.17 $
- * $Date: 1999/12/06 16:20:26 $
+ * $Revision: 1.18 $
+ * $Date: 1999/12/10 15:59:45 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Int local yylex Args((Void));
static Int local repeatLast Args((Void));
-static Void local parseInput Args((Int));
+static Cell local parseInput Args((Int));
static Bool local doesNotExceed Args((String,Int,Int));
static Int local stringToInt Args((String,Int));
* main entry points to parser/lexer:
* ------------------------------------------------------------------------*/
-static Void local parseInput(startWith)/* Parse input with given first tok,*/
+static Cell local parseInput(startWith)/* Parse input with given first tok,*/
Int startWith; { /* determining whether to read a */
- firstToken = TRUE; /* script or an expression */
+ Cell final = NIL; /* script or an expression */
+ firstToken = TRUE;
firstTokenIs = startWith;
if (startWith==INTERFACE) {
offsideON = FALSE; readingInterface = TRUE;
ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
EEND; /* in the parser... */
}
- drop();
+ final = pop();
if (!stackEmpty()) /* stack should now be empty */
internal("parseInput");
+ return final;
}
#ifdef HSCRIPT
}
#endif
-Void parseInterface(nm,len) /* Read a GHC interface file */
+Cell parseInterface(nm,len) /* Read a GHC interface file */
String nm;
Long len; { /* Used to set a target for reading */
- input(RESET);
- fileInput(nm,len);
- parseInput(INTERFACE);
+ input(RESET);
+ fileInput(nm,len);
+ return parseInput(INTERFACE);
}
Void input(what)
Int what; {
switch (what) {
- case INSTALL : initCharTab();
+ case POSTPREL: break;
+
+ case PREPREL : initCharTab();
textCase = findText("case");
textOfK = findText("of");
textData = findText("data");
instDefns = NIL;
selDefns = NIL;
genDefns = NIL;
- //primDefns = NIL;
unqualImports= NIL;
foreignImports= NIL;
foreignExports= NIL;
mark(instDefns);
mark(selDefns);
mark(genDefns);
- //mark(primDefns);
mark(unqualImports);
mark(foreignImports);
mark(foreignExports);
* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/12/03 17:01:21 $
+ * $Revision: 1.10 $
+ * $Date: 1999/12/10 15:59:46 $
* ------------------------------------------------------------------------*/
/* ToDo:
#include "Assembler.h" /* for wrapping GHC objects */
#include "dynamic.h"
-// #define DEBUG_IFACE
+#define DEBUG_IFACE
#define VERBOSE FALSE
extern void print ( Cell, Int );
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
- * local variables:
+ * local function prototypes:
* ------------------------------------------------------------------------*/
-static List ghcVarDecls;
-static List ghcConstrDecls;
-static List ghcSynonymDecls;
-static List ghcClassDecls;
-static List ghcInstanceDecls;
+static Void startGHCValue Args((Int,VarId,Type));
+static Void finishGHCValue Args((VarId));
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
+static Void startGHCSynonym Args((Int,Cell,List,Type));
+static Void finishGHCSynonym Args((Tycon));
-static List local addGHCConstrs Args((Int,List,List));
-static Name local addGHCSel Args((Int,Pair));
-static Name local addGHCConstr Args((Int,Int,Triple));
+static Void startGHCClass Args((Int,List,Cell,List,List));
+static Void finishGHCClass Args((Class));
+static Void startGHCInstance Args((Int,List,Pair,VarId));
+static Void finishGHCInstance Args((Inst));
-static Void local finishGHCVar Args((Name));
-static Void local finishGHCConstr Args((Name));
-static Void local finishGHCSynonym Args((Tycon));
-static Void local finishGHCClass Args((Class));
-static Void local finishGHCInstance Args((Inst));
-static Void local finishGHCImports Args((Triple));
-static Void local finishGHCExports Args((Pair));
-static Void local finishGHCModule Args((Module));
+static Void startGHCImports Args((ConId,List));
+static Void finishGHCImports Args((ConId,List));
-static Kinds local tvsToKind Args((List));
-static Int local arityFromType Args((Type));
-static Int local arityInclDictParams Args((Type));
+static Void startGHCExports Args((ConId,List));
+static Void finishGHCExports Args((ConId,List));
-
-static List local ifTyvarsIn Args((Type));
+static Void finishGHCModule Args((Module));
+static Void startGHCModule Args((Text, Int, Text));
-static Type local tvsToOffsets Args((Int,Type,List));
-static Type local conidcellsToTycons Args((Int,Type));
+static Void startGHCDataDecl Args((Int,List,Cell,List,List));
+static Void finishGHCDataDecl ( ConId tyc );
-static Void local resolveReferencesInObjectModule Args((Module,Bool));
-static Bool local validateOImage Args((void*, Int, Bool));
-static Void local readSyms Args((Module,Bool));
+static Void startGHCNewType Args((Int,List,Cell,List,Cell));
+static Void finishGHCNewType ( ConId tyc );
-static void* local lookupObjName ( char* );
+/* Supporting stuff for {start|finish}GHCDataDecl */
+static List startGHCConstrs Args((Int,List,List));
+static Name startGHCSel Args((Int,Pair));
+static Name startGHCConstr Args((Int,Int,Triple));
+static Void finishGHCConstr Args((Name));
-/* --------------------------------------------------------------------------
- * code:
- * ------------------------------------------------------------------------*/
+static Void loadSharedLib Args((String));
+
+
+
+static Kinds tvsToKind Args((List));
+static Int arityFromType Args((Type));
+static Int arityInclDictParams Args((Type));
+
+
+static List ifTyvarsIn Args((Type));
+
+static Type tvsToOffsets Args((Int,Type,List));
+static Type conidcellsToTycons Args((Int,Type));
+
+static Void resolveReferencesInObjectModule Args((Module,Bool));
+static Bool validateOImage Args((void*, Int, Bool));
+static Void readSyms Args((Module,Bool));
-List ifImports; /* [ConId] -- modules imported by current interface */
+static void* lookupObjName ( char* );
-List ghcImports; /* [(Module, Text, [ConId|VarId])]
- each (m1, m2, names) in this list
- represents 'module m1 where ... import m2 ( names ) ...'
- The list acts as a list of names to fix up in
- finishInterfaces().
- */
-List ghcExports; /* [(ConId, -- module name
- [ ConId | VarId | pair(ConId,[ConId|VarId])] )]
- -- list of entities
- */
-List ghcModules; /* [Module] -- modules of the .his loaded in this group */
-Void addGHCExports(mod,stuff)
-Cell mod;
-List stuff; {
- ghcExports = cons( pair(mod,stuff), ghcExports );
+
+/* --------------------------------------------------------------------------
+ * Top-level interface processing
+ * ------------------------------------------------------------------------*/
+
+ZPair readInterface(String fname, Long fileSize)
+{
+ List tops;
+ List imports = NIL;
+ ZPair iface = parseInterface(fname,fileSize);
+ assert (whatIs(iface)==I_INTERFACE);
+
+ for (tops = zsnd(snd(iface)); nonNull(tops); tops=tl(tops))
+ if (whatIs(hd(tops)) == I_IMPORT) {
+ ZPair imp_decl = unap(I_IMPORT,hd(tops));
+ ConId m_to_imp = zfst(imp_decl);
+ if (textOf(m_to_imp) != findText("PrelGHC")) {
+ imports = cons(m_to_imp,imports);
+ /* fprintf(stderr, "add iface %s\n", textToStr(textOf(m_to_imp))); */
+ }
+ }
+ return zpair(iface,imports);
}
-static Void local finishGHCExports(paire)
-Pair paire; {
- Text modTxt = textOf(fst(paire));
- List entities = snd(paire);
- Module mod = findModule(modTxt);
- if (isNull(mod)) {
- ERRMSG(0) "Can't find module \"%s\" mentioned in export list",
- textToStr(modTxt)
- EEND;
- }
-fprintf(stderr, "----------------------------------finishexports\n");
- /* Assume that each .hi file only contains one export decl */
- if (nonNull(module(mod).exports))
- internal("finishGHCExports: non-empty export list");
-
- /* Run along what the parser gave us and make export list entries */
- for (; nonNull(entities); entities=tl(entities)) {
- Cell ent = hd(entities);
- List subents;
- Cell c;
- switch (whatIs(ent)) {
- case VARIDCELL: /* variable */
- c = findName ( snd(ent) );
- assert(nonNull(c));
-fprintf(stderr, "var %s\n", textToStr(name(c).text));
- module(mod).exports = cons(c, module(mod).exports);
- break;
- case CONIDCELL: /* non data tycon */
- c = findTycon ( snd(ent) );
- assert(nonNull(c));
-fprintf(stderr, "non data tycon %s\n", textToStr(tycon(c).text));
- module(mod).exports = cons(c, module(mod).exports);
- break;
- default: /* data T = C1 ... Cn or class C where f1 ... fn */
- if (!isPair(ent)) internal("finishExports(2)");
- subents = snd(ent);
- ent = fst(ent);
- c = findTycon ( snd(ent) );
- if (nonNull(c)) {
- /* data */
-fprintf(stderr, "data %s = ", textToStr(tycon(c).text));
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isCon(ent2));
- c = findName ( snd(ent2) );
-fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
- }
-fprintf(stderr, "\n" );
- } else {
- /* class */
- c = findClass ( snd(ent) );
- assert(nonNull(c));
-fprintf(stderr, "class %s where ", textToStr(cclass(c).text));
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
-
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isVar(ent2));
- c = findName ( snd(ent2) );
-fprintf(stderr, "%s ", textToStr(name(c).text));
- assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
- }
-fprintf(stderr, "\n" );
- }
- break;
+static Bool elemExportList ( VarId nm, List exlist_list )
+{
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+ Text tnm = textOf(nm);
+ Int tlen = strlen(textToStr(tnm));
+ List exlist;
+ List t;
+ Cell c;
+
+ /* for each export list ... */
+ for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
+ exlist = hd(exlist_list);
+
+ /* for each entity in an export list ... */
+ for (t=exlist; nonNull(t); c=tl(t)) {
+ if (isZPair(hd(t))) {
+ /* A pair, which means an export entry
+ of the form ClassName(foo,bar). */
+ List subents = zsnd(hd(t));
+ for (; nonNull(subents); subents=tl(subents))
+ if (textOf(hd(subents)) == tnm) return TRUE;
+ } else {
+ /* Single name in the list. */
+ if (textOf(hd(t)) == tnm) return TRUE;
+ }
}
+
}
+ /* fprintf ( stderr, "elemExportList %s\n", textToStr(textOf(nm)) ); */
+ return FALSE;
}
-static Void local finishGHCImports(triple)
-Triple triple;
+
+/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
+static List getExportDeclsInIFace ( Cell root )
{
- Module dstMod = fst3(triple); // the importing module
- Text srcTxt = snd3(triple);
- List names = thd3(triple);
- Module srcMod = findModule ( srcTxt );
- Module tmpCurrentModule = currentModule;
- List exps;
- Bool found;
- Text tnm;
- Cell nm;
- Cell x;
- //fprintf(stderr, "finishGHCImports: dst=%s src=%s\n",
- // textToStr(module(dstMod).text),
- // textToStr(srcTxt) );
- //print(names, 100);
- //printf("\n");
- /* for each nm in names
- nm should be in module(src).exports -- if not, error
- if nm notElem module(dst).names cons it on
- */
-
- if (isNull(srcMod)) {
- /* I don't think this can actually ever happen, but still ... */
- ERRMSG(0) "Interface for module \"%s\" imports unknown module \"%s\"",
- textToStr(module(dstMod).text),
- textToStr(srcTxt)
+ Cell iface = unap(I_INTERFACE,root);
+ ConId iname = zfst(iface);
+ List decls = zsnd(iface);
+ List exports = NIL;
+ List ds;
+ for (ds=decls; nonNull(ds); ds=tl(ds))
+ if (whatIs(hd(ds))==I_EXPORT)
+ exports = cons(hd(ds), exports);
+ return exports;
+}
+
+
+/* Remove value bindings not mentioned in any of the export lists. */
+static Cell cleanIFace ( Cell root )
+{
+ Cell c;
+ Cell entity;
+ Cell iface = unap(I_INTERFACE,root);
+ ConId iname = zfst(iface);
+ List decls = zsnd(iface);
+ List decls2 = NIL;
+ List exlist_list = NIL;
+ List t;
+
+ fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+
+ exlist_list = getExportDeclsInIFace ( root );
+ /* exlist_list :: [I_EXPORT] */
+
+ for (t=exlist_list; nonNull(t); t=tl(t))
+ hd(t) = zsnd(unap(I_EXPORT,hd(t)));
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+
+ if (isNull(exlist_list)) {
+ ERRMSG(0) "Can't find any export lists in interface file"
EEND;
}
- //printf ( "exports of %s are\n", textToStr(module(srcMod).text) );
- //print( module(srcMod).exports, 100 );
- //printf( "\n" );
-
- setCurrModule ( srcMod ); // so that later lookups succeed
-
- for (; nonNull(names); names=tl(names)) {
- nm = hd(names);
- /* Check the exporting module really exports it. */
- found = FALSE;
- for (exps=module(srcMod).exports; nonNull(exps); exps=tl(exps)) {
- Cell c = hd(exps);
- //if (isPair(c)) c=fst(c);
- assert(whatIs(c)==CONIDCELL || whatIs(c)==VARIDCELL);
- assert(whatIs(nm)==CONIDCELL || whatIs(nm)==VARIDCELL);
- //printf( " compare `%s' `%s'\n", textToStr(textOf(c)), textToStr(textOf(nm)));
- if (textOf(c)==textOf(nm)) { found=TRUE; break; }
- }
- if (!found) {
- ERRMSG(0) "Interface for module \"%s\" imports \"%s\" from\n"
- "module \"%s\", but the latter doesn't export it",
- textToStr(module(dstMod).text), textToStr(textOf(nm)),
- textToStr(module(srcMod).text)
- EEND;
- }
- /* Ok, it's exported. Now figure out what it is we're really
- importing.
- */
- tnm = textOf(nm);
-
- x = findName(tnm);
- if (nonNull(x)) {
- if (!cellIsMember(x,module(dstMod).names))
- module(dstMod).names = cons(x, module(dstMod).names);
- continue;
- }
-
- x = findTycon(tnm);
- if (nonNull(x)) {
- if (!cellIsMember(x,module(dstMod).tycons))
- module(dstMod).tycons = cons(x, module(dstMod).tycons);
- continue;
- }
- x = findClass(tnm);
- if (nonNull(x)) {
- if (!cellIsMember(x,module(dstMod).classes))
- module(dstMod).classes = cons(x, module(dstMod).classes);
- continue;
+ decls2 = NIL;
+ for (; nonNull(decls); decls=tl(decls)) {
+ entity = hd(decls);
+ if (whatIs(entity) != I_VALUE) {
+ decls2 = cons(entity, decls2);
+ } else
+ if (elemExportList(zsnd3(unap(I_VALUE,entity)), exlist_list)) {
+ decls2 = cons(entity, decls2);
+ fprintf ( stderr, " retain %s\n",
+ textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
+ } else {
+ fprintf ( stderr, " dump %s\n",
+ textToStr(textOf(zsnd3(unap(I_VALUE,entity)))));
}
-
- fprintf(stderr, "\npanic: Can't figure out what this is in finishGHCImports\n"
- "\t%s\n", textToStr(tnm) );
- internal("finishGHCImports");
}
- setCurrModule(tmpCurrentModule);
+ return ap(I_INTERFACE, zpair(iname, reverse(decls2)));
}
-Void loadInterface(String fname, Long fileSize)
+/* ifaces_outstanding holds a list of parsed interfaces
+ for which we need to load objects and create symbol
+ table entries.
+*/
+Void processInterfaces ( void )
{
- ifImports = NIL;
- parseInterface(fname,fileSize);
- if (nonNull(ifImports))
- chase(ifImports);
-}
+ List tmp;
+ List xs;
+ ZTriple tr;
+ Cell iface;
+ Int sizeObj;
+ Text nameObj;
+ Text mname;
+ List decls;
+ Module mod;
+
+ fprintf ( stderr,
+ "processInterfaces: %d interfaces to process\n",
+ length(ifaces_outstanding) );
+
+ /* Clean up interfaces -- dump useless value bindings */
+
+ tmp = NIL;
+ for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
+ tr = hd(xs);
+ iface = zfst3(tr);
+ nameObj = zsnd3(tr);
+ sizeObj = zthd3(tr);
+ tmp = cons( ztriple(cleanIFace(iface),nameObj,sizeObj), tmp );
+ }
+ ifaces_outstanding = reverse(tmp);
+ tmp = NIL;
+
+ /* Allocate module table entries and read in object code. */
+
+ for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
+ tr = hd(xs);
+ iface = unap(I_INTERFACE,zfst3(tr));
+ nameObj = zsnd3(tr);
+ sizeObj = zthd3(tr);
+ mname = textOf(zfst(iface));
+ startGHCModule ( mname, intOf(sizeObj), nameObj );
+ }
+ /* Now work through the decl lists of the modules, and call the
+ startGHC* functions on the entities. This creates names in
+ various tables but doesn't bind them to anything.
+ */
-Void finishInterfaces ( void )
-{
- /* the order of these doesn't matter
- * (ToDo: unless synonyms have to be eliminated??)
- */
- mapProc(finishGHCVar, ghcVarDecls);
- mapProc(finishGHCConstr, ghcConstrDecls);
- mapProc(finishGHCSynonym, ghcSynonymDecls);
- mapProc(finishGHCClass, ghcClassDecls);
- mapProc(finishGHCInstance, ghcInstanceDecls);
- mapProc(finishGHCExports, ghcExports);
- mapProc(finishGHCImports, ghcImports);
- mapProc(finishGHCModule, ghcModules);
- ghcVarDecls = NIL;
- ghcConstrDecls = NIL;
- ghcSynonymDecls = NIL;
- ghcClassDecls = NIL;
- ghcInstanceDecls = NIL;
- ghcImports = NIL;
- ghcExports = NIL;
- ghcModules = NIL;
-}
+ for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
+ tr = hd(xs);
+ iface = unap(I_INTERFACE,zfst3(tr));
+ mname = textOf(zfst(iface));
+ mod = findModule(mname);
+ if (isNull(mod)) internal("processInterfaces(4)");
+ setCurrModule(mod);
+
+ for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
+ Cell decl = hd(decls);
+ switch(whatIs(decl)) {
+ case I_EXPORT: {
+ Cell exdecl = unap(I_EXPORT,decl);
+ startGHCExports ( zfst(exdecl), zsnd(exdecl) );
+ break;
+ }
+ case I_IMPORT: {
+ Cell imdecl = unap(I_IMPORT,decl);
+ startGHCImports ( zfst(imdecl), zsnd(imdecl) );
+ break;
+ }
+ case I_FIXDECL: {
+ break;
+ }
+ case I_INSTANCE: {
+ Cell instance = unap(I_INSTANCE,decl);
+ startGHCInstance ( zsel14(instance), zsel24(instance),
+ zsel34(instance), zsel44(instance) );
+ break;
+ }
+ case I_TYPE: {
+ Cell tydecl = unap(I_TYPE,decl);
+ startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
+ zsel34(tydecl), zsel44(tydecl) );
+ break;
+ }
+ case I_DATA: {
+ Cell ddecl = unap(I_DATA,decl);
+ startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
+ zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
+ break;
+ }
+ case I_NEWTYPE: {
+ Cell ntdecl = unap(I_NEWTYPE,decl);
+ startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
+ zsel35(ntdecl), zsel45(ntdecl),
+ zsel55(ntdecl) );
+ break;
+ }
+ case I_CLASS: {
+ Cell klass = unap(I_CLASS,decl);
+ startGHCClass ( zsel15(klass), zsel25(klass),
+ zsel35(klass), zsel45(klass),
+ zsel55(klass) );
+ break;
+ }
+ case I_VALUE: {
+ Cell value = unap(I_VALUE,decl);
+ startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
+ break;
+ }
+ default:
+ internal("processInterfaces(1)");
+ }
+ }
+ }
+ fprintf(stderr, "frambozenvla\n" );exit(1);
-static Void local finishGHCModule(mod)
-Module mod; {
- // do the implicit 'import Prelude' thing
- List pxs = module(modulePrelude).exports;
- for (; nonNull(pxs); pxs=tl(pxs)) {
- Cell px = hd(pxs);
- again:
- switch (whatIs(px)) {
- case AP:
- px = fst(px);
- goto again;
- case NAME:
- module(mod).names = cons ( px, module(mod).names );
- break;
- case TYCON:
- module(mod).tycons = cons ( px, module(mod).tycons );
- break;
- case CLASS:
- module(mod).classes = cons ( px, module(mod).classes );
- break;
- default:
- fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
- break;
- }
- }
+ /* Traverse again the decl lists of the modules, this time
+ calling the finishGHC* functions. But don't try process
+ the export lists; those must wait for later.
+ */
+ for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs)) {
+ tr = hd(xs);
+ iface = unap(I_INTERFACE,zfst3(tr));
+ mname = textOf(zfst(iface));
+ mod = findModule(mname);
+ if (isNull(mod)) internal("processInterfaces(3)");
+ setCurrModule(mod);
+
+ for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
+ Cell decl = hd(decls);
+ switch(whatIs(decl)) {
+ case I_EXPORT: {
+ break;
+ }
+ case I_IMPORT: {
+ break;
+ }
+ case I_FIXDECL: {
+ break;
+ }
+ case I_INSTANCE: {
+ Cell instance = unap(I_INSTANCE,decl);
+ finishGHCInstance ( zsel34(instance) );
+ break;
+ }
+ case I_TYPE: {
+ Cell tydecl = unap(I_TYPE,decl);
+ finishGHCSynonym ( zsel24(tydecl) );
+ break;
+ }
+ case I_DATA: {
+ Cell ddecl = unap(I_DATA,decl);
+ finishGHCDataDecl ( zsel35(ddecl) );
+ break;
+ }
+ case I_NEWTYPE: {
+ Cell ntdecl = unap(I_NEWTYPE,decl);
+ finishGHCNewType ( zsel35(ntdecl) );
+ break;
+ }
+ case I_CLASS: {
+ Cell klass = unap(I_CLASS,decl);
+ finishGHCClass ( zsel35(klass) );
+ break;
+ }
+ case I_VALUE: {
+ Cell value = unap(I_VALUE,decl);
+ finishGHCValue ( zsnd3(value) );
+ break;
+ }
+ default:
+ internal("processInterfaces(2)");
+ }
+ }
+ }
+
+ /* Build the module(m).export lists for each module, by running
+ through the export lists in the iface. Also, do the implicit
+ 'import Prelude' thing. And finally, do the object code
+ linking.
+ */
+ for (xs = ifaces_outstanding; nonNull(xs); xs = tl(xs))
+ finishGHCModule(hd(xs));
- // Last, but by no means least ...
- resolveReferencesInObjectModule ( mod, TRUE );
+ /* Finished! */
+ ifaces_outstanding = NIL;
}
-Void openGHCIface(t)
-Text t; {
+
+/* --------------------------------------------------------------------------
+ * Modules
+ * ------------------------------------------------------------------------*/
+
+Void startGHCModule ( Text mname, Int sizeObj, Text nameObj )
+{
FILE* f;
void* img;
- Module m = findModule(t);
+ Module m = findModule(mname);
if (isNull(m)) {
- m = newModule(t);
- //printf ( "new module %s\n", textToStr(t) );
+ m = newModule(mname);
+ fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
+ textToStr(mname), sizeObj );
} else if (m != modulePrelude) {
- ERRMSG(0) "Module \"%s\" already loaded", textToStr(t)
+ ERRMSG(0) "Module \"%s\" already loaded", textToStr(mname)
EEND;
}
- // sizeObj and nameObj will magically be set to the right
- // thing when we arrive here.
- // All this crud should be replaced with mmap when we do this
- // for real(tm)
img = malloc ( sizeObj );
if (!img) {
ERRMSG(0) "Can't allocate memory to load object file for module \"%s\"",
- textToStr(t)
+ textToStr(mname)
EEND;
}
- f = fopen( nameObj, "rb" );
+ f = fopen( textToStr(nameObj), "rb" );
if (!f) {
- // Really, this shouldn't happen, since makeStackEntry ensures the
- // object is available. Nevertheless ...
+ /* Really, this shouldn't happen, since makeStackEntry ensures the
+ object is available. Nevertheless ...
+ */
ERRMSG(0) "Object file \"%s\" can't be opened to read -- oops!",
- &(nameObj[0])
+ &(textToStr(nameObj)[0])
EEND;
}
if (sizeObj != fread ( img, 1, sizeObj, f)) {
- ERRMSG(0) "Read of object file \"%s\" failed", nameObj
+ ERRMSG(0) "Read of object file \"%s\" failed", textToStr(nameObj)
EEND;
}
if (!validateOImage(img,sizeObj,VERBOSE)) {
- ERRMSG(0) "Validation of object file \"%s\" failed", nameObj
+ ERRMSG(0) "Validation of object file \"%s\" failed",
+ textToStr(nameObj)
EEND;
}
readSyms(m,VERBOSE);
- if (!cellIsMember(m, ghcModules))
- ghcModules = cons(m, ghcModules);
+ /* setCurrModule(m); */
+}
+
- setCurrModule(m);
+/* For the module mod, augment both the export environment (.exports)
+ and the eval environment (.names, .tycons, .classes)
+ with the symbols mentioned in exlist. We don't actually need
+ to touch the eval environment, since previous processing of the
+ top-level decls in the iface should have done this already.
+
+ mn is the module mentioned in the export list; it is the "original"
+ module for the symbols in the export list. We should also record
+ this info with the symbols, since references to object code need to
+ refer to the original module in which a symbol was defined, rather
+ than to some module it has been imported into and then re-exported.
+
+ Also do an implicit 'import Prelude' thingy for the module.
+*/
+Void finishGHCModule ( Cell root )
+{
+ /* root :: I_INTERFACE */
+ Cell iface = unap(I_INTERFACE,root);
+ ConId iname = zfst(iface);
+ List decls = zsnd(iface);
+ Module mod = findModule(textOf(iname));
+ List decls2 = NIL;
+ List exlist_list = NIL;
+ List t;
+
+ fprintf(stderr, "\ncleaniface: %s\n", textToStr(textOf(iname)));
+
+ if (isNull(mod)) internal("finishExports(1)");
+ setCurrModule(mod);
+
+ exlist_list = getExportDeclsInIFace ( root );
+ /* exlist_list :: [I_EXPORT] */
+
+ for (t=exlist_list; nonNull(t); t=tl(t))
+ hd(t) = zsnd(unap(I_EXPORT,hd(t)));
+ /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
+
+ for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
+ List exlist = hd(exlist_list);
+ /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
+ for (; nonNull(exlist); exlist=tl(exlist)) {
+ List subents;
+ Cell c;
+ Cell ex = hd(exlist);
+
+ switch (whatIs(ex)) {
+
+ case VARIDCELL: /* variable */
+ c = findName ( textOf(ex) );
+ assert(nonNull(c));
+ fprintf(stderr, "var %s\n", textToStr(textOf(ex)) );
+ module(mod).exports = cons(c, module(mod).exports);
+ break;
+
+ case CONIDCELL: /* non data tycon */
+ c = findTycon ( textOf(ex) );
+ assert(nonNull(c));
+ fprintf(stderr, "non data tycon %s\n", textToStr(textOf(ex)) );
+ module(mod).exports = cons(c, module(mod).exports);
+ break;
+
+ case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
+ subents = zsnd(ex); /* :: [ConVarId] */
+ ex = zfst(ex); /* :: ConId */
+ c = findTycon ( textOf(ex) );
+
+ if (nonNull(c)) { /* data */
+ fprintf(stderr, "data %s = ", textToStr(textOf(ex)) );
+ module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ for (; nonNull(subents); subents = tl(subents)) {
+ Cell ent2 = hd(subents);
+ assert(isCon(ent2));
+ c = findName ( textOf(ent2) );
+ fprintf(stderr, "%s ", textToStr(name(c).text));
+ assert(nonNull(c));
+ module(mod).exports = cons(c, module(mod).exports);
+ }
+ fprintf(stderr, "\n" );
+ } else { /* class */
+ c = findClass ( textOf(ex) );
+ assert(nonNull(c));
+ fprintf(stderr, "class %s where ", textToStr(textOf(ex)) );
+ module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ for (; nonNull(subents); subents = tl(subents)) {
+ Cell ent2 = hd(subents);
+ assert(isVar(ent2));
+ c = findName ( textOf(ent2) );
+ fprintf(stderr, "%s ", textToStr(name(c).text));
+ assert(nonNull(c));
+ module(mod).exports = cons(c, module(mod).exports);
+ }
+ fprintf(stderr, "\n" );
+ }
+ break;
+
+ default:
+ internal("finishExports(2)");
+
+ } /* switch */
+ }
+ }
+
+ if (preludeLoaded) {
+ /* do the implicit 'import Prelude' thing */
+ List pxs = module(modulePrelude).exports;
+ for (; nonNull(pxs); pxs=tl(pxs)) {
+ Cell px = hd(pxs);
+ again:
+ switch (whatIs(px)) {
+ case AP:
+ px = fst(px);
+ goto again;
+ case NAME:
+ module(mod).names = cons ( px, module(mod).names );
+ break;
+ case TYCON:
+ module(mod).tycons = cons ( px, module(mod).tycons );
+ break;
+ case CLASS:
+ module(mod).classes = cons ( px, module(mod).classes );
+ break;
+ default:
+ fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
+ internal("finishGHCModule -- implicit import Prelude");
+ break;
+ }
+ }
+ }
+
+ /* Last, but by no means least ... */
+ resolveReferencesInObjectModule ( mod, VERBOSE );
}
-Void addGHCImports(line,mn,syms)
-Int line;
-Text mn; /* the module to import from */
-List syms; { /* [ConId | VarId] -- the names to import */
- List t;
- Bool found;
+/* --------------------------------------------------------------------------
+ * Exports
+ * ------------------------------------------------------------------------*/
+
+Void startGHCExports ( ConId mn, List exlist )
+{
# ifdef DEBUG_IFACE
- printf("\naddGHCImport %s\n", textToStr(mn) );
+ printf("startGHCExports %s\n", textToStr(textOf(mn)) );
# endif
-
- /* Don't chase PrelGHC -- it doesn't exist */
- if (strncmp(textToStr(mn), "PrelGHC",7)==0) return;
-
- found = FALSE;
- for (t=ifImports; nonNull(t); t=tl(t)) {
- if (textOf(hd(t)) == mn) {
- found = TRUE;
- break;
- }
- }
- if (!found) {
- ifImports = cons(mkCon(mn),ifImports);
- ghcImports = cons( triple(currentModule,mn,syms), ghcImports );
- }
+ /* Nothing to do. */
}
-void addGHCVar(line,v,ty)
-Int line;
-Text v;
-Type ty;
+Void finishGHCExports ( ConId mn, List exlist )
+{
+# ifdef DEBUG_IFACE
+ printf("finishGHCExports %s\n", textToStr(textOf(mn)) );
+# endif
+ /* Nothing to do. */
+}
+
+
+/* --------------------------------------------------------------------------
+ * Imports
+ * ------------------------------------------------------------------------*/
+
+Void startGHCImports ( ConId mn, List syms )
+/* nm the module to import from */
+/* syms [ConId | VarId] -- the names to import */
+{
+# ifdef DEBUG_IFACE
+ printf("startGHCImports %s\n", textToStr(textOf(mn)) );
+# endif
+ /* Nothing to do. */
+}
+
+
+Void finishGHCImports ( ConId nm, List syms )
+/* nm the module to import from */
+/* syms [ConId | VarId] -- the names to import */
+{
+# ifdef DEBUG_IFACE
+ printf("finishGHCImports %s\n", textToStr(textOf(nm)) );
+# endif
+ /* Nothing to do. */
+}
+
+
+/* --------------------------------------------------------------------------
+ * Vars (values)
+ * ------------------------------------------------------------------------*/
+
+void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
- String s;
List tmp, tvs;
- /* if this var is the name of a ghc-compiled dictionary,
- ie, starts zdfC where C is a capital,
- ignore it.
- */
- s = textToStr(v);
+ Text v = textOf(vid);
+
# ifdef DEBUG_IFACE
- printf("\nbegin addGHCVar %s\n", s);
+ printf("\nbegin startGHCValue %s\n", textToStr(v));
# endif
- if (s[0]=='z' && s[1]=='d' && s[2]=='f' && isupper((int)s[3])) {
-# ifdef DEBUG_IFACE
- printf(" ignoring %s\n", s);
-# endif
- return;
- }
+
n = findName(v);
if (nonNull(n)) {
ERRMSG(0) "Attempt to redefine variable \"%s\"", textToStr(v)
}
n = newName(v,NIL);
- tvs = nubList(ifTyvarsIn(ty));
+ tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- hd(tmp) = pair(hd(tmp),STAR);
+ hd(tmp) = zpair(hd(tmp),STAR);
if (nonNull(tvs))
ty = mkPolyType(tvsToKind(tvs),ty);
ty = tvsToOffsets(line,ty,tvs);
- /* prepare for finishGHCVar */
- name(n).type = ty;
+ /* prepare for finishGHCValue */
+ name(n).type = ty;
name(n).arity = arityInclDictParams(ty);
- name(n).line = line;
- ghcVarDecls = cons(n,ghcVarDecls);
+ name(n).line = line;
# ifdef DEBUG_IFACE
- printf("end addGHCVar %s\n", s);
+ printf("end startGHCValue %s\n", textToStr(v));
# endif
}
-static Void local finishGHCVar(Name n)
+
+void finishGHCValue ( VarId vid )
{
+ Name n = findName ( textOf(vid) );
Int line = name(n).line;
Type ty = name(n).type;
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin finishGHCVar %s\n", textToStr(name(n).text) );
+ fprintf(stderr, "\nbegin finishGHCValue %s\n", textToStr(name(n).text) );
# endif
- setCurrModule(name(n).mod);
+ assert(currentModule == name(n).mod);
+ //setCurrModule(name(n).mod);
name(n).type = conidcellsToTycons(line,ty);
# ifdef DEBUG_IFACE
- fprintf(stderr, "end finishGHCVar %s\n", textToStr(name(n).text) );
+ fprintf(stderr, "end finishGHCValue %s\n", textToStr(name(n).text) );
# endif
}
-Void addGHCSynonym(line,tycon,tvs,ty)
-Int line;
-Cell tycon; /* ConId */
-List tvs; /* [(VarId,Kind)] */
-Type ty; {
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
+
+/* --------------------------------------------------------------------------
+ * Type synonyms
+ * ------------------------------------------------------------------------*/
+
+Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
+{
+ /* tycon :: ConId */
+ /* tvs :: [((VarId,Kind))] */
+ /* ty :: Type */
Text t = textOf(tycon);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\nbegin startGHCSynonym %s\n", textToStr(t) );
+# endif
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
/* prepare for finishGHCSynonym */
tycon(tc).defn = tvsToOffsets(line,ty,tvs);
- ghcSynonymDecls = cons(tc,ghcSynonymDecls);
}
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "end startGHCSynonym %s\n", textToStr(t) );
+# endif
}
-static Void local finishGHCSynonym(Tycon tc)
+
+static Void finishGHCSynonym ( ConId tyc )
{
- Int line = tycon(tc).line;
+ Tycon tc = findTycon(textOf(tyc));
+ Int line = tycon(tc).line;
- setCurrModule(tycon(tc).mod);
+ assert (currentModule == tycon(tc).mod);
+ // setCurrModule(tycon(tc).mod);
tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
- /* ToDo: can't really do this until I've done all synonyms
+ /* (ADR) ToDo: can't really do this until I've done all synonyms
* and then I have to do them in order
* tycon(tc).defn = fullExpand(ty);
+ * (JRS) What?!?! i don't understand
*/
}
-Void addGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
-Int line;
-List ctx0; /* [(QConId,VarId)] */
-Cell tycon; /* ConId */
-List ktyvars; /* [(VarId,Kind)] */
-List constrs0; /* [(ConId,[(Type,Text,Int)],NIL)]
- The NIL will become the constr's type
- The Text is an optional field name
- The Int indicates strictness */
+
+/* --------------------------------------------------------------------------
+ * Data declarations
+ * ------------------------------------------------------------------------*/
+
+Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
+Int line;
+List ctx0; /* [((QConId,VarId))] */
+Cell tycon; /* ConId */
+List ktyvars; /* [((VarId,Kind))] */
+List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
+ /* The Text is an optional field name
+ The Int indicates strictness */
/* ToDo: worry about being given a decl for (->) ?
* and worry about qualidents for ()
*/
Text t = textOf(tycon);
# ifdef DEBUG_IFACE
- fprintf(stderr, "\nbegin addGHCDataDecl %s\n",textToStr(t));
+ fprintf(stderr, "\nbegin startGHCDataDecl %s\n",textToStr(t));
# endif
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
tycon(tc).kind = tvsToKind(ktyvars);
tycon(tc).what = DATATYPE;
- /* a list to accumulate selectors in :: [(VarId,Type)] */
+ /* a list to accumulate selectors in :: [((VarId,Type))] */
sels = NIL;
/* make resTy the result type of the constr, T v1 ... vn */
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
constr = hd(constrs);
- conid = fst3(constr);
- fields = snd3(constr);
- assert(isNull(thd3(constr)));
+ conid = zfst(constr);
+ fields = zsnd(constr);
/* Build type of constr and handle any selectors found.
Also collect up tyvars occurring in the constr's arg
context later.
*/
ty = resTy;
- tyvarsMentioned = NIL; /* [VarId] */
+ tyvarsMentioned = NIL;
+ /* tyvarsMentioned :: [VarId] */
+
conArgs = reverse(fields);
for (; nonNull(conArgs); conArgs=tl(conArgs)) {
conArg = hd(conArgs); /* (Type,Text) */
- conArgTy = fst3(conArg);
- conArgNm = snd3(conArg);
- conArgStrictness = intOf(thd3(conArg));
+ conArgTy = zfst3(conArg);
+ conArgNm = zsnd3(conArg);
+ conArgStrictness = intOf(zthd3(conArg));
tyvarsMentioned = dupListOnto(ifTyvarsIn(conArgTy),
tyvarsMentioned);
if (conArgStrictness > 0) conArgTy = bang(conArgTy);
ty = fn(conArgTy,ty);
if (nonNull(conArgNm)) {
- /* a field name is mentioned too */
+ /* a field name is mentioned too */
selTy = fn(resTy,conArgTy);
if (whatIs(tycon(tc).kind) != STAR)
selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
selTy = tvsToOffsets(line,selTy, ktyvars);
- sels = cons( pair(conArgNm,selTy), sels);
+ sels = cons( zpair(conArgNm,selTy), sels);
}
}
*/
ctx2 = NIL;
for (ctx=ctx0; nonNull(ctx); ctx=tl(ctx)) {
- ctxElem = hd(ctx); /* (QConId,VarId) */
- if (nonNull(cellIsMember(textOf(snd(ctxElem)),tyvarsMentioned)))
+ ctxElem = hd(ctx);
+ /* ctxElem :: ((QConId,VarId)) */
+ if (nonNull(cellIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
ctx2 = cons(ctxElem, ctx2);
}
if (nonNull(ctx2))
/* stick the tycon's kind on, if not simply STAR */
if (whatIs(tycon(tc).kind) != STAR)
- ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
+ ty = pair(POLYTYPE,zpair(tycon(tc).kind, ty));
ty = tvsToOffsets(line,ty, ktyvars);
/* Finally, stick the constructor's type onto it. */
- thd3(hd(constrs)) = ty;
+ hd(constrs) = ztriple(conid,fields,ty);
}
/* Final result is that
- constrs :: [(ConId,[(Type,Text)],Type)]
+ constrs :: [((ConId,[((Type,Text))],Type))]
lists the constructors and their types
- sels :: [(VarId,Type)]
+ sels :: [((VarId,Type))]
lists the selectors and their types
*/
- tycon(tc).defn = addGHCConstrs(line,constrs0,sels);
+ tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
}
# ifdef DEBUG_IFACE
- fprintf(stderr, "end addGHCDataDecl %s\n",textToStr(t));
+ fprintf(stderr, "end startGHCDataDecl %s\n",textToStr(t));
# endif
}
-static List local addGHCConstrs(line,cons,sels)
-Int line;
-List cons; /* [(ConId,[(Type,Text,Int)],Type)] */
-List sels; { /* [(VarId,Type)] */
+static List startGHCConstrs ( Int line, List cons, List sels )
+{
+ /* cons :: [((ConId,[((Type,Text,Int))],Type))] */
+ /* sels :: [((VarId,Type))] */
+ /* returns [Name] */
List cs, ss;
Int conNo = 0; /* or maybe 1? */
for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
- Name c = addGHCConstr(line,conNo,hd(cs));
+ Name c = startGHCConstr(line,conNo,hd(cs));
hd(cs) = c;
}
+ /* cons :: [Name] */
+
for(ss=sels; nonNull(ss); ss=tl(ss)) {
- hd(ss) = addGHCSel(line,hd(ss));
+ hd(ss) = startGHCSel(line,hd(ss));
}
+ /* sels :: [Name] */
return appendOnto(cons,sels);
}
-static Name local addGHCSel(line,sel)
-Int line;
-Pair sel; /* (VarId,Type) */
+
+static Name startGHCSel ( Int line, ZPair sel )
{
- Text t = textOf(fst(sel));
- Type type = snd(sel);
+ /* sel :: ((VarId, Type)) */
+ Text t = textOf(zfst(sel));
+ Type type = zsnd(sel);
Name n = findName(t);
if (nonNull(n)) {
name(n).number = SELNAME;
name(n).arity = 1;
name(n).defn = NIL;
-
- /* prepare for finishGHCVar */
name(n).type = type;
- ghcVarDecls = cons(n,ghcVarDecls);
-
return n;
}
-static Name local addGHCConstr(line,conNo,constr)
-Int line;
-Int conNo;
-Triple constr; { /* (ConId,[(Type,Text,Int)],Type) */
- /* ToDo: add rank2 annotation and existential annotation
+
+static Name startGHCConstr ( Int line, Int conNo, ZTriple constr )
+{
+ /* constr :: ((ConId,[((Type,Text,Int))],Type)) */
+ /* (ADR) ToDo: add rank2 annotation and existential annotation
* these affect how constr can be used.
*/
- Text con = textOf(fst3(constr));
- Type type = thd3(constr);
+ Text con = textOf(zfst3(constr));
+ Type type = zthd3(constr);
Int arity = arityFromType(type);
Name n = findName(con); /* Allocate constructor fun name */
if (isNull(n)) {
name(n).arity = arity; /* Save constructor fun details */
name(n).line = line;
name(n).number = cfunNo(conNo);
-
- /* prepare for finishGHCCon */
name(n).type = type;
- ghcConstrDecls = cons(n,ghcConstrDecls);
-
return n;
}
-static Void local finishGHCConstr(Name n)
+
+static Void finishGHCDataDecl ( ConId tyc )
{
- Int line = name(n).line;
- Type ty = name(n).type;
- setCurrModule(name(n).mod);
+ List nms;
+ Tycon tc = findTycon(textOf(tyc));
# ifdef DEBUG_IFACE
- printf ( "\nbegin finishGHCConstr %s\n", textToStr(name(n).text));
+ printf ( "\nbegin finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
# endif
- name(n).type = conidcellsToTycons(line,ty);
+ if (isNull(tc)) internal("finishGHCDataDecl");
+
+ for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
+ Name n = hd(nms);
+ Int line = name(n).line;
+ assert(currentModule == name(n).mod);
+ name(n).type = conidcellsToTycons(line,name(n).type);
+ }
# ifdef DEBUG_IFACE
- printf ( "end finishGHCConstr %s\n", textToStr(name(n).text));
+ printf ( "end finishGHCDataDecl %s\n", textToStr(textOf(tyc)) );
# endif
}
-Void addGHCNewType(line,ctx0,tycon,tvs,constr)
-Int line;
-List ctx0; /* [(QConId,VarId)] */
-Cell tycon; /* ConId | QualConId */
-List tvs; /* [(VarId,Kind)] */
-Cell constr; { /* (ConId,Type) */
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
+/* --------------------------------------------------------------------------
+ * Newtype decls
+ * ------------------------------------------------------------------------*/
+
+Void startGHCNewType ( Int line, List ctx0,
+ ConId tycon, List tvs, Cell constr )
+{
+ /* ctx0 :: [((QConId,VarId))] */
+ /* tycon :: ConId */
+ /* tvs :: [((VarId,Kind))] */
+ /* constr :: ((ConId,Type)) */
List tmp;
Type resTy;
Text t = textOf(tycon);
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "\nbegin startGHCNewType %s\n", textToStr(t) );
+# endif
if (nonNull(findTycon(t))) {
ERRMSG(line) "Repeated definition of type constructor \"%s\"",
textToStr(t)
tycon(tc).kind = tvsToKind(tvs);
/* can't really do this until I've read in all synonyms */
- assert(nonNull(constr));
- if (isNull(constr)) {
- tycon(tc).defn = NIL;
- } else {
- /* constr :: (ConId,Type) */
- Text con = textOf(fst(constr));
- Type type = snd(constr);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = 1; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(0);
- name(n).defn = nameId;
- tycon(tc).defn = singleton(n);
-
- /* prepare for finishGHCCon */
- /* ToDo: we use finishGHCCon instead of finishGHCVar in case
- * there's any existential quantification in the newtype -
- * but I don't think that's allowed in newtype constrs.
- * Still, no harm done by doing it this way...
- */
-
- /* make resTy the result type of the constr, T v1 ... vn */
- resTy = tycon;
- for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,fst(hd(tmp)));
- type = fn(type,resTy);
- if (nonNull(ctx0))
- type = ap(QUAL,pair(ctx0,type));
-
- type = tvsToOffsets(line,type,tvs);
-
- name(n).type = type;
- ghcConstrDecls = cons(n,ghcConstrDecls);
+ {
+ /* constr :: ((ConId,Type)) */
+ Text con = textOf(zfst(constr));
+ Type type = zsnd(constr);
+ Name n = findName(con); /* Allocate constructor fun name */
+ if (isNull(n)) {
+ n = newName(con,NIL);
+ } else if (name(n).defn!=PREDEFINED) {
+ ERRMSG(line) "Repeated definition for constructor \"%s\"",
+ textToStr(con)
+ EEND;
+ }
+ name(n).arity = 1; /* Save constructor fun details */
+ name(n).line = line;
+ name(n).number = cfunNo(0);
+ name(n).defn = nameId;
+ tycon(tc).defn = singleton(n);
+
+ /* make resTy the result type of the constr, T v1 ... vn */
+ resTy = tycon;
+ for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
+ resTy = ap(resTy,zfst(hd(tmp)));
+ type = fn(type,resTy);
+ if (nonNull(ctx0))
+ type = ap(QUAL,pair(ctx0,type));
+ type = tvsToOffsets(line,type,tvs);
+ name(n).type = type;
}
}
+# ifdef DEBUG_IFACE
+ fprintf(stderr, "end startGHCNewType %s\n", textToStr(t) );
+# endif
}
-Void addGHCClass(line,ctxt,tc_name,kinded_tv,mems0)
-Int line;
-List ctxt; /* [(QConId, VarId)] */
-Cell tc_name; /* ConId */
-Text kinded_tv; /* (VarId, Kind) */
-List mems0; { /* [(VarId, Type)] */
- List mems; /* [(VarId, Type)] */
- List tvsInT; /* [VarId] and then [(VarId,Kind)] */
- List tvs; /* [(VarId,Kind)] */
- Text ct = textOf(tc_name);
- Pair newCtx = pair(tc_name, fst(kinded_tv));
+
+static Void finishGHCNewType ( ConId tyc )
+{
+ Tycon tc = findTycon(tyc);
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin finishGHCNewType %s\n", textToStr(textOf(tyc)) );
+# endif
+
+ if (isNull(tc)) internal("finishGHCNewType");
+ if (length(tycon(tc).defn) != 1) internal("finishGHCNewType(2)");
+ {
+ Name n = hd(tycon(tc).defn);
+ Int line = name(n).line;
+ assert(currentModule == name(n).mod);
+ name(n).type = conidcellsToTycons(line,name(n).type);
+ }
# ifdef DEBUG_IFACE
- printf ( "\nbegin addGHCclass %s\n", textToStr(ct) );
+ printf ( "end finishGHCNewType %s\n", textToStr(textOf(tyc)) );
# endif
+}
+
+
+/* --------------------------------------------------------------------------
+ * Class declarations
+ * ------------------------------------------------------------------------*/
+
+Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
+Int line;
+List ctxt; /* [((QConId, VarId))] */
+ConId tc_name; /* ConId */
+List kinded_tvs; /* [((VarId, Kind))] */
+List mems0; { /* [((VarId, Type))] */
+
+ List mems; /* [((VarId, Type))] */
+ List tvsInT; /* [VarId] and then [((VarId,Kind))] */
+ List tvs; /* [((VarId,Kind))] */
+
+ ZPair kinded_tv = hd(kinded_tvs);
+ Text ct = textOf(tc_name);
+ Pair newCtx = pair(tc_name, zfst(kinded_tv));
+# ifdef DEBUG_IFACE
+ printf ( "\nbegin startGHCclass %s\n", textToStr(ct) );
+# endif
+
+ if (length(kinded_tvs) != 1) {
+ ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
+ EEND;
+ }
+
if (nonNull(findClass(ct))) {
ERRMSG(line) "Repeated definition of class \"%s\"",
textToStr(ct)
for (mems=mems0; nonNull(mems); mems=tl(mems)) {
- Pair mem = hd(mems);
- Type memT = snd(mem);
- Text mnt = textOf(fst(mem));
- Name mn;
+ ZPair mem = hd(mems);
+ Type memT = zsnd(mem);
+ Text mnt = textOf(zfst(mem));
+ Name mn;
/* Stick the new context on the member type */
- if (whatIs(memT)==POLYTYPE) internal("addGHCClass");
+ if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
if (whatIs(memT)==QUAL) {
memT = pair(QUAL,
pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
}
/* Cook up a kind for the type. */
- tvsInT = nubList(ifTyvarsIn(memT));
+ tvsInT = ifTyvarsIn(memT);
+ /* tvsInT :: [VarId] */
/* ToDo: maximally bogus */
for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
- hd(tvs) = pair(hd(tvs),STAR);
+ hd(tvs) = zpair(hd(tvs),STAR);
+ /* tvsIntT :: [((VarId,STAR))] */
memT = mkPolyType(tvsToKind(tvsInT),memT);
memT = tvsToOffsets(line,memT,tvsInT);
cclass(nw).members = mems0;
cclass(nw).numMembers = length(mems0);
- ghcClassDecls = cons(nw,ghcClassDecls);
- /* ToDo:
+ /* (ADR) ToDo:
* cclass(nw).dsels = ?;
* cclass(nw).dbuild = ?;
* cclass(nm).dcon = ?;
*/
}
# ifdef DEBUG_IFACE
- printf ( "end addGHCclass %s\n", textToStr(ct) );
+ printf ( "end startGHCclass %s\n", textToStr(ct) );
# endif
}
-static Void local finishGHCClass(Class nw)
-{
- List mems;
- Int line = cclass(nw).line;
- Int ctr = - length(cclass(nw).members);
+static Void finishGHCClass ( Tycon cls_tyc )
+{
+ List mems;
+ Int line;
+ Int ctr;
+ Class nw = findClass ( textOf(cls_tyc) );
# ifdef DEBUG_IFACE
printf ( "\nbegin finishGHCclass %s\n", textToStr(cclass(nw).text) );
# endif
+ if (isNull(nw)) internal("finishGHCClass");
- setCurrModule(cclass(nw).mod);
+ line = cclass(nw).line;
+ ctr = - length(cclass(nw).members);
+ assert (currentModule == cclass(nw).mod);
- cclass(nw).level = 0; /* ToDo: 1 + max (map level supers) */
- cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
- cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
- cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
+ cclass(nw).level = 0; /* (ADR) ToDo: 1 + max (map level supers) */
+ cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
+ cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
+ cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
Pair mem = hd(mems); /* (VarId, Type) */
# endif
}
-Void addGHCInstance (line,ctxt0,cls,var)
-Int line;
-List ctxt0; /* [(QConId, Type)] */
-List cls; /* [(ConId, Type)] */
-Text var; { /* Text */
+
+/* --------------------------------------------------------------------------
+ * Instances
+ * ------------------------------------------------------------------------*/
+
+Void startGHCInstance (line,ctxt0,cls,var)
+Int line;
+List ctxt0; /* [(QConId, VarId)] */
+Type cls; /* Type */
+VarId var; { /* VarId */
List tmp, tvs, ks;
Inst in = newInst();
# ifdef DEBUG_IFACE
- printf ( "\nbegin addGHCInstance\n" );
+ printf ( "\nbegin startGHCInstance\n" );
# endif
/* Make tvs into a list of tyvars with bogus kinds. */
- //print ( cls, 10 ); printf ( "\n");
- tvs = nubList(ifTyvarsIn(cls));
- //print ( tvs, 10 );
+ tvs = ifTyvarsIn(cls);
+ /* tvs :: [VarId] */
+
ks = NIL;
for (tmp = tvs; nonNull(tmp); tmp=tl(tmp)) {
- hd(tmp) = pair(hd(tmp),STAR);
+ hd(tmp) = zpair(hd(tmp),STAR);
ks = cons(STAR,ks);
}
+ /* tvs :: [((VarId,STAR))] */
inst(in).line = line;
inst(in).implements = NIL;
inst(in).numSpecifics = length(ctxt0);
inst(in).head = tvsToOffsets(line,cls,tvs);
#if 0
-Is this still needed?
+ Is this still needed?
{
Name b = newName(inventText(),NIL);
name(b).line = line;
bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
}
#endif
- ghcInstanceDecls = cons(in, ghcInstanceDecls);
# ifdef DEBUG_IFACE
- printf ( "end addGHCInstance\n" );
+ printf ( "end startGHCInstance\n" );
# endif
}
-static Void local finishGHCInstance(Inst in)
+
+static Void finishGHCInstance ( Type cls )
{
- Int line = inst(in).line;
- Cell cl = fst(inst(in).head);
+ /* Cls is the { C1 a1 } -> ... -> { Cn an }, where
+ an isn't a type variable -- it's a data or tuple. */
+ Inst in;
+ Int line;
+ Cell cl;
Class c;
+ ConId conid_cls;
+ ConId conid_ty;
+
# ifdef DEBUG_IFACE
printf ( "\nbegin finishGHCInstance\n" );
# endif
- setCurrModule(inst(in).mod);
+ cls = snd(cls); /* { Cn an } */
+ conid_cls = fst(cls);
+ conid_ty = snd(cls);
+
+ if (whatIs(conid_cls) != CONIDCELL ||
+ whatIs(conid_ty ) != CONIDCELL) internal("finishGHCInstance");
+
+ in = findSimpleInstance ( conid_cls, conid_ty );
+ line = inst(in).line;
+ cl = fst(inst(in).head);
+
+ assert (currentModule==inst(in).mod);
c = findClass(textOf(cl));
if (isNull(c)) {
ERRMSG(line) "Unknown class \"%s\" in instance",
# endif
}
+
/* --------------------------------------------------------------------------
* Helper fns
* ------------------------------------------------------------------------*/
-/* This is called from the addGHC* functions. It traverses a structure
+/* This is called from the startGHC* functions. It traverses a structure
and converts varidcells, ie, type variables parsed by the interface
parser, into Offsets, which is how Hugs wants to see them internally.
The Offset for a type variable is determined by its place in the list
passed as the second arg; the associated kinds are irrelevant.
+
+ ((t1,t2)) denotes the typed (z-)pair type of t1 and t2.
*/
-static Type local tvsToOffsets(line,type,ktyvars)
+
+/* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
+static Type tvsToOffsets(line,type,ktyvars)
Int line;
Type type;
-List ktyvars; { /* [(VarId|Text,Kind)] */
+List ktyvars; { /* [(VarId,Kind)] */
switch (whatIs(type)) {
case NIL:
case TUPLE:
case CONIDCELL:
case TYCON:
return type;
+ case ZTUP2: /* convert to the untyped representation */
+ return ap( tvsToOffsets(line,zfst(type),ktyvars),
+ tvsToOffsets(line,zsnd(type),ktyvars) );
case AP:
return ap( tvsToOffsets(line,fun(type),ktyvars),
tvsToOffsets(line,arg(type),ktyvars) );
{ Int i = 0;
Text tv = textOf(type);
for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
- Cell varid = fst(hd(ktyvars));
- Text tt = isVar(varid) ? textOf(varid) : varid;
+ Cell varid;
+ Text tt;
+assert(isZPair(hd(ktyvars)));
+ varid = zfst(hd(ktyvars));
+ tt = textOf(varid);
if (tv == tt) return mkOffset(i);
}
ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
and converts conidcells, ie, type constructors parsed by the interface
parser, into Tycons (or Classes), which is how Hugs wants to see them
internally. Calls to this fn have to be deferred to the second phase
- of interface loading (finishGHC* rather than addGHC*) so that all relevant
+ of interface loading (finishGHC* rather than startGHC*) so that all relevant
Tycons or Classes have been loaded into the symbol tables and can be
looked up.
*/
-
-static Type local conidcellsToTycons(line,type)
+static Type conidcellsToTycons(line,type)
Int line;
Type type; {
switch (whatIs(type)) {
* so they can be performed while reading interfaces.
* ------------------------------------------------------------------------*/
-static Kinds local tvsToKind(tvs)
-List tvs; { /* [(VarId,Kind)] */
+/* tvsToKind :: [((VarId,Kind))] -> Kinds */
+static Kinds tvsToKind(tvs)
+List tvs; { /* [((VarId,Kind))] */
List rs;
Kinds r = STAR;
for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
- r = ap(snd(hd(rs)),r);
+ if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
+ if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
+ r = ap(zsnd(hd(rs)),r);
}
return r;
}
-static Int local arityInclDictParams ( Type type )
+static Int arityInclDictParams ( Type type )
{
Int arity = 0;
if (isPolyType(type)) type = monotypeOf(type);
}
/* arity of a constructor with this type */
-static Int local arityFromType(type)
+static Int arityFromType(type)
Type type; {
Int arity = 0;
if (isPolyType(type)) {
}
-static List local ifTyvarsIn(type)
+/* ifTyvarsIn :: Type -> [VarId]
+ The returned list has no duplicates -- is a set.
+*/
+static List ifTyvarsIn(type)
Type type; {
List vs = typeVarsIn(type,NIL,NIL,NIL);
List vs2 = vs;
- for (; nonNull(vs2); vs2=tl(vs2)) {
- Cell v = hd(vs2);
- if (whatIs(v)==VARIDCELL || whatIs(v)==VAROPCELL) {
- hd(vs2) = textOf(hd(vs2));
- } else {
+ for (; nonNull(vs2); vs2=tl(vs2))
+ if (whatIs(hd(vs2)) != VARIDCELL)
internal("ifTyvarsIn");
- }
- }
return vs;
}
#include <elf.h>
-static char* local findElfSection ( void* objImage, Elf32_Word sh_type )
+static char* findElfSection ( void* objImage, Elf32_Word sh_type )
{
Int i;
char* ehdrC = (char*)objImage;
}
-static Void local resolveReferencesInObjectModule_elf ( Module m,
+static Void resolveReferencesInObjectModule_elf ( Module m,
Bool verb )
{
char symbol[1000]; // ToDo
}
-static Bool local validateOImage_elf ( void* imgV,
+static Bool validateOImage_elf ( void* imgV,
Int size,
Bool verb )
{
* Arch-independent interface to the runtime linker
* ------------------------------------------------------------------------*/
-static Bool local validateOImage ( void* img, Int size, Bool verb )
+static Bool validateOImage ( void* img, Int size, Bool verb )
{
#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
return
}
-static Void local resolveReferencesInObjectModule ( Module m, Bool verb )
+static Void resolveReferencesInObjectModule ( Module m, Bool verb )
{
#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
resolveReferencesInObjectModule_elf ( m, verb );
}
-static Void local readSyms ( Module m, Bool verb )
+static Void readSyms ( Module m, Bool verb )
{
#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
readSyms_elf ( m, verb );
Void interface(what)
Int what; {
switch (what) {
- case INSTALL:
- case RESET:
- ifImports = NIL;
- ghcVarDecls = NIL;
- ghcConstrDecls = NIL;
- ghcSynonymDecls = NIL;
- ghcClassDecls = NIL;
- ghcInstanceDecls = NIL;
- ghcExports = NIL;
- ghcImports = NIL;
- ghcModules = NIL;
- break;
- case MARK:
- mark(ifImports);
- mark(ghcVarDecls);
- mark(ghcConstrDecls);
- mark(ghcSynonymDecls);
- mark(ghcClassDecls);
- mark(ghcInstanceDecls);
- mark(ghcImports);
- mark(ghcExports);
- mark(ghcModules);
- break;
+ case POSTPREL: break;
+
+ case PREPREL:
+ case RESET:
+ ifaces_outstanding = NIL;
+ break;
+ case MARK:
+ mark(ifaces_outstanding);
+ break;
}
}
* included in the distribution.
*
* $RCSfile: lift.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/11/29 18:59:29 $
+ * $Revision: 1.10 $
+ * $Date: 1999/12/10 15:59:47 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Void liftControl(what)
Int what; {
switch (what) {
- case INSTALL:
- /* deliberate fall though */
- case RESET:
- liftedBinds = NIL;
- break;
- case MARK:
- mark(liftedBinds);
- break;
+ case POSTPREL: break;
+
+ case PREPREL:
+ case RESET:
+ liftedBinds = NIL;
+ break;
+ case MARK:
+ mark(liftedBinds);
+ break;
}
}
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.20 $
- * $Date: 1999/12/06 16:25:25 $
+ * $Revision: 1.21 $
+ * $Date: 1999/12/10 15:59:48 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Cell predMonad; /* Monad (mkOffset(0)) */
Type typeProgIO; /* IO a */
+
/* --------------------------------------------------------------------------
*
* ------------------------------------------------------------------------*/
static Tycon linkTycon ( String s );
static Tycon linkClass ( String s );
static Name linkName ( String s );
-static Void mkTypes ( void );
static Name predefinePrim ( String s );
return nm;
}
+
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
+/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPreludeNames
+ are called, in that order, during static analysis of Prelude.hs.
+ In combined mode such an analysis does not happen. Instead these
+ calls will be made as a result of a call link(POSTPREL).
+
+ linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both
+ standalone and combined modes.
+*/
+
+
Void linkPreludeTC(void) { /* Hook to tycons and classes in */
static Bool initialised = FALSE; /* prelude when first loaded */
if (!initialised) {
initialised = TRUE;
setCurrModule(modulePrelude);
- typeChar = linkTycon("Char");
- typeInt = linkTycon("Int");
- typeInteger = linkTycon("Integer");
- typeWord = linkTycon("Word");
- typeAddr = linkTycon("Addr");
+ typeChar = linkTycon("Char");
+ typeInt = linkTycon("Int");
+ typeInteger = linkTycon("Integer");
+ typeWord = linkTycon("Word");
+ typeAddr = linkTycon("Addr");
typePrimArray = linkTycon("PrimArray");
typePrimByteArray = linkTycon("PrimByteArray");
typeRef = linkTycon("STRef");
typePrimMutableArray = linkTycon("PrimMutableArray");
typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
- typeFloat = linkTycon("Float");
- typeDouble = linkTycon("Double");
- typeStable = linkTycon("StablePtr");
-#ifdef PROVIDE_WEAK
- typeWeak = linkTycon("Weak");
-#endif
-#ifdef PROVIDE_FOREIGN
- typeForeign = linkTycon("ForeignObj");
-#endif
- typeThreadId = linkTycon("ThreadId");
- typeMVar = linkTycon("MVar");
- typeBool = linkTycon("Bool");
- typeST = linkTycon("ST");
- typeIO = linkTycon("IO");
- typeException = linkTycon("Exception");
- typeString = linkTycon("String");
- typeOrdering = linkTycon("Ordering");
-
- classEq = linkClass("Eq");
- classOrd = linkClass("Ord");
- classIx = linkClass("Ix");
- classEnum = linkClass("Enum");
- classShow = linkClass("Show");
- classRead = linkClass("Read");
- classBounded = linkClass("Bounded");
- classReal = linkClass("Real");
- classIntegral = linkClass("Integral");
- classRealFrac = linkClass("RealFrac");
- classRealFloat = linkClass("RealFloat");
- classFractional = linkClass("Fractional");
- classFloating = linkClass("Floating");
- classNum = linkClass("Num");
- classMonad = linkClass("Monad");
-
- stdDefaults = NIL;
- stdDefaults = cons(typeDouble,stdDefaults);
-#if DEFAULT_BIGNUM
- stdDefaults = cons(typeInteger,stdDefaults);
-#else
- stdDefaults = cons(typeInt,stdDefaults);
-#endif
- mkTypes();
-
- nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
- nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
- nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
- nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
- nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
- nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
- nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
- nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
-
-#ifdef PROVIDE_FOREIGN
- nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
-#endif
-#ifdef PROVIDE_WEAK
- nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
-#endif
- nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
- nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
- nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
- nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
+ typeFloat = linkTycon("Float");
+ typeDouble = linkTycon("Double");
+ typeStable = linkTycon("StablePtr");
+# ifdef PROVIDE_WEAK
+ typeWeak = linkTycon("Weak");
+# endif
+# ifdef PROVIDE_FOREIGN
+ typeForeign = linkTycon("ForeignObj");
+# endif
+ typeThreadId = linkTycon("ThreadId");
+ typeMVar = linkTycon("MVar");
+ typeBool = linkTycon("Bool");
+ typeST = linkTycon("ST");
+ typeIO = linkTycon("IO");
+ typeException = linkTycon("Exception");
+ typeString = linkTycon("String");
+ typeOrdering = linkTycon("Ordering");
+
+ classEq = linkClass("Eq");
+ classOrd = linkClass("Ord");
+ classIx = linkClass("Ix");
+ classEnum = linkClass("Enum");
+ classShow = linkClass("Show");
+ classRead = linkClass("Read");
+ classBounded = linkClass("Bounded");
+ classReal = linkClass("Real");
+ classIntegral = linkClass("Integral");
+ classRealFrac = linkClass("RealFrac");
+ classRealFloat = linkClass("RealFloat");
+ classFractional = linkClass("Fractional");
+ classFloating = linkClass("Floating");
+ classNum = linkClass("Num");
+ classMonad = linkClass("Monad");
+
+ stdDefaults = NIL;
+ stdDefaults = cons(typeDouble,stdDefaults);
+# if DEFAULT_BIGNUM
+ stdDefaults = cons(typeInteger,stdDefaults);
+# else
+ stdDefaults = cons(typeInt,stdDefaults);
+# endif
+
+ predNum = ap(classNum,aVar);
+ predFractional = ap(classFractional,aVar);
+ predIntegral = ap(classIntegral,aVar);
+ predMonad = ap(classMonad,aVar);
+ typeProgIO = ap(typeIO,aVar);
+
+ nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
+ nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
+ nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
+ nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
+ nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
+ nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
+ nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
+ nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
+
+# ifdef PROVIDE_FOREIGN
+ nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
+# endif
+# ifdef PROVIDE_WEAK
+ nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
+# endif
+ nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
+ nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
+ nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
+ nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
- nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
- nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
-
- /* The following primitives are referred to in derived instances and
- * hence require types; the following types are a little more general
- * than we might like, but they are the closest we can get without a
- * special datatype class.
- */
-
- name(namePrimSeq).type
- = primType(MONAD_Id, "ab", "b");
- name(namePrimCatch).type
- = primType(MONAD_Id, "aH", "a");
- name(namePrimRaise).type
- = primType(MONAD_Id, "E", "a");
+ nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
+ nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
+
+ name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
+ name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
+ name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
/* This is a lie. For a more accurate type of primTakeMVar
see ghc/interpreter/lib/Prelude.hs.
*/
- name(namePrimTakeMVar).type
- = primType(MONAD_Id, "rbc", "d");
+ name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
addTupInst(classEq,i);
}
}
-static Void mkTypes ( void )
-{
- predNum = ap(classNum,aVar);
- predFractional = ap(classFractional,aVar);
- predIntegral = ap(classIntegral,aVar);
- predMonad = ap(classMonad,aVar);
- typeProgIO = ap(typeIO,aVar);
-}
-
Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
static Bool initialised = FALSE; /* prelude when first loaded */
if (!initialised) {
nameOtherwise = linkName("otherwise");
nameUndefined = linkName("undefined");
/* pmc */
-#if NPLUSK
+# if NPLUSK
namePmSub = linkName("primPmSub");
-#endif
+# endif
/* translator */
nameEqChar = linkName("primEqChar");
nameCreateAdjThunk = linkName("primCreateAdjThunk");
namePmFromInteger = linkName("primPmFromInteger");
namePmSubtract = linkName("primPmSubtract");
namePmLe = linkName("primPmLe");
+
+ implementCfun ( nameCons, NIL );
+ implementCfun ( nameNil, NIL );
+ implementCfun ( nameUnit, NIL );
}
}
+/* --------------------------------------------------------------------------
+ *
+ * ------------------------------------------------------------------------*/
+
/* ToDo: fix pFun (or eliminate its use) */
#define pFun(n,s) n = predefinePrim(s)
case MARK :
break;
- case INSTALL : linkControl(RESET);
-
- modulePrelude = newModule(textPrelude);
- setCurrModule(modulePrelude);
-
- for(i=0; i<NUM_TUPLES; ++i) {
- allocTupleTycon(i);
- }
-
- typeArrow = addPrimTycon(findText("(->)"),
- pair(STAR,pair(STAR,STAR)),
- 2,DATATYPE,NIL);
-
- /* newtype and USE_NEWTYPE_FOR_DICTS */
- pFun(nameId, "id");
-
- /* desugaring */
- pFun(nameInd, "_indirect");
- name(nameInd).number = DFUNNAME;
-
- /* pmc */
- pFun(nameSel, "_SEL");
-
- /* strict constructors */
- pFun(nameFlip, "flip" );
-
- /* parser */
- pFun(nameFromTo, "enumFromTo");
- pFun(nameFromThenTo, "enumFromThenTo");
- pFun(nameFrom, "enumFrom");
- pFun(nameFromThen, "enumFromThen");
-
- /* deriving */
- pFun(nameApp, "++");
- pFun(nameReadField, "readField");
- pFun(nameReadParen, "readParen");
- pFun(nameShowField, "showField");
- pFun(nameShowParen, "showParen");
- pFun(nameLex, "lex");
- pFun(nameComp, ".");
- pFun(nameAnd, "&&");
- pFun(nameCompAux, "primCompAux");
- pFun(nameMap, "map");
-
- /* implementTagToCon */
- pFun(namePMFail, "primPmFail");
- pFun(nameError, "error");
- pFun(nameUnpackString, "primUnpackString");
-
- /* hooks for handwritten bytecode */
- pFun(namePrimSeq, "primSeq");
- pFun(namePrimCatch, "primCatch");
- pFun(namePrimRaise, "primRaise");
- pFun(namePrimTakeMVar, "primTakeMVar");
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Name n = namePrimSeq;
- name(n).line = 0;
- name(n).arity = 1;
- name(n).type = NIL;
- vv = mkStgVar(NIL,NIL);
- stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- namePrimSeq = n;
- }
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Name n = namePrimCatch;
- name(n).line = 0;
- name(n).arity = 2;
- name(n).type = NIL;
- stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Name n = namePrimRaise;
- name(n).line = 0;
- name(n).arity = 1;
- name(n).type = NIL;
- stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Name n = namePrimTakeMVar;
- name(n).line = 0;
- name(n).arity = 2;
- name(n).type = NIL;
- stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
- break;
+ case POSTPREL:
+ fprintf(stderr, "linkControl(POSTPREL)\n");
+if (combined) assert(0);
+break;
+
+ case PREPREL :
+
+ modulePrelude = newModule(textPrelude);
+ setCurrModule(modulePrelude);
+
+ for (i=0; i<NUM_TUPLES; ++i) {
+ allocTupleTycon(i);
+ }
+
+ if (combined) {
+ } else {
+
+ typeArrow = addPrimTycon(findText("(->)"),
+ pair(STAR,pair(STAR,STAR)),
+ 2,DATATYPE,NIL);
+
+ /* newtype and USE_NEWTYPE_FOR_DICTS */
+ pFun(nameId, "id");
+
+ /* desugaring */
+ pFun(nameInd, "_indirect");
+ name(nameInd).number = DFUNNAME;
+
+ /* pmc */
+ pFun(nameSel, "_SEL");
+
+ /* strict constructors */
+ pFun(nameFlip, "flip" );
+
+ /* parser */
+ pFun(nameFromTo, "enumFromTo");
+ pFun(nameFromThenTo, "enumFromThenTo");
+ pFun(nameFrom, "enumFrom");
+ pFun(nameFromThen, "enumFromThen");
+
+ /* deriving */
+ pFun(nameApp, "++");
+ pFun(nameReadField, "readField");
+ pFun(nameReadParen, "readParen");
+ pFun(nameShowField, "showField");
+ pFun(nameShowParen, "showParen");
+ pFun(nameLex, "lex");
+ pFun(nameComp, ".");
+ pFun(nameAnd, "&&");
+ pFun(nameCompAux, "primCompAux");
+ pFun(nameMap, "map");
+
+ /* implementTagToCon */
+ pFun(namePMFail, "primPmFail");
+ pFun(nameError, "error");
+ pFun(nameUnpackString, "primUnpackString");
+
+ /* hooks for handwritten bytecode */
+ pFun(namePrimSeq, "primSeq");
+ pFun(namePrimCatch, "primCatch");
+ pFun(namePrimRaise, "primRaise");
+ pFun(namePrimTakeMVar, "primTakeMVar");
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimSeq;
+ name(n).line = 0;
+ name(n).arity = 1;
+ name(n).type = NIL;
+ vv = mkStgVar(NIL,NIL);
+ stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ namePrimSeq = n;
+ }
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimCatch;
+ name(n).line = 0;
+ name(n).arity = 2;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimRaise;
+ name(n).line = 0;
+ name(n).arity = 1;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimTakeMVar;
+ name(n).line = 0;
+ name(n).arity = 2;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_takeMVar() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+ }
+ break;
}
}
#undef pFun
* included in the distribution.
*
* $RCSfile: machdep.c,v $
- * $Revision: 1.16 $
- * $Date: 1999/12/03 14:38:39 $
+ * $Revision: 1.17 $
+ * $Date: 1999/12/10 15:59:48 $
* ------------------------------------------------------------------------*/
#ifdef HAVE_SIGNAL_H
Int what; { /* initialisation etc.. */
switch (what) {
case MARK : break;
- case INSTALL : installHandlers();
+ case POSTPREL: break;
+ case PREPREL : installHandlers();
break;
case RESET :
case BREAK :
* included in the distribution.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.17 $
- * $Date: 1999/12/03 17:01:22 $
+ * $Revision: 1.18 $
+ * $Date: 1999/12/10 15:59:49 $
* ------------------------------------------------------------------------*/
%{
*/
/*- Top-level interface files -----------------------------*/
-iface : INTERFACE ifName NUMLIT orphans checkVersion WHERE ifDecls
- {$$ = gc7(NIL); }
+iface : INTERFACE ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
+ {$$ = gc7(ap(I_INTERFACE,
+ zpair($2,$7))); }
| INTERFACE error {syntaxError("interface file");}
;
-ifDecls: {$$=gc0(NIL);}
- | ifDecl ';' ifDecls {$$=gc3(cons($1,$3));}
- ;
-varid_or_conid
- : VARID { $$=gc1($1); }
- | CONID { $$=gc1($1); }
- ;
-ifName : CONID {openGHCIface(textOf($1));
- $$ = gc1(NIL);}
-checkVersion
- : NUMLIT {$$ = gc1(NIL); }
+ifTopDecls: {$$=gc0(NIL);}
+ | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
;
-ifDecl
- : IMPORT CONID NUMLIT orphans opt_COCO version_list_junk
- { addGHCImports(intOf($3),textOf($2),
- $6);
- $$ = gc6(NIL);
- }
- | INSTIMPORT CONID {$$=gc2(NIL);}
+ifTopDecl
+ : IMPORT CONID NUMLIT ifOrphans ifOptCOCO ifVersionList
+ {$$=gc6(ap(I_IMPORT,zpair($2,$6))); }
+
+ | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
- | UUEXPORT CONID ifEntities { addGHCExports($2,$3);
- $$=gc3(NIL);}
+ | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
- | NUMLIT INFIXL optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- LEFT_ASS,$3)); }
- | NUMLIT INFIXR optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- RIGHT_ASS,$3)); }
- | NUMLIT INFIXN optDigit varid_or_conid
- {$$ = gc4(fixdecl($2,singleton($4),
- NON_ASS,$3)); }
+ | NUMLIT INFIXL optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(LEFT_ASS),$4)));}
+ | NUMLIT INFIXR optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(RIGHT_ASS),$4)));}
+ | NUMLIT INFIXN optDigit ifVarCon
+ {$$=gc4(ap(I_FIXDECL,
+ ztriple($3,mkInt(NON_ASS),$4)));}
| TINSTANCE ifCtxInst ifInstHdL '=' ifVar
- { addGHCInstance(intOf($1),$2,$3,
- textOf($5));
- $$ = gc5(NIL); }
+ {$$=gc5(ap(I_INSTANCE,
+ z4ble($1,$2,$3,$5)));}
+
| NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
- { addGHCSynonym(intOf($2),$3,$4,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_TYPE,
+ z4ble($2,$3,$4,$6)));}
| NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
- { addGHCDataDecl(intOf($2),
- $3,$4,$5,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_DATA,
+ z5ble($2,$3,$4,$5,$6)));}
| NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
- { addGHCNewType(intOf($2),
- $3,$4,$5,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_NEWTYPE,
+ z5ble($2,$3,$4,$5,$6)));}
+
| NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
- { addGHCClass(intOf($2),$3,$4,$5,$6);
- $$ = gc6(NIL); }
+ {$$=gc6(ap(I_CLASS,
+ z5ble($2,$3,$4,
+ singleton($5),$6)));}
+
| NUMLIT ifVar COCO ifType
- { addGHCVar(intOf($3),textOf($2),$4);
- $$ = gc4(NIL); }
+ {$$=gc4(ap(I_VALUE,
+ ztriple($3,$2,$4)));}
+
| error { syntaxError(
"interface declaration"); }
;
/*- Top-level misc interface stuff ------------------------*/
-orphans : '!' {$$=gc1(NIL);}
+ifOrphans : '!' {$$=gc1(NIL);}
| {$$=gc0(NIL);}
;
-opt_COCO : COCO {$$=gc1(NIL);}
+ifOptCOCO : COCO {$$=gc1(NIL);}
| {$$=gc0(NIL);}
;
+ifCheckVersion
+ : NUMLIT {$$ = gc1(NIL); }
+ ;
;
ifCon : CONID {$$ = gc1($1);}
;
+
+ifVarCon : VARID {$$ = gc1($1);}
+ | CONID {$$ = gc1($1);}
+ ;
+
ifQCon : CONID {$$ = gc1($1);}
| QCONID {$$ = gc1($1);}
;
| {$$=gc0(NIL);}
;
ifInstHd /* { Class aType } :: (ConId, Type) */
- : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,pair($2,singleton($3))));}
+ : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
+ zpair($2,singleton($3))));}
;
-ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: [(ConId, Type)] */
- /* Note: not constructing the list with fn($1,$3) */
+ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
: ifInstHd ARROW ifInstHdL {$$=gc3(fn($1,$3));}
| ifInstHd {$$=gc1(NIL);}
;
-
ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
- : { $$ = gc0(NIL); }
- | '{' ifCtxDeclL '}' IMPLIES { $$ = gc4($2); }
+ : ifCtxDeclT IMPLIES { $$ = gc2($1); }
+ | { $$ = gc0(NIL); }
;
ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
: { $$ = gc0(NIL); }
| '{' ifCtxDeclL '}' { $$ = gc3($2); }
;
+
ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
: ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));}
| ifCtxDeclLE {$$=gc1(cons($1,NIL));}
| {$$=gc0(NIL);}
;
ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
- : ifQCon ifTyvar {$$=gc2(pair($1,$2));}
+ : ifQCon ifTyvar {$$=gc2(zpair($1,$2));}
;
/*- Interface data declarations - constructor lists -------*/
-/* The (Type,Text,Int) are (field type, name (or NIL), strictness).
+/* The (Type,VarId,Int) are (field type, name (or NIL), strictness).
Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
indicates a strict field (!type) as in standard H98, and
mkInt(2) indicates unpacked -- a GHC extension.
*/
-ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,Text,Int)],NIL)] */
+ifConstrs /* = Con1 | ... | ConN :: [(ConId,[(Type,VarId,Int)])] */
: {$$ = gc0(NIL);}
| '=' ifConstrL {$$ = gc2($2);}
;
-ifConstrL /* [(ConId,[(Type,Text,Int)],NIL)] */
+ifConstrL /* [(ConId,[(Type,VarId,Int)])] */
: ifConstr {$$ = gc1(singleton($1));}
| ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
;
-ifConstr /* (ConId,[(Type,Text,Int)],NIL) */
- : ifConData ifDataAnonFieldL {$$ = gc2(triple($1,$2,NIL));}
+ifConstr /* (ConId,[(Type,VarId,Int)]) */
+ : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
| ifConData '{' ifDataNamedFieldL '}'
- {$$ = gc4(triple($1,$3,NIL));}
+ {$$ = gc4(zpair($1,$3));}
;
-ifDataAnonFieldL /* [(Type,Text,Int)] */
+ifDataAnonFieldL /* [(Type,VarId,Int)] */
: {$$=gc0(NIL);}
| ifDataAnonField ifDataAnonFieldL
{$$=gc2(cons($1,$2));}
;
-ifDataNamedFieldL /* [(Type,Text,Int)] */
+ifDataNamedFieldL /* [(Type,VarId,Int)] */
: {$$=gc0(NIL);}
| ifDataNamedField {$$=gc1(cons($1,NIL));}
| ifDataNamedField ',' ifDataNamedFieldL
{$$=gc3(cons($1,$3));}
;
-ifDataAnonField /* (Type,Text,Int) */
- : ifAType {$$=gc1(triple($1,NIL,mkInt(0)));}
- | '!' ifAType {$$=gc2(triple($2,NIL,mkInt(1)));}
- | '!' '!' ifAType {$$=gc3(triple($3,NIL,mkInt(2)));}
+ifDataAnonField /* (Type,VarId,Int) */
+ : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
+ | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
+ | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
;
-ifDataNamedField /* (Type,Text,Int) */
- : VARID COCO ifAType {$$=gc3(triple($3,$1,mkInt(0)));}
- | VARID COCO '!' ifAType {$$=gc4(triple($4,$1,mkInt(1)));}
- | VARID COCO '!' '!' ifAType {$$=gc5(triple($5,$1,mkInt(2)));}
+ifDataNamedField /* (Type,VarId,Int) */
+ : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
+ | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
+ | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
;
| ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
;
ifCmeth /* (VarId,Type) */
- : ifVar COCO ifType { $$ = gc3(pair($1,$3)); }
- | ifVar '=' COCO ifType { $$ = gc4(pair($1,$4)); }
+ : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
+ | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
/* has default method */
;
/*- Interface newtype declararions ------------------------*/
ifNewTypeConstr /* (ConId,Type) */
- : '=' ifCon ifAType { $$ = gc3(pair($2,$3)); }
+ : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
;
| ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
;
ifKindedTyvar /* (VarId,Kind) */
- : ifTyvar { $$ = gc1(pair($1,STAR)); }
- | ifTyvar COCO ifAKind { $$ = gc3(pair($1,$3)); }
+ : ifTyvar { $$ = gc1(zpair($1,STAR)); }
+ | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); }
;
ifKind : ifAKind { $$ = gc1($1); }
| ifAKind ARROW ifKind { $$ = gc3(fn($1,$3)); }
;
ifEntity
: ifEntityOcc {$$=gc1($1);}
- | ifEntityOcc ifStuffInside {$$=gc2(pair($1,$2));}
+ | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));}
;
ifEntityOcc
: ifVar { $$ = gc1($1); }
| ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
| ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
;
-version_list_junk
- : {$$=gc0(NIL);}
- | VARID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
- | CONID NUMLIT version_list_junk {$$=gc3(cons($1,$3));}
+
+ifVersionList
+ : {$$=gc0(NIL);}
+ | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
+ | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
;
/*- Haskell module header/import parsing: -----------------------------------
-
* Syntax for Haskell modules (module headers and imports) is parsed but
* most of it is ignored. However, module names in import declarations
* are used, of course, if import chasing is turned on.
* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.19 $
- * $Date: 1999/12/03 12:39:44 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/10 15:59:50 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
}
mapProc(checkImportList, unqualImports);
- 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(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);
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 */
#endif
break;
- case INSTALL : staticAnalysis(RESET);
+ case POSTPREL: break;
+
+ case PREPREL : staticAnalysis(RESET);
#if TREX
extKind = pair(STAR,pair(ROW,ROW));
#endif
- break;
}
}
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.24 $
- * $Date: 1999/12/07 11:14:57 $
+ * $Revision: 1.25 $
+ * $Date: 1999/12/10 15:59:53 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
return ts;
}
-Text ghcTupleText(tup)
-Tycon tup; {
+Text ghcTupleText_n ( Int n )
+{
Int i;
char buf[103];
- assert(isTuple(tup));
- tup = tupleOf(tup);
- if (tup >= 100) internal("ghcTupleText");
+ if (n < 0 || n >= 100) internal("ghcTupleText_n");
buf[0] = '(';
- for (i = 1; i <= tup; i++) buf[i] = ',';
+ for (i = 1; i <= n; i++) buf[i] = ',';
buf[i] = ')';
buf[i+1] = 0;
return findText(buf);
}
+Text ghcTupleText(tup)
+Tycon tup; {
+ assert(isTuple(tup));
+ return ghcTupleText_n ( tupleOf(tup) );
+}
+
+
Tycon mkTuple ( Int n )
{
Int i;
Void allocTupleTycon ( Int n )
{
Int i;
- char buf[20];
Kind k;
Tycon t;
for (i = TYCMIN; i < tyconHw; i++)
if (tycon(i).tuple == n) return;
- sprintf(buf,"Tuple%d",n);
+
//t = addPrimTycon(findText(buf),simpleKind(n),n, DATATYPE,NIL);
k = STAR;
for (i = 0; i < n; i++) k = ap(STAR,k);
- t = newTycon(findText(buf));
+ t = newTycon(ghcTupleText_n(n));
tycon(t).kind = k;
tycon(t).tuple = n;
tycon(t).what = DATATYPE;
|| typeInvolves(arg(ty),tc)));
}
+Inst findSimpleInstance ( ConId klass, ConId dataty )
+{
+ Inst in;
+ for (in = INSTMIN; in < instHw; in++) {
+ Cell head = inst(in).head;
+ if (isClass(fun(head))
+ && cclass(fun(head)).text==textOf(klass)
+ && typeInvolves(arg(head), findTycon(textOf(dataty)) )
+ )
+ return in;
+ }
+ return NIL;
+}
+
/* --------------------------------------------------------------------------
* Control stack:
*
Printf("Offset %d", offsetOf(c));
break;
case TUPLE:
- Printf("Tuple %d", tupleOf(c));
+ Printf("%s", textToStr(ghcTupleText(tupleOf(c))));
break;
case POLYTYPE:
Printf("Polytype");
print(snd(c),depth-1);
Putchar(')');
break;
+ case ZTUP2:
+ Printf("<ZPair ");
+ print(snd(c),depth-1);
+ Putchar('>');
case BANG:
Printf("(BANG,");
print(snd(c),depth-1);
return outs;
}
+
+/* --------------------------------------------------------------------------
+ * Strongly-typed lists (z-lists) and tuples (experimental)
+ * ------------------------------------------------------------------------*/
+
+static void z_tag_check ( Cell x, int tag, char* caller )
+{
+ char buf[100];
+ if (isNull(x)) {
+ sprintf(buf,"z_tag_check(%s): null\n", caller);
+ internal(buf);
+ }
+ if (whatIs(x) != tag) {
+ sprintf(buf,
+ "z_tag_check(%s): tag was %d, expected %d\n",
+ caller, whatIs(x), tag );
+ internal(buf);
+ }
+}
+
+#if 0
+Cell zcons ( Cell x, Cell xs )
+{
+ if (!(isNull(xs) || whatIs(xs)==ZCONS))
+ internal("zcons: ill typed tail");
+ return ap(ZCONS,ap(x,xs));
+}
+
+Cell zhd ( Cell xs )
+{
+ if (isNull(xs)) internal("zhd: empty list");
+ z_tag_check(xs,ZCONS,"zhd");
+ return fst( snd(xs) );
+}
+
+Cell ztl ( Cell xs )
+{
+ if (isNull(xs)) internal("ztl: empty list");
+ z_tag_check(xs,ZCONS,"zhd");
+ return snd( snd(xs) );
+}
+
+Int zlength ( ZList xs )
+{
+ Int n = 0;
+ while (nonNull(xs)) {
+ z_tag_check(xs,ZCONS,"zlength");
+ n++;
+ xs = snd( snd(xs) );
+ }
+ return n;
+}
+
+ZList zreverse ( ZList xs )
+{
+ ZList rev = NIL;
+ while (nonNull(xs)) {
+ z_tag_check(xs,ZCONS,"zreverse");
+ rev = zcons(zhd(xs),rev);
+ xs = ztl(xs);
+ }
+ return rev;
+}
+
+Cell zsingleton ( Cell x )
+{
+ return zcons (x,NIL);
+}
+
+Cell zdoubleton ( Cell x, Cell y )
+{
+ return zcons(x,zcons(y,NIL));
+}
+#endif
+
+Cell zpair ( Cell x1, Cell x2 )
+{ return ap(ZTUP2,ap(x1,x2)); }
+Cell zfst ( Cell zpair )
+{ z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
+Cell zsnd ( Cell zpair )
+{ z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
+
+Cell ztriple ( Cell x1, Cell x2, Cell x3 )
+{ return ap(ZTUP3,ap(x1,ap(x2,x3))); }
+Cell zfst3 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
+Cell zsnd3 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
+Cell zthd3 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
+
+Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
+{ return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
+Cell zsel14 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
+Cell zsel24 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
+Cell zsel34 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
+Cell zsel44 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
+
+Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
+{ return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
+Cell zsel15 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
+Cell zsel25 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
+Cell zsel35 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
+Cell zsel45 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
+Cell zsel55 ( Cell zpair )
+{ z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
+
+
+Cell unap ( int tag, Cell c )
+{
+ char buf[100];
+ if (whatIs(c) != tag) {
+ sprintf(buf, "unap: specified %d, actual %d\n",
+ tag, whatIs(c) );
+ internal(buf);
+ }
+ return snd(c);
+}
+
/* --------------------------------------------------------------------------
* Operations on applications:
* ------------------------------------------------------------------------*/
Int i;
switch (what) {
+ case POSTPREL: break;
+
case RESET : clearStack();
/* the next 2 statements are particularly important
break;
- case INSTALL : heapFst = heapAlloc(heapSize);
+ case PREPREL : heapFst = heapAlloc(heapSize);
heapSnd = heapAlloc(heapSize);
if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
* included in the distribution.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.19 $
- * $Date: 1999/12/07 11:14:58 $
+ * $Revision: 1.20 $
+ * $Date: 1999/12/10 15:59:54 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
typedef Cell Ext; /* extension label */
#endif
+typedef Cell ConId;
+typedef Cell VarId;
+
/* --------------------------------------------------------------------------
* Text storage:
* provides storage for the characters making up identifier and symbol
#define PTRCELL 82 /* C Heap Pointer snd :: (Int,Int) */
#endif
+/* STG syntax */
#define STGVAR 92 /* STGVAR snd :: (StgRhs,info) */
#define STGAPP 93 /* STGAPP snd :: (StgVar,[Arg]) */
#define STGPRIM 94 /* STGPRIM snd :: (PrimOp,[Arg]) */
#define DEEFALT 97 /* DEEFALT snd :: (Var,Expr) */
#define CASEALT 98 /* CASEALT snd :: (Con,[Var],Expr) */
#define PRIMALT 99 /* PRIMALT snd :: ([Var],Expr) */
+
+
+/*
+ Top-level interface entities
+ type Line = Int -- a line number
+ type ConVarId = CONIDCELL | VARIDCELL
+ type <a> = ZList a
+ type ExportListEntry = ConVarId | (ConId, <ConVarId>)
+ type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
+ type Constr = (ConId, <(Type,VarId,Int)>)
+ (constr name, list of (type, field name if any, strictness))
+ strictness: 0 => none, 1 => !, 2 => !! (unpacked)
+ All 2/3/4/5 tuples in the interface abstract syntax are done with
+ z-tuples.
+*/
+
+#define I_INTERFACE 109 /* snd :: (ConId, <I_IMPORT..I_VALUE>)
+ interface name, list of iface entities */
+
+#define I_IMPORT 110 /* snd :: (ConId, <ConVarId>)
+ module name, list of entities */
+
+#define I_INSTIMPORT 111 /* snd :: NIL -- not used at present */
+
+#define I_EXPORT 112 /* snd :: (ConId, <ExportListEntry>
+ this module name?, entities to export */
+
+#define I_FIXDECL 113 /* snd :: (NIL|Int, Associativity, ConVarId)
+ fixity, associativity, name */
+
+#define I_INSTANCE 114 /* snd :: (Line, <(QConId,VarId)>, Type, VarId)
+ lineno,
+ forall-y bit (eg __forall [a b] {M.C1 a, M.C2 b} =>),
+ other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
+ name of dictionary builder */
+
+#define I_TYPE 115 /* snd :: (Line, ConId, <(VarId,Kind)>, Type)
+ lineno, tycon, kinded tyvars, the type expr */
+
+#define I_DATA 116 /* snd :: (Line, <(QConId,VarId)>, ConId,
+ <(VarId,Kind)>, <Constr>)
+ lineno, context, tycon, kinded tyvars, constrs */
+
+#define I_NEWTYPE 117 /* snd :: (Line, <(QConId,VarId)>, ConId,
+ <(VarId,Kind)>, (ConId,Type))
+ lineno, context, tycon, kinded tyvars, constr */
+
+#define I_CLASS 118 /* snd :: (Line, <(QConId,VarId)>, ConId,
+ <(VarId,Kind)>, <(VarId,Type)>)
+ lineno, context, classname,
+ kinded tyvars, method sigs */
+
+#define I_VALUE 119 /* snd :: (Line, VarId, Type) */
+
+
+
+/* Generic syntax */
+#if 0
+#define ZCONS 190 /* snd :: (Cell,Cell) */
+#endif
+
+
+#define ZTUP2 192 /* snd :: (Cell,Cell) */
+#define ZTUP3 193 /* snd :: (Cell,(Cell,Cell)) */
+#define ZTUP4 194 /* snd :: (Cell,(Cell,(Cell,Cell))) */
+#define ZTUP5 195 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
+
/* Last constructor tag must be less than SPECMIN */
/* --------------------------------------------------------------------------
* Special cell values:
* ------------------------------------------------------------------------*/
-#define SPECMIN 101
+#define SPECMIN 201
#if TREX
#define isSpec(c) (SPECMIN<=(c) && (c)<EXTMIN)/* Special cell values */
#define isSpec(c) (SPECMIN<=(c) && (c)<OFFMIN)
#endif
-#define NONE 101 /* Dummy stub */
-#define STAR 102 /* Representing the kind of types */
+#define NONE 201 /* Dummy stub */
+#define STAR 202 /* Representing the kind of types */
#if TREX
-#define ROW 103 /* Representing the kind of rows */
+#define ROW 203 /* Representing the kind of rows */
#endif
-#define WILDCARD 104 /* Wildcard pattern */
-#define SKOLEM 105 /* Skolem constant */
-
-#define DOTDOT 106 /* ".." in import/export list */
-
-#define NAME 110 /* whatIs code for isName */
-#define TYCON 111 /* whatIs code for isTycon */
-#define CLASS 112 /* whatIs code for isClass */
-#define MODULE 113 /* whatIs code for isModule */
-#define INSTANCE 114 /* whatIs code for isInst */
-#define TUPLE 115 /* whatIs code for tuple constructor */
-#define OFFSET 116 /* whatis code for offset */
-#define AP 117 /* whatIs code for application node */
-#define CHARCELL 118 /* whatIs code for isChar */
+#define WILDCARD 204 /* Wildcard pattern */
+#define SKOLEM 205 /* Skolem constant */
+
+#define DOTDOT 206 /* ".." in import/export list */
+
+#define NAME 210 /* whatIs code for isName */
+#define TYCON 211 /* whatIs code for isTycon */
+#define CLASS 212 /* whatIs code for isClass */
+#define MODULE 213 /* whatIs code for isModule */
+#define INSTANCE 214 /* whatIs code for isInst */
+#define TUPLE 215 /* whatIs code for tuple constructor */
+#define OFFSET 216 /* whatis code for offset */
+#define AP 217 /* whatIs code for application node */
+#define CHARCELL 218 /* whatIs code for isChar */
#if TREX
-#define EXT 119 /* whatIs code for isExt */
+#define EXT 219 /* whatIs code for isExt */
#endif
-#define SIGDECL 120 /* Signature declaration */
-#define FIXDECL 121 /* Fixity declaration */
-#define FUNBIND 122 /* Function binding */
-#define PATBIND 123 /* Pattern binding */
+#define SIGDECL 220 /* Signature declaration */
+#define FIXDECL 221 /* Fixity declaration */
+#define FUNBIND 222 /* Function binding */
+#define PATBIND 223 /* Pattern binding */
-#define DATATYPE 130 /* Datatype type constructor */
-#define NEWTYPE 131 /* Newtype type constructor */
-#define SYNONYM 132 /* Synonym type constructor */
-#define RESTRICTSYN 133 /* Synonym with restricted scope */
+#define DATATYPE 230 /* Datatype type constructor */
+#define NEWTYPE 231 /* Newtype type constructor */
+#define SYNONYM 232 /* Synonym type constructor */
+#define RESTRICTSYN 233 /* Synonym with restricted scope */
-#define NODEPENDS 135 /* Stop calculation of deps in type check*/
-#define PREDEFINED 136 /* Predefined name, not yet filled */
+#define NODEPENDS 235 /* Stop calculation of deps in type check*/
+#define PREDEFINED 236 /* Predefined name, not yet filled */
/* --------------------------------------------------------------------------
* Tuple data/type constructors:
* ------------------------------------------------------------------------*/
-extern Text ghcTupleText Args((Tycon));
+extern Text ghcTupleText Args((Tycon));
+extern Text ghcTupleText_n Args((Int));
#if TREX
-#define EXTMIN 201
+#define EXTMIN 301
#define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
#define extText(e) tabExt[(e)-EXTMIN]
#define extField(c) arg(fun(c))
#if TREX
#define OFFMIN (EXTMIN+NUM_EXT)
#else
-#define OFFMIN 201
+#define OFFMIN 301
#endif
#define isOffset(c) (OFFMIN<=(c) && (c)<MODMIN)
#define offsetOf(c) ((c)-OFFMIN)
extern Inst newInst Args((Void));
extern Inst findFirstInst Args((Tycon));
extern Inst findNextInst Args((Tycon,Inst));
+extern Inst findSimpleInstance ( ConId klass, ConId dataty );
/* --------------------------------------------------------------------------
* Character values:
#define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
#define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
+
+/* --------------------------------------------------------------------------
+ * Strongly-typed lists (z-lists) and tuples (experimental)
+ * ------------------------------------------------------------------------*/
+
+typedef Cell ZPair;
+typedef Cell ZTriple;
+typedef Cell Z4Ble;
+typedef Cell Z5Ble;
+
+#if 0
+typedef Cell ZList;
+extern Cell zcons ( Cell x, Cell xs );
+extern Cell zhd ( Cell xs );
+extern Cell ztl ( Cell xs );
+extern Cell zsingleton ( Cell x );
+extern Cell zdoubleton ( Cell x, Cell y );
+extern Int zlength ( ZList xs );
+extern ZList zreverse ( ZList xs );
+#endif
+
+extern Cell zpair ( Cell x1, Cell x2 );
+extern Cell zfst ( Cell zpair );
+extern Cell zsnd ( Cell zpair );
+
+extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
+extern Cell zfst3 ( Cell zpair );
+extern Cell zsnd3 ( Cell zpair );
+extern Cell zthd3 ( Cell zpair );
+
+extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
+extern Cell zsel14 ( Cell zpair );
+extern Cell zsel24 ( Cell zpair );
+extern Cell zsel34 ( Cell zpair );
+extern Cell zsel44 ( Cell zpair );
+
+extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
+extern Cell zsel15 ( Cell zpair );
+extern Cell zsel25 ( Cell zpair );
+extern Cell zsel35 ( Cell zpair );
+extern Cell zsel45 ( Cell zpair );
+extern Cell zsel55 ( Cell zpair );
+
+extern Cell unap ( int tag, Cell c );
+#define isZPair(c) (whatIs((c))==ZTUP2)
+
/* --------------------------------------------------------------------------
* Implementation of function application nodes:
* ------------------------------------------------------------------------*/
* included in the distribution.
*
* $RCSfile: subst.c,v $
- * $Revision: 1.9 $
- * $Date: 1999/11/23 15:12:07 $
+ * $Revision: 1.10 $
+ * $Date: 1999/12/10 15:59:55 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#endif
break;
- case INSTALL : substitution(RESET);
+ case POSTPREL: break;
+
+ case PREPREL : substitution(RESET);
for (i=0; i<MAXTUPCON; ++i)
tupleConTypes[i] = NIL;
for (i=0; i<MAXKINDFUN; ++i) {
* included in the distribution.
*
* $RCSfile: translate.c,v $
- * $Revision: 1.23 $
- * $Date: 1999/12/07 11:36:40 $
+ * $Revision: 1.24 $
+ * $Date: 1999/12/10 15:59:56 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Void translateControl(what)
Int what; {
switch (what) {
- case INSTALL:
- {
- /* deliberate fall through */
- }
- case RESET:
- stgGlobals=NIL;
- break;
- case MARK:
- mark(stgGlobals);
- break;
+ case POSTPREL: break;
+ case PREPREL:
+ case RESET:
+ stgGlobals=NIL;
+ break;
+ case MARK:
+ mark(stgGlobals);
+ break;
}
}
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.18 $
- * $Date: 1999/12/06 16:25:28 $
+ * $Revision: 1.19 $
+ * $Date: 1999/12/10 15:59:57 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
mark(typeProgIO);
break;
- case INSTALL : typeChecker(RESET);
- dummyVar = inventVar();
+ case POSTPREL: break;
- setCurrModule(modulePrelude);
+ case PREPREL :
+ typeChecker(RESET);
- starToStar = simpleKind(1);
+ if (combined) {
+ } else {
+ dummyVar = inventVar();
- typeUnit = addPrimTycon(findText("()"),
- STAR,0,DATATYPE,NIL);
- typeArrow = addPrimTycon(findText("(->)"),
- simpleKind(2),2,
- DATATYPE,NIL);
- typeList = addPrimTycon(findText("[]"),
- starToStar,1,
- DATATYPE,NIL);
+ setCurrModule(modulePrelude);
- arrow = fn(aVar,bVar);
- listof = ap(typeList,aVar);
- boundPair = ap(ap(mkTuple(2),aVar),aVar);
+ starToStar = simpleKind(1);
- nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
- tycon(typeUnit).defn
- = singleton(nameUnit);
+ typeUnit = addPrimTycon(findText("()"),
+ STAR,0,DATATYPE,NIL);
+ typeArrow = addPrimTycon(findText("(->)"),
+ simpleKind(2),2,
+ DATATYPE,NIL);
+ typeList = addPrimTycon(findText("[]"),
+ starToStar,1,
+ DATATYPE,NIL);
- nameNil = addPrimCfun(findText("[]"),0,1,
- mkPolyType(starToStar,
- listof));
- nameCons = addPrimCfun(findText(":"),2,2,
- mkPolyType(starToStar,
- fn(aVar,
- fn(listof,
- listof))));
- name(nameNil).parent =
- name(nameCons).parent = typeList;
+ arrow = fn(aVar,bVar);
+ listof = ap(typeList,aVar);
+ boundPair = ap(ap(mkTuple(2),aVar),aVar);
- name(nameCons).syntax
- = mkSyntax(RIGHT_ASS,5);
+ nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
+ tycon(typeUnit).defn
+ = singleton(nameUnit);
- tycon(typeList).defn
- = cons(nameNil,cons(nameCons,NIL));
+ nameNil = addPrimCfun(findText("[]"),0,1,
+ mkPolyType(starToStar,
+ listof));
+ nameCons = addPrimCfun(findText(":"),2,2,
+ mkPolyType(starToStar,
+ fn(aVar,
+ fn(listof,
+ listof))));
+ name(nameNil).parent =
+ name(nameCons).parent = typeList;
- typeVarToVar = fn(aVar,aVar);
+ name(nameCons).syntax
+ = mkSyntax(RIGHT_ASS,5);
+
+ tycon(typeList).defn
+ = cons(nameNil,cons(nameCons,NIL));
+
+ typeVarToVar = fn(aVar,aVar);
#if TREX
- typeNoRow = addPrimTycon(findText("EmptyRow"),
- ROW,0,DATATYPE,NIL);
- typeRec = addPrimTycon(findText("Rec"),
- pair(ROW,STAR),1,
- DATATYPE,NIL);
- nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
- ap(typeRec,typeNoRow));
+ typeNoRow = addPrimTycon(findText("EmptyRow"),
+ ROW,0,DATATYPE,NIL);
+ typeRec = addPrimTycon(findText("Rec"),
+ pair(ROW,STAR),1,
+ DATATYPE,NIL);
+ nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
+ ap(typeRec,typeNoRow));
#else
- /* bogus definitions to avoid changing the prelude */
- addPrimCfun(findText("Rec"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
+ /* bogus definitions to avoid changing the prelude */
+ addPrimCfun(findText("Rec"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
+ addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
#endif
- break;
+ }
+ break;
+
}
}
projects / ghc-hetmet.git / commitdiff