From 0198d56193b0e77eb39b050d314485c0f79c7f48 Mon Sep 17 00:00:00 2001
From: sewardj <unknown>
Date: Wed, 9 Feb 2000 14:50:21 +0000
Subject: [PATCH] [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.
---
ghc/interpreter/compiler.c | 7 +++--
ghc/interpreter/interface.c | 54 +++++++++++++++++++++++-----------
ghc/interpreter/lib/Prelude.hs | 12 ++++----
ghc/interpreter/link.c | 51 ++++++++++++++++++++++++++++----
ghc/interpreter/object.c | 2 ++
ghc/lib/hugs/Prelude.hs | 12 ++++----
ghc/lib/std/PrelHugs.lhs | 16 ++++++++--
7 files changed, 114 insertions(+), 40 deletions(-)
diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c
index 93c4b96e05d2..4b535ede9538 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 cf4e399546db..31e68dc90504 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: {
@@ -1372,6 +1376,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 2f615908ea4d..729a3dee6d4e 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 f107aa7f8a61..0bdf68e49b2e 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 11f8976722dc..df5be207e9ab 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 2f615908ea4d..729a3dee6d4e 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 dab4162fa07e..23a106fe3295 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 -> ()
--
GitLab