[project @ 2000-01-13 14:33:57 by hwloidl]

[ghc-hetmet.git] / ghc / interpreter / interface.c

diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index bb3cc73..0778639 100644 (file)
--- a/ghc/interpreter/interface.c
+++ b/ghc/interpreter/interface.c
@@ -7,8 +7,8 @@
  * Hugs version 1.4, December 1997
  *
  * $RCSfile: interface.c,v $
- * $Revision: 1.21 $
- * $Date: 2000/01/07 10:29:59 $
+ * $Revision: 1.25 $
+ * $Date: 2000/01/11 14:56:07 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -537,8 +537,10 @@ Void ppModule ( Text modt )
 /* 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;
@@ -551,12 +553,13 @@ Void processInterfaces ( void )
     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;
+    if (isNull(ifaces_outstanding)) return FALSE;
 
     fprintf ( stderr, 
               "processInterfaces: %d interfaces to process\n", 
@@ -841,6 +844,7 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent)
        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));
@@ -849,6 +853,8 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent)
        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)) {
@@ -909,6 +915,8 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent)
 
     /* Finished! */
     ifaces_outstanding = NIL;
+
+    return didPrelude;
 }
 
 
@@ -1066,7 +1074,7 @@ Void finishGHCModule ( Cell root )
                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;
 
@@ -1087,7 +1095,7 @@ Void finishGHCModule ( Cell root )
                      original (defining) module.
                  */
                   if (abstract) {
-                     module(mod).exports = cons(c, module(mod).exports);
+                     module(mod).exports = cons(pair(c,NIL), module(mod).exports);
                      addTycon(c);
                      fprintf ( stderr, "(abstract) ");
                  } else {
@@ -1101,7 +1109,7 @@ Void finishGHCModule ( Cell root )
                         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);
                      }
                   }
@@ -1120,7 +1128,7 @@ Void finishGHCModule ( Cell root )
                      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" );
@@ -1296,10 +1304,6 @@ void startGHCValue ( Int line, VarId vid, Type ty )
     }
     n = newName(v,NIL);
 
-    /* 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 ))
-    */
     ty = dictapsToQualtype(ty);
 
     tvs = ifTyvarsIn(ty);
@@ -1733,6 +1737,7 @@ List  mems0; {    /* [((VarId, Type))]     */
            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,
@@ -1812,6 +1817,7 @@ static Void finishGHCClass ( Tycon cls_tyc )
        name(n).line   = cclass(nw).line;
        name(n).type   = ty;
        name(n).number = ctr++;
+       name(n).arity  = arityInclDictParams(name(n).type);
        hd(mems) = n;
     }
 }
@@ -1877,17 +1883,15 @@ VarId var; {   /* VarId */
        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;
 }