* 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"
nv));
}
- default : fprintf(stderr, "stuff=%d\n",whatIs(e));internal("translate");
+ default : fprintf(stderr, "stuff=%d\n",whatIs(e));
+ internal("translate");
}
return e;
}
* 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"
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));
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);
break;
}
case I_FIXDECL: {
+ Cell fixdecl = unap(I_FIXDECL,decl);
+ finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
break;
}
case I_INSTANCE: {
/* --------------------------------------------------------------------------
+ * 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)
* ------------------------------------------------------------------------*/
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));
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);
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);
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) \
Sym(timezone) \
Sym(mktime) \
Sym(gmtime) \
+ SymX(getenv) \
+ Sym(shutdownHaskellAndExit) \
/* AJG Hack */
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
(")",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 "" = [("","")]
* 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"
break;
case POSTPREL: {
+ Name nm;
Module modulePrelBase = findModule(findText("PrelBase"));
assert(nonNull(modulePrelBase));
fprintf(stderr, "linkControl(POSTPREL)\n");
/* 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, ".");
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 :
/* 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, ".");
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
}
}
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
(")",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 "" = [("","")]
hugsprimUnpackString,
hugsprimPmFail,
hugsprimCompAux,
- hugsprimError
+ hugsprimError,
+ hugsprimShowField,
+ hugsprimReadField
)
where
import PrelGHC
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)
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 -> ()
projects / ghc-hetmet.git / commitdiff