* Hugs version 1.4, December 1997
*
* $RCSfile: interface.c,v $
- * $Revision: 1.15 $
- * $Date: 2000/01/05 13:53:36 $
+ * $Revision: 1.25 $
+ * $Date: 2000/01/11 14:56:07 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
}
-#if 0
-I hope this can be nuked.
-/* Kludge. Stuff imported from PrelGHC isn't referred to in a
- qualified way, so arrange it so it is.
-*/
-QualId magicRequalify ( ConId id )
-{
- Text tid;
- Text tmid;
- assert(isCon(id));
- tid = textOf(id);
-
- fprintf ( stderr, "$--$--$--$--$--$ magicRequalify: %s",
- textToStr(tid) );
-
- if (tid == findText("[]")) {
- tmid = findText("PrelList");
- } else
- if (tid == findText("Ratio")) {
- tmid = findText("PrelNum");
- } else
- if (tid == findText("Char")) {
- tmid = findText("PrelGHC");
- } else {
- fprintf(stderr, "??? \n");
- return id;
- }
-
- fprintf ( stderr, " -> %s.%s\n",
- textToStr(tmid), textToStr(tid) );
- return mkQualId ( mkCon(tmid), id );
-}
-#endif
-
-
/* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
/* mod is the current module being processed -- so we can qualify unqual'd
names. Strange calling convention for aktys and mod is so we can call this
/* ifaces_outstanding holds a list of parsed interfaces
for which we need to load objects and create symbol
table entries.
+
+ Return TRUE if Prelude `elem` ifaces_outstanding, else FALSE.
*/
-Void processInterfaces ( void )
+Bool processInterfaces ( void )
{
List tmp;
List xs;
Module mod;
List all_known_types;
Int num_known_types;
+ Bool didPrelude;
List ifaces = NIL; /* :: List I_INTERFACE */
List iface_sizes = NIL; /* :: List Int */
List iface_onames = NIL; /* :: List Text */
+ if (isNull(ifaces_outstanding)) return FALSE;
+
fprintf ( stderr,
"processInterfaces: %d interfaces to process\n",
length(ifaces_outstanding) );
-
/* unzip3 ifaces_outstanding into ifaces, iface_sizes, iface_onames */
for (xs = ifaces_outstanding; nonNull(xs); xs=tl(xs)) {
ifaces = cons ( zfst3(hd(xs)), ifaces );
be value defns, classes and instances which refer to unknown types.
Delete iteratively until a fixed point is reached.
*/
-printf("\n");
+ printf("\n");
num_known_types = 999999999;
while (TRUE) {
calling the finishGHC* functions. But don't process
the export lists; those must wait for later.
*/
+ didPrelude = FALSE;
for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
iface = unap(I_INTERFACE,hd(xs));
mname = textOf(zfst(iface));
setCurrModule(mod);
ppModule ( module(mod).text );
+ if (mname == textPrelude) didPrelude = TRUE;
+
for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
Cell decl = hd(decls);
switch(whatIs(decl)) {
}
}
}
-
fprintf(stderr, "\n+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
fprintf(stderr, "+++++++++++++++++++++++++++++++++++++++++++++++++++++++++\n");
+
/* 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
/* Finished! */
ifaces_outstanding = NIL;
+
+ return didPrelude;
}
if (isNull(c)) goto notfound;
fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
module(mod).exports = cons(c, module(mod).exports);
+ addName(c);
break;
case CONIDCELL: /* non data tycon */
c = findQualTyconWithoutConsultingExportList ( q );
if (isNull(c)) goto notfound;
fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
- module(mod).exports = cons(c, module(mod).exports);
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
break;
case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
original (defining) module.
*/
if (abstract) {
- module(mod).exports = cons ( ex, module(mod).exports );
+ module(mod).exports = cons(pair(c,NIL), module(mod).exports);
+ addTycon(c);
fprintf ( stderr, "(abstract) ");
} else {
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addTycon(c);
for (; nonNull(subents); subents = tl(subents)) {
Cell ent2 = hd(subents);
assert(isCon(ent2) || isVar(ent2));
c = findQualNameWithoutConsultingExportList ( q );
fprintf(stderr, "%s ", textToStr(name(c).text));
assert(nonNull(c));
- module(mod).exports = cons(c, module(mod).exports);
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
}
}
fprintf(stderr, "}\n" );
if (isNull(c)) goto notfound;
fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
+ addClass(c);
for (; nonNull(subents); subents = tl(subents)) {
Cell ent2 = hd(subents);
assert(isVar(ent2));
c = findQualNameWithoutConsultingExportList ( q );
fprintf(stderr, "%s ", textToStr(name(c).text));
if (isNull(c)) goto notfound;
- module(mod).exports = cons(c, module(mod).exports);
+ /* module(mod).exports = cons(c, module(mod).exports); */
+ addName(c);
}
fprintf(stderr, "}\n" );
}
}
}
+#if 0
if (preludeLoaded) {
/* do the implicit 'import Prelude' thing */
List pxs = module(modulePrelude).exports;
}
}
}
+#endif
/* Last, but by no means least ... */
if (!ocResolve(module(mod).object,0||VERBOSE))
* Vars (values)
* ------------------------------------------------------------------------*/
+/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
+ { C1 a } -> { C2 b } -> T into
+ ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
+*/
+static Type dictapsToQualtype ( Type ty )
+{
+ List pieces = NIL;
+ List preds, dictaps;
+
+ /* break ty into pieces at the top-level arrows */
+ while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
+ pieces = cons ( arg(fun(ty)), pieces );
+ ty = arg(ty);
+ }
+ pieces = cons ( ty, pieces );
+ pieces = reverse ( pieces );
+
+ dictaps = NIL;
+ while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
+ dictaps = cons ( hd(pieces), dictaps );
+ pieces = tl(pieces);
+ }
+
+ /* dictaps holds the predicates, backwards */
+ /* pieces holds the remainder of the type, forwards */
+ assert(nonNull(pieces));
+ pieces = reverse(pieces);
+ ty = hd(pieces);
+ pieces = tl(pieces);
+ for (; nonNull(pieces); pieces=tl(pieces))
+ ty = fn(hd(pieces),ty);
+
+ preds = NIL;
+ for (; nonNull(dictaps); dictaps=tl(dictaps)) {
+ Cell da = hd(dictaps);
+ QualId cl = fst(unap(DICTAP,da));
+ Cell arg = snd(unap(DICTAP,da));
+ preds = cons ( pair(cl,arg), preds );
+ }
+
+ if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
+ return ty;
+}
+
+
+
void startGHCValue ( Int line, VarId vid, Type ty )
{
Name n;
}
n = newName(v,NIL);
+ ty = dictapsToQualtype(ty);
+
tvs = ifTyvarsIn(ty);
for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
hd(tmp) = zpair(hd(tmp),STAR);
/* make resTy the result type of the constr, T v1 ... vn */
resTy = tycon;
for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,fst(hd(tmp)));
+ resTy = ap(resTy,zfst(hd(tmp)));
/* for each constructor ... */
for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
Name mn;
/* Stick the new context on the member type */
+ memT = dictapsToQualtype(memT);
if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
if (whatIs(memT)==QUAL) {
memT = pair(QUAL,
name(n).line = cclass(nw).line;
name(n).type = ty;
name(n).number = ctr++;
+ name(n).arity = arityInclDictParams(name(n).type);
hd(mems) = n;
}
}
inst(in).c = cl;
}
-#if 0
- Is this still needed?
{
- Name b = newName(inventText(),NIL);
+ Name b = newName( /*inventText()*/ textOf(var),NIL);
name(b).line = line;
- name(b).arity = length(ctxt); /* unused? */
+ name(b).arity = length(spec); /* unused? */ /* and surely wrong */
name(b).number = DFUNNAME;
inst(in).builder = b;
- bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var));
+ /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
}
-#endif
+
return in;
}
case QUAL:
return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
conidcellsToTycons(line,snd(snd(type)))));
- case DICTAP: /* :: ap(DICTAP, pair(Class,[Type]))
+ case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
Not sure if this is really the right place to
convert it to the form Hugs wants, but will do so anyway.
*/
{
Class cl = fst(unap(DICTAP,type));
List args = snd(unap(DICTAP,type));
- if (length(args) != 1)
- internal("conidcellsToTycons: DICTAP: multiparam ap");
return
- conidcellsToTycons(line,pair(cl,hd(args)));
+ conidcellsToTycons(line,pair(cl,args));
}
case UNBOXEDTUP:
return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
case QUALIDENT:
if (isNull(qualidIsMember(type,aktys))) goto missing;
return TRUE;
+ case TYCON:
+ return TRUE;
default:
fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
Sym(stg_gc_noregs) \
Sym(stg_gc_seq_1) \
Sym(stg_gc_d1) \
+ Sym(stg_gc_f1) \
Sym(stg_chk_0) \
Sym(stg_chk_1) \
Sym(stg_gen_chk) \
Sym(waitReadzh_fast) \
Sym(waitWritezh_fast) \
Sym(CHARLIKE_closure) \
+ Sym(INTLIKE_closure) \
Sym(suspendThread) \
Sym(resumeThread) \
Sym(stackOverflow) \
Sym(__int_encodeDouble) \
Sym(mpz_cmp_si) \
Sym(mpz_cmp) \
+ Sym(__mpn_gcd_1) \
+ Sym(gcdIntegerzh_fast) \
Sym(newArrayzh_fast) \
Sym(unsafeThawArrayzh_fast) \
Sym(newDoubleArrayzh_fast) \
Sym(newCharArrayzh_fast) \
Sym(newMutVarzh_fast) \
Sym(quotRemIntegerzh_fast) \
+ Sym(quotIntegerzh_fast) \
+ Sym(remIntegerzh_fast) \
+ Sym(divExactIntegerzh_fast) \
Sym(divModIntegerzh_fast) \
Sym(timesIntegerzh_fast) \
Sym(minusIntegerzh_fast) \
Sym(gmtime) \
+/* AJG Hack */
+#if 0
+#undef EXTERN_SYMS
+#define EXTERN_SYMS
+#endif
+
/* entirely bogus claims about types of these symbols */
#define Sym(vvv) extern int vvv;
#define SymX(vvv) /* nothing */
projects / ghc-hetmet.git / blobdiff