[project @ 2000-02-09 14:50:19 by sewardj]

More bug fixes resulting from trying to load small programs into Hugs
using the GHC Prelude:

-- Better handling of kinds on class method types.  It's still a kludge
   (I reckon) but works well enough to correctly handle methods in
   Monad and Functor.  See comment in startGHCClass() in interface.c.

-- Add hugsprimReadField and hugsprimShowField.

-- Make error be exported from the Prelude.  For some reason, PrelErr.hi
   doesn't give a signature for error, so we have to fake it by copying
   that of hugsprimError.

-- Handle fixity declarations read from interfaces.

-- Set nameListMonad so that list comprehensions can be translated.

7 files changed, 114 insertions, 40 deletions

diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 93c4b96e05..4b535ede95 100644
--- a/ghc/interpreter/compiler.c
+++ b/ghc/interpreter/compiler.c
@@ -11,8 +11,8 @@
  * included in the distribution.
  *
  * $RCSfile: compiler.c,v $
- * $Revision: 1.18 $
- * $Date: 2000/02/08 15:32:29 $
+ * $Revision: 1.19 $
+ * $Date: 2000/02/09 14:50:19 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -188,7 +188,8 @@ Cell e; {
                                              nv));
                           }
 
-        default         : fprintf(stderr, "stuff=%d\n",whatIs(e));internal("translate");
+        default         : fprintf(stderr, "stuff=%d\n",whatIs(e));
+                          internal("translate");
     }
     return e;
 }
diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c
index cf4e399546..31e68dc905 100644
--- 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.29 $
- * $Date: 2000/02/08 17:50:46 $
+ * $Revision: 1.30 $
+ * $Date: 2000/02/09 14:50:20 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -139,6 +139,8 @@ static Void finishGHCImports    Args((ConId,List));
 static Void startGHCExports     Args((ConId,List));
 static Void finishGHCExports    Args((ConId,List));
 
+static Void finishGHCFixdecl    ( Cell prec, Cell assoc, ConVarId name );
+
 static Void finishGHCModule     Args((Cell));
 static Void startGHCModule      Args((Text, Int, Text));
 
@@ -767,7 +769,7 @@ Bool processInterfaces ( void )
                 if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
              for (t = constrs; nonNull(t); t=tl(t))
                 for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
-                    if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;          
+                    if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
           }
           else if (whatIs(ent)==I_NEWTYPE) {
              Cell  newty  = unap(I_NEWTYPE,ent);
@@ -994,6 +996,8 @@ fprintf(stderr, "abstractify newtype %s\n", textToStr(textOf(getIEntityName(ent)
                 break;
              }
              case I_FIXDECL: {
+                Cell fixdecl = unap(I_FIXDECL,decl);
+                finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
                 break;
              }
              case I_INSTANCE: {
@@ -1373,6 +1377,20 @@ static Void finishGHCImports ( ConId nm, List syms )
 
 
 /* --------------------------------------------------------------------------
+ * Fixity decls
+ * ------------------------------------------------------------------------*/
+
+static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
+{
+   Int  p = intOf(prec);
+   Int  a = intOf(assoc);
+   Name n = findName(textOf(name));
+   assert (nonNull(n));
+   name(n).syntax = mkSyntax ( a, p );
+}
+
+
+/* --------------------------------------------------------------------------
  * Vars (values)
  * ------------------------------------------------------------------------*/
 
@@ -1886,13 +1904,8 @@ List  mems0; {    /* [((VarId, Type))]     */
         cclass(nw).instances  = NIL;
         cclass(nw).numSupers  = length(ctxt);
 
-
-
         /* Kludge to map the single tyvar in the context to Offset 0.
            Need to do something better for multiparam type classes.
-
-        cclass(nw).supers     = tvsToOffsets(line,ctxt,
-                                             singleton(pair(tv,STAR)));
         */
         cclass(nw).supers     = tvsToOffsets(line,ctxt,
                                              singleton(kinded_tv));
@@ -1919,10 +1932,18 @@ List  mems0; {    /* [((VarId, Type))]     */
            tvsInT = ifTyvarsIn(memT);
            /* tvsInT :: [VarId] */
 
-           /* ToDo: maximally bogus */
-           for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs))
-              hd(tvs) = zpair(hd(tvs),STAR);
-           /* tvsIntT :: [((VarId,STAR))] */
+           /* ToDo: maximally bogus.  We allow the class tyvar to
+              have the kind as supplied by the parser, but we just
+              assume that all others have kind *.  It's a kludge.
+           */
+           for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
+              Kind k;
+              if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
+                 k = zsnd(kinded_tv); else
+                 k = STAR;
+              hd(tvs) = zpair(hd(tvs),k);
+           }
+           /* tvsIntT :: [((VarId,Kind))] */
 
            memT = mkPolyType(tvsToKind(tvsInT),memT);
            memT = tvsToOffsets(line,memT,tvsInT);
@@ -1946,11 +1967,6 @@ List  mems0; {    /* [((VarId, Type))]     */
         cclass(nw).members    = mems0;
         cclass(nw).numMembers = length(mems0);
 
-        /* (ADR) ToDo: 
-         * cclass(nw).dsels    = ?;
-         * cclass(nm).defaults = ?;
-         */
-
         ns = NIL;
         for (mno=0; mno<cclass(nw).numSupers; mno++) {
            ns = cons(newDSel(nw,mno),ns);
@@ -2421,6 +2437,8 @@ Type type; {
       Sym(__ap_4_upd_info)           \
       Sym(__ap_5_upd_info)           \
       Sym(__ap_6_upd_info)           \
+      Sym(__ap_7_upd_info)           \
+      Sym(__ap_8_upd_info)           \
       Sym(__sel_0_upd_info)          \
       Sym(__sel_1_upd_info)          \
       Sym(__sel_2_upd_info)          \
@@ -2548,6 +2566,8 @@ Type type; {
       Sym(timezone)                  \
       Sym(mktime)                    \
       Sym(gmtime)                    \
+      SymX(getenv)                   \
+      Sym(shutdownHaskellAndExit)    \
 
 
 /* AJG Hack */
diff --git a/ghc/interpreter/lib/Prelude.hs b/ghc/interpreter/lib/Prelude.hs
index 2f615908ea..729a3dee6d 100644
--- a/ghc/interpreter/lib/Prelude.hs
+++ b/ghc/interpreter/lib/Prelude.hs
@@ -1337,8 +1337,8 @@ showString    = (++)
 showParen    :: Bool -> ShowS -> ShowS
 showParen b p = if b then showChar '(' . p . showChar ')' else p
 
-showField    :: Show a => String -> a -> ShowS
-showField m v = showString m . showChar '=' . shows v
+hugsprimShowField    :: Show a => String -> a -> ShowS
+hugsprimShowField m v = showString m . showChar '=' . shows v
 
 readParen    :: Bool -> ReadS a -> ReadS a
 readParen b g = if b then mandatory else optional
@@ -1348,10 +1348,10 @@ readParen b g = if b then mandatory else optional
 					     (")",u) <- lex t    ]
 
 
-readField    :: Read a => String -> ReadS a
-readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
-                       ("=",s2) <- lex s1,
-                       r        <- reads s2 ]
+hugsprimReadField    :: Read a => String -> ReadS a
+hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
+                               ("=",s2) <- lex s1,
+                               r        <- reads s2 ]
 
 lex                    :: ReadS String
 lex ""                  = [("","")]
diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c
index f107aa7f8a..0bdf68e49b 100644
--- a/ghc/interpreter/link.c
+++ b/ghc/interpreter/link.c
@@ -9,8 +9,8 @@
  * included in the distribution.
  *
  * $RCSfile: link.c,v $
- * $Revision: 1.41 $
- * $Date: 2000/02/08 17:50:46 $
+ * $Revision: 1.42 $
+ * $Date: 2000/02/09 14:50:20 $
  * ------------------------------------------------------------------------*/
 
 #include "prelude.h"
@@ -515,6 +515,7 @@ Int what; {
                        break;
 
         case POSTPREL: {
+           Name nm;
            Module modulePrelBase = findModule(findText("PrelBase"));
            assert(nonNull(modulePrelBase));
 	   fprintf(stderr, "linkControl(POSTPREL)\n");
@@ -543,9 +544,9 @@ assert(nonNull(namePMFail));
 
                /* deriving                              */
                xyzzy(nameApp,            "++");
-               xyzzy(nameReadField,      "readField");
+               xyzzy(nameReadField,      "hugsprimReadField");
                xyzzy(nameReadParen,      "readParen");
-               xyzzy(nameShowField,      "showField");
+               xyzzy(nameShowField,      "hugsprimShowField");
                xyzzy(nameShowParen,      "showParen");
                xyzzy(nameLex,            "lex");
                xyzzy(nameComp,           ".");
@@ -564,6 +565,44 @@ assert(nonNull(namePMFail));
            ifLinkConstrItbl ( nameTrue );
            ifLinkConstrItbl ( nameNil );
            ifLinkConstrItbl ( nameCons );
+
+           /* PrelErr.hi doesn't give a type for error, alas.  
+              So error never appears in any symbol table.
+              So we fake it by copying the table entry for
+              hugsprimError -- which is just a call to error.
+              Although we put it on the Prelude export list, we
+              have to claim internally that it lives in PrelErr, 
+              so that the correct symbol (PrelErr_error_closure)
+              is referred to.
+              Big Big Sigh.
+           */
+           nm            = newName ( findText("error"), NIL );
+           name(nm)      = name(nameError);
+           name(nm).mod  = findModule(findText("PrelErr"));
+           name(nm).text = findText("error");
+           setCurrModule(modulePrelude);
+           module(modulePrelude).exports
+              = cons ( nm, module(modulePrelude).exports );
+
+           /* Make nameListMonad be the builder fn for instance Monad [].
+              Standalone hugs does this with a disgusting hack in 
+              checkInstDefn() in static.c.  We have a slightly different
+              disgusting hack for the combined case.
+           */
+           {
+           Class cm;   /* :: Class   */
+           List  is;   /* :: [Inst]  */
+           cm = findClassInAnyModule(findText("Monad"));
+           assert(nonNull(cm));
+           is = cclass(cm).instances;
+           assert(nonNull(is));
+           while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
+              is = tl(is);
+           assert(nonNull(is));
+           nameListMonad = inst(hd(is)).builder;
+           assert(nonNull(nameListMonad));
+           }
+
            break;
         }
         case PREPREL : 
@@ -651,9 +690,9 @@ assert(nonNull(namePMFail));
 
                /* deriving                              */
                pFun(nameApp,            "++");
-               pFun(nameReadField,      "readField");
+               pFun(nameReadField,      "hugsprimReadField");
                pFun(nameReadParen,      "readParen");
-               pFun(nameShowField,      "showField");
+               pFun(nameShowField,      "hugsprimShowField");
                pFun(nameShowParen,      "showParen");
                pFun(nameLex,            "lex");
                pFun(nameComp,           ".");
diff --git a/ghc/interpreter/object.c b/ghc/interpreter/object.c
index 11f8976722..df5be207e9 100644
--- a/ghc/interpreter/object.c
+++ b/ghc/interpreter/object.c
@@ -631,7 +631,9 @@ static int ocGetNames_ELF ( ObjectCode* oc, int verb )
                        ad, oc->objFileName, nm );
             if (!addSymbol ( oc, nm, ad )) return FALSE;
          }
+#if 0
 	 else fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
+#endif
       }
    }
 
diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs
index 2f615908ea..729a3dee6d 100644
--- a/ghc/lib/hugs/Prelude.hs
+++ b/ghc/lib/hugs/Prelude.hs
@@ -1337,8 +1337,8 @@ showString    = (++)
 showParen    :: Bool -> ShowS -> ShowS
 showParen b p = if b then showChar '(' . p . showChar ')' else p
 
-showField    :: Show a => String -> a -> ShowS
-showField m v = showString m . showChar '=' . shows v
+hugsprimShowField    :: Show a => String -> a -> ShowS
+hugsprimShowField m v = showString m . showChar '=' . shows v
 
 readParen    :: Bool -> ReadS a -> ReadS a
 readParen b g = if b then mandatory else optional
@@ -1348,10 +1348,10 @@ readParen b g = if b then mandatory else optional
 					     (")",u) <- lex t    ]
 
 
-readField    :: Read a => String -> ReadS a
-readField m s0 = [ r | (t,  s1) <- lex s0, t == m,
-                       ("=",s2) <- lex s1,
-                       r        <- reads s2 ]
+hugsprimReadField    :: Read a => String -> ReadS a
+hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
+                               ("=",s2) <- lex s1,
+                               r        <- reads s2 ]
 
 lex                    :: ReadS String
 lex ""                  = [("","")]
diff --git a/ghc/lib/std/PrelHugs.lhs b/ghc/lib/std/PrelHugs.lhs
index dab4162fa0..23a106fe32 100644
--- a/ghc/lib/std/PrelHugs.lhs
+++ b/ghc/lib/std/PrelHugs.lhs
@@ -21,7 +21,9 @@ module PrelHugs (
    hugsprimUnpackString,
    hugsprimPmFail,
    hugsprimCompAux,
-   hugsprimError
+   hugsprimError,
+   hugsprimShowField,
+   hugsprimReadField
 )
 where
 import PrelGHC
@@ -32,7 +34,8 @@ import Prelude(fromIntegral)
 import IO(putStr,hFlush,stdout,stderr)
 import PrelException(catch)
 import PrelIOBase(IO,unsafePerformIO)
-import PrelShow(show)
+import PrelShow(show,shows,showString,showChar,Show,ShowS)
+import PrelRead(Read,ReadS,lex,reads)
 import PrelFloat(Double)
 import PrelReal(Fractional,fromRational,toRational)
 import PrelAddr(Addr)
@@ -95,6 +98,15 @@ hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
 hugsprimError        :: String -> a
 hugsprimError s       = error s
 
+hugsprimShowField    :: Show a => String -> a -> ShowS
+hugsprimShowField m v = showString m . showChar '=' . shows v
+
+hugsprimReadField    :: Read a => String -> ReadS a
+hugsprimReadField m s0 = [ r | (t,  s1) <- lex s0, t == m,
+                               ("=",s2) <- lex s1,
+                               r        <- reads s2 ]
+
+
 -- used when Hugs invokes top level function
 {-
 hugsprimRunIO_toplevel :: IO a -> ()