X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Finterpreter%2Fstorage.c;h=a302cb7bc659cfba0ce5619fcea3009eaca9187a;hb=9df21476c4963a6ec4de6401a6e7275ba632f4bd;hp=903296e1bb54010ea988ed547b031148698573fb;hpb=333e9b497dd063a37af367abd937d2f6454ae84c;p=ghc-hetmet.git diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index 903296e..a302cb7 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.17 $ - * $Date: 1999/11/17 16:57:46 $ + * $Revision: 1.34 $ + * $Date: 2000/01/10 16:23:33 $ * ------------------------------------------------------------------------*/ #include "prelude.h" @@ -18,6 +18,7 @@ #include "backend.h" #include "connect.h" #include "errors.h" +#include "object.h" #include /*#define DEBUG_SHOWUSE*/ @@ -230,6 +231,183 @@ Text t; { /* at top of text table */ } +static int fromHexDigit ( char c ) +{ + switch (c) { + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + return c - '0'; + case 'a': case 'A': return 10; + case 'b': case 'B': return 11; + case 'c': case 'C': return 12; + case 'd': case 'D': return 13; + case 'e': case 'E': return 14; + case 'f': case 'F': return 15; + default: return -1; + } +} + + +/* returns findText (unZencode s) */ +Text unZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn, i; + Text t; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("unZcodeThenFindText: malloc failed"); + n = 0; + + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("unZcodeThenFindText: result is too big"); + if (*s != 'z' && *s != 'Z') { + p[n] = *s; n++; s++; + continue; + } + s++; + if (!(*s)) goto parse_error; + switch (*s++) { + case 'Z': p[n++] = 'Z'; break; + case 'C': p[n++] = ':'; break; + case 'L': p[n++] = '('; break; + case 'R': p[n++] = ')'; break; + case 'M': p[n++] = '['; break; + case 'N': p[n++] = ']'; break; + case 'z': p[n++] = 'z'; break; + case 'a': p[n++] = '&'; break; + case 'b': p[n++] = '|'; break; + case 'd': p[n++] = '$'; break; + case 'e': p[n++] = '='; break; + case 'g': p[n++] = '>'; break; + case 'h': p[n++] = '#'; break; + case 'i': p[n++] = '.'; break; + case 'l': p[n++] = '<'; break; + case 'm': p[n++] = '-'; break; + case 'n': p[n++] = '!'; break; + case 'p': p[n++] = '+'; break; + case 'q': p[n++] = '\\'; break; + case 'r': p[n++] = '\''; break; + case 's': p[n++] = '/'; break; + case 't': p[n++] = '*'; break; + case 'u': p[n++] = '^'; break; + case 'v': p[n++] = '%'; break; + case 'x': + if (!s[0] || !s[1]) goto parse_error; + if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error; + p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]); + p += 2; s += 2; + break; + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + i = 0; + s--; + while (*s && isdigit((int)(*s))) { + i = 10 * i + (*s - '0'); + s++; + } + if (*s != 'T') goto parse_error; + s++; + p[n++] = '('; + while (i > 0) { p[n++] = ','; i--; }; + p[n++] = ')'; + break; + default: + goto parse_error; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; + + parse_error: + free(p); + fprintf ( stderr, "\nstring = `%s'\n", s ); + internal ( "unZcodeThenFindText: parse error on above string"); + return NIL; /*notreached*/ +} + + +Text enZcodeThenFindText ( String s ) +{ + unsigned char* p; + Int n, nn; + Text t; + char toHex[16] = "0123456789ABCDEF"; + + assert(s); + nn = 100 + 10 * strlen(s); + p = malloc ( nn ); + if (!p) internal ("enZcodeThenFindText: malloc failed"); + n = 0; + while (1) { + if (!(*s)) break; + if (n > nn-90) internal ("enZcodeThenFindText: result is too big"); + if (*s != 'z' + && *s != 'Z' + && (isalnum((int)(*s)) || *s == '_')) { + p[n] = *s; n++; s++; + continue; + } + switch (*s++) { + case '(': p[n++] = 'Z'; p[n++] = 'L'; break; + case ')': p[n++] = 'Z'; p[n++] = 'R'; break; + case '[': p[n++] = 'Z'; p[n++] = 'M'; break; + case ']': p[n++] = 'Z'; p[n++] = 'N'; break; + case ':': p[n++] = 'Z'; p[n++] = 'C'; break; + case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break; + case 'z': p[n++] = 'z'; p[n++] = 'z'; break; + case '&': p[n++] = 'z'; p[n++] = 'a'; break; + case '|': p[n++] = 'z'; p[n++] = 'b'; break; + case '$': p[n++] = 'z'; p[n++] = 'd'; break; + case '=': p[n++] = 'z'; p[n++] = 'e'; break; + case '>': p[n++] = 'z'; p[n++] = 'g'; break; + case '#': p[n++] = 'z'; p[n++] = 'h'; break; + case '.': p[n++] = 'z'; p[n++] = 'i'; break; + case '<': p[n++] = 'z'; p[n++] = 'l'; break; + case '-': p[n++] = 'z'; p[n++] = 'm'; break; + case '!': p[n++] = 'z'; p[n++] = 'n'; break; + case '+': p[n++] = 'z'; p[n++] = 'p'; break; + case '\'': p[n++] = 'z'; p[n++] = 'q'; break; + case '\\': p[n++] = 'z'; p[n++] = 'r'; break; + case '/': p[n++] = 'z'; p[n++] = 's'; break; + case '*': p[n++] = 'z'; p[n++] = 't'; break; + case '^': p[n++] = 'z'; p[n++] = 'u'; break; + case '%': p[n++] = 'z'; p[n++] = 'v'; break; + default: s--; p[n++] = 'z'; p[n++] = 'x'; + p[n++] = toHex[(int)(*s)/16]; + p[n++] = toHex[(int)(*s)%16]; + s++; break; + } + } + p[n] = 0; + t = findText(p); + free(p); + return t; +} + + +Text textOf ( Cell c ) +{ + Bool ok = + (whatIs(c)==VARIDCELL + || whatIs(c)==CONIDCELL + || whatIs(c)==VAROPCELL + || whatIs(c)==CONOPCELL + || whatIs(c)==STRCELL + || whatIs(c)==DICTVAR + ); + if (!ok) { + fprintf(stderr, "\ntextOf: bad tag %d\n",whatIs(c) ); + internal("textOf: bad tag"); + } + return snd(c); +} + /* -------------------------------------------------------------------------- * Ext storage: * @@ -289,7 +467,9 @@ Text t; { tycon(tyconHw).what = NIL; tycon(tyconHw).conToTag = NIL; tycon(tyconHw).tagToCon = NIL; + tycon(tyconHw).tuple = -1; tycon(tyconHw).mod = currentModule; + tycon(tyconHw).itbl = NULL; module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons); tycon(tyconHw).nextTyconHash = tyconHash[h]; tyconHash[h] = tyconHw; @@ -308,7 +488,9 @@ Text t; { Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */ Tycon tc; { - Tycon oldtc = findTycon(tycon(tc).text); + Tycon oldtc; + assert(whatIs(tc)==TYCON || whatIs(tc)==TUPLE); + oldtc = findTycon(tycon(tc).text); if (isNull(oldtc)) { hashTycon(tc); module(currentModule).tycons=cons(tc,module(currentModule).tycons); @@ -319,7 +501,10 @@ Tycon tc; { static Void local hashTycon(tc) /* Insert Tycon into hash table */ Tycon tc; { - assert(isTycon(tc)); + if (!(isTycon(tc) || isTuple(tc))) { + printf("\nbad stuff: " ); print(tc,10); printf("\n"); + assert(isTycon(tc) || isTuple(tc)); + } if (1) { Text t = tycon(tc).text; Int h = tHash(t); @@ -399,6 +584,38 @@ List ts; { /* Null pattern matches every tycon*/ return ts; } +Text ghcTupleText_n ( Int n ) +{ + Int i; + char buf[104]; + if (n < 0 || n >= 100) internal("ghcTupleText_n"); + buf[0] = '('; + for (i = 1; i <= n; i++) buf[i] = ','; + buf[n+1] = ')'; + buf[n+2] = 0; + return findText(buf); +} + +Text ghcTupleText(tup) +Tycon tup; { + if (!isTuple(tup)) { + assert(isTuple(tup)); + } + return ghcTupleText_n ( tupleOf(tup) ); +} + + +Tycon mkTuple ( Int n ) +{ + Int i; + if (n >= NUM_TUPLES) + internal("mkTuple: request for tuple of unsupported size"); + for (i = TYCMIN; i < tyconHw; i++) + if (tycon(i).tuple == n) return i; + internal("mkTuple: request for non-existent tuple"); +} + + /* -------------------------------------------------------------------------- * Name storage: * @@ -438,6 +655,7 @@ Cell parent; { name(nameHw).type = NIL; name(nameHw).primop = 0; name(nameHw).mod = currentModule; + name(nameHw).itbl = NULL; module(currentModule).names=cons(nameHw,module(currentModule).names); name(nameHw).nextNameHash = nameHash[h]; nameHash[h] = nameHw; @@ -455,7 +673,9 @@ Text t; { Name addName(nm) /* Insert Name in name table - if */ Name nm; { /* no clash is caused */ - Name oldnm = findName(name(nm).text); + Name oldnm; + assert(whatIs(nm)==NAME); + oldnm = findName(name(nm).text); if (isNull(oldnm)) { hashName(nm); module(currentModule).names=cons(nm,module(currentModule).names); @@ -544,6 +764,103 @@ void* getHugs_AsmObject_for ( char* s ) * Primitive functions: * ------------------------------------------------------------------------*/ +Module findFakeModule ( Text t ) +{ + Module m = findModule(t); + if (nonNull(m)) { + if (!module(m).fake) internal("findFakeModule"); + } else { + m = newModule(t); + module(m).fake = TRUE; + } + return m; +} + + +Name addWiredInBoxingTycon + ( String modNm, String typeNm, String constrNm, + Int arity, Int no, Int rep ) +{ + Name n; + Tycon t; + Text modT = findText(modNm); + Text typeT = findText(typeNm); + Text conT = findText(constrNm); + Module m = findFakeModule(modT); + setCurrModule(m); + + n = newName(conT,NIL); + name(n).arity = arity; + name(n).number = cfunNo(no); + name(n).type = NIL; + name(n).primop = (void*)rep; + + t = newTycon(typeT); + tycon(t).what = DATATYPE; + return n; +} + + +Tycon addTupleTycon ( Int n ) +{ + Int i; + Kind k; + Tycon t; + Module m; + Name nm; + + for (i = TYCMIN; i < tyconHw; i++) + if (tycon(i).tuple == n) return i; + + if (combined) + m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else + m = findModule(findText("Prelude")); + + setCurrModule(m); + k = STAR; + for (i = 0; i < n; i++) k = ap(STAR,k); + t = newTycon(ghcTupleText_n(n)); + tycon(t).kind = k; + tycon(t).tuple = n; + tycon(t).what = DATATYPE; + + if (n == 0) { + /* maybe we want to do this for all n ? */ + nm = newName(ghcTupleText_n(n), t); + name(nm).type = t; /* ummm ... for n > 0 */ + } + + return t; +} + + +Tycon addWiredInEnumTycon ( String modNm, String typeNm, + List /*of Text*/ constrs ) +{ + Int i; + Tycon t; + Text modT = findText(modNm); + Text typeT = findText(typeNm); + Module m = findFakeModule(modT); + setCurrModule(m); + + t = newTycon(typeT); + tycon(t).kind = STAR; + tycon(t).what = DATATYPE; + + constrs = reverse(constrs); + i = length(constrs); + for (; nonNull(constrs); constrs=tl(constrs),i--) { + Text conT = hd(constrs); + Name con = newName(conT,t); + name(con).number = cfunNo(i); + name(con).type = t; + tycon(t).defn = cons(con, tycon(t).defn); + } + return t; +} + + Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */ Text t; /* sets rep, not type */ Int arity; @@ -745,7 +1062,9 @@ Text t; { Class addClass(c) /* Insert Class in class list */ Class c; { /* - if no clash caused */ - Class oldc = findClass(cclass(c).text); + Class oldc; + assert(whatIs(c)==CLASS); + oldc = findClass(cclass(c).text); if (isNull(oldc)) { classes=cons(c,classes); module(currentModule).classes=cons(c,module(currentModule).classes); @@ -825,6 +1144,146 @@ Type tc; { || typeInvolves(arg(ty),tc))); } + +/* Needed by finishGHCInstance to find classes, before the + export list has been built -- so we can't use + findQualClass. +*/ +Class findQualClassWithoutConsultingExportList ( QualId q ) +{ + Class cl; + Text t_mod; + Text t_class; + + assert(isQCon(q)); + + if (isCon(q)) { + t_mod = NIL; + t_class = textOf(q); + } else { + t_mod = qmodOf(q); + t_class = qtextOf(q); + } + + for (cl = CLASSMIN; cl < classHw; cl++) { + if (cclass(cl).text == t_class) { + /* Class name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(cclass(cl).mod).text) + ) + return cl; + } + } + return NIL; +} + + +/* Same deal, except for Tycons. */ +Tycon findQualTyconWithoutConsultingExportList ( QualId q ) +{ + Tycon tc; + Text t_mod; + Text t_tycon; + + assert(isQCon(q)); + + if (isCon(q)) { + t_mod = NIL; + t_tycon = textOf(q); + } else { + t_mod = qmodOf(q); + t_tycon = qtextOf(q); + } + + for (tc = TYCMIN; tc < tyconHw; tc++) { + if (tycon(tc).text == t_tycon) { + /* Tycon name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(tycon(tc).mod).text) + ) + return tc; + } + } + return NIL; +} + +Tycon findTyconInAnyModule ( Text t ) +{ + Tycon tc; + for (tc = TYCMIN; tc < tyconHw; tc++) + if (tycon(tc).text == t) return tc; + return NIL; +} + +Class findClassInAnyModule ( Text t ) +{ + Class cc; + for (cc = CLASSMIN; cc < classHw; cc++) + if (cclass(cc).text == t) return cc; + return NIL; +} + +Name findNameInAnyModule ( Text t ) +{ + Name nm; + for (nm = NAMEMIN; nm < nameHw; nm++) + if (name(nm).text == t) return nm; + return NIL; +} + +/* Same deal, except for Names. */ +Name findQualNameWithoutConsultingExportList ( QualId q ) +{ + Name nm; + Text t_mod; + Text t_name; + + assert(isQVar(q) || isQCon(q)); + + if (isCon(q) || isVar(q)) { + t_mod = NIL; + t_name = textOf(q); + } else { + t_mod = qmodOf(q); + t_name = qtextOf(q); + } + + for (nm = NAMEMIN; nm < nameHw; nm++) { + if (name(nm).text == t_name) { + /* Name is ok, but is this the right module? */ + if (isNull(t_mod) /* no module name specified */ + || (nonNull(t_mod) + && t_mod == module(name(nm).mod).text) + ) + return nm; + } + } + return NIL; +} + + +/* returns List of QualId */ +List getAllKnownTyconsAndClasses ( void ) +{ + Tycon tc; + Class nw; + List xs = NIL; + for (tc = TYCMIN; tc < tyconHw; tc++) { + /* almost certainly undue paranoia about duplicate avoidance, but .. */ + QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } + for (nw = CLASSMIN; nw < classHw; nw++) { + QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text ); + if (!qualidIsMember(q,xs)) + xs = cons ( q, xs ); + } + return xs; +} + /* -------------------------------------------------------------------------- * Control stack: * @@ -910,19 +1369,16 @@ Text t; { ERRMSG(0) "Module storage space exhausted" EEND; } - module(moduleHw).text = t; /* clear new module record */ - module(moduleHw).qualImports = NIL; - module(moduleHw).exports = NIL; - module(moduleHw).tycons = NIL; - module(moduleHw).names = NIL; - module(moduleHw).classes = NIL; - module(moduleHw).oImage = NULL; - module(moduleHw).oTab = NULL; - module(moduleHw).sizeoTab = 0; - module(moduleHw).usedoTab = 0; - module(moduleHw).dlTab = NULL; - module(moduleHw).sizedlTab = 0; - module(moduleHw).useddlTab = 0; + module(moduleHw).text = t; /* clear new module record */ + module(moduleHw).qualImports = NIL; + module(moduleHw).fake = FALSE; + module(moduleHw).exports = NIL; + module(moduleHw).tycons = NIL; + module(moduleHw).names = NIL; + module(moduleHw).classes = NIL; + module(moduleHw).object = NULL; + module(moduleHw).objectExtras = NULL; + module(moduleHw).objectExtraNames = NIL; return moduleHw++; } @@ -965,7 +1421,6 @@ Cell c; { static local Module findQualifier(t) /* locate Module in import list */ Text t; { Module ms; -printf ( "findQualifier %s\n", textToStr(t)); for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) { if (textOf(fst(hd(ms)))==t) return snd(hd(ms)); @@ -1009,91 +1464,49 @@ Name jrsFindQualName ( Text mn, Text sn ) } -/* A bit tricky. Assumes that if tab==NULL, then - currUsed and *currSize must be zero. -*/ -static -void* genericExpand ( void* tab, - int* currSize, int currUsed, - int initSize, int elemSize ) +char* nameFromOPtr ( void* p ) { - int size2; - void* tab2; - if (currUsed < *currSize) - return tab; - size2 = (*currSize == 0) ? initSize : (2 * *currSize); - tab2 = malloc ( size2 * elemSize ); - if (!tab2) { - ERRMSG(0) "Can't allocate enough memory to resize a table" - EEND; + int i; + Module m; + for (m=MODMIN; m 0) - memcpy ( tab2, tab, elemSize * *currSize ); - *currSize = size2; - if (tab) free ( tab ); - return tab2; -} - -void addOTabName ( Module m, char* nm, void* ad ) -{ - module(m).oTab - = genericExpand ( module(m).oTab, - &module(m).sizeoTab, - module(m).usedoTab, - 8, sizeof(OSym) ); - - module(m).oTab[ module(m).usedoTab ].nm = nm; - module(m).oTab[ module(m).usedoTab ].ad = ad; - module(m).usedoTab++; -} - - -void addDLSect ( Module m, void* start, void* end, DLSect sect ) -{ - module(m).dlTab - = genericExpand ( module(m).dlTab, - &module(m).sizedlTab, - module(m).useddlTab, - 4, sizeof(DLTabEnt) ); - module(m).dlTab[ module(m).useddlTab ].start = start; - module(m).dlTab[ module(m).useddlTab ].end = end; - module(m).dlTab[ module(m).useddlTab ].sect = sect; - module(m).useddlTab++; + return NULL; } -void* lookupOTabName ( Module m, char* nm ) +void* lookupOTabName ( Module m, char* sym ) { - int i; - for (i = 0; i < module(m).usedoTab; i++) - if (0==strcmp(nm,module(m).oTab[i].nm)) - return module(m).oTab[i].ad; - return NULL; + return ocLookupSym ( module(m).object, sym ); } -char* nameFromOPtr ( void* p ) +void* lookupOExtraTabName ( char* sym ) { - int i; - Module m; - for (m=MODMIN; mnext) { + void* ad = ocLookupSym ( oc, sym ); + if (ad) return ad; + } + } return NULL; } -DLSect lookupDLSect ( void* ad ) +OSectionKind lookupSection ( void* ad ) { int i; Module m; - for (m=MODMIN; m=INTMIN) return INTCELL; if (c>=NAMEMIN){if (c>=CLASSMIN) {if (c>=CHARMIN) return CHARCELL; else return CLASS;} else if (c>=INSTMIN) return INSTANCE; else return NAME;} - else if (c>=MODMIN) {if (c>=TYCMIN) return TYCON; + else if (c>=MODMIN) {if (c>=TYCMIN) return isTuple(c) ? TUPLE : TYCON; else return MODULE;} else if (c>=OFFMIN) return OFFSET; #if TREX @@ -1721,7 +2137,7 @@ Int depth; { Printf("Offset %d", offsetOf(c)); break; case TUPLE: - Printf("Tuple %d", tupleOf(c)); + Printf("%s", textToStr(ghcTupleText(c))); break; case POLYTYPE: Printf("Polytype"); @@ -1843,6 +2259,37 @@ Int depth; { print(snd(snd(c)),depth-1); Putchar(')'); break; + case DICTAP: + Printf("(DICTAP,"); + print(snd(c),depth-1); + Putchar(')'); + break; + case UNBOXEDTUP: + Printf("(UNBOXEDTUP,"); + print(snd(c),depth-1); + Putchar(')'); + break; + case ZTUP2: + Printf("'); + break; + case ZTUP3: + Printf("'); + break; + case BANG: + Printf("(BANG,"); + print(snd(c),depth-1); + Putchar(')'); + break; default: if (isBoxTag(tag)) { Printf("Tag(%d)=%d", c, tag); @@ -1905,6 +2352,16 @@ Cell c; { return isPair(c) && (fst(c)==QUALIDENT); } +Bool eqQualIdent ( QualId c1, QualId c2 ) +{ + assert(isQualIdent(c1)); + if (!isQualIdent(c2)) { + assert(isQualIdent(c2)); + } + return qmodOf(c1)==qmodOf(c2) && + qtextOf(c1)==qtextOf(c2); +} + Bool isIdent(c) /* is cell an identifier? */ Cell c; { if (!isPair(c)) return FALSE; @@ -2082,6 +2539,15 @@ List xs, ys; { /* list xs onto list ys... */ return ys; } +QualId qualidIsMember ( QualId q, List xs ) +{ + for (; nonNull(xs); xs=tl(xs)) { + if (eqQualIdent(q, hd(xs))) + return hd(xs); + } + return NIL; +} + Cell varIsMember(t,xs) /* Test if variable is a member of */ Text t; /* given list of variables */ List xs; { @@ -2235,6 +2701,133 @@ List xs; { /* non destructive */ 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: * ------------------------------------------------------------------------*/ @@ -2393,6 +2986,8 @@ Int what; { Int i; switch (what) { + case POSTPREL: break; + case RESET : clearStack(); /* the next 2 statements are particularly important @@ -2426,6 +3021,7 @@ Int what; { mark(module(i).classes); mark(module(i).exports); mark(module(i).qualImports); + mark(module(i).objectExtraNames); } end("Modules", moduleHw-MODMIN); @@ -2480,7 +3076,7 @@ Int what; { break; - case INSTALL : heapFst = heapAlloc(heapSize); + case PREPREL : heapFst = heapAlloc(heapSize); heapSnd = heapAlloc(heapSize); if (heapFst==(Heap)0 || heapSnd==(Heap)0) {