Commit 0198d561 authored by sewardj's avatar sewardj
Browse files

[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.
parent 91e42781
......@@ -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;
}
......
......@@ -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 */
......
......@@ -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 "" = [("","")]
......
......@@ -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, ".");
......
......@@ -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
}
}
......
......@@ -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 "" = [("","")]
......
......@@ -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 -> ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment