# ----------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.5 1999/03/01 14:58:56 sewardj Exp $ #
+# $Id: Makefile,v 1.6 1999/03/09 14:51:03 sewardj Exp $ #
# ----------------------------------------------------------------------------- #
TOP = ../..
translate.c codegen.c lift.c free.c stgSubst.c optimise.c output.c \
hugs.c dynamic.c stg.c
-SRC_CC_OPTS = -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes -D_POSIX_C_SOURCE
+SRC_CC_OPTS = -O2 -Winline -g -I$(GHC_DIR)/includes -I$(GHC_DIR)/rts -D__HUGS__ -Wall -Wstrict-prototypes
GHC_LIBS_NEEDED = $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/gmp/libgmp.a
GHC_DYN_CBITS_DIR = $(TOP)/ghc/lib/std/cbits
GHC_DYN_CBITS = $(GHC_DYN_CBITS_DIR)/libHS_cbits.so
-###all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs Prelude.hs
all :: parser.c $(GHC_LIBS_NEEDED) $(GHC_DYN_CBITS) hugs
### EXTREMELY hacky
-hugs: $(C_OBJS) ../rts/Assembler.o ../rts/Disassembler.o ../rts/Evaluator.o ../rts/ForeignCall.o \
+hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o \
../rts/Printer.o
$(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) -lbfd -liberty -ldl -lm
snapshot:
/bin/rm -f snapshot.tar
- tar cvf snapshot.tar Makefile Prelude.hs *.[chy] *-ORIG-* \
+ tar cvf snapshot.tar Makefile *.[chy] *-ORIG-* \
../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \
../rts/ForeignCall.c ../rts/Printer.c \
../includes/options.h ../includes/Assembler.h nHandle.c \
- ../includes/Assembler.h ../rts/Bytecodes.h
-
-# --------------------------------------------------------------------- #
-# Prelude #
-# --------------------------------------------------------------------- #
-
-# HPPFLAGS += "-DBEGIN_FOR_HUGS={-"
-# HPPFLAGS += "-DEND_FOR_HUGS=-}"
-
-CPPFLAGS += -I$(GHC_DIR)/includes
-CPPFLAGS += -D__HUGS__
-HPP = gcc -E -P -traditional -xc -DSTD_PRELUDE=0 $(HPPFLAGS) $(CPPFLAGS) -Iprelude -Ilibrary -I.
-UNLIT = ../utils/unlit/unlit
-
-# we cleanup by deleting adjacent blank lines - which just happen to be the
-# only duplicate adjacent lines in all the files we process
-CLEANUP = uniq
-
-# Fiendishly cunning this:
-# o PreludeBuiltin.hs contains the BODY of the libraries it requires.
-# o All the other libraries just contain the HEAD of the file.
-Prelude.hs : $(wildcard prelude/*.hs) $(wildcard library/*.hs) $(wildcard ../lib/*/*.lhs)
- echo Building PreludeBuiltin
- $(HPP) ../lib/std/PrelHandle.lhs | $(UNLIT) - PrelHandle.unlit
- $(HPP) ../lib/std/PrelIOBase.lhs | $(UNLIT) - PrelIOBase.unlit
- $(HPP) ../lib/std/PrelException.lhs | $(UNLIT) - PrelException.unlit
- $(HPP) ../lib/std/PrelDynamic.lhs | $(UNLIT) - PrelDynamic.unlit
- $(HPP) -DBODY ../lib/std/IO.lhs | $(UNLIT) - IO.unlit
- $(HPP) -DHEAD ../lib/std/IO.lhs | $(UNLIT) - IO.hs
- $(HPP) -DBODY prelude/Prelude.hs | $(CLEANUP) > PreludeBuiltin.hs
- $(HPP) -DHEAD prelude/Prelude.hs | $(CLEANUP) > Prelude.hs
- $(HPP) -DHEAD library/Array.hs | $(CLEANUP) > Array.hs
- $(HPP) -DHEAD library/Char.hs | $(CLEANUP) > Char.hs
- $(HPP) -DHEAD library/Ix.hs | $(CLEANUP) > Ix.hs
- $(HPP) -DHEAD library/List.hs | $(CLEANUP) > List.hs
- $(HPP) -DHEAD library/Maybe.hs | $(CLEANUP) > Maybe.hs
- $(HPP) -DHEAD library/Numeric.hs | $(CLEANUP) > Numeric.hs
- $(HPP) -DHEAD library/Ratio.hs | $(CLEANUP) > Ratio.hs
- $(HPP) -DHEAD library/UnicodePrims.hs| $(CLEANUP) > UnicodePrims.hs
- $(HPP) -DHEAD prelude/PreludeIO.hs | $(CLEANUP) > PreludeIO.hs
- $(HPP) -DHEAD prelude/PreludeList.hs | $(CLEANUP) > PreludeList.hs
- $(HPP) -DHEAD prelude/PreludeText.hs | $(CLEANUP) > PreludeText.hs
- $(HPP) -DHEAD prelude/PrelConc.hs | $(CLEANUP) > PrelConc.hs
- echo "Building standard libraries"
- $(HPP) library/Complex.hs > Complex.hs
- $(HPP) library/Monad.hs > Monad.hs
- $(HPP) ../lib/std/System.lhs > System.lhs
- $(HPP) ../lib/std/Directory.lhs > Directory.lhs
- $(HPP) ../lib/std/Locale.lhs > Locale.lhs
- $(HPP) ../lib/std/Random.lhs > Random.lhs
- $(HPP) ../lib/std/CPUTime.lhs > CPUTime.lhs
- $(HPP) ../lib/std/Time.lhs > Time.lhs
- echo "And some standard libraries which ain't done yet"
- # $(HPP) library/IO.hs > IO.hs
- #
- echo "Building Hugs-GHC libraries"
- $(HPP) ../lib/exts/ST.lhs > ST.lhs
- $(HPP) ../lib/misc/Pretty.lhs > Pretty.lhs
- $(HPP) ../lib/exts/IOExts.lhs > IOExts.lhs
- $(HPP) ../lib/exts/NumExts.lhs > NumExts.lhs
- $(HPP) ../lib/exts/Dynamic.lhs > Dynamic.lhs
- $(HPP) ../lib/exts/Bits.lhs > Bits.lhs
- $(HPP) ../lib/exts/Exception.lhs > Exception.lhs
- $(HPP) library/Int.hs > Int.hs
- $(HPP) library/Word.hs > Word.hs
- $(HPP) ../lib/exts/Addr.lhs > Addr.lhs
- $(HPP) ../lib/concurrent/Channel.lhs > Channel.lhs
- $(HPP) ../lib/concurrent/ChannelVar.lhs > ChannelVar.lhs
- $(HPP) ../lib/concurrent/Concurrent.lhs > Concurrent.lhs
- $(HPP) ../lib/concurrent/Merge.lhs > Merge.lhs
- $(HPP) ../lib/concurrent/SampleVar.lhs > SampleVar.lhs
- $(HPP) ../lib/concurrent/Semaphore.lhs > Semaphore.lhs
- echo "And some libraries which ain't converted yet"
- # $(HPP) ../lib/exts/Foreign.lhs > Foreign.lhs
- #
- # $(HPP) ../lib/concurrent/Parallel.lhs > Parallel.lhs
-
-prelclean:
- $(RM) Array.hs Dynamic.lhs NumExts.lhs Pretty.lhs
- $(RM) Bits.lhs Exception.lhs Numeric.hs Ratio.hs
- $(RM) Channel.lhs IOExts.lhs PrelConc.hs ST.lhs
- $(RM) ChannelVar.lhs Ix.hs Prelude.hs SampleVar.lhs
- $(RM) Char.hs List.hs PreludeBuiltin.hs Semaphore.lhs
- $(RM) Complex.hs Maybe.hs PreludeIO.hs System.lhs
- $(RM) Concurrent.lhs Merge.lhs PreludeList.hs UnicodePrims.hs
- $(RM) Directory.lhs Monad.hs PreludeText.hs
- $(RM) Locale.lhs Int.hs IO.hs Addr.lhs Time.lhs Word.hs
- $(RM) *.unlit
+ ../includes/Assembler.h ../rts/Bytecodes.h \
+ lib/*.hs
# --------------------------------------------------------------------- #
INSTALL_LIBEXECS = hugs
-###clean :: prelclean
-
depend :: $(LOOPS) $(SRCS_UGNHS)
* Hugs version 1.4, December 1997
*
* $RCSfile: backend.h,v $
- * $Revision: 1.2 $
- * $Date: 1999/03/01 14:46:42 $
+ * $Revision: 1.3 $
+ * $Date: 1999/03/09 14:51:04 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern StgVar mkStgVar ( StgRhs rhs, Cell info );
-#define mkSeq(x,y) mkStgCase(mkStgApp(nameForce,singleton(x)),singleton(mkStgDefault(mkStgVar(NIL,NIL),y)))
-
-
#define mkStgRep(c) mkChar(c)
/*-------------------------------------------------------------------------*/
* Hugs version 1.4, December 1997
*
* $RCSfile: codegen.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:42 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:04 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
List b;
int i;
- //if (lastModule() != modulePrelude) {
- // printf("\n\ncgBinds: before ll\n\n" );
- // for (b=binds; nonNull(b); b=tl(b)) {
- // printStg ( stdout, hd(b) ); printf("\n\n");
- // }
- //}
+#if 0
+ if (lastModule() != modulePrelude) {
+ printf("\n\ncgBinds: before ll\n\n" );
+ for (b=binds; nonNull(b); b=tl(b)) {
+ printStg ( stdout, hd(b) ); printf("\n\n");
+ }
+ }
+#endif
binds = liftBinds(binds);
- //if (lastModule() != modulePrelude) {
- // printf("\n\ncgBinds: after ll\n\n" );
- // for (b=binds; nonNull(b); b=tl(b)) {
- // printStg ( stdout, hd(b) ); printf("\n\n");
- // }
- //}
-
+#if 0
+ if (lastModule() != modulePrelude) {
+ printf("\n\ncgBinds: after ll\n\n" );
+ for (b=binds; nonNull(b); b=tl(b)) {
+ printStg ( stdout, hd(b) ); printf("\n\n");
+ }
+ }
+#endif
//mapProc(beginTop,binds);
for (b=binds,i=0; nonNull(b); b=tl(b),i++) {
* in the distribution for details.
*
* $RCSfile: compiler.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:43 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:05 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
RevertCAFs();
break;
case Success:
- /* Nothing to do */
break;
default:
internal("evalExp: Unrecognised SchedulerStatus");
/* a nasty hack. But I don't know an easier way to make */
/* these things appear. */
if (lastModule() == modulePrelude) {
- //printf ( "------ Adding cons (:) [] () \n" );
implementCfun ( nameCons, NIL );
implementCfun ( nameNil, NIL );
implementCfun ( nameUnit, NIL );
/* binds=revOnto(binds,NIL); *//* ToDo: maintain compilation order?? */
binds = addGlobals(binds);
#if USE_HUGS_OPTIMIZER
- mapProc(optimiseBind,binds);
#error optimiser
+ if (lastModule() != modulePrelude)
+ mapProc(optimiseTopBind,binds);
#endif
stgCGBinds(binds);
* in the distribution for details.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:43 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:05 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
extern Module modulePrelude;
-//extern Module modulePreludeHugs;
/* --------------------------------------------------------------------------
* Primitive constructor functions
extern Long numCells; /* number of cells allocated */
extern Int numGcs; /* number of garbage collections */
extern Bool broken; /* indicates interrupt received */
-/*ToDo?? extern Bool preludeLoaded;*/ /* TRUE => prelude has been loaded */
+extern Bool preludeLoaded; /* TRUE => prelude has been loaded */
extern Bool gcMessages; /* TRUE => print GC messages */
extern Bool literateScripts; /* TRUE => default lit scripts */
* Hugs version 1.4, December 1997
*
* $RCSfile: derive.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:44 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:06 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#include "Assembler.h"
#include "link.h"
+#if 0
static Cell varTrue;
static Cell varFalse;
#if DERIVE_ORD
#endif
#if DERIVE_SHOW || DERIVE_READ
static Cell varAppend; /* list append */
-List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
#endif
#if DERIVE_EQ || DERIVE_IX
static Cell varAnd; /* built-in logical connectives */
#if DERIVE_EQ || DERIVE_ORD
static Cell varEq;
#endif
+#endif /* 0 */
+List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
/* --------------------------------------------------------------------------
* local function prototypes:
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltEq(tycon(t).line,
- makeDPats2(hd(cs),name(hd(cs)).arity)),
+ makeDPats2(hd(cs),userArity(hd(cs)))),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
alts = cons(pair(cons(WILDCARD,cons(WILDCARD,NIL)),
- pair(mkInt(tycon(t).line),varFalse)),alts);
+ pair(mkInt(tycon(t).line),nameFalse)),alts);
}
alts = rev(alts);
} else { /* special case for tuples */
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = varTrue;
+ Cell e = nameTrue;
if (isAp(p)) {
- e = ap2(varEq,arg(p),arg(q));
+ e = ap2(nameEq,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap2(varAnd,ap2(varEq,arg(p),arg(q)),e);
+ e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
}
}
return pair(pats,pair(mkInt(line),e));
Cell rhs = NIL;
if (cfunOf(hd(tycon(t).defn))!=0) {
implementConToTag(t);
- rhs = ap2(varCompare,
+ rhs = ap2(nameCompare,
ap(tycon(t).conToTag,u),
ap(tycon(t).conToTag,w));
} else {
- rhs = varEQ;
+ rhs = nameEQ;
}
alts = singleton(pair(doubleton(u,w),pair(mkInt(tycon(t).line),rhs)));
} else if (isTycon(t)) { /* deal with type constrs */
List cs = tycon(t).defn;
for (; hasCfun(cs); cs=tl(cs)) {
alts = cons(mkAltOrd(tycon(t).line,
- makeDPats2(hd(cs),name(hd(cs)).arity)),
+ makeDPats2(hd(cs),userArity(hd(cs)))),
alts);
}
if (cfunOf(hd(tycon(t).defn))!=0) {
implementConToTag(t);
alts = cons(pair(doubleton(u,w),
pair(mkInt(tycon(t).line),
- ap2(varCompare,
+ ap2(nameCompare,
ap(tycon(t).conToTag,u),
ap(tycon(t).conToTag,w)))),
alts);
List pats; { /* arguments */
Cell p = hd(pats);
Cell q = hd(tl(pats));
- Cell e = varEQ;
+ Cell e = nameEQ;
if (isAp(p)) {
- e = ap2(varCompare,arg(p),arg(q));
+ e = ap2(nameCompare,arg(p),arg(q));
for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap3(varCompAux,arg(p),arg(q),e);
+ e = ap3(nameCompAux,arg(p),arg(q),e);
}
}
#if DERIVE_ENUM
List deriveEnum(t) /* Construct definition of enumeration */
Tycon t; {
- Int l = tycon(t).line;
- Cell x = inventVar();
- Cell y = inventVar();
+ Int l = tycon(t).line;
+ Cell x = inventVar();
+ Cell y = inventVar();
Cell first = hd(tycon(t).defn);
- Cell last = tycon(t).defn;
+ Cell last = tycon(t).defn;
if (!isEnumType(t)) {
ERRMSG(l) "Can only derive instances of Enum for enumeration types"
cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
cons(mkBind("enumFrom", singleton(pair(singleton(x),
pair(mkInt(l),
- ap2(varEnumFromTo,x,last))))),
+ ap2(nameFromTo,x,last))))),
/* default instance of enumFromTo is good */
cons(mkBind("enumFromThen",singleton(pair(doubleton(x,y),
pair(mkInt(l),
- ap3(varEnumFromThenTo,x,y,
- ap(COND,triple(ap2(varLe,x,y),
+ ap3(nameFromThenTo,x,y,
+ ap(COND,triple(ap2(nameLe,x,y),
last,first))))))),
/* default instance of enumFromThenTo is good */
NIL))));
} else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
return mkIxBinds(tycon(t).line,
hd(tycon(t).defn),
- name(hd(tycon(t).defn)).arity);
+ userArity(hd(tycon(t).defn)));
}
ERRMSG(tycon(t).line)
"Can only derive instances of Ix for enumeration or product types"
Cell c2 = inventVar();
Cell ci = inventVar();
return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
- c1,c2)), pair(mkInt(l),ap2(varMap,tagToCon,
- ap2(varEnumFromTo,ap(conToTag,c1),
+ c1,c2)), pair(mkInt(l),ap2(nameMap,tagToCon,
+ ap2(nameFromTo,ap(conToTag,c1),
ap(conToTag,c2))))))),
cons(mkBind("index", singleton(pair(doubleton(ap(ASPAT,pair(b,
ap2(mkTuple(2),c1,c2))),ci),
pair(mkInt(l),ap(COND,
- triple(ap2(varInRange,b,ci),
- ap2(qvarMinus,ap(conToTag,ci),
+ triple(ap2(nameInRange,b,ci),
+ ap2(nameMinus,ap(conToTag,ci),
ap(conToTag,c1)),
- ap(varError,mkStr(findText(
+ ap(nameError,mkStr(findText(
"Ix.index: Index out of range"))))))))),
cons(mkBind("inRange",singleton(pair(doubleton(ap2(mkTuple(2),
- c1,c2),ci), pair(mkInt(l),ap2(varAnd,
- ap2(varLe,ap(conToTag,c1),ap(conToTag,ci)),
- ap2(varLe,ap(conToTag,ci),
+ c1,c2),ci), pair(mkInt(l),ap2(nameAnd,
+ ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
+ ap2(nameLe,ap(conToTag,ci),
ap(conToTag,c2))))))),
/* ToDo: share conToTag ci */
NIL)));
List e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
e = cons(ap(FROMQUAL,pair(arg(is),
- ap(varRange,ap2(mkTuple(2),
+ ap(nameRange,ap2(mkTuple(2),
arg(ls),
arg(us))))),e);
}
List xs = NIL;
Cell e = NIL;
for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
- xs = cons(ap2(varIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
+ xs = cons(ap2(nameIndex,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),xs);
}
for (e=hd(xs); nonNull(xs=tl(xs));) {
Cell x = hd(xs);
- e = ap2(qvarPlus,x,ap2(varMult,ap(varRangeSize,arg(fun(x))),e));
+ e = ap2(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
}
e = singleton(pair(pats,pair(mkInt(line),e)));
return mkBind("index",e);
* inRange (X a b c, X p q r) (X x y z)
* = inRange (a,p) x && inRange (b,q) y && inRange (c,r) z
*/
- Cell e = ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
+ Cell e = ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
- e = ap2(varAnd,
- ap2(varInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
+ e = ap2(nameAnd,
+ ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
e);
}
e = singleton(pair(pats,pair(mkInt(line),e)));
/* \ v -> case v of { ...; i -> Ci; ... } */
Void implementTagToCon(t)
-Tycon t; {
+Tycon t; {
if (isNull(tycon(t).tagToCon)) {
String etxt;
String tyconname;
Text textPrelude = findText("Prelude");
switch (what) {
case INSTALL :
+#if 0
varTrue = mkQVar(textPrelude,findText("True"));
varFalse = mkQVar(textPrelude,findText("False"));
#if DERIVE_ORD
#if DERIVE_EQ || DERIVE_ORD
varEq = mkQVar(textPrelude,findText("=="));
#endif
+#endif /* 0 */
/* deliberate fall through */
case RESET :
diVars = NIL;
#if DERIVE_SHOW | DERIVE_READ
mark(cfunSfuns);
#endif
+#if 0
mark(varTrue);
mark(varFalse);
#if DERIVE_ORD
#if DERIVE_EQ || DERIVE_ORD
mark(varEq);
#endif
+#endif /* 0 */
break;
}
}
* in the distribution for details.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:45 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:07 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
static String scriptName[NUM_SCRIPTS]; /* Script file names */
static Time lastChange[NUM_SCRIPTS]; /* Time of last change to script */
static Bool postponed[NUM_SCRIPTS]; /* Indicates postponed load */
-static Int scriptBase; /* Number of scripts in Prelude */
static Int numScripts; /* Number of scripts loaded */
static Int namesUpto; /* Number of script names set */
static Bool needsImports; /* set to TRUE if imports required */
static Int lastEdLine = 0; /* Editor line number (if possible)*/
static String prompt = 0; /* Prompt string */
static Int hpSize = DEFAULTHEAP; /* Desired heap size */
-String hugsEdit = 0; /* String for editor command */
-String hugsPath = 0; /* String for file search path */
+ String hugsEdit = 0; /* String for editor command */
+ String hugsPath = 0; /* String for file search path */
+Bool preludeLoaded = FALSE;
#if REDIRECT_OUTPUT
static Bool disableOutput = FALSE; /* redirect output to buffer? */
readOptions(readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"Options",""));
readOptions(readRegString(HKEY_CURRENT_USER, HugsRoot,"Options",""));
#endif /* USE_REGISTRY */
- readOptions(fromEnv("HUGSFLAGS",""));
+ readOptions(fromEnv("STGHUGSFLAGS",""));
startupHaskell ( argc, argv );
argc = prog_argc; argv = prog_argv;
loadProject(strCopy(proj));
}
readScripts(0);
- scriptBase = numScripts;
}
/* --------------------------------------------------------------------------
case 'h' : setHeapSize(s+1);
return TRUE;
- case 'd' : /* hack */
+ case 'D' : /* hack */
{
extern void setRtsFlags( int x );
setRtsFlags(argToInt(s+1));
currProject = s;
projInput(currProject);
scriptFile = currProject;
- forgetScriptsFrom(scriptBase);
+ forgetScriptsFrom(1);
while ((s=readFilename())!=0)
addScriptName(s,TRUE);
if (namesUpto<=1) {
}
#endif
scriptFile = 0;
+ preludeLoaded = TRUE;
return TRUE;
}
for (i=scno; i<namesUpto; ++i)
if (scriptName[i])
free(scriptName[i]);
- dropScriptsFrom(scno);
+ dropScriptsFrom(scno-1);
namesUpto = scno;
if (numScripts>namesUpto)
numScripts = scno;
/* to be read */
while ((s=readFilename())!=0)
addScriptName(s,TRUE);
- readScripts(scriptBase);
+ readScripts(1);
}
static Void local project() { /* read list of script names from */
EEND;
}
loadProject(s);
- readScripts(scriptBase);
+ readScripts(1);
}
static Void local readScripts(n) /* Reread current list of scripts, */
for (; n<numScripts; n++) { /* Scan previously loaded scripts */
getFileInfo(scriptName[n], &timeStamp, &fileSize);
if (timeChanged(timeStamp,lastChange[n])) {
- dropScriptsFrom(n);
+ dropScriptsFrom(n-1);
numScripts = n;
break;
}
while (numScripts<namesUpto) { /* Process any remaining scripts */
getFileInfo(scriptName[numScripts], &timeStamp, &fileSize);
timeSet(lastChange[numScripts],timeStamp);
- startNewScript(scriptName[numScripts]);
+ if (numScripts>0) /* no new script for prelude */
+ startNewScript(scriptName[numScripts]);
if (addScript(scriptName[numScripts],fileSize))
numScripts++;
else
- dropScriptsFrom(numScripts);
+ dropScriptsFrom(numScripts-1);
}
if (listScripts)
whatScripts();
- if (numScripts<=scriptBase)
+ if (numScripts<=1)
setLastEdit((String)0, 0);
}
startNewScript(0);
if (nonNull(c=findTycon(t=findText(nm)))) {
if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
- readScripts(scriptBase);
+ readScripts(1);
}
} else if (nonNull(c=findName(t))) {
if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
- readScripts(scriptBase);
+ readScripts(1);
}
} else {
ERRMSG(0) "No current definition for name \"%s\"", nm
static Void local runEditor() { /* run editor on script lastEdit */
if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
- readScripts(scriptBase);
+ readScripts(1);
}
static Void local setLastEdit(fname,line)/* keep name of last file to edit */
for (;;) {
Command cmd;
everybody(RESET); /* reset to sensible initial state */
- dropScriptsFrom(numScripts); /* remove partially loaded scripts */
+ dropScriptsFrom(numScripts-1); /* remove partially loaded scripts */
+ /* not counting prelude as a script*/
promptForInput(textToStr(module(findEvalModule()).text));
case FIND : find();
break;
case LOAD : clearProject();
- forgetScriptsFrom(scriptBase);
+ forgetScriptsFrom(1);
load();
break;
case ALSO : clearProject();
forgetScriptsFrom(numScripts);
load();
break;
- case RELOAD : readScripts(scriptBase);
+ case RELOAD : readScripts(1);
break;
case PROJECT: project();
break;
storage(what); /* important for the INSTALL command */
substitution(what);
input(what);
+ translateControl(what);
linkControl(what);
staticAnalysis(what);
deriveControl(what);
typeChecker(what);
- translateControl(what);
compiler(what);
codegen(what);
}
-
/* --------------------------------------------------------------------------
* Hugs for Windows code (WinMain and related functions)
* ------------------------------------------------------------------------*/
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Array operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Array (
+ module Ix, -- export all of Ix
+ Array, array, listArray, (!), bounds, indices, elems, assocs,
+ accumArray, (//), accum, ixmap ) where
+
+import Ix
+import List( (\\) )
+
+infixl 9 !, //
+
+data Array ix elt = Array (ix,ix) (PrimArray elt)
+
+array :: Ix a => (a,a) -> [(a,b)] -> Array a b
+array ixs@(ix_start, ix_end) ivs = runST (do
+ { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom
+ ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs
+ ; arr <- primUnsafeFreezeArray mut_arr
+ ; return (Array ixs arr)
+ }
+ )
+ where
+ arrEleBottom = error "(Array.!): undefined array element"
+
+listArray :: Ix a => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+(!) :: Ix a => Array a b -> a -> b
+(Array bounds arr) ! i = primIndexArray arr (index bounds i)
+
+bounds :: Ix a => Array a b -> (a,a)
+bounds (Array b _) = b
+
+indices :: Ix a => Array a b -> [a]
+indices = range . bounds
+
+elems :: Ix a => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+assocs :: Ix a => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+(//) :: Ix a => Array a b -> [(a,b)] -> Array a b
+a // us = array (bounds a)
+ ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
+ ++ us)
+
+accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)])
+
+accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+accumArray f z b = accum f (array b [(i,z) | i <- range b])
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+
+
+instance (Ix a) => Functor (Array a) where
+ fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a]
+
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ a <= a' = assocs a <= assocs a'
+
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Char operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Char (
+ isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ digitToInt, intToDigit,
+ toUpper, toLower,
+ ord, chr,
+ readLitChar, showLitChar, lexLitChar,
+
+ -- ... and what the prelude exports
+ Char, String
+ ) where
+
+-- This module is (almost) empty; Char operations are currently defined in
+-- the prelude, but should eventually be moved to this library file instead.
+-- No Unicode support yet.
+
+isLatin1 c = True
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Complex numbers
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,
+ cis, polar, magnitude, phase) where
+
+infix 6 :+
+
+data (RealFloat a) => Complex a = !a :+ !a
+ deriving (Eq,Read,Show)
+
+realPart, imagPart :: (RealFloat a) => Complex a -> a
+realPart (x:+y) = x
+imagPart (x:+y) = y
+
+conjugate :: (RealFloat a) => Complex a -> Complex a
+conjugate (x:+y) = x :+ (-y)
+
+mkPolar :: (RealFloat a) => a -> a -> Complex a
+mkPolar r theta = r * cos theta :+ r * sin theta
+
+cis :: (RealFloat a) => a -> Complex a
+cis theta = cos theta :+ sin theta
+
+polar :: (RealFloat a) => Complex a -> (a,a)
+polar z = (magnitude z, phase z)
+
+magnitude, phase :: (RealFloat a) => Complex a -> a
+magnitude (x:+y) = scaleFloat k
+ (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2))
+ where k = max (exponent x) (exponent y)
+ mk = - k
+phase (0:+0) = 0
+phase (x:+y) = atan2 y x
+
+instance (RealFloat a) => Num (Complex a) where
+ (x:+y) + (x':+y') = (x+x') :+ (y+y')
+ (x:+y) - (x':+y') = (x-x') :+ (y-y')
+ (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')
+ negate (x:+y) = negate x :+ negate y
+ abs z = magnitude z :+ 0
+ signum 0 = 0
+ signum z@(x:+y) = x/r :+ y/r where r = magnitude z
+ fromInteger n = fromInteger n :+ 0
+ fromInt n = fromInt n :+ 0
+
+instance (RealFloat a) => Fractional (Complex a) where
+ (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
+ where x'' = scaleFloat k x'
+ y'' = scaleFloat k y'
+ k = - max (exponent x') (exponent y')
+ d = x'*x'' + y'*y''
+ fromRational a = fromRational a :+ 0
+ fromDouble a = fromDouble a :+ 0
+
+instance (RealFloat a) => Floating (Complex a) where
+ pi = pi :+ 0
+ exp (x:+y) = expx * cos y :+ expx * sin y
+ where expx = exp x
+ log z = log (magnitude z) :+ phase z
+ sqrt 0 = 0
+ sqrt z@(x:+y) = u :+ (if y < 0 then -v else v)
+ where (u,v) = if x < 0 then (v',u') else (u',v')
+ v' = abs y / (u'*2)
+ u' = sqrt ((magnitude z + abs x) / 2)
+ sin (x:+y) = sin x * cosh y :+ cos x * sinh y
+ cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y)
+ tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
+ where sinx = sin x
+ cosx = cos x
+ sinhy = sinh y
+ coshy = cosh y
+ sinh (x:+y) = cos y * sinh x :+ sin y * cosh x
+ cosh (x:+y) = cos y * cosh x :+ sin y * sinh x
+ tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
+ where siny = sin y
+ cosy = cos y
+ sinhx = sinh x
+ coshx = cosh x
+ asin z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
+ acos z@(x:+y) = y'':+(-x'')
+ where (x'':+y'') = log (z + ((-y'):+x'))
+ (x':+y') = sqrt (1 - z*z)
+ atan z@(x:+y) = y':+(-x')
+ where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))
+ asinh z = log (z + sqrt (1+z*z))
+ acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))
+ atanh z = log ((1+z) / sqrt (1-z*z))
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Ix operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Ix (
+ -- official Haskell 98 interface: Ix(range, index, inRange), rangeSize
+ Ix(range, index, inRange, rangeSize)
+ ) where
+
+-- This module is empty; Ix is currently defined in the prelude, but should
+-- eventually be moved to this library file instead.
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: List operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module List (
+ elemIndex, elemIndices,
+ find, findIndex, findIndices,
+ nub, nubBy, delete, deleteBy, (\\), deleteFirstsBy,
+ union, unionBy, intersect, intersectBy,
+ intersperse, transpose, partition, group, groupBy,
+ inits, tails, isPrefixOf, isSuffixOf,
+ mapAccumL, mapAccumR,
+ sort, sortBy, insert, insertBy, maximumBy, minimumBy,
+ genericLength, genericTake, genericDrop,
+ genericSplitAt, genericIndex, genericReplicate,
+ zip4, zip5, zip6, zip7,
+ zipWith4, zipWith5, zipWith6, zipWith7,
+ unzip4, unzip5, unzip6, unzip7, unfoldr,
+
+ -- ... and what the Prelude exports
+ -- List type: []((:), [])
+ (:),
+ map, (++), concat, filter,
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ lines, words, unlines, unwords, reverse, and, or,
+ any, all, elem, notElem, lookup,
+ sum, product, maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3
+ ) where
+
+import Maybe( listToMaybe )
+
+infix 5 \\
+
+elemIndex :: Eq a => a -> [a] -> Maybe Int
+elemIndex x = findIndex (x ==)
+
+elemIndices :: Eq a => a -> [a] -> [Int]
+elemIndices x = findIndices (x ==)
+
+find :: (a -> Bool) -> [a] -> Maybe a
+find p = listToMaybe . filter p
+
+findIndex :: (a -> Bool) -> [a] -> Maybe Int
+findIndex p = listToMaybe . findIndices p
+
+findIndices :: (a -> Bool) -> [a] -> [Int]
+findIndices p xs = [ i | (x,i) <- zip xs [0..], p x ]
+
+nub :: (Eq a) => [a] -> [a]
+nub = nubBy (==)
+
+nubBy :: (a -> a -> Bool) -> [a] -> [a]
+nubBy eq [] = []
+nubBy eq (x:xs) = x : nubBy eq (filter (\y -> not (eq x y)) xs)
+
+delete :: (Eq a) => a -> [a] -> [a]
+delete = deleteBy (==)
+
+deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a]
+deleteBy eq x [] = []
+deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys
+
+(\\) :: (Eq a) => [a] -> [a] -> [a]
+(\\) = foldl (flip delete)
+
+deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+deleteFirstsBy eq = foldl (flip (deleteBy eq))
+
+union :: (Eq a) => [a] -> [a] -> [a]
+union = unionBy (==)
+
+unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs
+
+intersect :: (Eq a) => [a] -> [a] -> [a]
+intersect = intersectBy (==)
+
+intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
+intersectBy eq xs ys = [x | x <- xs, any (eq x) ys]
+
+intersperse :: a -> [a] -> [a]
+intersperse sep [] = []
+intersperse sep [x] = [x]
+intersperse sep (x:xs) = x : sep : intersperse sep xs
+
+transpose :: [[a]] -> [[a]]
+transpose [] = []
+transpose ([] : xss) = transpose xss
+transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) :
+ transpose (xs : [ t | (h:t) <- xss])
+
+partition :: (a -> Bool) -> [a] -> ([a],[a])
+partition p xs = foldr select ([],[]) xs
+ where select x (ts,fs) | p x = (x:ts,fs)
+ | otherwise = (ts,x:fs)
+
+-- group splits its list argument into a list of lists of equal, adjacent
+-- elements. e.g.,
+-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"]
+group :: (Eq a) => [a] -> [[a]]
+group = groupBy (==)
+
+groupBy :: (a -> a -> Bool) -> [a] -> [[a]]
+groupBy eq [] = []
+groupBy eq (x:xs) = (x:ys) : groupBy eq zs
+ where (ys,zs) = span (eq x) xs
+
+-- inits xs returns the list of initial segments of xs, shortest first.
+-- e.g., inits "abc" == ["","a","ab","abc"]
+inits :: [a] -> [[a]]
+inits [] = [[]]
+inits (x:xs) = [[]] ++ map (x:) (inits xs)
+
+-- tails xs returns the list of all final segments of xs, longest first.
+-- e.g., tails "abc" == ["abc", "bc", "c",""]
+tails :: [a] -> [[a]]
+tails [] = [[]]
+tails xxs@(_:xs) = xxs : tails xs
+
+isPrefixOf :: (Eq a) => [a] -> [a] -> Bool
+isPrefixOf [] _ = True
+isPrefixOf _ [] = False
+isPrefixOf (x:xs) (y:ys) = x == y && isPrefixOf xs ys
+
+isSuffixOf :: (Eq a) => [a] -> [a] -> Bool
+isSuffixOf x y = reverse x `isPrefixOf` reverse y
+
+mapAccumL :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumL f s [] = (s, [])
+mapAccumL f s (x:xs) = (s'',y:ys)
+ where (s', y ) = f s x
+ (s'',ys) = mapAccumL f s' xs
+
+mapAccumR :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
+mapAccumR f s [] = (s, [])
+mapAccumR f s (x:xs) = (s'', y:ys)
+ where (s'',y ) = f s' x
+ (s', ys) = mapAccumR f s xs
+
+unfoldr :: (b -> Maybe (a,b)) -> b -> [a]
+unfoldr f b = case f b of Nothing -> []
+ Just (a,b) -> a : unfoldr f b
+
+sort :: (Ord a) => [a] -> [a]
+sort = sortBy compare
+
+sortBy :: (a -> a -> Ordering) -> [a] -> [a]
+sortBy cmp = foldr (insertBy cmp) []
+
+insert :: (Ord a) => a -> [a] -> [a]
+insert = insertBy compare
+
+insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a]
+insertBy cmp x [] = [x]
+insertBy cmp x ys@(y:ys')
+ = case cmp x y of
+ GT -> y : insertBy cmp x ys'
+ _ -> x : ys
+
+maximumBy :: (a -> a -> a) -> [a] -> a
+maximumBy max [] = error "List.maximumBy: empty list"
+maximumBy max xs = foldl1 max xs
+
+minimumBy :: (a -> a -> a) -> [a] -> a
+minimumBy min [] = error "List.minimumBy: empty list"
+minimumBy min xs = foldl1 min xs
+
+genericLength :: (Integral a) => [b] -> a
+genericLength [] = 0
+genericLength (x:xs) = 1 + genericLength xs
+
+genericTake :: (Integral a) => a -> [b] -> [b]
+genericTake 0 _ = []
+genericTake _ [] = []
+genericTake n (x:xs)
+ | n > 0 = x : genericTake (n-1) xs
+ | otherwise = error "List.genericTake: negative argument"
+
+genericDrop :: (Integral a) => a -> [b] -> [b]
+genericDrop 0 xs = xs
+genericDrop _ [] = []
+genericDrop n (_:xs)
+ | n > 0 = genericDrop (n-1) xs
+ | otherwise = error "List.genericDrop: negative argument"
+
+genericSplitAt :: (Integral a) => a -> [b] -> ([b],[b])
+genericSplitAt 0 xs = ([],xs)
+genericSplitAt _ [] = ([],[])
+genericSplitAt n (x:xs)
+ | n > 0 = (x:xs',xs'')
+ | otherwise = error "List.genericSplitAt: negative argument"
+ where (xs',xs'') = genericSplitAt (n-1) xs
+
+genericIndex :: (Integral a) => [b] -> a -> b
+genericIndex (x:_) 0 = x
+genericIndex (_:xs) n
+ | n > 0 = genericIndex xs (n-1)
+ | otherwise = error "List.genericIndex: negative argument"
+genericIndex _ _ = error "List.genericIndex: index too large"
+
+genericReplicate :: (Integral a) => a -> b -> [b]
+genericReplicate n x = genericTake n (repeat x)
+
+zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)]
+zip4 = zipWith4 (,,,)
+
+zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)]
+zip5 = zipWith5 (,,,,)
+
+zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [(a,b,c,d,e,f)]
+zip6 = zipWith6 (,,,,,)
+
+zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] ->
+ [g] -> [(a,b,c,d,e,f,g)]
+zip7 = zipWith7 (,,,,,,)
+
+zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e]
+zipWith4 z (a:as) (b:bs) (c:cs) (d:ds)
+ = z a b c d : zipWith4 z as bs cs ds
+zipWith4 _ _ _ _ _ = []
+
+zipWith5 :: (a->b->c->d->e->f) ->
+ [a]->[b]->[c]->[d]->[e]->[f]
+zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es)
+ = z a b c d e : zipWith5 z as bs cs ds es
+zipWith5 _ _ _ _ _ _ = []
+
+zipWith6 :: (a->b->c->d->e->f->g) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]
+zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs)
+ = z a b c d e f : zipWith6 z as bs cs ds es fs
+zipWith6 _ _ _ _ _ _ _ = []
+
+zipWith7 :: (a->b->c->d->e->f->g->h) ->
+ [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h]
+zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs)
+ = z a b c d e f g : zipWith7 z as bs cs ds es fs gs
+zipWith7 _ _ _ _ _ _ _ _ = []
+
+unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d])
+unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) ->
+ (a:as,b:bs,c:cs,d:ds))
+ ([],[],[],[])
+
+unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e])
+unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) ->
+ (a:as,b:bs,c:cs,d:ds,e:es))
+ ([],[],[],[],[])
+
+unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f])
+unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs))
+ ([],[],[],[],[],[])
+
+unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g])
+unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) ->
+ (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs))
+ ([],[],[],[],[],[],[])
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Operations on the Maybe datatype
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+module Maybe(
+ isJust, fromJust, fromMaybe, listToMaybe, maybeToList,
+ catMaybes, mapMaybe,
+
+ -- ... and what the Prelude exports
+ Maybe(Nothing, Just),
+ maybe
+ ) where
+
+isJust :: Maybe a -> Bool
+isJust (Just a) = True
+isJust Nothing = False
+
+fromJust :: Maybe a -> a
+fromJust (Just a) = a
+fromJust Nothing = error "Maybe.fromJust: Nothing"
+
+fromMaybe :: a -> Maybe a -> a
+fromMaybe d Nothing = d
+fromMaybe d (Just a) = a
+
+maybeToList :: Maybe a -> [a]
+maybeToList Nothing = []
+maybeToList (Just a) = [a]
+
+listToMaybe :: [a] -> Maybe a
+listToMaybe [] = Nothing
+listToMaybe (a:as) = Just a
+
+catMaybes :: [Maybe a] -> [a]
+catMaybes ms = [ m | Just m <- ms ]
+
+mapMaybe :: (a -> Maybe b) -> [a] -> [b]
+mapMaybe f = catMaybes . map f
+
+-----------------------------------------------------------------------------
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Monad operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Monad (
+ MonadPlus(mzero, mplus),
+ join, guard, when, unless, ap,
+ msum,
+ filterM, mapAndUnzipM, zipWithM, zipWithM_, foldM,
+ liftM, liftM2, liftM3, liftM4, liftM5,
+
+ -- ... and what the Prelude exports
+ Monad((>>=), (>>), return, fail),
+ Functor(fmap),
+ mapM, mapM_, accumulate, sequence, (=<<),
+ ) where
+
+-- The MonadPlus class definition
+
+class Monad m => MonadPlus m where
+ mzero :: m a
+ mplus :: m a -> m a -> m a
+
+-- Instances of MonadPlus
+
+instance MonadPlus Maybe where
+ mzero = Nothing
+ Nothing `mplus` ys = ys
+ xs `mplus` ys = xs
+
+instance MonadPlus [ ] where
+ mzero = []
+ mplus = (++)
+
+-- Functions
+
+msum :: MonadPlus m => [m a] -> m a
+msum = foldr mplus mzero
+
+join :: (Monad m) => m (m a) -> m a
+join x = x >>= id
+
+when :: (Monad m) => Bool -> m () -> m ()
+when p s = if p then s else return ()
+
+unless :: (Monad m) => Bool -> m () -> m ()
+unless p s = when (not p) s
+
+ap :: (Monad m) => m (a -> b) -> m a -> m b
+ap = liftM2 ($)
+
+guard :: MonadPlus m => Bool -> m ()
+guard p = if p then return () else mzero
+
+mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip
+
+zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys = accumulate (zipWith f xs ys)
+
+zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m ()
+zipWithM_ f xs ys = sequence (zipWith f xs ys)
+
+foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM f a [] = return a
+foldM f a (x:xs) = f a x >>= \ y -> foldM f y xs
+
+filterM :: MonadPlus m => (a -> m Bool) -> [a] -> m [a]
+filterM p [] = return []
+filterM p (x:xs) = do b <- p x
+ ys <- filterM p xs
+ return (if b then (x:ys) else ys)
+
+liftM :: (Monad m) => (a -> b) -> (m a -> m b)
+liftM f = \a -> do { a' <- a; return (f a') }
+
+liftM2 :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
+liftM2 f = \a b -> do { a' <- a; b' <- b; return (f a' b') }
+
+liftM3 :: (Monad m) => (a -> b -> c -> d) ->
+ (m a -> m b -> m c -> m d)
+liftM3 f = \a b c -> do { a' <- a; b' <- b; c' <- c;
+ return (f a' b' c')}
+
+liftM4 :: (Monad m) => (a -> b -> c -> d -> e) ->
+ (m a -> m b -> m c -> m d -> m e)
+liftM4 f = \a b c d -> do { a' <- a; b' <- b; c' <- c; d' <- d;
+ return (f a' b' c' d')}
+
+liftM5 :: (Monad m) => (a -> b -> c -> d -> e -> f) ->
+ (m a -> m b -> m c -> m d -> m e -> m f)
+liftM5 f = \a b c d e -> do { a' <- a; b' <- b; c' <- c; d' <- d;
+ e' <- e; return (f a' b' c' d' e')}
+
+-----------------------------------------------------------------------------
--- /dev/null
+{----------------------------------------------------------------------------
+__ __ __ __ ____ ___ _______________________________________________
+|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
+||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
+||---|| ___|| World Wide Web: http://haskell.org/hugs
+|| || Report bugs to: hugs-bugs@haskell.org
+|| || Version: January 1999 _______________________________________________
+
+ This is the Hugs 98 Standard Prelude, based very closely on the Standard
+ Prelude for Haskell 98.
+
+ WARNING: This file is an integral part of the Hugs source code. Changes to
+ the definitions in this file without corresponding modifications in other
+ parts of the program may cause the interpreter to fail unexpectedly. Under
+ normal circumstances, you should not attempt to modify this file in any way!
+
+-----------------------------------------------------------------------------
+ Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
+ Group 1994-99, and is distributed as Open Source software under the
+ Artistic License; see the file "Artistic" that is included in the
+ distribution for details.
+----------------------------------------------------------------------------}
+
+module Prelude (
+-- module PreludeList,
+ map, (++), concat, filter,
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ lines, words, unlines, unwords, reverse, and, or,
+ any, all, elem, notElem, lookup,
+ sum, product, maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3,
+-- module PreludeText,
+ ReadS, ShowS,
+ Read(readsPrec, readList),
+ Show(show, showsPrec, showList),
+ reads, shows, read, lex,
+ showChar, showString, readParen, showParen,
+-- module PreludeIO,
+ FilePath, IOError, ioError, userError, catch,
+ putChar, putStr, putStrLn, print,
+ getChar, getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn,
+-- module Ix,
+ Ix(range, index, inRange, rangeSize),
+-- module Char,
+ isAscii, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ digitToInt, intToDigit,
+ toUpper, toLower,
+ ord, chr,
+ readLitChar, showLitChar, lexLitChar,
+-- module Numeric
+ showSigned, showInt,
+ readSigned, readInt,
+ readDec, readOct, readHex, readSigned,
+ readFloat, lexDigits,
+-- module Ratio,
+ Ratio, Rational, (%), numerator, denominator, approxRational,
+-- Non-standard exports
+ IO(..), IOResult(..), Addr,
+
+ Bool(False, True),
+ Maybe(Nothing, Just),
+ Either(Left, Right),
+ Ordering(LT, EQ, GT),
+ Char, String, Int, Integer, Float, Double, IO,
+-- List type: []((:), [])
+ (:),
+-- Tuple types: (,), (,,), etc.
+-- Trivial type: ()
+-- Functions: (->)
+ Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
+ Eq((==), (/=)),
+ Ord(compare, (<), (<=), (>=), (>), max, min),
+ Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
+ enumFromTo, enumFromThenTo),
+ Bounded(minBound, maxBound),
+-- Num((+), (-), (*), negate, abs, signum, fromInteger),
+ Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
+ Real(toRational),
+-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
+ Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
+-- Fractional((/), recip, fromRational),
+ Fractional((/), recip, fromRational, fromDouble),
+ Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
+ asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
+ RealFrac(properFraction, truncate, round, ceiling, floor),
+ RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
+ encodeFloat, exponent, significand, scaleFloat, isNaN,
+ isInfinite, isDenormalized, isIEEE, isNegativeZero),
+ Monad((>>=), (>>), return, fail),
+ Functor(fmap),
+ mapM, mapM_, accumulate, sequence, (=<<),
+ maybe, either,
+ (&&), (||), not, otherwise,
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, realToFrac, atan2,
+ fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
+ asTypeOf, error, undefined,
+ seq, ($!)
+
+ ,primCompAux
+ ) where
+
+-- Standard value bindings {Prelude} ----------------------------------------
+
+infixr 9 .
+infixl 9 !!
+infixr 8 ^, ^^, **
+infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
+infixl 6 +, -
+--infixr 5 : -- this fixity declaration is hard-wired into Hugs
+infixr 5 ++
+infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
+infixr 3 &&
+infixr 2 ||
+infixl 1 >>, >>=
+infixr 1 =<<
+infixr 0 $, $!, `seq`
+
+-- Equality and Ordered classes ---------------------------------------------
+
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ -- Minimal complete definition: (==) or (/=)
+ x == y = not (x/=y)
+ x /= y = not (x==y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>=), (>) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+ -- Minimal complete definition: (<=) or compare
+ -- using compare can be more efficient for complex types
+ compare x y | x==y = EQ
+ | x<=y = LT
+ | otherwise = GT
+
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+
+ max x y | x >= y = x
+ | otherwise = y
+ min x y | x <= y = x
+ | otherwise = y
+
+class Bounded a where
+ minBound, maxBound :: a
+ -- Minimal complete definition: All
+
+-- Numeric classes ----------------------------------------------------------
+
+class (Eq a, Show a) => Num a where
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: Integer -> a
+ fromInt :: Int -> a
+
+ -- Minimal complete definition: All, except negate or (-)
+ x - y = x + negate y
+ fromInt = fromIntegral
+ negate x = 0 - x
+
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot, rem, div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ even, odd :: a -> Bool
+ toInteger :: a -> Integer
+ toInt :: a -> Int
+
+ -- Minimal complete definition: quotRem and toInteger
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+ divMod n d = if signum r == - signum d then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+ even n = n `rem` 2 == 0
+ odd = not . even
+ toInt = toInt . toInteger
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+ fromDouble :: Double -> a
+
+ -- Minimal complete definition: fromRational and ((/) or recip)
+ recip x = 1 / x
+ fromDouble = fromRational . toRational
+ x / y = x * recip y
+
+
+class (Fractional a) => Floating a where
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
+ asinh, acosh, atanh :: a -> a
+
+ -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
+ -- asinh, acosh, atanh
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ sinh x = (exp x - exp (-x)) / 2
+ cosh x = (exp x + exp (-x)) / 2
+ tanh x = sinh x / cosh x
+ asinh x = log (x + sqrt (x*x + 1))
+ acosh x = log (x + sqrt (x*x - 1))
+ atanh x = (log (1 + x) - log (1 - x)) / 2
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, floor :: (Integral b) => a -> b
+
+ -- Minimal complete definition: properFraction
+ truncate x = m where (m,_) = properFraction x
+
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
+
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
+
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> Integer
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (Integer,Int)
+ encodeFloat :: Integer -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+ atan2 :: a -> a -> a
+
+ -- Minimal complete definition: All, except exponent, signficand,
+ -- scaleFloat, atan2
+ exponent x = if m==0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+ significand x = encodeFloat m (- floatDigits x)
+ where (m,_) = decodeFloat x
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+ atan2 y x
+ | x>0 = atan (y/x)
+ | x==0 && y>0 = pi/2
+ | x<0 && y>0 = pi + atan (y/x)
+ | (x<=0 && y<0) ||
+ (x<0 && isNegativeZero y) ||
+ (isNegativeZero x && isNegativeZero y)
+ = - atan2 (-y) x
+ | y==0 && (x<0 || isNegativeZero x)
+ = pi -- must be after the previous test on zero y
+ | x==0 && y==0 = y -- must be after the other double zero tests
+ | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
+
+-- Numeric functions --------------------------------------------------------
+
+subtract :: Num a => a -> a -> a
+subtract = flip (-)
+
+gcd :: Integral a => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' x 0 = x
+ gcd' x y = gcd' y (x `rem` y)
+
+lcm :: (Integral a) => a -> a -> a
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` gcd x y) * y)
+
+(^) :: (Num a, Integral b) => a -> b -> a
+x ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f x n y = g x n where
+ g x n | even n = g (x*x) (n`quot`2)
+ | otherwise = f x (n-1) (x*y)
+_ ^ _ = error "Prelude.^: negative exponent"
+
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
+
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+realToFrac :: (Real a, Fractional b) => a -> b
+realToFrac = fromRational . toRational
+
+-- Index and Enumeration classes --------------------------------------------
+
+class (Ord a) => Ix a where
+ range :: (a,a) -> [a]
+ index :: (a,a) -> a -> Int
+ inRange :: (a,a) -> a -> Bool
+ rangeSize :: (a,a) -> Int
+
+ rangeSize r@(l,u)
+ | l > u = 0
+ | otherwise = index r u + 1
+
+class Enum a where
+ succ, pred :: a -> a
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,m..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ -- Minimal complete definition: toEnum, fromEnum
+ succ = toEnum . (1+) . fromEnum
+ pred = toEnum . subtract 1 . fromEnum
+ enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
+ enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
+
+-- Read and Show classes ------------------------------------------------------
+
+type ReadS a = String -> [(a,String)]
+type ShowS = String -> String
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+ readList :: ReadS [a]
+
+ -- Minimal complete definition: readsPrec
+ readList = readParen False (\r -> [pr | ("[",s) <- lex r,
+ pr <- readl s ])
+ where readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- reads s,
+ (xs,u) <- readl' t]
+ readl' s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s,
+ (x,u) <- reads t,
+ (xs,v) <- readl' u]
+
+class Show a where
+ show :: a -> String
+ showsPrec :: Int -> a -> ShowS
+ showList :: [a] -> ShowS
+
+ -- Minimal complete definition: show or showsPrec
+ show x = showsPrec 0 x ""
+ showsPrec _ x s = show x ++ s
+ showList [] = showString "[]"
+ showList (x:xs) = showChar '[' . shows x . showl xs
+ where showl [] = showChar ']'
+ showl (x:xs) = showChar ',' . shows x . showl xs
+
+-- Monad classes ------------------------------------------------------------
+
+class Functor f where
+ fmap :: (a -> b) -> (f a -> f b)
+
+class Monad m where
+ return :: a -> m a
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ fail :: String -> m a
+
+ -- Minimal complete definition: (>>=), return
+ p >> q = p >>= \ _ -> q
+ fail s = error s
+
+accumulate :: Monad m => [m a] -> m [a]
+accumulate [] = return []
+accumulate (c:cs) = do x <- c
+ xs <- accumulate cs
+ return (x:xs)
+
+sequence :: Monad m => [m a] -> m ()
+sequence = foldr (>>) (return ())
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f = accumulate . map f
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f = sequence . map f
+
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+-- Evaluation and strictness ------------------------------------------------
+
+seq :: a -> b -> b
+seq x y = --case primForce x of () -> y
+ primSeq x y
+
+($!) :: (a -> b) -> a -> b
+f $! x = x `seq` f x
+
+-- Trivial type -------------------------------------------------------------
+
+-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+instance Eq () where
+ () == () = True
+
+instance Ord () where
+ compare () () = EQ
+
+instance Ix () where
+ range ((),()) = [()]
+ index ((),()) () = 0
+ inRange ((),()) () = True
+
+instance Enum () where
+ toEnum 0 = ()
+ fromEnum () = 0
+ enumFrom () = [()]
+ enumFromThen () () = [()]
+
+instance Read () where
+ readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
+ (")",t) <- lex s ])
+
+instance Show () where
+ showsPrec p () = showString "()"
+
+instance Bounded () where
+ minBound = ()
+ maxBound = ()
+
+-- Boolean type -------------------------------------------------------------
+
+data Bool = False | True
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+(&&), (||) :: Bool -> Bool -> Bool
+False && x = False
+True && x = x
+False || x = x
+True || x = True
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+otherwise :: Bool
+otherwise = True
+
+-- Character type -----------------------------------------------------------
+
+data Char -- builtin datatype of ISO Latin characters
+type String = [Char] -- strings are lists of characters
+
+instance Eq Char where (==) = primEqChar
+instance Ord Char where (<=) = primLeChar
+
+instance Enum Char where
+ toEnum = primIntToChar
+ fromEnum = primCharToInt
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
+ where lastChar = if d < c then minBound else maxBound
+
+instance Ix Char where
+ range (c,c') = [c..c']
+ index b@(c,c') ci
+ | inRange b ci = fromEnum ci - fromEnum c
+ | otherwise = error "Ix.index: Index out of range."
+ inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
+ where i = fromEnum ci
+
+instance Read Char where
+ readsPrec p = readParen False
+ (\r -> [(c,t) | ('\'':s,t) <- lex r,
+ (c,"\'") <- readLitChar s ])
+ readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+ (l,_) <- readl s ])
+ where readl ('"':s) = [("",s)]
+ readl ('\\':'&':s) = readl s
+ readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
+ (cs,u) <- readl t ]
+instance Show Char where
+ showsPrec p '\'' = showString "'\\''"
+ showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
+
+ showList cs = showChar '"' . showl cs
+ where showl "" = showChar '"'
+ showl ('"':cs) = showString "\\\"" . showl cs
+ showl (c:cs) = showLitChar c . showl cs
+
+instance Bounded Char where
+ minBound = '\0'
+ maxBound = '\255'
+
+isAscii, isControl, isPrint, isSpace :: Char -> Bool
+isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
+
+isAscii c = fromEnum c < 128
+isControl c = c < ' ' || c == '\DEL'
+isPrint c = c >= ' ' && c <= '~'
+isSpace c = c == ' ' || c == '\t' || c == '\n' ||
+ c == '\r' || c == '\f' || c == '\v'
+isUpper c = c >= 'A' && c <= 'Z'
+isLower c = c >= 'a' && c <= 'z'
+isAlpha c = isUpper c || isLower c
+isDigit c = c >= '0' && c <= '9'
+isAlphaNum c = isAlpha c || isDigit c
+
+-- Digit conversion operations
+digitToInt :: Char -> Int
+digitToInt c
+ | isDigit c = fromEnum c - fromEnum '0'
+ | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error "Char.digitToInt: not a digit"
+
+intToDigit :: Int -> Char
+intToDigit i
+ | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
+ | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
+ | otherwise = error "Char.intToDigit: not a digit"
+
+toUpper, toLower :: Char -> Char
+toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
+ | otherwise = c
+
+toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
+ | otherwise = c
+
+ord :: Char -> Int
+ord = fromEnum
+
+chr :: Int -> Char
+chr = toEnum
+
+-- Maybe type ---------------------------------------------------------------
+
+data Maybe a = Nothing | Just a
+ deriving (Eq, Ord, Read, Show)
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
+
+instance Functor Maybe where
+ fmap f Nothing = Nothing
+ fmap f (Just x) = Just (f x)
+
+instance Monad Maybe where
+ Just x >>= k = k x
+ Nothing >>= k = Nothing
+ return = Just
+ fail s = Nothing
+
+-- Either type --------------------------------------------------------------
+
+data Either a b = Left a | Right b
+ deriving (Eq, Ord, Read, Show)
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either l r (Left x) = l x
+either l r (Right y) = r y
+
+-- Ordering type ------------------------------------------------------------
+
+data Ordering = LT | EQ | GT
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+-- Lists --------------------------------------------------------------------
+
+--data [a] = [] | a : [a] deriving (Eq, Ord)
+
+instance Eq a => Eq [a] where
+ [] == [] = True
+ (x:xs) == (y:ys) = x==y && xs==ys
+ _ == _ = False
+
+instance Ord a => Ord [a] where
+ compare [] (_:_) = LT
+ compare [] [] = EQ
+ compare (_:_) [] = GT
+ compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
+
+instance Functor [] where
+ fmap = map
+
+instance Monad [ ] where
+ (x:xs) >>= f = f x ++ (xs >>= f)
+ [] >>= f = []
+ return x = [x]
+ fail s = []
+
+instance Read a => Read [a] where
+ readsPrec p = readList
+
+instance Show a => Show [a] where
+ showsPrec p = showList
+
+-- Tuples -------------------------------------------------------------------
+
+-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
+-- etc..
+
+-- Functions ----------------------------------------------------------------
+
+instance Show (a -> b) where
+ showsPrec p f = showString "<<function>>"
+
+instance Functor ((->) a) where
+ fmap = (.)
+
+-- Standard Integral types --------------------------------------------------
+
+data Int -- builtin datatype of fixed size integers
+data Integer -- builtin datatype of arbitrary size integers
+
+instance Eq Integer where
+ (==) x y = primCompareInteger x y == 0
+
+instance Ord Integer where
+ compare x y = case primCompareInteger x y of
+ -1 -> LT
+ 0 -> EQ
+ 1 -> GT
+
+instance Eq Int where
+ (==) = primEqInt
+ (/=) = primNeInt
+
+instance Ord Int where
+ (<) = primLtInt
+ (<=) = primLeInt
+ (>=) = primGeInt
+ (>) = primGtInt
+
+instance Num Int where
+ (+) = primPlusInt
+ (-) = primMinusInt
+ negate = primNegateInt
+ (*) = primTimesInt
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToInt
+ fromInt x = x
+
+instance Bounded Int where
+ minBound = primMinInt
+ maxBound = primMaxInt
+
+instance Num Integer where
+ (+) = primPlusInteger
+ (-) = primMinusInteger
+ negate = primNegateInteger
+ (*) = primTimesInteger
+ abs = absReal
+ signum = signumReal
+ fromInteger x = x
+ fromInt = primIntToInteger
+
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Real Integer where
+ toRational x = x % 1
+
+instance Integral Int where
+ quotRem = primQuotRemInt
+ toInteger = primIntToInteger
+ toInt x = x
+
+instance Integral Integer where
+ quotRem = primQuotRemInteger
+ divMod = primDivModInteger
+ toInteger = id
+ toInt = primIntegerToInt
+
+instance Ix Int where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = i - m
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Ix Integer where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = fromInteger (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int where
+ toEnum = id
+ fromEnum = id
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Integer where
+ toEnum = primIntToInteger
+ fromEnum = primIntegerToInt
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: Real a => a -> [a]
+numericEnumFromThen :: Real a => a -> a -> [a]
+numericEnumFromTo :: Real a => a -> a -> [a]
+numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
+numericEnumFrom n = n : (numericEnumFrom $! (n+1))
+numericEnumFromThen n m = iterate ((m-n)+) n
+numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
+ where p | n' > n = (<= m)
+ | otherwise = (>= m)
+
+instance Read Int where
+ readsPrec p = readSigned readDec
+
+instance Show Int where
+ showsPrec p n
+ | n == minBound = showSigned showInt p (toInteger n)
+ | otherwise = showSigned showInt p n
+
+instance Read Integer where
+ readsPrec p = readSigned readDec
+
+instance Show Integer where
+ showsPrec = showSigned showInt
+
+-- Standard Floating types --------------------------------------------------
+
+data Float -- builtin datatype of single precision floating point numbers
+data Double -- builtin datatype of double precision floating point numbers
+
+instance Eq Float where
+ (==) = primEqFloat
+ (/=) = primNeFloat
+
+instance Ord Float where
+ (<) = primLtFloat
+ (<=) = primLeFloat
+ (>=) = primGeFloat
+ (>) = primGtFloat
+
+instance Num Float where
+ (+) = primPlusFloat
+ (-) = primMinusFloat
+ negate = primNegateFloat
+ (*) = primTimesFloat
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToFloat
+ fromInt = primIntToFloat
+
+
+
+instance Eq Double where
+ (==) = primEqDouble
+ (/=) = primNeDouble
+
+instance Ord Double where
+ (<) = primLtDouble
+ (<=) = primLeDouble
+ (>=) = primGeDouble
+ (>) = primGtDouble
+
+instance Num Double where
+ (+) = primPlusDouble
+ (-) = primMinusDouble
+ negate = primNegateDouble
+ (*) = primTimesDouble
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToDouble
+ fromInt = primIntToDouble
+
+
+
+instance Real Float where
+ toRational = floatToRational
+
+instance Real Double where
+ toRational = doubleToRational
+
+-- Calls to these functions are optimised when passed as arguments to
+-- fromRational.
+floatToRational :: Float -> Rational
+doubleToRational :: Double -> Rational
+floatToRational x = realFloatToRational x
+doubleToRational x = realFloatToRational x
+
+realFloatToRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) = primDivideFloat
+ fromRational = rationalToRealFloat
+ fromDouble = primDoubleToFloat
+
+
+instance Fractional Double where
+ (/) = primDivideDouble
+ fromRational = rationalToRealFloat
+ fromDouble x = x
+
+rationalToRealFloat x = x'
+ where x' = f e
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1%b)^^e)) e
+ (_,e') = decodeFloat y
+ (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+ b = floatRadix x'
+
+instance Floating Float where
+ pi = 3.14159265358979323846
+ exp = primExpFloat
+ log = primLogFloat
+ sqrt = primSqrtFloat
+ sin = primSinFloat
+ cos = primCosFloat
+ tan = primTanFloat
+ asin = primAsinFloat
+ acos = primAcosFloat
+ atan = primAtanFloat
+
+instance Floating Double where
+ pi = 3.14159265358979323846
+ exp = primExpDouble
+ log = primLogDouble
+ sqrt = primSqrtDouble
+ sin = primSinDouble
+ cos = primCosDouble
+ tan = primTanDouble
+ asin = primAsinDouble
+ acos = primAcosDouble
+ atan = primAtanDouble
+
+instance RealFrac Float where
+ properFraction = floatProperFraction
+
+instance RealFrac Double where
+ properFraction = floatProperFraction
+
+floatProperFraction x
+ | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
+ | otherwise = (fromInteger w, encodeFloat r n)
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+ (w,r) = quotRem m (b^(-n))
+
+instance RealFloat Float where
+ floatRadix _ = toInteger primRadixFloat
+ floatDigits _ = primDigitsFloat
+ floatRange _ = (primMinExpFloat,primMaxExpFloat)
+ encodeFloat = primEncodeFloatZ
+ decodeFloat = primDecodeFloatZ
+ isNaN = primIsNaNFloat
+ isInfinite = primIsInfiniteFloat
+ isDenormalized= primIsDenormalizedFloat
+ isNegativeZero= primIsNegativeZeroFloat
+ isIEEE = const primIsIEEEFloat
+
+instance RealFloat Double where
+ floatRadix _ = toInteger primRadixDouble
+ floatDigits _ = primDigitsDouble
+ floatRange _ = (primMinExpDouble,primMaxExpDouble)
+ encodeFloat = primEncodeDoubleZ
+ decodeFloat = primDecodeDoubleZ
+ isNaN = primIsNaNDouble
+ isInfinite = primIsInfiniteDouble
+ isDenormalized= primIsDenormalizedDouble
+ isNegativeZero= primIsNegativeZeroDouble
+ isIEEE = const primIsIEEEDouble
+
+instance Enum Float where
+ toEnum = primIntToFloat
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Enum Double where
+ toEnum = primIntToDouble
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Read Float where
+ readsPrec p = readSigned readFloat
+
+instance Show Float where
+ showsPrec p = showFloat
+ --error "should call showFloat"
+
+instance Read Double where
+ readsPrec p = readSigned readFloat
+
+-- Note that showFloat in Numeric isn't used here
+instance Show Double where
+ showsPrec p = showFloat
+ --error "should call showFloat"
+
+-- Some standard functions --------------------------------------------------
+
+fst :: (a,b) -> a
+fst (x,_) = x
+
+snd :: (a,b) -> b
+snd (_,y) = y
+
+curry :: ((a,b) -> c) -> (a -> b -> c)
+curry f x y = f (x,y)
+
+uncurry :: (a -> b -> c) -> ((a,b) -> c)
+uncurry f p = f (fst p) (snd p)
+
+id :: a -> a
+id x = x
+
+const :: a -> b -> a
+const k _ = k
+
+(.) :: (b -> c) -> (a -> b) -> (a -> c)
+(f . g) x = f (g x)
+
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+($) :: (a -> b) -> a -> b
+f $ x = f x
+
+until :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x = if p x then x else until p f (f x)
+
+asTypeOf :: a -> a -> a
+asTypeOf = const
+
+error :: String -> a
+error msg = primRaise (ErrorCall msg)
+
+undefined :: a
+undefined | False = undefined
+
+-- Standard functions on rational numbers {PreludeRatio} --------------------
+
+data Integral a => Ratio a = a :% a deriving (Eq)
+type Rational = Ratio Integer
+
+(%) :: Integral a => a -> a -> Ratio a
+x % y = reduce (x * signum y) (abs y)
+
+reduce :: Integral a => a -> a -> Ratio a
+reduce x y | y == 0 = error "Ratio.%: zero denominator"
+ | otherwise = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+
+numerator, denominator :: Integral a => Ratio a -> a
+numerator (x :% y) = x
+denominator (x :% y) = y
+
+instance Integral a => Ord (Ratio a) where
+ compare (x:%y) (x':%y') = compare (x*y') (x'*y)
+
+instance Integral a => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x*x') (y*y')
+ negate (x :% y) = negate x :% y
+ abs (x :% y) = abs x :% y
+ signum (x :% y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+ fromInt = intToRatio
+
+-- Hugs optimises code of the form fromRational (intToRatio x)
+intToRatio :: Integral a => Int -> Ratio a
+intToRatio x = fromInt x :% 1
+
+instance Integral a => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance Integral a => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+ fromDouble = doubleToRatio
+
+-- Hugs optimises code of the form fromRational (doubleToRatio x)
+doubleToRatio :: Integral a => Double -> Ratio a
+doubleToRatio x
+ | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
+ | otherwise = fromInteger m % (fromInteger b ^ (-n))
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Integral a => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromIntegral q, r:%y)
+ where (q,r) = quotRem x y
+
+instance Integral a => Enum (Ratio a) where
+ toEnum = fromInt
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+
+instance (Read a, Integral a) => Read (Ratio a) where
+ readsPrec p = readParen (p > 7)
+ (\r -> [(x%y,u) | (x,s) <- reads r,
+ ("%",t) <- lex s,
+ (y,u) <- reads t ])
+
+instance Integral a => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > 7)
+ (shows x . showString " % " . shows y)
+
+approxRational :: RealFrac a => a -> a -> Rational
+approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr@(n:%d) = toRational x
+ (n':%d') = toRational y
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ (n'':%d'') = simplest' d' r' d r
+
+-- Standard list functions {PreludeList} ------------------------------------
+
+head :: [a] -> a
+head (x:_) = x
+
+last :: [a] -> a
+last [x] = x
+last (_:xs) = last xs
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+
+init :: [a] -> [a]
+init [x] = []
+init (x:xs) = x : init xs
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+(++) :: [a] -> [a] -> [a]
+[] ++ ys = ys
+(x:xs) ++ ys = x : (xs ++ ys)
+
+map :: (a -> b) -> [a] -> [b]
+map f xs = [ f x | x <- xs ]
+
+filter :: (a -> Bool) -> [a] -> [a]
+filter p xs = [ x | x <- xs, p x ]
+
+concat :: [[a]] -> [a]
+concat = foldr (++) []
+
+length :: [a] -> Int
+length = foldl' (\n _ -> n + 1) 0
+
+(!!) :: [b] -> Int -> b
+(x:_) !! 0 = x
+(_:xs) !! n | n>0 = xs !! (n-1)
+(_:_) !! _ = error "Prelude.!!: negative index"
+[] !! _ = error "Prelude.!!: index too large"
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z [] = z
+foldl f z (x:xs) = foldl f (f z x) xs
+
+foldl' :: (a -> b -> a) -> a -> [b] -> a
+foldl' f a [] = a
+foldl' f a (x:xs) = (foldl' f $! f a x) xs
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs = q : (case xs of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 f [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+
+scanr :: (a -> b -> b) -> b -> [a] -> [b]
+scanr f q0 [] = [q0]
+scanr f q0 (x:xs) = f x q : qs
+ where qs@(q:_) = scanr f q0 xs
+
+scanr1 :: (a -> a -> a) -> [a] -> [a]
+scanr1 f [x] = [x]
+scanr1 f (x:xs) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+repeat :: a -> [a]
+repeat x = xs where xs = x:xs
+
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+cycle :: [a] -> [a]
+cycle [] = error "Prelude.cycle: empty list"
+cycle xs = xs' where xs'=xs++xs'
+
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n>0 = x : take (n-1) xs
+take _ _ = error "Prelude.take: negative argument"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n>0 = drop (n-1) xs
+drop _ _ = error "Prelude.drop: negative argument"
+
+splitAt :: Int -> [a] -> ([a], [a])
+splitAt 0 xs = ([],xs)
+splitAt _ [] = ([],[])
+splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
+splitAt _ _ = error "Prelude.splitAt: negative argument"
+
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile p [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+dropWhile :: (a -> Bool) -> [a] -> [a]
+dropWhile p [] = []
+dropWhile p xs@(x:xs')
+ | p x = dropWhile p xs'
+ | otherwise = xs
+
+span, break :: (a -> Bool) -> [a] -> ([a],[a])
+span p [] = ([],[])
+span p xs@(x:xs')
+ | p x = (x:ys, zs)
+ | otherwise = ([],xs)
+ where (ys,zs) = span p xs'
+break p = span (not . p)
+
+lines :: String -> [String]
+lines "" = []
+lines s = let (l,s') = break ('\n'==) s
+ in l : case s' of [] -> []
+ (_:s'') -> lines s''
+
+words :: String -> [String]
+words s = case dropWhile isSpace s of
+ "" -> []
+ s' -> w : words s''
+ where (w,s'') = break isSpace s'
+
+unlines :: [String] -> String
+unlines = concatMap (\l -> l ++ "\n")
+
+unwords :: [String] -> String
+unwords [] = []
+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
+
+reverse :: [a] -> [a]
+reverse = foldl (flip (:)) []
+
+and, or :: [Bool] -> Bool
+and = foldr (&&) True
+or = foldr (||) False
+
+any, all :: (a -> Bool) -> [a] -> Bool
+any p = or . map p
+all p = and . map p
+
+elem, notElem :: Eq a => a -> [a] -> Bool
+elem = any . (==)
+notElem = all . (/=)
+
+lookup :: Eq a => a -> [(a,b)] -> Maybe b
+lookup k [] = Nothing
+lookup k ((x,y):xys)
+ | k==x = Just y
+ | otherwise = lookup k xys
+
+sum, product :: Num a => [a] -> a
+sum = foldl' (+) 0
+product = foldl' (*) 1
+
+maximum, minimum :: Ord a => [a] -> a
+maximum = foldl1 max
+minimum = foldl1 min
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = concat . map f
+
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipWith (\a b -> (a,b))
+
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3 = zipWith3 (\a b c -> (a,b,c))
+
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
+zipWith _ _ _ = []
+
+zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ = []
+
+unzip :: [(a,b)] -> ([a],[b])
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
+
+unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+ ([],[],[])
+
+-- PreludeText ----------------------------------------------------------------
+
+reads :: Read a => ReadS a
+reads = readsPrec 0
+
+shows :: Show a => a -> ShowS
+shows = showsPrec 0
+
+read :: Read a => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error "Prelude.read: no parse"
+ _ -> error "Prelude.read: ambiguous parse"
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+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
+
+readParen :: Bool -> ReadS a -> ReadS a
+readParen b g = if b then mandatory else optional
+ where optional r = g r ++ mandatory r
+ mandatory r = [(x,u) | ("(",s) <- lex r,
+ (x,t) <- optional s,
+ (")",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 ]
+
+lex :: ReadS String
+lex "" = [("","")]
+lex (c:s) | isSpace c = lex (dropWhile isSpace s)
+lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
+ ch /= "'" ]
+lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
+ where
+ lexString ('"':s) = [("\"",s)]
+ lexString s = [(ch++str, u)
+ | (ch,t) <- lexStrItem s,
+ (str,u) <- lexString t ]
+
+ lexStrItem ('\\':'&':s) = [("\\&",s)]
+ lexStrItem ('\\':c:s) | isSpace c
+ = [("",t) | '\\':t <- [dropWhile isSpace s]]
+ lexStrItem s = lexLitChar s
+
+lex (c:s) | isSingle c = [([c],s)]
+ | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
+ | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
+ | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
+ (fe,t) <- lexFracExp s ]
+ | otherwise = [] -- bad character
+ where
+ isSingle c = c `elem` ",;()[]{}_`"
+ isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
+ isIdChar c = isAlphaNum c || c `elem` "_'"
+
+ lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
+ (e,u) <- lexExp t ]
+ lexFracExp s = [("",s)]
+
+ lexExp (e:s) | e `elem` "eE"
+ = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
+ (ds,u) <- lexDigits t] ++
+ [(e:ds,t) | (ds,t) <- lexDigits s]
+ lexExp s = [("",s)]
+
+lexDigits :: ReadS String
+lexDigits = nonnull isDigit
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+lexLitChar :: ReadS String
+lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
+ where
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(mne,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ lexEsc _ = []
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+
+isOctDigit c = c >= '0' && c <= '7'
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
+ || c >= 'a' && c <= 'f'
+
+lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
+lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
+lexmatch xs ys = (xs,ys)
+
+asciiTab = zip ['\NUL'..' ']
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+
+readLitChar :: ReadS Char
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = [('\a',s)]
+ readEsc ('b':s) = [('\b',s)]
+ readEsc ('f':s) = [('\f',s)]
+ readEsc ('n':s) = [('\n',s)]
+ readEsc ('r':s) = [('\r',s)]
+ readEsc ('t':s) = [('\t',s)]
+ readEsc ('v':s) = [('\v',s)]
+ readEsc ('\\':s) = [('\\',s)]
+ readEsc ('"':s) = [('"',s)]
+ readEsc ('\'':s) = [('\'',s)]
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = [(toEnum (fromEnum c - fromEnum '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(toEnum n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' .
+ protectEsc isDigit (shows (fromEnum c))
+showLitChar '\DEL' = showString "\\DEL"
+showLitChar '\\' = showString "\\\\"
+showLitChar c | c >= ' ' = showChar c
+showLitChar '\a' = showString "\\a"
+showLitChar '\b' = showString "\\b"
+showLitChar '\f' = showString "\\f"
+showLitChar '\n' = showString "\\n"
+showLitChar '\r' = showString "\\r"
+showLitChar '\t' = showString "\\t"
+showLitChar '\v' = showString "\\v"
+showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
+showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+-- Unsigned readers for various bases
+readDec, readOct, readHex :: Integral a => ReadS a
+readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
+readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
+readHex = readInt 16 isHexDigit hex
+ where hex d = fromEnum d -
+ (if isDigit d
+ then fromEnum '0'
+ else fromEnum (if isUpper d then 'A' else 'a') - 10)
+
+-- readInt reads a string of digits using an arbitrary base.
+-- Leading minus signs must be handled elsewhere.
+
+readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+-- showInt is used for positive numbers only
+showInt :: Integral a => a -> ShowS
+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
+ | otherwise =
+ let (n',d) = quotRem n 10
+ r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+
+readSigned:: Real a => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+ where read' r = read'' r ++
+ [(-x,t) | ("-",s) <- lex r,
+ (x,t) <- read'' s]
+ read'' r = [(n,s) | (str,s) <- lex r,
+ (n,"") <- readPos str]
+
+showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ else showPos x
+
+readFloat :: RealFloat a => ReadS a
+readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
+ (k,t) <- readExp s]
+ where readFix r = [(read (ds++ds'), length ds', t)
+ | (ds, s) <- lexDigits r
+ , (ds',t) <- lexFrac s ]
+
+ lexFrac ('.':s) = lexDigits s
+ lexFrac s = [("",s)]
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = [(0,s)]
+
+ readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+ readExp' ('+':s) = readDec s
+ readExp' s = readDec s
+
+
+-- Hooks for primitives: -----------------------------------------------------
+-- Do not mess with these!
+
+primCompAux :: Ord a => a -> a -> Ordering -> Ordering
+primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+
+primPmInt :: Num a => Int -> a -> Bool
+primPmInt n x = fromInt n == x
+
+primPmInteger :: Num a => Integer -> a -> Bool
+primPmInteger n x = fromInteger n == x
+
+primPmFlt :: Fractional a => Double -> a -> Bool
+primPmFlt n x = fromDouble n == x
+
+-- ToDo: make the message more informative.
+primPmFail :: a
+primPmFail = error "Pattern Match Failure"
+primPmFailBUG :: a
+primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++
+ "**Please** report to v-julsew@microsoft.com. Thx!\n")
+
+-- used in desugaring Foreign functions
+primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+primMkIO = ST
+
+-- The following primitives are only needed if (n+k) patterns are enabled:
+primPmNpk :: Integral a => Int -> a -> Maybe a
+primPmNpk n x = if n'<=x then Just (x-n') else Nothing
+ where n' = fromInt n
+
+primPmSub :: Integral a => Int -> a -> a
+primPmSub n x = x - fromInt n
+
+-- Unpack strings generated by the Hugs code generator.
+-- Strings can contain \0 provided they're coded right.
+--
+-- ToDo: change this (and Hugs code generator) to use ByteArrays
+
+primUnpackString :: Addr -> String
+primUnpackString a = unpack 0
+ where
+ -- The following decoding is based on evalString in the old machine.c
+ unpack i
+ | c == '\0' = []
+ | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
+ then '\\' : unpack (i+2)
+ else '\0' : unpack (i+2)
+ | otherwise = c : unpack (i+1)
+ where
+ c = primIndexCharOffAddr a i
+
+
+-- Monadic I/O: --------------------------------------------------------------
+
+type FilePath = String
+
+--data IOError = ...
+--instance Eq IOError ...
+--instance Show IOError ...
+
+data IOError = IOError String
+instance Show IOError where
+ showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
+
+ioError :: IOError -> IO a
+ioError (IOError s) = primRaise (IOExcept s)
+
+userError :: String -> IOError
+userError s = primRaise (ErrorCall s)
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch x eh = primCatch x (eh.exception2ioerror)
+ where
+ exception2ioerror (IOExcept s) = IOError s
+ exception2ioerror other = IOError (show other)
+
+putChar :: Char -> IO ()
+putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
+
+putStr :: String -> IO ()
+putStr s = --mapM_ putChar s -- correct, but slow
+ nh_stdout >>= \h ->
+ let loop [] = return ()
+ loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
+ in loop s
+
+putStrLn :: String -> IO ()
+putStrLn s = do { putStr s; putChar '\n' }
+
+print :: Show a => a -> IO ()
+print = putStrLn . show
+
+getChar :: IO Char
+getChar = unsafeInterleaveIO (
+ nh_stdin >>= \h ->
+ nh_read h >>= \ci ->
+ return (primIntToChar ci)
+ )
+
+getLine :: IO String
+getLine = do c <- getChar
+ if c=='\n' then return ""
+ else do cs <- getLine
+ return (c:cs)
+
+getContents :: IO String
+getContents = nh_stdin >>= \h -> readfromhandle h
+
+interact :: (String -> String) -> IO ()
+interact f = getContents >>= (putStr . f)
+
+readFile :: FilePath -> IO String
+readFile fname
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 0 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("readFile: can't open file " ++ fname)
+ else readfromhandle h
+
+writeFile :: FilePath -> String -> IO ()
+writeFile fname contents
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 1 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("writeFile: can't create file " ++ fname)
+ else writetohandle fname h contents
+
+
+appendFile :: FilePath -> String -> IO ()
+appendFile fname contents
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 2 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("appendFile: can't open file " ++ fname)
+ else writetohandle fname h contents
+
+
+-- raises an exception instead of an error
+readIO :: Read a => String -> IO a
+readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> return x
+ [] -> ioError (userError "PreludeIO.readIO: no parse")
+ _ -> ioError (userError
+ "PreludeIO.readIO: ambiguous parse")
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+
+-- End of Hugs standard prelude ----------------------------------------------
+
+data Exception
+ = ErrorCall String
+ | IOExcept String
+
+instance Show Exception where
+ showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
+ showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
+
+data IOResult = IOResult deriving (Show)
+
+type FILE_STAR = Int
+
+foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
+foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
+foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
+foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
+
+foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int
+foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO ()
+foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int
+
+fileopen_sendname :: String -> IO Int
+fileopen_sendname fname
+ = nh_malloc (1 + length fname) >>= \ptr ->
+ let loop i [] = nh_assign ptr i 0 >> return ptr
+ loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs
+ in
+ loop 0 fname
+
+readfromhandle :: FILE_STAR -> IO String
+readfromhandle h
+ = unsafeInterleaveIO (
+ nh_read h >>= \ci ->
+ if ci == -1 {-EOF-} then return "" else
+ readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
+ )
+
+writetohandle :: String -> FILE_STAR -> String -> IO ()
+writetohandle fname h []
+ = nh_close h >>
+ nh_errno >>= \errno ->
+ if errno == 0
+ then return ()
+ else error ( "writeFile/appendFile: error closing file " ++ fname)
+writetohandle fname h (c:cs)
+ = nh_write h (primCharToInt c) >>
+ writetohandle fname h cs
+
+------------------------------------------------------------------------------
+-- ST, IO --------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+newtype ST s a = ST (s -> (a,s))
+
+data RealWorld
+type IO a = ST RealWorld a
+
+
+--runST :: (forall s. ST s a) -> a
+runST :: ST RealWorld a -> a
+runST m = fst (unST m theWorld)
+ where
+ theWorld :: RealWorld
+ theWorld = error "runST: entered the RealWorld"
+
+unST (ST a) = a
+
+instance Functor (ST s) where
+ fmap f x = x >>= (return . f)
+
+instance Monad (ST s) where
+ m >> k = m >>= \ _ -> k
+ return x = ST $ \ s -> (x,s)
+ m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
+
+
+-- used when Hugs invokes top level function
+primRunIO :: IO () -> ()
+primRunIO m
+ = protect (fst (unST m realWorld))
+ where
+ realWorld = error "panic: Hugs entered the real world"
+ protect :: () -> ()
+ protect comp
+ = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld))
+
+trace :: String -> a -> a
+trace s x
+ = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO = unsafeInterleaveST
+
+
+------------------------------------------------------------------------------
+-- Addr, ForeignObj, Prim*Array ----------------------------------------------
+------------------------------------------------------------------------------
+
+data Addr
+
+nullAddr = primIntToAddr 0
+
+instance Eq Addr where
+ (==) = primEqAddr
+ (/=) = primNeAddr
+
+instance Ord Addr where
+ (<) = primLtAddr
+ (<=) = primLeAddr
+ (>=) = primGeAddr
+ (>) = primGtAddr
+
+
+data ForeignObj
+makeForeignObj :: Addr -> IO ForeignObj
+makeForeignObj = primMakeForeignObj
+
+
+data PrimArray a -- immutable arrays with Int indices
+data PrimByteArray
+
+data Ref s a -- mutable variables
+data PrimMutableArray s a -- mutable arrays with Int indices
+data PrimMutableByteArray s
+
+
+------------------------------------------------------------------------------
+-- hooks to call libHS_cbits -------------------------------------------------
+------------------------------------------------------------------------------
+{-
+type FILE_OBJ = ForeignObj -- as passed into functions
+type CString = PrimByteArray
+type How = Int
+type Binary = Int
+type OpenFlags = Int
+type IOFileAddr = Addr -- as returned from functions
+type FD = Int
+type OpenStdFlags = Int
+type Readable = Int -- really Bool
+type Exclusive = Int -- really Bool
+type RC = Int -- standard return code
+type Bytes = PrimMutableByteArray RealWorld
+type Flush = Int -- really Bool
+
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
+ freeStdFileObject :: ForeignObj -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "freeFileObject"
+ freeFileObject :: ForeignObj -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "setBuf"
+ prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "getBufSize"
+ prim_getBufSize :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "inputReady"
+ prim_inputReady :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "fileGetc"
+ prim_fileGetc :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "fileLookAhead"
+ prim_fileLookAhead :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readBlock"
+ prim_readBlock :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readLine"
+ prim_readLine :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readChar"
+ prim_readChar :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "writeFileObject"
+ prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "filePutc"
+ prim_filePutc :: FILE_OBJ -> Char -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getBufStart"
+ prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
+ prim_getWriteableBuf :: FILE_OBJ -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getBufWPtr"
+ prim_getBufWPtr :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "setBufWPtr"
+ prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "closeFile"
+ prim_closeFile :: FILE_OBJ -> Flush -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "fileEOF"
+ prim_fileEOF :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setBuffering"
+ prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "flushFile"
+ prim_flushFile :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getBufferMode"
+ prim_getBufferMode :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "seekFileP"
+ prim_seekFileP :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
+ prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
+ prim_getTerminalEcho :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
+ prim_isTerminalDevice :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setConnectedTo"
+ prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "ungetChar"
+ prim_ungetChar :: FILE_OBJ -> Char -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "readChunk"
+ prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "writeBuf"
+ prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getFileFd"
+ prim_getFileFd :: FILE_OBJ -> IO FD
+
+foreign import stdcall "libHS_cbits.so" "fileSize_int64"
+ prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getFilePosn"
+ prim_getFilePosn :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "setFilePosn"
+ prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "getConnFileFd"
+ prim_getConnFileFd :: FILE_OBJ -> IO FD
+
+foreign import stdcall "libHS_cbits.so" "allocMemory__"
+ prim_allocMemory__ :: Int -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getLock"
+ prim_getLock :: FD -> Exclusive -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "openStdFile"
+ prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
+
+foreign import stdcall "libHS_cbits.so" "openFile"
+ prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
+
+foreign import stdcall "libHS_cbits.so" "freeFileObject"
+ prim_freeFileObject :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
+ prim_freeStdFileObject :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
+ const_BUFSIZ :: Int
+
+foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
+ prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
+ prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
+ prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
+ prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "getErrStr__"
+ prim_getErrStr__ :: IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getErrNo__"
+ prim_getErrNo__ :: IO Int
+
+foreign import stdcall "libHS_cbits.so" "getErrType__"
+ prim_getErrType__ :: IO Int
+
+--foreign import stdcall "libHS_cbits.so" "seekFile_int64"
+-- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+-}
+
+-- showFloat ------------------------------------------------------------------
+
+showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat :: (RealFloat a) => a -> ShowS
+
+showEFloat d x = showString (formatRealFloat FFExponent d x)
+showFFloat d x = showString (formatRealFloat FFFixed d x)
+showGFloat d x = showString (formatRealFloat FFGeneric d x)
+showFloat = showGFloat Nothing
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where base = 10
+ s = if isNaN x then
+ "NaN"
+ else if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else if x < 0 || isNegativeZero x then
+ '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is
+ in case fmt of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is, e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ case ds of
+ ['0'] -> "0.0e0"
+ [d] -> d : ".0e" ++ show (e-1)
+ d:ds -> d : '.' : ds ++ 'e':show (e-1)
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let (ei, is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit
+ (if ei > 0 then init is' else is')
+ in d:'.':ds ++ "e" ++ show (e-1+ei)
+ FFFixed ->
+ case decs of
+ Nothing ->
+ let f 0 s ds = mk0 s ++ "." ++ mk0 ds
+ f n s "" = f (n-1) (s++"0") ""
+ f n s (d:ds) = f (n-1) (s++[d]) ds
+ mk0 "" = "0"
+ mk0 s = s
+ in f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let (ei, is') = roundTo base (dec' + e) is
+ (ls, rs) = splitAt (e+ei) (map intToDigit is')
+ in (if null ls then "0" else ls) ++
+ (if null rs then "" else '.' : rs)
+ else
+ let (ei, is') = roundTo base dec'
+ (replicate (-e) 0 ++ is)
+ d : ds = map intToDigit
+ (if ei > 0 then is' else 0:is')
+ in d : '.' : ds
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+ (0, is) -> (0, is)
+ (1, is) -> (1, 1 : is)
+ where b2 = base `div` 2
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+ f d (i:is) =
+ let (c, ds) = f (d-1) is
+ i' = c + i
+ in if i' == base then (1, 0:ds) else (0, i':ds)
+
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) = let n = minExp - e0
+ in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let k0 =
+
+ 0
+
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n
+ else fixup (n+1)
+ in fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k)
+ in gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in (map toInt (reverse rds), k)
+
+-- Exponentiation with(out) a cache for the most common numbers.
+expt :: Integer -> Int -> Integer
+expt base n = base^n
--- /dev/null
+-----------------------------------------------------------------------------
+-- Standard Library: Ratio and Rational types and operations
+--
+-- Suitable for use with Hugs 98
+-----------------------------------------------------------------------------
+
+module Ratio (
+ Ratio, Rational, (%), numerator, denominator, approxRational ) where
+
+-- This module is empty; Rational is currently defined in the prelude,
+-- but should eventually be moved to this library file instead.
+
+-----------------------------------------------------------------------------
* Hugs version 1.4, December 1997
*
* $RCSfile: link.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/01 14:46:47 $
+ * $Revision: 1.6 $
+ * $Date: 1999/03/09 14:51:08 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
Name namePmSub =BOGUS(63);
#endif
Name namePMFail =BOGUS(64);
+Name namePMFailBUG = BOGUS(666);
Name nameEqChar =BOGUS(65);
Name nameEqInt =BOGUS(66);
#if !OVERLOADED_CONSTANTS
Name nameError =BOGUS(77);
Name nameInd =BOGUS(78);
-Name nameForce =BOGUS(79);
-
Name nameAnd =BOGUS(80);
Name nameConCmp =BOGUS(82);
Name nameCompAux =BOGUS(83);
Name nameLex =BOGUS(98);
Name nameReadField =BOGUS(99);
Name nameFlip =BOGUS(100);
+
+Name namePrimSeq =BOGUS(1000);
+Name namePrimCatch =BOGUS(1001);
+Name namePrimRaise =BOGUS(1002);
+
Name nameFromTo =BOGUS(101);
Name nameFromThen =BOGUS(102);
Name nameFrom =BOGUS(103);
Name nameMFail =BOGUS(413);
Type typeOrdering =BOGUS(414);
Module modulePrelude =BOGUS(415);
+Name nameMap = BOGUS(416);
+Name nameMinus = BOGUS(417);
#define QQ(lval) assert(lval != 0); assert(lval <= -900000); lval
static Tycon linkClass ( String s );
static Name linkName ( String s );
static Void mkTypes ( void );
+static Name predefinePrim ( String s );
static Tycon linkTycon( String s )
EEND;
}
-/* ToDo: kill this! */
-static Name predefinePrim ( String s );
-static Name predefinePrim ( String s )
+static Name predefinePrim ( String s )
{
- Name nm = newName(findText(s),NIL);
- name(nm).defn=PREDEFINED;
+ Name nm;
+ Text t = findText(s);
+ nm = findName(t);
+ if (nonNull(nm)) {
+ //fprintf(stderr, "predefinePrim: %s already exists\n", s );
+ } else {
+ nm = newName(t,NIL);
+ name(nm).defn=PREDEFINED;
+ }
return nm;
}
if (!initialised) {
Int i;
initialised = TRUE;
- ////setCurrModule(modulePreludeHugs);
setCurrModule(modulePrelude);
QQ(typeChar ) = linkTycon("Char");
QQ(nameMkThreadId) = addPrimCfun(findTextREP("ThreadId#"),1,0,0);
QQ(nameMkMVar ) = addPrimCfun(findTextREP("MVar#"),1,0,0);
#endif
-#if 1
/* The following primitives are referred to in derived instances and
* hence require types; the following types are a little more general
* than we might like, but they are the closest we can get without a
name(nameEnFrTo).type
= name(nameEnFrTh).type
= mkPolyType(starToStar,fn(aVar,fn(aVar,listof)));
-#endif
+
+ name(namePrimSeq).type
+ = primType(MONAD_Id, "ab", "b");
+ name(namePrimCatch).type
+ = primType(MONAD_Id, "aH", "a");
+ name(namePrimRaise).type
+ = primType(MONAD_Id, "E", "a");
#if EVAL_INSTANCES
addEvalInst(0,typeArrow,2,NIL); /* Add Eval instances for (->) */
#endif
QQ(nameMult ) = linkName("*");
QQ(nameRangeSize ) = linkName("rangeSize");
QQ(nameInRange ) = linkName("inRange");
+ QQ(nameMinus ) = linkName("-");
/* These come before calls to implementPrim */
for(i=0; i<NUM_TUPLES; ++i) {
implementTuple(i);
implementPrim(n);
}
- /* hooks for handwritten bytecode */
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Text t = findText("primSeq");
- Name n = newName(t,NIL);
- name(n).line = name(n).defn = 0;
- name(n).arity = 1;
- name(n).type = primType(MONAD_Id, "ab", "b");
- vv = mkStgVar(NIL,NIL);
- stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
-
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Text t = findText("primCatch");
- Name n = newName(t,NIL);
- name(n).line = name(n).defn = 0;
- name(n).arity = 2;
- name(n).type = primType(MONAD_Id, "aH", "a");
- stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
-
- {
- StgVar vv = mkStgVar(NIL,NIL);
- Text t = findText("primRaise");
- Name n = newName(t,NIL);
- name(n).line = name(n).defn = 0;
- name(n).arity = 1;
- name(n).type = primType(MONAD_Id, "E", "a");
- stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
- name(n).stgVar = vv;
- stgGlobals=cons(pair(n,vv),stgGlobals);
- }
-
/* static(tidyInfix) */
QQ(nameNegate ) = linkName("negate");
/* user interface */
////namePmLe = linkName("primPmLe");
////namePmSubtract = linkName("primPmSubtract");
////namePmFromInteger = linkName("primPmFromInteger");
+ ////QQ(nameMap ) = linkName("map");
}
}
pFun(nameComp, ".");
pFun(nameAnd, "&&");
pFun(nameCompAux, "primCompAux");
+ pFun(nameMap, "map");
/* implementTagToCon */
pFun(namePMFail, "primPmFail");
+ pFun(namePMFailBUG, "primPmFailBUG");
pFun(nameError, "error");
pFun(nameUnpackString, "primUnpackString");
+ /* hooks for handwritten bytecode */
+ pFun(namePrimSeq, "primSeq");
+ pFun(namePrimCatch, "primCatch");
+ pFun(namePrimRaise, "primRaise");
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimSeq;
+ name(n).line = 0;
+ name(n).arity = 1;
+ name(n).type = NIL;
+ vv = mkStgVar(NIL,NIL);
+ stgVarInfo(vv) = mkPtr ( asm_BCO_seq() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ namePrimSeq = n;
+ }
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimCatch;
+ name(n).line = 0;
+ name(n).arity = 2;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_catch() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+ {
+ StgVar vv = mkStgVar(NIL,NIL);
+ Name n = namePrimRaise;
+ name(n).line = 0;
+ name(n).arity = 1;
+ name(n).type = NIL;
+ stgVarInfo(vv) = mkPtr ( asm_BCO_raise() );
+ name(n).stgVar = vv;
+ stgGlobals=cons(pair(n,vv),stgGlobals);
+ }
+
break;
}
}
extern Cell conCons;
-extern Name nameForce;
extern Name nameRunIO;
/* The following data constructors are used to box unboxed
/* used in translation */
extern Name nameEq;
extern Name namePMFail;
+extern Name namePMFailBUG;
extern Name nameEqChar;
extern Name nameEqInt;
extern Name nameEqInteger;
extern Name namePmFromInteger;
extern Name nameMkIO;
extern Name nameUnpackString;
+extern Name namePrimSeq;
+extern Name nameMap;
+extern Name nameMinus;
+
extern Type arrow; /* mkOffset(0) -> mkOffset(1) */
extern Type listof; /* [ mkOffset(0) ] */
* Hugs version 1.4, December 1997
*
* $RCSfile: optimise.c,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:33 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/09 14:51:09 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static StgVar optimiseVar(StgVar v)
{
StgRhs rhs = stgVarBody(v);
- /* short circuit: let x = y in ...x... --> let x = y ...y... */
+fprintf(stderr,"optimiseVar ");printStg(stderr,v);fprintf(stderr,"\n");
+ /* short circuit: let x = y in ...x... --> let x = y in ...y... */
if (whatIs(rhs) == STGVAR && rhs != v) {
StgVar v1 = rhs;
+fprintf(stderr, "dumpable\n");
/* find last variable in chain */
rhs = stgVarBody(v1);
void optimiseBind( StgVar v )
{
- StgRhs rhs = stgVarBody(v);
+ StgRhs rhs;
+ rhs = stgVarBody(v);
switch (whatIs(rhs)) {
case STGCON:
mapOver(optimiseAtom,stgConArgs(rhs));
* by optimiseVar so we can drop the binding
* right now.
*/
+fprintf(stderr, "dropping bind ");printStg(stderr,b);fprintf(stderr, "\n");
} else {
+fprintf(stderr, "retaining bind ");printStg(stderr,b);fprintf(stderr, "\n");
binds = cons(hd(bs),binds);
}
}
return e;
}
+
+void optimiseTopBind( StgVar v )
+{
+if (lastModule() != modulePrelude) {
+fflush(stdout); fflush(stderr);
+fprintf ( stderr, "------------------------------\n" );
+fflush(stderr);
+printStg ( stderr, v );
+fprintf(stderr, "\n" );
+}
+optimiseBind ( v );
+if (lastModule() != modulePrelude) {
+printStg ( stderr,v );
+fprintf(stderr, "\n\n" );
+fflush(stderr);
+}
+}
+
/*-------------------------------------------------------------------------*/
* in the distribution for details.
*
* $RCSfile: parser.y,v $
- * $Revision: 1.3 $
- * $Date: 1999/02/03 17:08:34 $
+ * $Revision: 1.4 $
+ * $Date: 1999/03/09 14:51:09 $
* ------------------------------------------------------------------------*/
%{
ERRMSG(row) "Illegal left hand side in datatype definition"
EEND;
}
- assert(0); return 0; /* NOTREACHED */
+ return 0; /* NOTREACHED */
}
#if !TREX
* in the distribution for details.
*
* $RCSfile: static.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:51 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:10 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
EEND;
}
}
- assert(0); return 0; /* NOTREACHED */
+ return 0; /* NOTREACHED */
}
static List local checkExports(exports)
List ns = NIL; /* List of names */
Int mno; /* Member function number */
-//printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) );
+ //printf ( "\naddMembers: class = %s\n", textToStr ( cclass(c).text ) );
for (mno=0; mno<cclass(c).numSupers; mno++) {
ns = cons(newDSel(c,mno),ns);
}
name(m).arity = 1;
name(m).number = mfunNo(no);
name(m).type = t;
-//printf ( " [%d %d] %s :: ", m, m-NAMEMIN, textToStr ( name(m).text ) );
-//printType(stdout, t );
-//printf ( "\n" );
+ //printf ( " [%d %d] %s :: ", m, m-NAMEMIN, textToStr ( name(m).text ) );
+ //printType(stdout, t );
+ //printf ( "\n" );
return m;
}
inst(in).c,
extractBindings(inst(in).implements));
inst(in).builder = newInstImp(in);
- /*ToDo*/
- //fprintf(stderr, "\npreludeLoaded query\n" );
- if (/*!preludeLoaded &&*/ isNull(nameListMonad) && isAp(inst(in).head)
+ if (!preludeLoaded && isNull(nameListMonad) && isAp(inst(in).head)
&& fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
nameListMonad = inst(in).builder;
}
#endif
else if (isFloat(arg(temp))) {
if (nneg&1)
- arg(temp) = mkFloat(-floatOf(arg(temp)));
+ arg(temp) = floatNegate(arg(temp));
+ //mkFloat(-floatOf(arg(temp)));
}
else {
fun(prev) = nameNegate;
static List local dependencyAnal(bs) /* Separate lists of bindings into */
List bs; { /* mutually recursive groups in */
+ /* order of dependency */
mapProc(addDepField,bs); /* add extra field for dependents */
mapProc(depBinding,bs); /* find dependents of each binding */
bs = bscc(bs); /* sort to strongly connected comps*/
List bs; { /* bindings, possibly containing */
for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
if (nonNull(hd(bs))) { /* No need to add extra field for */
-
- //Printf("\n=========================================\n" ); print(hd(bs),1000); Printf("\n");
-
mapProc(depAlt,snd(hd(bs)));/* dependency information... */
}
}
mapProc(addMembers,classDefns); /* add definitions for member funs */
mapProc(visitClass,classDefns); /* check class hierarchy */
linkPreludeCM(); /* Get prelude cfuns and mfuns */
-
- /* ToDo: reinstate?
- mapOver(checkPrimDefn,primDefns); */ /* check primitive declarations */
instDefns = rev(instDefns); /* process instance definitions */
mapProc(checkInstDefn,instDefns);
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:53 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:13 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
* Hugs version 1.4, December 1997
*
* $RCSfile: stg.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:53 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:13 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
Void ppStgAlts( List alts )
{
- if (debugCode) {
+ if (1 /*debugCode*/ ) {
beginStgPP(stdout);
putStgAlts(0,alts);
endStgPP(stdout);
extern Void ppStgPrimAlts( List alts )
{
- if (debugCode) {
+ if (1 /*debugCode*/ ) {
beginStgPP(stdout);
putStgPrimAlts(0,alts);
endStgPP(stdout);
extern Void ppStgVars( List vs )
{
- if (debugCode) {
+ if (1 /*debugCode*/ ) {
beginStgPP(stdout);
printf("Vars: ");
putStgVars(vs);
* in the distribution for details.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:54 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:13 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
#if !IGNORE_MODULES
static Module local findQualifier Args((Text));
#endif
+static Void local hashTycon Args((Tycon));
static List local insertTycon Args((Tycon,List));
+static Void local hashName Args((Name));
static List local insertName Args((Name,List));
static Void local patternError Args((String));
static Bool local stringMatch Args((String,String));
}
}
internal("identToStr2");
- assert(0); return 0; /* NOTREACHED */
+ return 0; /* NOTREACHED */
}
Text inventText() { /* return new unused variable name */
* the most recent entry at the front of the list.
* ------------------------------------------------------------------------*/
- Tycon tyconHw; /* next unused Tycon */
+#define TYCONHSZ 256 /* Size of Tycon hash table*/
+#define tHash(x) ((x)%TYCONHSZ) /* Tycon hash function */
+static Tycon tyconHw; /* next unused Tycon */
+static Tycon DEFTABLE(tyconHash,TYCONHSZ); /* Hash table storage */
struct strTycon DEFTABLE(tabTycon,NUM_TYCON); /* Tycon storage */
Tycon newTycon(t) /* add new tycon to tycon table */
Text t; {
+ Int h = tHash(t);
if (tyconHw-TYCMIN >= NUM_TYCON) {
ERRMSG(0) "Type constructor storage space exhausted"
EEND;
tycon(tyconHw).mod = currentModule;
module(currentModule).tycons = cons(tyconHw,module(currentModule).tycons);
#endif
+ tycon(tyconHw).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tyconHw;
+
return tyconHw++;
}
-Tycon findTycon ( Text t )
-{
- int n;
- for (n = TYCMIN; n < tyconHw; n++)
- if (tycon(n).text == t) return n;
- return NIL;
+Tycon findTycon(t) /* locate Tycon in tycon table */
+Text t; {
+ Tycon tc = tyconHash[tHash(t)];
+
+ while (nonNull(tc) && tycon(tc).text!=t)
+ tc = tycon(tc).nextTyconHash;
+ return tc;
}
Tycon addTycon(tc) /* Insert Tycon in tycon table - if no clash is caused */
Tycon tc; {
Tycon oldtc = findTycon(tycon(tc).text);
if (isNull(oldtc)) {
- // hashTycon(tc);
+ hashTycon(tc);
#if !IGNORE_MODULES
module(currentModule).tycons=cons(tc,module(currentModule).tycons);
#endif
return oldtc;
}
+static Void local hashTycon(tc) /* Insert Tycon into hash table */
+Tycon tc; {
+ Text t = tycon(tc).text;
+ Int h = tHash(t);
+ tycon(tc).nextTyconHash = tyconHash[h];
+ tyconHash[h] = tc;
+}
+
Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
Cell id; {
if (!isPair(id)) internal("findQualTycon");
}
default : internal("findQualTycon2");
}
- assert(0); return 0; /* NOTREACHED */
+ return 0; /* NOTREACHED */
}
Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
Name newName(t,parent) /* Add new name to name table */
Text t;
Cell parent; {
- //Int h = nHash(t);
-
+ Int h = nHash(t);
if (nameHw-NAMEMIN >= NUM_NAME) {
ERRMSG(0) "Name storage space exhausted"
EEND;
name(nameHw).primop = 0;
name(nameHw).mod = currentModule;
module(currentModule).names=cons(nameHw,module(currentModule).names);
+ name(nameHw).nextNameHash = nameHash[h];
+ nameHash[h] = nameHw;
+assert ( name(nameHw).nextNameHash != nameHash[h] );
return nameHw++;
}
-Name findName ( Text t )
-{
- int n;
- for (n = NAMEMIN; n < nameHw; n++)
- if (name(n).text == t) return n;
- return NIL;
-}
-
+Name findName(t) /* Locate name in name table */
+Text t; {
+ Name n = nameHash[nHash(t)];
+ while (nonNull(n) && name(n).text!=t)
+ n = name(n).nextNameHash;
+ return n;
+}
Name addName(nm) /* Insert Name in name table - if */
Name nm; { /* no clash is caused */
Name oldnm = findName(name(nm).text);
if (isNull(oldnm)) {
- // hashName(nm);
+ hashName(nm);
#if !IGNORE_MODULES
module(currentModule).names=cons(nm,module(currentModule).names);
#endif
return oldnm;
}
+static Void local hashName(nm) /* Insert Name into hash table */
+Name nm; {
+ Text t = name(nm).text;
+ Int h = nHash(t);
+ name(nm).nextNameHash = nameHash[h];
+ nameHash[h] = nm;
+}
+
Name findQualName(id) /* Locate (possibly qualified) name*/
Cell id; { /* in name table */
if (!isPair(id))
Module m = findQualifier(qmodOf(id));
List es = NIL;
if (isNull(m)) return NIL;
- if (m==currentModule) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- return findName(t);
- }
for(es=module(m).exports; nonNull(es); es=tl(es)) {
Cell e = hd(es);
if (isName(e) && name(e).text==t)
else if (isClass(c))
subentities = cclass(c).members;
for(; nonNull(subentities); subentities=tl(subentities)) {
- assert(isName(hd(subentities)));
+ if (!isName(hd(subentities)))
+ internal("findQualName3");
if (name(hd(subentities)).text == t)
return hd(subentities);
}
}
default : internal("findQualName2");
}
- assert(0); return 0; /* NOTREACHED */
+ return 0; /* NOTREACHED */
}
/* --------------------------------------------------------------------------
inst(instHw).specifics = NIL;
inst(instHw).implements = NIL;
inst(instHw).builder = NIL;
- /* from STG */ inst(instHw).mod = currentModule;
return instHw++;
}
static local Module findQualifier(t) /* locate Module in import list */
Text t; {
Module ms;
- ////if (t==module(modulePreludeHugs).text) {
- if (t==module(modulePrelude).text) {
- /* The Haskell report (rightly) forbids this.
- * We added it to let the Prelude refer to itself
- * without having to import itself.
- */
- ////return modulePreludeHugs;
- return modulePrelude;
- }
for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
if (textOf(fst(hd(ms)))==t)
return snd(hd(ms));
Void setCurrModule(m) /* set lookup tables for current module */
Module m; {
- //Int i;
+ Int i;
if (m!=currentModule) {
currentModule = m; /* This is the only assignment to currentModule */
-#if 0
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
mapProc(hashTycon,module(m).tycons);
for (i=0; i<NAMEHSZ; ++i)
nameHash[i] = NIL;
mapProc(hashName,module(m).names);
-#endif
classes = module(m).classes;
}
}
static Void local showUse(msg,val,mx)
String msg;
Int val, mx; {
- Printf("%6s : %d of %d (%d%%)\n",msg,val,mx,(100*val)/mx);
+ Printf("%6s : %5d of %5d (%2d%%)\n",msg,val,mx,(100*val)/mx);
}
#endif
}
Bool isPreludeScript() { /* Test whether this is the Prelude*/
- return (scriptHw==0
- /*ToDo: jrs hack*/ || scriptHw==1
- );
+ return (scriptHw==0);
}
#if !IGNORE_MODULES
extHw = scripts[sno].extHw;
#endif
+#if 0 //zzzzzzzzzzzzzzzzz
for (i=moduleHw; i >= scripts[sno].moduleHw; --i) {
if (module(i).objectFile) {
printf("[bogus] closing objectFile for module %d\n",i);
}
}
moduleHw = scripts[sno].moduleHw;
-
+#endif
for (i=0; i<TEXTHSZ; ++i) {
int j = 0;
while (j<NUM_TEXTH && textHash[i][j]!=NOTEXT
}
#else /* !IGNORE_MODULES */
currentModule=NIL;
-#if 0
for (i=0; i<TYCONHSZ; ++i) {
tyconHash[i] = NIL;
}
for (i=0; i<NAMEHSZ; ++i) {
nameHash[i] = NIL;
}
-#endif
#endif /* !IGNORE_MODULES */
for (i=CLASSMIN; i<classHw; i++) {
}
#endif
+String stringNegate( s )
+String s;
+{
+ if (s[0] == '-') {
+ return &s[1];
+ } else {
+ static char t[100];
+ t[0] = '-';
+ strcpy(&t[1],s); /* ToDo: use strncpy instead */
+ return t;
+ }
+}
+
/* --------------------------------------------------------------------------
* List operations:
* ------------------------------------------------------------------------*/
#endif
tyconHw = TYCMIN;
-#if 0
for (i=0; i<TYCONHSZ; ++i)
tyconHash[i] = NIL;
-#endif
+
#if GC_WEAKPTRS
finalizers = NIL;
liveWeakPtrs = NIL;
* in the distribution for details.
*
* $RCSfile: storage.h,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:55 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:14 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
extern Bool isQualIdent Args((Cell));
extern Bool isIdent Args((Cell));
-#if 0
-Originally ...
-#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
-extern Cell mkFloat Args((FloatPro));
-extern FloatPro floatOf Args((Cell));
-extern String floatToString Args((FloatPro));
-extern FloatPro stringToFloat Args((String));
-#else
-#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
-#define stringToFloat(s) pair(FLOATCELL,findText(s))
-#define floatToString(f) textToStr(snd(f))
-#define floatEq(f1,f2) (snd(f1) == snd(f2))
-#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
-#define floatOf(f) atof(floatToString(f))
-#endif
-
-
-
+extern String stringNegate Args((String));
#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
#define stringToFloat(s) pair(FLOATCELL,findText(s))
#define floatToString(f) textToStr(snd(f))
-#define floatEq(f1,f2) (snd(f1) == snd(f2))
-#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
#define floatOf(f) atof(floatToString(f))
#define mkFloat(f) (f) /* ToDo: is this right? */
+#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
#define bignumToString(b) textToStr(snd(b))
Cell defn;
Name conToTag; /* used in derived code */
Name tagToCon;
- //Tycon nextTyconHash;
+ Tycon nextTyconHash;
};
extern struct strTycon DECTABLE(tabTycon);
Cell defn;
Cell stgVar; /* really StgVar */
const void* primop; /* really StgPrim* */
- //Name nextNameHash;
+ Name nextNameHash;
};
extern int numNames Args(( Void ));
struct strInst {
Class c; /* class C */
Int line;
- Module mod; /* module that defines it */
+ //Module mod; /* module that defines it */
Kinds kinds; /* Kinds of variables in head */
Cell head; /* :: Pred */
List specifics; /* :: [Pred] */
* Hugs version 1.4, December 1997
*
* $RCSfile: translate.c,v $
- * $Revision: 1.5 $
- * $Date: 1999/03/01 14:46:57 $
+ * $Revision: 1.6 $
+ * $Date: 1999/03/09 14:51:15 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static StgVar local stgOffset Args((Offset,List));
static StgVar local stgText Args((Text,List));
-static StgRhs local stgRhs Args((Cell,Int,List));
+static StgRhs local stgRhs Args((Cell,Int,List,StgExpr));
static StgCaseAlt local stgCaseAlt Args((Cell,Int,List,StgExpr));
static StgExpr local stgExpr Args((Cell,Int,List,StgExpr));
/* ---------------------------------------------------------------- */
-static StgRhs local stgRhs(e,co,sc)
+static StgRhs local stgRhs(e,co,sc,failExpr)
Cell e;
Int co;
-List sc; {
+List sc;
+StgExpr failExpr; {
switch (whatIs(e)) {
/* Identifiers */
return mkStgApp(nameUnpackString,singleton(e));
#endif
case AP:
- return stgExpr(e,co,sc,namePMFail);
+ return stgExpr(e,co,sc,namePMFailBUG);
case NIL:
internal("stgRhs2");
default:
- return stgExpr(e,co,sc,namePMFail);
+ return stgExpr(e,co,sc,failExpr/*namePMFail*/);
}
}
StgVar dIntegral = NIL;
/* bind dictionary */
- dIntegral = stgRhs(dictIntegral,co,sc);
+ dIntegral = stgRhs(dictIntegral,co,sc,namePMFailBUG);
if (!isAtomic(dIntegral)) { /* wasn't atomic */
dIntegral = mkStgVar(dIntegral,NIL);
binds = cons(dIntegral,binds);
altsc = cons(pair(mkOffset(co+i),nv),altsc);
}
/* bind dictionary */
- d = stgRhs(dict,co,sc);
+ d = stgRhs(dict,co,sc,namePMFailBUG);
if (!isAtomic(d)) { /* wasn't atomic */
d = mkStgVar(d,NIL);
binds = cons(d,binds);
for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
Cell rhs = hd(bs);
Cell nv = hd(vs);
- stgVarBody(nv) = stgRhs(rhs,co,sc);
+ stgVarBody(nv) = stgRhs(rhs,co,sc,namePMFailBUG);
}
- return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc));
+ return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFailBUG*/));
}
default: /* convert to an StgApp or StgVar plus some bindings */
{
/* Arguments must be StgAtoms */
for(as=args; nonNull(as); as=tl(as)) {
- StgRhs a = stgRhs(hd(as),co,sc);
+ StgRhs a = stgRhs(hd(as),co,sc,namePMFailBUG);
#if 1 /* optional flattening of let bindings */
if (whatIs(a) == LETREC) {
binds = appendOnto(stgLetBinds(a),binds);
}
/* Function must be StgVar or Name */
- e = stgRhs(e,co,sc);
+ e = stgRhs(e,co,sc,namePMFailBUG);
if (!isStgVar(e) && !isName(e)) {
e = mkStgVar(e,NIL);
binds = cons(e,binds);
#if 0 /* apparently not used */
static Void ppExp( Name n, Int arity, Cell e )
{
-#if DEBUG_CODE
- if (debugCode) {
+ if (1 || debugCode) {
Int i;
printf("%s", textToStr(name(n).text));
for (i = arity; i > 0; i--) {
printExp(stdout,e);
printf("\n");
}
-#endif
}
#endif
List vs = NIL;
List sc = NIL;
Int i;
- // ppExp(n,arity,e);
+#if 0
+ if (lastModule() != modulePrelude) {
+ fprintf(stderr, "\n===========================================\n" );
+ ppExp ( n,arity,e);
+ printf("\n\n"); fflush(stdout);
+ }
+#endif
for (i = 1; i <= arity; ++i) {
Cell nv = mkStgVar(NIL,NIL);
vs = cons(nv,vs);
}
stgVarBody(name(n).stgVar)
= makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
- //ppStg(name(n).stgVar);
- //printStg(stdout, name(n).stgVar);
-}
-
-static StgExpr forceArgs( List is, List args, StgExpr e );
-
-/* force the args numbered in is */
-static StgExpr forceArgs( List is, List args, StgExpr e )
-{
- for(; nonNull(is); is=tl(is)) {
- e = mkSeq(nth(intOf(hd(is))-1,args),e);
+#if 0
+ if (lastModule() != modulePrelude) {
+ ppStg(name(n).stgVar);
+ fprintf(stderr, "\n\n");
}
- return e;
+ //printStg(stdout, name(n).stgVar);
+#endif
}
-
Void implementCfun(c,scs) /* Build implementation for constr */
Name c; /* fun c. scs lists integers (1..)*/
List scs; { /* in incr order of strict comps. */
Int a = name(c).arity;
- //printf ( "implementCfun %s\n", textToStr(name(c).text) );
- if (name(c).arity > 0) {
- List args = makeArgs(a);
- StgVar tv = mkStgVar(mkStgCon(c,args),NIL);
- StgExpr e1 = mkStgLet(singleton(tv),tv);
- StgExpr e2 = forceArgs(scs,args,e1);
- StgVar v = mkStgVar(mkStgLambda(args,e2),NIL);
+ //fprintf ( stderr,"implementCfun %s\n", textToStr(name(c).text) );
+ if (a > 0) {
+ StgVar vcurr, e1, v, vsi;
+ List args = makeArgs(a);
+ StgVar v0 = mkStgVar(mkStgCon(c,args),NIL);
+ List binds = singleton(v0);
+
+ vcurr = v0;
+ for (; nonNull(scs); scs=tl(scs)) {
+ vsi = nth(intOf(hd(scs))-1,args);
+ vcurr = mkStgVar(mkStgApp(namePrimSeq,doubleton(vsi,vcurr)), NIL);
+ binds = cons(vcurr,binds);
+ }
+ binds = rev(binds);
+ e1 = mkStgLet(binds,vcurr);
+ v = mkStgVar(mkStgLambda(args,e1),NIL);
name(c).stgVar = v;
} else {
StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
name(c).stgVar = v;
}
- /* hack to make it print out */
stgGlobals = cons(pair(c,name(c).stgVar),stgGlobals);
+ //printStg(stderr, name(c).stgVar); fprintf(stderr,"\n\n");
}
/* --------------------------------------------------------------------------
* in the distribution for details.
*
* $RCSfile: type.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:46:57 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:16 $
* ------------------------------------------------------------------------*/
#include "prelude.h"
static Void local typeDefnGroup(bs) /* type check group of value defns */
List bs; { /* (one top level scc) */
List as;
-// printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n");
-//{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){
-// print(hd(qq),4);
-// printf("\n");
-//}}
+ // printf("\n\n+++ DefnGroup ++++++++++++++++++++++++++++\n");
+ //{ List qq; for (qq=bs;nonNull(qq);qq=tl(qq)){
+ // print(hd(qq),4);
+ // printf("\n");
+ //}}
emptySubstitution();
hd(defnBounds) = NIL;
--- /dev/null
+{----------------------------------------------------------------------------
+__ __ __ __ ____ ___ _______________________________________________
+|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
+||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
+||---|| ___|| World Wide Web: http://haskell.org/hugs
+|| || Report bugs to: hugs-bugs@haskell.org
+|| || Version: January 1999 _______________________________________________
+
+ This is the Hugs 98 Standard Prelude, based very closely on the Standard
+ Prelude for Haskell 98.
+
+ WARNING: This file is an integral part of the Hugs source code. Changes to
+ the definitions in this file without corresponding modifications in other
+ parts of the program may cause the interpreter to fail unexpectedly. Under
+ normal circumstances, you should not attempt to modify this file in any way!
+
+-----------------------------------------------------------------------------
+ Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
+ Group 1994-99, and is distributed as Open Source software under the
+ Artistic License; see the file "Artistic" that is included in the
+ distribution for details.
+----------------------------------------------------------------------------}
+
+module Prelude (
+-- module PreludeList,
+ map, (++), concat, filter,
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ lines, words, unlines, unwords, reverse, and, or,
+ any, all, elem, notElem, lookup,
+ sum, product, maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3,
+-- module PreludeText,
+ ReadS, ShowS,
+ Read(readsPrec, readList),
+ Show(show, showsPrec, showList),
+ reads, shows, read, lex,
+ showChar, showString, readParen, showParen,
+-- module PreludeIO,
+ FilePath, IOError, ioError, userError, catch,
+ putChar, putStr, putStrLn, print,
+ getChar, getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn,
+-- module Ix,
+ Ix(range, index, inRange, rangeSize),
+-- module Char,
+ isAscii, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ digitToInt, intToDigit,
+ toUpper, toLower,
+ ord, chr,
+ readLitChar, showLitChar, lexLitChar,
+-- module Numeric
+ showSigned, showInt,
+ readSigned, readInt,
+ readDec, readOct, readHex, readSigned,
+ readFloat, lexDigits,
+-- module Ratio,
+ Ratio, Rational, (%), numerator, denominator, approxRational,
+-- Non-standard exports
+ IO(..), IOResult(..), Addr,
+
+ Bool(False, True),
+ Maybe(Nothing, Just),
+ Either(Left, Right),
+ Ordering(LT, EQ, GT),
+ Char, String, Int, Integer, Float, Double, IO,
+-- List type: []((:), [])
+ (:),
+-- Tuple types: (,), (,,), etc.
+-- Trivial type: ()
+-- Functions: (->)
+ Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
+ Eq((==), (/=)),
+ Ord(compare, (<), (<=), (>=), (>), max, min),
+ Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
+ enumFromTo, enumFromThenTo),
+ Bounded(minBound, maxBound),
+-- Num((+), (-), (*), negate, abs, signum, fromInteger),
+ Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
+ Real(toRational),
+-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
+ Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
+-- Fractional((/), recip, fromRational),
+ Fractional((/), recip, fromRational, fromDouble),
+ Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
+ asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
+ RealFrac(properFraction, truncate, round, ceiling, floor),
+ RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
+ encodeFloat, exponent, significand, scaleFloat, isNaN,
+ isInfinite, isDenormalized, isIEEE, isNegativeZero),
+ Monad((>>=), (>>), return, fail),
+ Functor(fmap),
+ mapM, mapM_, accumulate, sequence, (=<<),
+ maybe, either,
+ (&&), (||), not, otherwise,
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, realToFrac, atan2,
+ fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
+ asTypeOf, error, undefined,
+ seq, ($!)
+
+ ,primCompAux
+ ) where
+
+-- Standard value bindings {Prelude} ----------------------------------------
+
+infixr 9 .
+infixl 9 !!
+infixr 8 ^, ^^, **
+infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
+infixl 6 +, -
+--infixr 5 : -- this fixity declaration is hard-wired into Hugs
+infixr 5 ++
+infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
+infixr 3 &&
+infixr 2 ||
+infixl 1 >>, >>=
+infixr 1 =<<
+infixr 0 $, $!, `seq`
+
+-- Equality and Ordered classes ---------------------------------------------
+
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ -- Minimal complete definition: (==) or (/=)
+ x == y = not (x/=y)
+ x /= y = not (x==y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>=), (>) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+ -- Minimal complete definition: (<=) or compare
+ -- using compare can be more efficient for complex types
+ compare x y | x==y = EQ
+ | x<=y = LT
+ | otherwise = GT
+
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+
+ max x y | x >= y = x
+ | otherwise = y
+ min x y | x <= y = x
+ | otherwise = y
+
+class Bounded a where
+ minBound, maxBound :: a
+ -- Minimal complete definition: All
+
+-- Numeric classes ----------------------------------------------------------
+
+class (Eq a, Show a) => Num a where
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: Integer -> a
+ fromInt :: Int -> a
+
+ -- Minimal complete definition: All, except negate or (-)
+ x - y = x + negate y
+ fromInt = fromIntegral
+ negate x = 0 - x
+
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot, rem, div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ even, odd :: a -> Bool
+ toInteger :: a -> Integer
+ toInt :: a -> Int
+
+ -- Minimal complete definition: quotRem and toInteger
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+ divMod n d = if signum r == - signum d then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+ even n = n `rem` 2 == 0
+ odd = not . even
+ toInt = toInt . toInteger
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+ fromDouble :: Double -> a
+
+ -- Minimal complete definition: fromRational and ((/) or recip)
+ recip x = 1 / x
+ fromDouble = fromRational . toRational
+ x / y = x * recip y
+
+
+class (Fractional a) => Floating a where
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
+ asinh, acosh, atanh :: a -> a
+
+ -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
+ -- asinh, acosh, atanh
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ sinh x = (exp x - exp (-x)) / 2
+ cosh x = (exp x + exp (-x)) / 2
+ tanh x = sinh x / cosh x
+ asinh x = log (x + sqrt (x*x + 1))
+ acosh x = log (x + sqrt (x*x - 1))
+ atanh x = (log (1 + x) - log (1 - x)) / 2
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, floor :: (Integral b) => a -> b
+
+ -- Minimal complete definition: properFraction
+ truncate x = m where (m,_) = properFraction x
+
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
+
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
+
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> Integer
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (Integer,Int)
+ encodeFloat :: Integer -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+ atan2 :: a -> a -> a
+
+ -- Minimal complete definition: All, except exponent, signficand,
+ -- scaleFloat, atan2
+ exponent x = if m==0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+ significand x = encodeFloat m (- floatDigits x)
+ where (m,_) = decodeFloat x
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+ atan2 y x
+ | x>0 = atan (y/x)
+ | x==0 && y>0 = pi/2
+ | x<0 && y>0 = pi + atan (y/x)
+ | (x<=0 && y<0) ||
+ (x<0 && isNegativeZero y) ||
+ (isNegativeZero x && isNegativeZero y)
+ = - atan2 (-y) x
+ | y==0 && (x<0 || isNegativeZero x)
+ = pi -- must be after the previous test on zero y
+ | x==0 && y==0 = y -- must be after the other double zero tests
+ | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
+
+-- Numeric functions --------------------------------------------------------
+
+subtract :: Num a => a -> a -> a
+subtract = flip (-)
+
+gcd :: Integral a => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' x 0 = x
+ gcd' x y = gcd' y (x `rem` y)
+
+lcm :: (Integral a) => a -> a -> a
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` gcd x y) * y)
+
+(^) :: (Num a, Integral b) => a -> b -> a
+x ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f x n y = g x n where
+ g x n | even n = g (x*x) (n`quot`2)
+ | otherwise = f x (n-1) (x*y)
+_ ^ _ = error "Prelude.^: negative exponent"
+
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x ^ n else recip (x^(-n))
+
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+realToFrac :: (Real a, Fractional b) => a -> b
+realToFrac = fromRational . toRational
+
+-- Index and Enumeration classes --------------------------------------------
+
+class (Ord a) => Ix a where
+ range :: (a,a) -> [a]
+ index :: (a,a) -> a -> Int
+ inRange :: (a,a) -> a -> Bool
+ rangeSize :: (a,a) -> Int
+
+ rangeSize r@(l,u)
+ | l > u = 0
+ | otherwise = index r u + 1
+
+class Enum a where
+ succ, pred :: a -> a
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,m..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ -- Minimal complete definition: toEnum, fromEnum
+ succ = toEnum . (1+) . fromEnum
+ pred = toEnum . subtract 1 . fromEnum
+ enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
+ enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
+
+-- Read and Show classes ------------------------------------------------------
+
+type ReadS a = String -> [(a,String)]
+type ShowS = String -> String
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+ readList :: ReadS [a]
+
+ -- Minimal complete definition: readsPrec
+ readList = readParen False (\r -> [pr | ("[",s) <- lex r,
+ pr <- readl s ])
+ where readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- reads s,
+ (xs,u) <- readl' t]
+ readl' s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s,
+ (x,u) <- reads t,
+ (xs,v) <- readl' u]
+
+class Show a where
+ show :: a -> String
+ showsPrec :: Int -> a -> ShowS
+ showList :: [a] -> ShowS
+
+ -- Minimal complete definition: show or showsPrec
+ show x = showsPrec 0 x ""
+ showsPrec _ x s = show x ++ s
+ showList [] = showString "[]"
+ showList (x:xs) = showChar '[' . shows x . showl xs
+ where showl [] = showChar ']'
+ showl (x:xs) = showChar ',' . shows x . showl xs
+
+-- Monad classes ------------------------------------------------------------
+
+class Functor f where
+ fmap :: (a -> b) -> (f a -> f b)
+
+class Monad m where
+ return :: a -> m a
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ fail :: String -> m a
+
+ -- Minimal complete definition: (>>=), return
+ p >> q = p >>= \ _ -> q
+ fail s = error s
+
+accumulate :: Monad m => [m a] -> m [a]
+accumulate [] = return []
+accumulate (c:cs) = do x <- c
+ xs <- accumulate cs
+ return (x:xs)
+
+sequence :: Monad m => [m a] -> m ()
+sequence = foldr (>>) (return ())
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f = accumulate . map f
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f = sequence . map f
+
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+-- Evaluation and strictness ------------------------------------------------
+
+seq :: a -> b -> b
+seq x y = --case primForce x of () -> y
+ primSeq x y
+
+($!) :: (a -> b) -> a -> b
+f $! x = x `seq` f x
+
+-- Trivial type -------------------------------------------------------------
+
+-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+instance Eq () where
+ () == () = True
+
+instance Ord () where
+ compare () () = EQ
+
+instance Ix () where
+ range ((),()) = [()]
+ index ((),()) () = 0
+ inRange ((),()) () = True
+
+instance Enum () where
+ toEnum 0 = ()
+ fromEnum () = 0
+ enumFrom () = [()]
+ enumFromThen () () = [()]
+
+instance Read () where
+ readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
+ (")",t) <- lex s ])
+
+instance Show () where
+ showsPrec p () = showString "()"
+
+instance Bounded () where
+ minBound = ()
+ maxBound = ()
+
+-- Boolean type -------------------------------------------------------------
+
+data Bool = False | True
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+(&&), (||) :: Bool -> Bool -> Bool
+False && x = False
+True && x = x
+False || x = x
+True || x = True
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+otherwise :: Bool
+otherwise = True
+
+-- Character type -----------------------------------------------------------
+
+data Char -- builtin datatype of ISO Latin characters
+type String = [Char] -- strings are lists of characters
+
+instance Eq Char where (==) = primEqChar
+instance Ord Char where (<=) = primLeChar
+
+instance Enum Char where
+ toEnum = primIntToChar
+ fromEnum = primCharToInt
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
+ where lastChar = if d < c then minBound else maxBound
+
+instance Ix Char where
+ range (c,c') = [c..c']
+ index b@(c,c') ci
+ | inRange b ci = fromEnum ci - fromEnum c
+ | otherwise = error "Ix.index: Index out of range."
+ inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
+ where i = fromEnum ci
+
+instance Read Char where
+ readsPrec p = readParen False
+ (\r -> [(c,t) | ('\'':s,t) <- lex r,
+ (c,"\'") <- readLitChar s ])
+ readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+ (l,_) <- readl s ])
+ where readl ('"':s) = [("",s)]
+ readl ('\\':'&':s) = readl s
+ readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
+ (cs,u) <- readl t ]
+instance Show Char where
+ showsPrec p '\'' = showString "'\\''"
+ showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
+
+ showList cs = showChar '"' . showl cs
+ where showl "" = showChar '"'
+ showl ('"':cs) = showString "\\\"" . showl cs
+ showl (c:cs) = showLitChar c . showl cs
+
+instance Bounded Char where
+ minBound = '\0'
+ maxBound = '\255'
+
+isAscii, isControl, isPrint, isSpace :: Char -> Bool
+isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
+
+isAscii c = fromEnum c < 128
+isControl c = c < ' ' || c == '\DEL'
+isPrint c = c >= ' ' && c <= '~'
+isSpace c = c == ' ' || c == '\t' || c == '\n' ||
+ c == '\r' || c == '\f' || c == '\v'
+isUpper c = c >= 'A' && c <= 'Z'
+isLower c = c >= 'a' && c <= 'z'
+isAlpha c = isUpper c || isLower c
+isDigit c = c >= '0' && c <= '9'
+isAlphaNum c = isAlpha c || isDigit c
+
+-- Digit conversion operations
+digitToInt :: Char -> Int
+digitToInt c
+ | isDigit c = fromEnum c - fromEnum '0'
+ | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error "Char.digitToInt: not a digit"
+
+intToDigit :: Int -> Char
+intToDigit i
+ | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
+ | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
+ | otherwise = error "Char.intToDigit: not a digit"
+
+toUpper, toLower :: Char -> Char
+toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
+ | otherwise = c
+
+toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
+ | otherwise = c
+
+ord :: Char -> Int
+ord = fromEnum
+
+chr :: Int -> Char
+chr = toEnum
+
+-- Maybe type ---------------------------------------------------------------
+
+data Maybe a = Nothing | Just a
+ deriving (Eq, Ord, Read, Show)
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
+
+instance Functor Maybe where
+ fmap f Nothing = Nothing
+ fmap f (Just x) = Just (f x)
+
+instance Monad Maybe where
+ Just x >>= k = k x
+ Nothing >>= k = Nothing
+ return = Just
+ fail s = Nothing
+
+-- Either type --------------------------------------------------------------
+
+data Either a b = Left a | Right b
+ deriving (Eq, Ord, Read, Show)
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either l r (Left x) = l x
+either l r (Right y) = r y
+
+-- Ordering type ------------------------------------------------------------
+
+data Ordering = LT | EQ | GT
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+-- Lists --------------------------------------------------------------------
+
+--data [a] = [] | a : [a] deriving (Eq, Ord)
+
+instance Eq a => Eq [a] where
+ [] == [] = True
+ (x:xs) == (y:ys) = x==y && xs==ys
+ _ == _ = False
+
+instance Ord a => Ord [a] where
+ compare [] (_:_) = LT
+ compare [] [] = EQ
+ compare (_:_) [] = GT
+ compare (x:xs) (y:ys) = primCompAux x y (compare xs ys)
+
+instance Functor [] where
+ fmap = map
+
+instance Monad [ ] where
+ (x:xs) >>= f = f x ++ (xs >>= f)
+ [] >>= f = []
+ return x = [x]
+ fail s = []
+
+instance Read a => Read [a] where
+ readsPrec p = readList
+
+instance Show a => Show [a] where
+ showsPrec p = showList
+
+-- Tuples -------------------------------------------------------------------
+
+-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
+-- etc..
+
+-- Functions ----------------------------------------------------------------
+
+instance Show (a -> b) where
+ showsPrec p f = showString "<<function>>"
+
+instance Functor ((->) a) where
+ fmap = (.)
+
+-- Standard Integral types --------------------------------------------------
+
+data Int -- builtin datatype of fixed size integers
+data Integer -- builtin datatype of arbitrary size integers
+
+instance Eq Integer where
+ (==) x y = primCompareInteger x y == 0
+
+instance Ord Integer where
+ compare x y = case primCompareInteger x y of
+ -1 -> LT
+ 0 -> EQ
+ 1 -> GT
+
+instance Eq Int where
+ (==) = primEqInt
+ (/=) = primNeInt
+
+instance Ord Int where
+ (<) = primLtInt
+ (<=) = primLeInt
+ (>=) = primGeInt
+ (>) = primGtInt
+
+instance Num Int where
+ (+) = primPlusInt
+ (-) = primMinusInt
+ negate = primNegateInt
+ (*) = primTimesInt
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToInt
+ fromInt x = x
+
+instance Bounded Int where
+ minBound = primMinInt
+ maxBound = primMaxInt
+
+instance Num Integer where
+ (+) = primPlusInteger
+ (-) = primMinusInteger
+ negate = primNegateInteger
+ (*) = primTimesInteger
+ abs = absReal
+ signum = signumReal
+ fromInteger x = x
+ fromInt = primIntToInteger
+
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Real Integer where
+ toRational x = x % 1
+
+instance Integral Int where
+ quotRem = primQuotRemInt
+ toInteger = primIntToInteger
+ toInt x = x
+
+instance Integral Integer where
+ quotRem = primQuotRemInteger
+ divMod = primDivModInteger
+ toInteger = id
+ toInt = primIntegerToInt
+
+instance Ix Int where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = i - m
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Ix Integer where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = fromInteger (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int where
+ toEnum = id
+ fromEnum = id
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Integer where
+ toEnum = primIntToInteger
+ fromEnum = primIntegerToInt
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: Real a => a -> [a]
+numericEnumFromThen :: Real a => a -> a -> [a]
+numericEnumFromTo :: Real a => a -> a -> [a]
+numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
+numericEnumFrom n = n : (numericEnumFrom $! (n+1))
+numericEnumFromThen n m = iterate ((m-n)+) n
+numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
+ where p | n' > n = (<= m)
+ | otherwise = (>= m)
+
+instance Read Int where
+ readsPrec p = readSigned readDec
+
+instance Show Int where
+ showsPrec p n
+ | n == minBound = showSigned showInt p (toInteger n)
+ | otherwise = showSigned showInt p n
+
+instance Read Integer where
+ readsPrec p = readSigned readDec
+
+instance Show Integer where
+ showsPrec = showSigned showInt
+
+-- Standard Floating types --------------------------------------------------
+
+data Float -- builtin datatype of single precision floating point numbers
+data Double -- builtin datatype of double precision floating point numbers
+
+instance Eq Float where
+ (==) = primEqFloat
+ (/=) = primNeFloat
+
+instance Ord Float where
+ (<) = primLtFloat
+ (<=) = primLeFloat
+ (>=) = primGeFloat
+ (>) = primGtFloat
+
+instance Num Float where
+ (+) = primPlusFloat
+ (-) = primMinusFloat
+ negate = primNegateFloat
+ (*) = primTimesFloat
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToFloat
+ fromInt = primIntToFloat
+
+
+
+instance Eq Double where
+ (==) = primEqDouble
+ (/=) = primNeDouble
+
+instance Ord Double where
+ (<) = primLtDouble
+ (<=) = primLeDouble
+ (>=) = primGeDouble
+ (>) = primGtDouble
+
+instance Num Double where
+ (+) = primPlusDouble
+ (-) = primMinusDouble
+ negate = primNegateDouble
+ (*) = primTimesDouble
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToDouble
+ fromInt = primIntToDouble
+
+
+
+instance Real Float where
+ toRational = floatToRational
+
+instance Real Double where
+ toRational = doubleToRational
+
+-- Calls to these functions are optimised when passed as arguments to
+-- fromRational.
+floatToRational :: Float -> Rational
+doubleToRational :: Double -> Rational
+floatToRational x = realFloatToRational x
+doubleToRational x = realFloatToRational x
+
+realFloatToRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) = primDivideFloat
+ fromRational = rationalToRealFloat
+ fromDouble = primDoubleToFloat
+
+
+instance Fractional Double where
+ (/) = primDivideDouble
+ fromRational = rationalToRealFloat
+ fromDouble x = x
+
+rationalToRealFloat x = x'
+ where x' = f e
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1%b)^^e)) e
+ (_,e') = decodeFloat y
+ (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+ b = floatRadix x'
+
+instance Floating Float where
+ pi = 3.14159265358979323846
+ exp = primExpFloat
+ log = primLogFloat
+ sqrt = primSqrtFloat
+ sin = primSinFloat
+ cos = primCosFloat
+ tan = primTanFloat
+ asin = primAsinFloat
+ acos = primAcosFloat
+ atan = primAtanFloat
+
+instance Floating Double where
+ pi = 3.14159265358979323846
+ exp = primExpDouble
+ log = primLogDouble
+ sqrt = primSqrtDouble
+ sin = primSinDouble
+ cos = primCosDouble
+ tan = primTanDouble
+ asin = primAsinDouble
+ acos = primAcosDouble
+ atan = primAtanDouble
+
+instance RealFrac Float where
+ properFraction = floatProperFraction
+
+instance RealFrac Double where
+ properFraction = floatProperFraction
+
+floatProperFraction x
+ | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
+ | otherwise = (fromInteger w, encodeFloat r n)
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+ (w,r) = quotRem m (b^(-n))
+
+instance RealFloat Float where
+ floatRadix _ = toInteger primRadixFloat
+ floatDigits _ = primDigitsFloat
+ floatRange _ = (primMinExpFloat,primMaxExpFloat)
+ encodeFloat = primEncodeFloatZ
+ decodeFloat = primDecodeFloatZ
+ isNaN = primIsNaNFloat
+ isInfinite = primIsInfiniteFloat
+ isDenormalized= primIsDenormalizedFloat
+ isNegativeZero= primIsNegativeZeroFloat
+ isIEEE = const primIsIEEEFloat
+
+instance RealFloat Double where
+ floatRadix _ = toInteger primRadixDouble
+ floatDigits _ = primDigitsDouble
+ floatRange _ = (primMinExpDouble,primMaxExpDouble)
+ encodeFloat = primEncodeDoubleZ
+ decodeFloat = primDecodeDoubleZ
+ isNaN = primIsNaNDouble
+ isInfinite = primIsInfiniteDouble
+ isDenormalized= primIsDenormalizedDouble
+ isNegativeZero= primIsNegativeZeroDouble
+ isIEEE = const primIsIEEEDouble
+
+instance Enum Float where
+ toEnum = primIntToFloat
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Enum Double where
+ toEnum = primIntToDouble
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Read Float where
+ readsPrec p = readSigned readFloat
+
+instance Show Float where
+ showsPrec p = showFloat
+ --error "should call showFloat"
+
+instance Read Double where
+ readsPrec p = readSigned readFloat
+
+-- Note that showFloat in Numeric isn't used here
+instance Show Double where
+ showsPrec p = showFloat
+ --error "should call showFloat"
+
+-- Some standard functions --------------------------------------------------
+
+fst :: (a,b) -> a
+fst (x,_) = x
+
+snd :: (a,b) -> b
+snd (_,y) = y
+
+curry :: ((a,b) -> c) -> (a -> b -> c)
+curry f x y = f (x,y)
+
+uncurry :: (a -> b -> c) -> ((a,b) -> c)
+uncurry f p = f (fst p) (snd p)
+
+id :: a -> a
+id x = x
+
+const :: a -> b -> a
+const k _ = k
+
+(.) :: (b -> c) -> (a -> b) -> (a -> c)
+(f . g) x = f (g x)
+
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+($) :: (a -> b) -> a -> b
+f $ x = f x
+
+until :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x = if p x then x else until p f (f x)
+
+asTypeOf :: a -> a -> a
+asTypeOf = const
+
+error :: String -> a
+error msg = primRaise (ErrorCall msg)
+
+undefined :: a
+undefined | False = undefined
+
+-- Standard functions on rational numbers {PreludeRatio} --------------------
+
+data Integral a => Ratio a = a :% a deriving (Eq)
+type Rational = Ratio Integer
+
+(%) :: Integral a => a -> a -> Ratio a
+x % y = reduce (x * signum y) (abs y)
+
+reduce :: Integral a => a -> a -> Ratio a
+reduce x y | y == 0 = error "Ratio.%: zero denominator"
+ | otherwise = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+
+numerator, denominator :: Integral a => Ratio a -> a
+numerator (x :% y) = x
+denominator (x :% y) = y
+
+instance Integral a => Ord (Ratio a) where
+ compare (x:%y) (x':%y') = compare (x*y') (x'*y)
+
+instance Integral a => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x*x') (y*y')
+ negate (x :% y) = negate x :% y
+ abs (x :% y) = abs x :% y
+ signum (x :% y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+ fromInt = intToRatio
+
+-- Hugs optimises code of the form fromRational (intToRatio x)
+intToRatio :: Integral a => Int -> Ratio a
+intToRatio x = fromInt x :% 1
+
+instance Integral a => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance Integral a => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+ fromDouble = doubleToRatio
+
+-- Hugs optimises code of the form fromRational (doubleToRatio x)
+doubleToRatio :: Integral a => Double -> Ratio a
+doubleToRatio x
+ | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
+ | otherwise = fromInteger m % (fromInteger b ^ (-n))
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Integral a => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromIntegral q, r:%y)
+ where (q,r) = quotRem x y
+
+instance Integral a => Enum (Ratio a) where
+ toEnum = fromInt
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+
+instance (Read a, Integral a) => Read (Ratio a) where
+ readsPrec p = readParen (p > 7)
+ (\r -> [(x%y,u) | (x,s) <- reads r,
+ ("%",t) <- lex s,
+ (y,u) <- reads t ])
+
+instance Integral a => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > 7)
+ (shows x . showString " % " . shows y)
+
+approxRational :: RealFrac a => a -> a -> Rational
+approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr@(n:%d) = toRational x
+ (n':%d') = toRational y
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ (n'':%d'') = simplest' d' r' d r
+
+-- Standard list functions {PreludeList} ------------------------------------
+
+head :: [a] -> a
+head (x:_) = x
+
+last :: [a] -> a
+last [x] = x
+last (_:xs) = last xs
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+
+init :: [a] -> [a]
+init [x] = []
+init (x:xs) = x : init xs
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+(++) :: [a] -> [a] -> [a]
+[] ++ ys = ys
+(x:xs) ++ ys = x : (xs ++ ys)
+
+map :: (a -> b) -> [a] -> [b]
+map f xs = [ f x | x <- xs ]
+
+filter :: (a -> Bool) -> [a] -> [a]
+filter p xs = [ x | x <- xs, p x ]
+
+concat :: [[a]] -> [a]
+concat = foldr (++) []
+
+length :: [a] -> Int
+length = foldl' (\n _ -> n + 1) 0
+
+(!!) :: [b] -> Int -> b
+(x:_) !! 0 = x
+(_:xs) !! n | n>0 = xs !! (n-1)
+(_:_) !! _ = error "Prelude.!!: negative index"
+[] !! _ = error "Prelude.!!: index too large"
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z [] = z
+foldl f z (x:xs) = foldl f (f z x) xs
+
+foldl' :: (a -> b -> a) -> a -> [b] -> a
+foldl' f a [] = a
+foldl' f a (x:xs) = (foldl' f $! f a x) xs
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs = q : (case xs of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 f [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+
+scanr :: (a -> b -> b) -> b -> [a] -> [b]
+scanr f q0 [] = [q0]
+scanr f q0 (x:xs) = f x q : qs
+ where qs@(q:_) = scanr f q0 xs
+
+scanr1 :: (a -> a -> a) -> [a] -> [a]
+scanr1 f [x] = [x]
+scanr1 f (x:xs) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+repeat :: a -> [a]
+repeat x = xs where xs = x:xs
+
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+cycle :: [a] -> [a]
+cycle [] = error "Prelude.cycle: empty list"
+cycle xs = xs' where xs'=xs++xs'
+
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n>0 = x : take (n-1) xs
+take _ _ = error "Prelude.take: negative argument"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n>0 = drop (n-1) xs
+drop _ _ = error "Prelude.drop: negative argument"
+
+splitAt :: Int -> [a] -> ([a], [a])
+splitAt 0 xs = ([],xs)
+splitAt _ [] = ([],[])
+splitAt n (x:xs) | n>0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
+splitAt _ _ = error "Prelude.splitAt: negative argument"
+
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile p [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+dropWhile :: (a -> Bool) -> [a] -> [a]
+dropWhile p [] = []
+dropWhile p xs@(x:xs')
+ | p x = dropWhile p xs'
+ | otherwise = xs
+
+span, break :: (a -> Bool) -> [a] -> ([a],[a])
+span p [] = ([],[])
+span p xs@(x:xs')
+ | p x = (x:ys, zs)
+ | otherwise = ([],xs)
+ where (ys,zs) = span p xs'
+break p = span (not . p)
+
+lines :: String -> [String]
+lines "" = []
+lines s = let (l,s') = break ('\n'==) s
+ in l : case s' of [] -> []
+ (_:s'') -> lines s''
+
+words :: String -> [String]
+words s = case dropWhile isSpace s of
+ "" -> []
+ s' -> w : words s''
+ where (w,s'') = break isSpace s'
+
+unlines :: [String] -> String
+unlines = concatMap (\l -> l ++ "\n")
+
+unwords :: [String] -> String
+unwords [] = []
+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
+
+reverse :: [a] -> [a]
+reverse = foldl (flip (:)) []
+
+and, or :: [Bool] -> Bool
+and = foldr (&&) True
+or = foldr (||) False
+
+any, all :: (a -> Bool) -> [a] -> Bool
+any p = or . map p
+all p = and . map p
+
+elem, notElem :: Eq a => a -> [a] -> Bool
+elem = any . (==)
+notElem = all . (/=)
+
+lookup :: Eq a => a -> [(a,b)] -> Maybe b
+lookup k [] = Nothing
+lookup k ((x,y):xys)
+ | k==x = Just y
+ | otherwise = lookup k xys
+
+sum, product :: Num a => [a] -> a
+sum = foldl' (+) 0
+product = foldl' (*) 1
+
+maximum, minimum :: Ord a => [a] -> a
+maximum = foldl1 max
+minimum = foldl1 min
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = concat . map f
+
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipWith (\a b -> (a,b))
+
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3 = zipWith3 (\a b c -> (a,b,c))
+
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
+zipWith _ _ _ = []
+
+zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ = []
+
+unzip :: [(a,b)] -> ([a],[b])
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as, b:bs)) ([], [])
+
+unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+ ([],[],[])
+
+-- PreludeText ----------------------------------------------------------------
+
+reads :: Read a => ReadS a
+reads = readsPrec 0
+
+shows :: Show a => a -> ShowS
+shows = showsPrec 0
+
+read :: Read a => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error "Prelude.read: no parse"
+ _ -> error "Prelude.read: ambiguous parse"
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+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
+
+readParen :: Bool -> ReadS a -> ReadS a
+readParen b g = if b then mandatory else optional
+ where optional r = g r ++ mandatory r
+ mandatory r = [(x,u) | ("(",s) <- lex r,
+ (x,t) <- optional s,
+ (")",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 ]
+
+lex :: ReadS String
+lex "" = [("","")]
+lex (c:s) | isSpace c = lex (dropWhile isSpace s)
+lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
+ ch /= "'" ]
+lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
+ where
+ lexString ('"':s) = [("\"",s)]
+ lexString s = [(ch++str, u)
+ | (ch,t) <- lexStrItem s,
+ (str,u) <- lexString t ]
+
+ lexStrItem ('\\':'&':s) = [("\\&",s)]
+ lexStrItem ('\\':c:s) | isSpace c
+ = [("",t) | '\\':t <- [dropWhile isSpace s]]
+ lexStrItem s = lexLitChar s
+
+lex (c:s) | isSingle c = [([c],s)]
+ | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
+ | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
+ | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
+ (fe,t) <- lexFracExp s ]
+ | otherwise = [] -- bad character
+ where
+ isSingle c = c `elem` ",;()[]{}_`"
+ isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
+ isIdChar c = isAlphaNum c || c `elem` "_'"
+
+ lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
+ (e,u) <- lexExp t ]
+ lexFracExp s = [("",s)]
+
+ lexExp (e:s) | e `elem` "eE"
+ = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
+ (ds,u) <- lexDigits t] ++
+ [(e:ds,t) | (ds,t) <- lexDigits s]
+ lexExp s = [("",s)]
+
+lexDigits :: ReadS String
+lexDigits = nonnull isDigit
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+lexLitChar :: ReadS String
+lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
+ where
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(mne,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ lexEsc _ = []
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+
+isOctDigit c = c >= '0' && c <= '7'
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
+ || c >= 'a' && c <= 'f'
+
+lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
+lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
+lexmatch xs ys = (xs,ys)
+
+asciiTab = zip ['\NUL'..' ']
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+
+readLitChar :: ReadS Char
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = [('\a',s)]
+ readEsc ('b':s) = [('\b',s)]
+ readEsc ('f':s) = [('\f',s)]
+ readEsc ('n':s) = [('\n',s)]
+ readEsc ('r':s) = [('\r',s)]
+ readEsc ('t':s) = [('\t',s)]
+ readEsc ('v':s) = [('\v',s)]
+ readEsc ('\\':s) = [('\\',s)]
+ readEsc ('"':s) = [('"',s)]
+ readEsc ('\'':s) = [('\'',s)]
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = [(toEnum (fromEnum c - fromEnum '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(toEnum n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' .
+ protectEsc isDigit (shows (fromEnum c))
+showLitChar '\DEL' = showString "\\DEL"
+showLitChar '\\' = showString "\\\\"
+showLitChar c | c >= ' ' = showChar c
+showLitChar '\a' = showString "\\a"
+showLitChar '\b' = showString "\\b"
+showLitChar '\f' = showString "\\f"
+showLitChar '\n' = showString "\\n"
+showLitChar '\r' = showString "\\r"
+showLitChar '\t' = showString "\\t"
+showLitChar '\v' = showString "\\v"
+showLitChar '\SO' = protectEsc ('H'==) (showString "\\SO")
+showLitChar c = showString ('\\' : snd (asciiTab!!fromEnum c))
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+-- Unsigned readers for various bases
+readDec, readOct, readHex :: Integral a => ReadS a
+readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
+readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
+readHex = readInt 16 isHexDigit hex
+ where hex d = fromEnum d -
+ (if isDigit d
+ then fromEnum '0'
+ else fromEnum (if isUpper d then 'A' else 'a') - 10)
+
+-- readInt reads a string of digits using an arbitrary base.
+-- Leading minus signs must be handled elsewhere.
+
+readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+-- showInt is used for positive numbers only
+showInt :: Integral a => a -> ShowS
+showInt n r | n < 0 = error "Numeric.showInt: can't show negative numbers"
+ | otherwise =
+ let (n',d) = quotRem n 10
+ r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+
+readSigned:: Real a => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+ where read' r = read'' r ++
+ [(-x,t) | ("-",s) <- lex r,
+ (x,t) <- read'' s]
+ read'' r = [(n,s) | (str,s) <- lex r,
+ (n,"") <- readPos str]
+
+showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ else showPos x
+
+readFloat :: RealFloat a => ReadS a
+readFloat r = [(fromRational ((n%1)*10^^(k-d)),t) | (n,d,s) <- readFix r,
+ (k,t) <- readExp s]
+ where readFix r = [(read (ds++ds'), length ds', t)
+ | (ds, s) <- lexDigits r
+ , (ds',t) <- lexFrac s ]
+
+ lexFrac ('.':s) = lexDigits s
+ lexFrac s = [("",s)]
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = [(0,s)]
+
+ readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+ readExp' ('+':s) = readDec s
+ readExp' s = readDec s
+
+
+-- Hooks for primitives: -----------------------------------------------------
+-- Do not mess with these!
+
+primCompAux :: Ord a => a -> a -> Ordering -> Ordering
+primCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+
+primPmInt :: Num a => Int -> a -> Bool
+primPmInt n x = fromInt n == x
+
+primPmInteger :: Num a => Integer -> a -> Bool
+primPmInteger n x = fromInteger n == x
+
+primPmFlt :: Fractional a => Double -> a -> Bool
+primPmFlt n x = fromDouble n == x
+
+-- ToDo: make the message more informative.
+primPmFail :: a
+primPmFail = error "Pattern Match Failure"
+primPmFailBUG :: a
+primPmFailBUG = error ("\nSTG-Hugs: detected a bug in translation to STG code.\n" ++
+ "**Please** report to v-julsew@microsoft.com. Thx!\n")
+
+-- used in desugaring Foreign functions
+primMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+primMkIO = ST
+
+-- The following primitives are only needed if (n+k) patterns are enabled:
+primPmNpk :: Integral a => Int -> a -> Maybe a
+primPmNpk n x = if n'<=x then Just (x-n') else Nothing
+ where n' = fromInt n
+
+primPmSub :: Integral a => Int -> a -> a
+primPmSub n x = x - fromInt n
+
+-- Unpack strings generated by the Hugs code generator.
+-- Strings can contain \0 provided they're coded right.
+--
+-- ToDo: change this (and Hugs code generator) to use ByteArrays
+
+primUnpackString :: Addr -> String
+primUnpackString a = unpack 0
+ where
+ -- The following decoding is based on evalString in the old machine.c
+ unpack i
+ | c == '\0' = []
+ | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
+ then '\\' : unpack (i+2)
+ else '\0' : unpack (i+2)
+ | otherwise = c : unpack (i+1)
+ where
+ c = primIndexCharOffAddr a i
+
+
+-- Monadic I/O: --------------------------------------------------------------
+
+type FilePath = String
+
+--data IOError = ...
+--instance Eq IOError ...
+--instance Show IOError ...
+
+data IOError = IOError String
+instance Show IOError where
+ showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
+
+ioError :: IOError -> IO a
+ioError (IOError s) = primRaise (IOExcept s)
+
+userError :: String -> IOError
+userError s = primRaise (ErrorCall s)
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch x eh = primCatch x (eh.exception2ioerror)
+ where
+ exception2ioerror (IOExcept s) = IOError s
+ exception2ioerror other = IOError (show other)
+
+putChar :: Char -> IO ()
+putChar c = nh_stdout >>= \h -> nh_write h (primCharToInt c)
+
+putStr :: String -> IO ()
+putStr s = --mapM_ putChar s -- correct, but slow
+ nh_stdout >>= \h ->
+ let loop [] = return ()
+ loop (c:cs) = nh_write h (primCharToInt c) >> loop cs
+ in loop s
+
+putStrLn :: String -> IO ()
+putStrLn s = do { putStr s; putChar '\n' }
+
+print :: Show a => a -> IO ()
+print = putStrLn . show
+
+getChar :: IO Char
+getChar = unsafeInterleaveIO (
+ nh_stdin >>= \h ->
+ nh_read h >>= \ci ->
+ return (primIntToChar ci)
+ )
+
+getLine :: IO String
+getLine = do c <- getChar
+ if c=='\n' then return ""
+ else do cs <- getLine
+ return (c:cs)
+
+getContents :: IO String
+getContents = nh_stdin >>= \h -> readfromhandle h
+
+interact :: (String -> String) -> IO ()
+interact f = getContents >>= (putStr . f)
+
+readFile :: FilePath -> IO String
+readFile fname
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 0 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("readFile: can't open file " ++ fname)
+ else readfromhandle h
+
+writeFile :: FilePath -> String -> IO ()
+writeFile fname contents
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 1 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("writeFile: can't create file " ++ fname)
+ else writetohandle fname h contents
+
+
+appendFile :: FilePath -> String -> IO ()
+appendFile fname contents
+ = fileopen_sendname fname >>= \ptr ->
+ nh_open ptr 2 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (h == 0 || errno /= 0)
+ then (ioError.IOError) ("appendFile: can't open file " ++ fname)
+ else writetohandle fname h contents
+
+
+-- raises an exception instead of an error
+readIO :: Read a => String -> IO a
+readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> return x
+ [] -> ioError (userError "PreludeIO.readIO: no parse")
+ _ -> ioError (userError
+ "PreludeIO.readIO: ambiguous parse")
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+
+-- End of Hugs standard prelude ----------------------------------------------
+
+data Exception
+ = ErrorCall String
+ | IOExcept String
+
+instance Show Exception where
+ showsPrec _ (ErrorCall s) = showString ("error: " ++ s)
+ showsPrec _ (IOExcept s) = showString ("I/O error: " ++ s)
+
+data IOResult = IOResult deriving (Show)
+
+type FILE_STAR = Int
+
+foreign import stdcall "nHandle.so" "nh_stdin" nh_stdin :: IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_stdout" nh_stdout :: IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_write" nh_write :: FILE_STAR -> Int -> IO ()
+foreign import stdcall "nHandle.so" "nh_read" nh_read :: FILE_STAR -> IO Int
+foreign import stdcall "nHandle.so" "nh_open" nh_open :: Int -> Int -> IO FILE_STAR
+foreign import stdcall "nHandle.so" "nh_close" nh_close :: FILE_STAR -> IO ()
+foreign import stdcall "nHandle.so" "nh_errno" nh_errno :: IO Int
+
+foreign import stdcall "nHandle.so" "nh_malloc" nh_malloc :: Int -> IO Int
+foreign import stdcall "nHandle.so" "nh_free" nh_free :: Int -> IO ()
+foreign import stdcall "nHandle.so" "nh_assign" nh_assign :: Int -> Int -> Int -> IO Int
+
+fileopen_sendname :: String -> IO Int
+fileopen_sendname fname
+ = nh_malloc (1 + length fname) >>= \ptr ->
+ let loop i [] = nh_assign ptr i 0 >> return ptr
+ loop i (c:cs) = nh_assign ptr i (primCharToInt c) >> loop (i+1) cs
+ in
+ loop 0 fname
+
+readfromhandle :: FILE_STAR -> IO String
+readfromhandle h
+ = unsafeInterleaveIO (
+ nh_read h >>= \ci ->
+ if ci == -1 {-EOF-} then return "" else
+ readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
+ )
+
+writetohandle :: String -> FILE_STAR -> String -> IO ()
+writetohandle fname h []
+ = nh_close h >>
+ nh_errno >>= \errno ->
+ if errno == 0
+ then return ()
+ else error ( "writeFile/appendFile: error closing file " ++ fname)
+writetohandle fname h (c:cs)
+ = nh_write h (primCharToInt c) >>
+ writetohandle fname h cs
+
+------------------------------------------------------------------------------
+-- ST, IO --------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+newtype ST s a = ST (s -> (a,s))
+
+data RealWorld
+type IO a = ST RealWorld a
+
+
+--runST :: (forall s. ST s a) -> a
+runST :: ST RealWorld a -> a
+runST m = fst (unST m theWorld)
+ where
+ theWorld :: RealWorld
+ theWorld = error "runST: entered the RealWorld"
+
+unST (ST a) = a
+
+instance Functor (ST s) where
+ fmap f x = x >>= (return . f)
+
+instance Monad (ST s) where
+ m >> k = m >>= \ _ -> k
+ return x = ST $ \ s -> (x,s)
+ m >>= k = ST $ \s -> case unST m s of { (a,s') -> unST (k a) s' }
+
+
+-- used when Hugs invokes top level function
+primRunIO :: IO () -> ()
+primRunIO m
+ = protect (fst (unST m realWorld))
+ where
+ realWorld = error "panic: Hugs entered the real world"
+ protect :: () -> ()
+ protect comp
+ = primCatch comp (\e -> fst (unST (putStr (show e)) realWorld))
+
+trace :: String -> a -> a
+trace s x
+ = (runST (putStr ("trace: " ++ s ++ "\n"))) `seq` x
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO = unsafeInterleaveST
+
+
+------------------------------------------------------------------------------
+-- Addr, ForeignObj, Prim*Array ----------------------------------------------
+------------------------------------------------------------------------------
+
+data Addr
+
+nullAddr = primIntToAddr 0
+
+instance Eq Addr where
+ (==) = primEqAddr
+ (/=) = primNeAddr
+
+instance Ord Addr where
+ (<) = primLtAddr
+ (<=) = primLeAddr
+ (>=) = primGeAddr
+ (>) = primGtAddr
+
+
+data ForeignObj
+makeForeignObj :: Addr -> IO ForeignObj
+makeForeignObj = primMakeForeignObj
+
+
+data PrimArray a -- immutable arrays with Int indices
+data PrimByteArray
+
+data Ref s a -- mutable variables
+data PrimMutableArray s a -- mutable arrays with Int indices
+data PrimMutableByteArray s
+
+
+------------------------------------------------------------------------------
+-- hooks to call libHS_cbits -------------------------------------------------
+------------------------------------------------------------------------------
+{-
+type FILE_OBJ = ForeignObj -- as passed into functions
+type CString = PrimByteArray
+type How = Int
+type Binary = Int
+type OpenFlags = Int
+type IOFileAddr = Addr -- as returned from functions
+type FD = Int
+type OpenStdFlags = Int
+type Readable = Int -- really Bool
+type Exclusive = Int -- really Bool
+type RC = Int -- standard return code
+type Bytes = PrimMutableByteArray RealWorld
+type Flush = Int -- really Bool
+
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
+ freeStdFileObject :: ForeignObj -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "freeFileObject"
+ freeFileObject :: ForeignObj -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "setBuf"
+ prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "getBufSize"
+ prim_getBufSize :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "inputReady"
+ prim_inputReady :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "fileGetc"
+ prim_fileGetc :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "fileLookAhead"
+ prim_fileLookAhead :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readBlock"
+ prim_readBlock :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readLine"
+ prim_readLine :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "readChar"
+ prim_readChar :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "writeFileObject"
+ prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "filePutc"
+ prim_filePutc :: FILE_OBJ -> Char -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getBufStart"
+ prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getWriteableBuf"
+ prim_getWriteableBuf :: FILE_OBJ -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getBufWPtr"
+ prim_getBufWPtr :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "setBufWPtr"
+ prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "closeFile"
+ prim_closeFile :: FILE_OBJ -> Flush -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "fileEOF"
+ prim_fileEOF :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setBuffering"
+ prim_setBuffering :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "flushFile"
+ prim_flushFile :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getBufferMode"
+ prim_getBufferMode :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "seekFileP"
+ prim_seekFileP :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setTerminalEcho"
+ prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getTerminalEcho"
+ prim_getTerminalEcho :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "isTerminalDevice"
+ prim_isTerminalDevice :: FILE_OBJ -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "setConnectedTo"
+ prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "ungetChar"
+ prim_ungetChar :: FILE_OBJ -> Char -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "readChunk"
+ prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "writeBuf"
+ prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getFileFd"
+ prim_getFileFd :: FILE_OBJ -> IO FD
+
+foreign import stdcall "libHS_cbits.so" "fileSize_int64"
+ prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "getFilePosn"
+ prim_getFilePosn :: FILE_OBJ -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "setFilePosn"
+ prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
+
+foreign import stdcall "libHS_cbits.so" "getConnFileFd"
+ prim_getConnFileFd :: FILE_OBJ -> IO FD
+
+foreign import stdcall "libHS_cbits.so" "allocMemory__"
+ prim_allocMemory__ :: Int -> IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getLock"
+ prim_getLock :: FD -> Exclusive -> IO RC
+
+foreign import stdcall "libHS_cbits.so" "openStdFile"
+ prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
+
+foreign import stdcall "libHS_cbits.so" "openFile"
+ prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
+
+foreign import stdcall "libHS_cbits.so" "freeFileObject"
+ prim_freeFileObject :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "freeStdFileObject"
+ prim_freeStdFileObject :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "const_BUFSIZ"
+ const_BUFSIZ :: Int
+
+foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__"
+ prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__"
+ prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__"
+ prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__"
+ prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
+
+foreign import stdcall "libHS_cbits.so" "getErrStr__"
+ prim_getErrStr__ :: IO Addr
+
+foreign import stdcall "libHS_cbits.so" "getErrNo__"
+ prim_getErrNo__ :: IO Int
+
+foreign import stdcall "libHS_cbits.so" "getErrType__"
+ prim_getErrType__ :: IO Int
+
+--foreign import stdcall "libHS_cbits.so" "seekFile_int64"
+-- prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
+-}
+
+-- showFloat ------------------------------------------------------------------
+
+showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat :: (RealFloat a) => a -> ShowS
+
+showEFloat d x = showString (formatRealFloat FFExponent d x)
+showFFloat d x = showString (formatRealFloat FFFixed d x)
+showGFloat d x = showString (formatRealFloat FFGeneric d x)
+showFloat = showGFloat Nothing
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where base = 10
+ s = if isNaN x then
+ "NaN"
+ else if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else if x < 0 || isNegativeZero x then
+ '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is
+ in case fmt of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is, e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ case ds of
+ ['0'] -> "0.0e0"
+ [d] -> d : ".0e" ++ show (e-1)
+ d:ds -> d : '.' : ds ++ 'e':show (e-1)
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let (ei, is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit
+ (if ei > 0 then init is' else is')
+ in d:'.':ds ++ "e" ++ show (e-1+ei)
+ FFFixed ->
+ case decs of
+ Nothing ->
+ let f 0 s ds = mk0 s ++ "." ++ mk0 ds
+ f n s "" = f (n-1) (s++"0") ""
+ f n s (d:ds) = f (n-1) (s++[d]) ds
+ mk0 "" = "0"
+ mk0 s = s
+ in f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let (ei, is') = roundTo base (dec' + e) is
+ (ls, rs) = splitAt (e+ei) (map intToDigit is')
+ in (if null ls then "0" else ls) ++
+ (if null rs then "" else '.' : rs)
+ else
+ let (ei, is') = roundTo base dec'
+ (replicate (-e) 0 ++ is)
+ d : ds = map intToDigit
+ (if ei > 0 then is' else 0:is')
+ in d : '.' : ds
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+ (0, is) -> (0, is)
+ (1, is) -> (1, 1 : is)
+ where b2 = base `div` 2
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+ f d (i:is) =
+ let (c, ds) = f (d-1) is
+ i' = c + i
+ in if i' == base then (1, 0:ds) else (0, i':ds)
+
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) = let n = minExp - e0
+ in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let k0 =
+
+ 0
+
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n
+ else fixup (n+1)
+ in fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k)
+ in gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in (map toInt (reverse rds), k)
+
+-- Exponentiation with(out) a cache for the most common numbers.
+expt :: Integer -> Int -> Integer
+expt base n = base^n
* Copyright (c) 1994-1998.
*
* $RCSfile: Assembler.c,v $
- * $Revision: 1.6 $
- * $Date: 1999/03/02 19:52:24 $
+ * $Revision: 1.7 $
+ * $Date: 1999/03/09 14:51:19 $
*
* This module provides functions to construct BCOs and other closures
* required by the bytecode compiler.
*
* ------------------------------------------------------------------------*/
-static void asmInstr( AsmBCO bco, StgWord i )
+static void asmInstr8 ( AsmBCO bco, StgWord i )
{
+ if (i >= 256) {
+ fprintf(stderr, "too big (256)\n");
+ }
ASSERT(i < 256); /* must be a byte */
insertInstrs(&(bco->is),i);
}
+static void asmInstr16 ( AsmBCO bco, StgWord i )
+{
+ if (i >= 65536) {
+ fprintf(stderr, "too big (65536)\n");
+ }
+ ASSERT(i < 65536); /* must be a byte */
+ insertInstrs(&(bco->is),i / 256);
+ insertInstrs(&(bco->is),i % 256);
+}
+
static void asmPtr( AsmBCO bco, AsmObject x )
{
insertPtrs( &bco->object.ptrs, x );
}
/* --------------------------------------------------------------------------
+ * Instruction emission
+ * ------------------------------------------------------------------------*/
+
+static void emit_i0 ( AsmBCO bco, Instr opcode )
+{
+ asmInstr8(bco,opcode);
+}
+
+static void emit_i1 ( AsmBCO bco, Instr opcode, int arg1 )
+{
+ asmInstr8(bco,opcode);
+ asmInstr8(bco,arg1);
+}
+
+static void emit_i2 ( AsmBCO bco, Instr opcode, int arg1, int arg2 )
+{
+ asmInstr8(bco,opcode);
+ asmInstr8(bco,arg1);
+ asmInstr8(bco,arg2);
+}
+
+static void emit_i_VAR_INT ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR_INT);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_INT_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+#ifdef PROVIDE_ADDR
+static void emit_i_VAR_ADDR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR_ADDR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_ADDR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+#endif
+
+static void emit_i_VAR_CHAR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR_CHAR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_CHAR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_VAR_FLOAT ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR_FLOAT);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_FLOAT_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_VAR_DOUBLE ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR_DOUBLE);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_DOUBLE_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_VAR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_VAR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_VAR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_SLIDE ( AsmBCO bco, int arg1, int arg2 )
+{
+ ASSERT(arg1 >= 0);
+ ASSERT(arg2 >= 0);
+ if (arg1 < 256 && arg2 < 256) {
+ asmInstr8(bco,i_SLIDE);
+ asmInstr8(bco,arg1);
+ asmInstr8(bco,arg2);
+ } else {
+ asmInstr8(bco,i_SLIDE_big);
+ asmInstr16(bco,arg1);
+ asmInstr16(bco,arg2);
+ }
+}
+
+static void emit_i_MKAP ( AsmBCO bco, int arg1, int arg2 )
+{
+ ASSERT(arg1 >= 0);
+ ASSERT(arg2 >= 0);
+ if (arg1 < 256 && arg2 < 256) {
+ asmInstr8(bco,i_MKAP);
+ asmInstr8(bco,arg1);
+ asmInstr8(bco,arg2);
+ } else {
+ asmInstr8(bco,i_MKAP_big);
+ asmInstr16(bco,arg1);
+ asmInstr16(bco,arg2);
+ }
+}
+
+static void emit_i_CONST_INT ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_INT);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_INT_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+#ifdef PROVIDE_INTEGER
+static void emit_i_CONST_INTEGER ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_INTEGER);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_INTEGER_big);
+ asmInstr16(bco,arg1);
+ }
+}
+#endif
+
+static void emit_i_CONST_ADDR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_ADDR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_ADDR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_CONST_CHAR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_CHAR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_CHAR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_CONST_FLOAT ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_FLOAT);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_FLOAT_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_CONST_DOUBLE ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST_DOUBLE);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_DOUBLE_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_RETADDR ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_RETADDR);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_RETADDR_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+static void emit_i_CONST ( AsmBCO bco, int arg1 )
+{
+ ASSERT(arg1 >= 0);
+ if (arg1 < 256) {
+ asmInstr8(bco,i_CONST);
+ asmInstr8(bco,arg1);
+ } else {
+ asmInstr8(bco,i_CONST_big);
+ asmInstr16(bco,arg1);
+ }
+}
+
+
+/* --------------------------------------------------------------------------
* Arg checks.
* ------------------------------------------------------------------------*/
{
nat args = bco->sp - last_arg;
if (args != 0) { /* optimisation */
- asmInstr(bco,i_ARG_CHECK);
- asmInstr(bco,args);
+ emit_i1(bco,i_ARG_CHECK,args);
grabHpNonUpd(bco,PAP_sizeW(args-1));
resetHp(bco,0);
}
void asmVar ( AsmBCO bco, AsmVar v, AsmRep rep )
{
+ int offset;
+
+ if (rep == VOID_REP) {
+ emit_i0(bco,i_VOID);
+ bco->sp += repSizeW(rep);
+ return;
+ }
+
+ offset = bco->sp - v;
switch (rep) {
case BOOL_REP:
case INT_REP:
- asmInstr(bco,i_VAR_INT);
+ emit_i_VAR_INT(bco,offset);
break;
#ifdef PROVIDE_INT64
case INT64_REP:
- asmInstr(bco,i_VAR_INT64);
+ emit_i_VAR_INT64(bco,offset);
break;
#endif
#ifdef PROVIDE_WORD
case WORD_REP:
- asmInstr(bco,i_VAR_WORD);
+ emit_i_VAR_WORD(bco,offset);
break;
#endif
#ifdef PROVIDE_ADDR
case ADDR_REP:
- asmInstr(bco,i_VAR_ADDR);
+ emit_i_VAR_ADDR(bco,offset);
break;
#endif
case CHAR_REP:
- asmInstr(bco,i_VAR_CHAR);
+ emit_i_VAR_CHAR(bco,offset);
break;
case FLOAT_REP:
- asmInstr(bco,i_VAR_FLOAT);
+ emit_i_VAR_FLOAT(bco,offset);
break;
case DOUBLE_REP:
- asmInstr(bco,i_VAR_DOUBLE);
+ emit_i_VAR_DOUBLE(bco,offset);
break;
#ifdef PROVIDE_STABLE
case STABLE_REP:
- asmInstr(bco,i_VAR_STABLE);
+ emit_i_VAR_STABLE(bco,offset);
break;
#endif
case MVAR_REP: /* MVar a */
#endif
case PTR_REP:
- asmInstr(bco,i_VAR);
+ emit_i_VAR(bco,offset);
break;
-
- case VOID_REP:
- asmInstr(bco,i_VOID);
- bco->sp += repSizeW(rep);
- return; /* NB we don't break! */
default:
barf("asmVar %d",rep);
}
- asmInstr(bco,bco->sp - v);
bco->sp += repSizeW(rep);
}
int y = sp1 - sp2;
ASSERT(x >= 0 && y >= 0);
if (y != 0) {
- asmInstr(bco,i_SLIDE);
- asmInstr(bco,x);
- asmInstr(bco,y);
+ emit_i_SLIDE(bco,x,y);
bco->sp -= sp1 - sp2;
}
- asmInstr(bco,i_ENTER);
+ emit_i0(bco,i_ENTER);
}
/* --------------------------------------------------------------------------
{
switch (rep) {
case CHAR_REP:
- asmInstr(bco,i_PACK_CHAR);
+ emit_i0(bco,i_PACK_CHAR);
grabHpNonUpd(bco,Czh_sizeW);
break;
case INT_REP:
- asmInstr(bco,i_PACK_INT);
+ emit_i0(bco,i_PACK_INT);
grabHpNonUpd(bco,Izh_sizeW);
break;
#ifdef PROVIDE_INT64
case INT64_REP:
- asmInstr(bco,i_PACK_INT64);
+ emit_i0(bco,i_PACK_INT64);
grabHpNonUpd(bco,I64zh_sizeW);
break;
#endif
#ifdef PROVIDE_WORD
case WORD_REP:
- asmInstr(bco,i_PACK_WORD);
+ emit_i0(bco,i_PACK_WORD);
grabHpNonUpd(bco,Wzh_sizeW);
break;
#endif
#ifdef PROVIDE_ADDR
case ADDR_REP:
- asmInstr(bco,i_PACK_ADDR);
+ emit_i0(bco,i_PACK_ADDR);
grabHpNonUpd(bco,Azh_sizeW);
break;
#endif
case FLOAT_REP:
- asmInstr(bco,i_PACK_FLOAT);
+ emit_i0(bco,i_PACK_FLOAT);
grabHpNonUpd(bco,Fzh_sizeW);
break;
case DOUBLE_REP:
- asmInstr(bco,i_PACK_DOUBLE);
+ emit_i0(bco,i_PACK_DOUBLE);
grabHpNonUpd(bco,Dzh_sizeW);
break;
#ifdef PROVIDE_STABLE
case STABLE_REP:
- asmInstr(bco,i_PACK_STABLE);
+ emit_i0(bco,i_PACK_STABLE);
grabHpNonUpd(bco,Stablezh_sizeW);
break;
#endif
{
switch (rep) {
case INT_REP:
- asmInstr(bco,i_UNPACK_INT);
+ emit_i0(bco,i_UNPACK_INT);
break;
#ifdef PROVIDE_INT64
case INT64_REP:
- asmInstr(bco,i_UNPACK_INT64);
+ emit_i0(bco,i_UNPACK_INT64);
break;
#endif
#ifdef PROVIDE_WORD
case WORD_REP:
- asmInstr(bco,i_UNPACK_WORD);
+ emit_i0(bco,i_UNPACK_WORD);
break;
#endif
#ifdef PROVIDE_ADDR
case ADDR_REP:
- asmInstr(bco,i_UNPACK_ADDR);
+ emit_i0(bco,i_UNPACK_ADDR);
break;
#endif
case CHAR_REP:
- asmInstr(bco,i_UNPACK_CHAR);
+ emit_i0(bco,i_UNPACK_CHAR);
break;
case FLOAT_REP:
- asmInstr(bco,i_UNPACK_FLOAT);
+ emit_i0(bco,i_UNPACK_FLOAT);
break;
case DOUBLE_REP:
- asmInstr(bco,i_UNPACK_DOUBLE);
+ emit_i0(bco,i_UNPACK_DOUBLE);
break;
#ifdef PROVIDE_STABLE
case STABLE_REP:
- asmInstr(bco,i_UNPACK_STABLE);
+ emit_i0(bco,i_UNPACK_STABLE);
break;
#endif
default:
{
switch (rep) {
case CHAR_REP:
- asmInstr(bco,i_RETURN_CHAR);
+ emit_i0(bco,i_RETURN_CHAR);
break;
case INT_REP:
- asmInstr(bco,i_RETURN_INT);
+ emit_i0(bco,i_RETURN_INT);
break;
#ifdef PROVIDE_INT64
case INT64_REP:
- asmInstr(bco,i_RETURN_INT64);
+ emit_i0(bco,i_RETURN_INT64);
break;
#endif
#ifdef PROVIDE_WORD
case WORD_REP:
- asmInstr(bco,i_RETURN_WORD);
+ emit_i0(bco,i_RETURN_WORD);
break;
#endif
#ifdef PROVIDE_ADDR
case ADDR_REP:
- asmInstr(bco,i_RETURN_ADDR);
+ emit_i0(bco,i_RETURN_ADDR);
break;
#endif
case FLOAT_REP:
- asmInstr(bco,i_RETURN_FLOAT);
+ emit_i0(bco,i_RETURN_FLOAT);
break;
case DOUBLE_REP:
- asmInstr(bco,i_RETURN_DOUBLE);
+ emit_i0(bco,i_RETURN_DOUBLE);
break;
#ifdef PROVIDE_STABLE
case STABLE_REP:
- asmInstr(bco,i_RETURN_STABLE);
+ emit_i0(bco,i_RETURN_STABLE);
break;
#endif
#ifdef PROVIDE_INTEGER
case THREADID_REP: /* ThreadId */
case MVAR_REP: /* MVar a */
#endif
- asmInstr(bco,i_RETURN_GENERIC);
+ emit_i0(bco,i_RETURN_GENERIC);
break;
default:
barf("asmReturnUnboxed %d",rep);
void asmConstInt( AsmBCO bco, AsmInt x )
{
- asmInstr(bco,i_CONST_INT);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_INT(bco,bco->nps.len);
asmWords(bco,AsmInt,x);
bco->sp += repSizeW(INT_REP);
}
#ifdef PROVIDE_INT64
void asmConstInt64( AsmBCO bco, AsmInt64 x )
{
- asmInstr(bco,i_CONST_INT64);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_INT64(bco,bco->nps.len);
asmWords(bco,AsmInt64,x);
bco->sp += repSizeW(INT64_REP);
}
#ifdef PROVIDE_INTEGER
void asmConstInteger( AsmBCO bco, AsmString x )
{
- asmInstr(bco,i_CONST_INTEGER);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_INTEGER(bco,bco->nps.len);
asmWords(bco,AsmString,x);
bco->sp += repSizeW(INTEGER_REP);
}
#ifdef PROVIDE_ADDR
void asmConstAddr( AsmBCO bco, AsmAddr x )
{
- asmInstr(bco,i_CONST_ADDR);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_ADDR(bco,bco->nps.len);
asmWords(bco,AsmAddr,x);
bco->sp += repSizeW(ADDR_REP);
}
#ifdef PROVIDE_WORD
void asmConstWord( AsmBCO bco, AsmWord x )
{
- asmInstr(bco,i_CONST_INT);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_INT(bco->nps.len);
asmWords(bco,AsmWord,x);
bco->sp += repSizeW(WORD_REP);
}
void asmConstChar( AsmBCO bco, AsmChar x )
{
- asmInstr(bco,i_CONST_CHAR);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_CHAR(bco,bco->nps.len);
asmWords(bco,AsmChar,x);
bco->sp += repSizeW(CHAR_REP);
}
void asmConstFloat( AsmBCO bco, AsmFloat x )
{
- asmInstr(bco,i_CONST_FLOAT);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_FLOAT(bco,bco->nps.len);
asmWords(bco,AsmFloat,x);
bco->sp += repSizeW(FLOAT_REP);
}
void asmConstDouble( AsmBCO bco, AsmDouble x )
{
- asmInstr(bco,i_CONST_DOUBLE);
- asmInstr(bco,bco->nps.len);
+ emit_i_CONST_DOUBLE(bco,bco->nps.len);
asmWords(bco,AsmDouble,x);
bco->sp += repSizeW(DOUBLE_REP);
}
/* --------------------------------------------------------------------------
- *
+ * Algebraic case helpers
* ------------------------------------------------------------------------*/
/* a mildly bogus pair of functions... */
AsmSp asmContinuation( AsmBCO bco, AsmBCO ret_addr )
{
- asmInstr(bco,i_RETADDR);
- asmInstr(bco,bco->object.ptrs.len);
+ emit_i_RETADDR(bco,bco->object.ptrs.len);
asmPtr(bco,&(ret_addr->object));
bco->sp += 2 * sizeofW(StgPtr);
return bco->sp;
AsmPc asmTest( AsmBCO bco, AsmWord tag )
{
- asmInstr(bco,i_TEST);
- asmInstr(bco,tag);
- asmInstr(bco,0);
+ asmInstr8(bco,i_TEST);
+ asmInstr8(bco,tag);
+ asmInstr16(bco,0);
return bco->is.len;
}
{
asmVar(bco,v,INT_REP);
asmConstInt(bco,x);
- asmInstr(bco,i_TEST_INT);
- asmInstr(bco,0);
+ asmInstr8(bco,i_TEST_INT);
+ asmInstr16(bco,0);
bco->sp -= 2*repSizeW(INT_REP);
return bco->is.len;
}
{
int distance = bco->is.len - from;
ASSERT(distance >= 0);
- setInstrs(&(bco->is),from-1,distance);
+ ASSERT(distance < 65536);
+ setInstrs(&(bco->is),from-2,distance/256);
+ setInstrs(&(bco->is),from-1,distance%256);
}
void asmPanic( AsmBCO bco )
{
- asmInstr(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
+ emit_i0(bco,i_PANIC); /* "irrefutable" pattern failed - oops! */
}
/* --------------------------------------------------------------------------
void asmEndPrim( AsmBCO bco, const AsmPrim* prim, AsmSp base )
{
- asmInstr(bco,prim->prefix);
- asmInstr(bco,prim->opcode);
+ emit_i1(bco,prim->prefix,prim->opcode);
bco->sp = base;
}
AsmBCO asm_BCO_catch ( void )
{
AsmBCO bco = asmBeginBCO(0 /*NIL*/);
- asmInstr(bco,i_ARG_CHECK); asmInstr(bco,2);
- asmInstr(bco,i_PRIMOP1); asmInstr(bco,i_pushcatchframe);
+ emit_i1(bco,i_ARG_CHECK,2);
+ emit_i1(bco,i_PRIMOP1,i_pushcatchframe);
bco->sp += (1-2)*sizeofW(StgPtr) + sizeofW(StgCatchFrame);
- asmInstr(bco,i_ENTER);
+ emit_i0(bco,i_ENTER);
asmEndBCO(bco);
return bco;
}
AsmBCO asm_BCO_raise ( void )
{
AsmBCO bco = asmBeginBCO(0 /*NIL*/);
- asmInstr(bco,i_ARG_CHECK); asmInstr(bco,1);
- asmInstr(bco,i_PRIMOP2); asmInstr(bco,i_raise);
+ emit_i1(bco,i_ARG_CHECK,1);
+ emit_i1(bco,i_PRIMOP2,i_raise);
asmEndBCO(bco);
return bco;
}
AsmBCO eval, cont;
cont = asmBeginBCO(0 /*NIL*/);
- asmInstr(cont,i_ARG_CHECK); asmInstr(cont,2);
- asmInstr(cont,i_VAR); asmInstr(cont,1);
- asmInstr(cont,i_SLIDE); asmInstr(cont,1); asmInstr(cont,2);
- asmInstr(cont,i_ENTER);
+ emit_i1(cont,i_ARG_CHECK,2);
+ emit_i_VAR(cont,1);
+ emit_i_SLIDE(cont,1,2);
+ emit_i0(cont,i_ENTER);
cont->sp += 3*sizeofW(StgPtr);
asmEndBCO(cont);
eval = asmBeginBCO(0 /*NIL*/);
- asmInstr(eval,i_ARG_CHECK); asmInstr(eval,2);
- asmInstr(eval,i_RETADDR);
- asmInstr(eval,eval->object.ptrs.len);
+ emit_i1(eval,i_ARG_CHECK,2);
+ emit_i_RETADDR(eval,eval->object.ptrs.len);
asmPtr(eval,&(cont->object));
- asmInstr(eval,i_VAR); asmInstr(eval,2);
- asmInstr(eval,i_SLIDE); asmInstr(eval,3); asmInstr(eval,1);
- asmInstr(eval,i_PRIMOP1); asmInstr(eval,i_pushseqframe);
- asmInstr(eval,i_ENTER);
+ emit_i_VAR(eval,2);
+ emit_i_SLIDE(eval,3,1);
+ emit_i1(eval,i_PRIMOP1,i_pushseqframe);
+ emit_i0(eval,i_ENTER);
eval->sp += sizeofW(StgSeqFrame) + 4*sizeofW(StgPtr);
asmEndBCO(eval);
AsmVar asmAllocCONSTR ( AsmBCO bco, AsmInfo info )
{
ASSERT( sizeW_fromITBL(info) >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
- asmInstr(bco,i_ALLOC_CONSTR);
- asmInstr(bco,bco->nps.len);
+ emit_i1(bco,i_ALLOC_CONSTR,bco->nps.len);
asmWords(bco,AsmInfo,info);
bco->sp += sizeofW(StgClosurePtr);
grabHpNonUpd(bco,sizeW_fromITBL(info));
assert(start >= v);
/* only reason to include info is for this assertion */
assert(info->layout.payload.ptrs == size);
- asmInstr(bco,i_PACK);
- asmInstr(bco,bco->sp - v);
+ emit_i1(bco,i_PACK,bco->sp - v);
bco->sp = start;
}
void asmEndUnpack( AsmBCO bco )
{
- asmInstr(bco,i_UNPACK);
+ emit_i0(bco,i_UNPACK);
}
AsmVar asmAllocAP( AsmBCO bco, AsmNat words )
{
- asmInstr(bco,i_ALLOC_AP);
- asmInstr(bco,words);
+ emit_i1(bco,i_ALLOC_AP,words);
bco->sp += sizeofW(StgPtr);
grabHpUpd(bco,AP_sizeW(words));
return bco->sp;
void asmEndMkAP( AsmBCO bco, AsmVar v, AsmSp start )
{
- asmInstr(bco,i_MKAP);
- asmInstr(bco,bco->sp-v);
- asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */
+ emit_i_MKAP(bco,bco->sp-v,bco->sp-start-1);
+ /* -1 because fun isn't counted */
bco->sp = start;
}
AsmVar asmAllocPAP( AsmBCO bco, AsmNat size )
{
- asmInstr(bco,i_ALLOC_PAP);
- asmInstr(bco,size);
+ emit_i1(bco,i_ALLOC_PAP,size);
bco->sp += sizeofW(StgPtr);
return bco->sp;
}
void asmEndMkPAP( AsmBCO bco, AsmVar v, AsmSp start )
{
- asmInstr(bco,i_MKPAP);
- asmInstr(bco,bco->sp-v);
- asmInstr(bco,bco->sp-start-1); /* -1 because fun isn't counted */
+ emit_i2(bco,i_MKPAP,bco->sp-v,bco->sp-start-1);
+ /* -1 because fun isn't counted */
bco->sp = start;
}
AsmVar asmClosure( AsmBCO bco, AsmObject p )
{
- StgWord o = bco->object.ptrs.len;
- if (o < 256) {
- asmInstr(bco,i_CONST);
- asmInstr(bco,o);
- asmPtr(bco,p);
- } else {
- asmInstr(bco,i_CONST2);
- asmInstr(bco,o / 256);
- asmInstr(bco,o % 256);
- asmPtr(bco,p);
- }
+ emit_i_CONST(bco,bco->object.ptrs.len);
+ asmPtr(bco,p);
bco->sp += sizeofW(StgPtr);
return bco->sp;
}
/* -----------------------------------------------------------------------------
- * $Id: Bytecodes.h,v 1.4 1999/03/01 14:47:07 sewardj Exp $
+ * $Id: Bytecodes.h,v 1.5 1999/03/09 14:51:24 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
, i_PANIC /* irrefutable pattern match failed! */
, i_STK_CHECK
- , i_HP_CHECK
, i_ARG_CHECK
, i_ALLOC_PAP
, i_ALLOC_CONSTR
, i_MKAP
+ , i_MKAP_big
, i_MKPAP
, i_PACK
, i_SLIDE
+ , i_SLIDE_big
, i_TEST
, i_UNPACK
, i_VAR
+ , i_VAR_big
, i_CONST
- , i_CONST2 /* 16 bit offsets - ad-hoc fix for general problem */
+ , i_CONST_big
, i_ENTER
, i_RETADDR
+ , i_RETADDR_big
, i_VOID
, i_RETURN_GENERIC
, i_VAR_INT
+ , i_VAR_INT_big
, i_CONST_INT
+ , i_CONST_INT_big
, i_RETURN_INT
, i_PACK_INT
, i_UNPACK_INT
#endif
#ifdef PROVIDE_INTEGER
, i_CONST_INTEGER
+ , i_CONST_INTEGER_big
#endif
#ifdef PROVIDE_WORD
, i_VAR_WORD
#endif
#ifdef PROVIDE_ADDR
, i_VAR_ADDR
+ , i_VAR_ADDR_big
, i_CONST_ADDR
+ , i_CONST_ADDR_big
, i_RETURN_ADDR
, i_PACK_ADDR
, i_UNPACK_ADDR
#endif
, i_VAR_CHAR
+ , i_VAR_CHAR_big
, i_CONST_CHAR
+ , i_CONST_CHAR_big
, i_RETURN_CHAR
, i_PACK_CHAR
, i_UNPACK_CHAR
, i_VAR_FLOAT
+ , i_VAR_FLOAT_big
, i_CONST_FLOAT
+ , i_CONST_FLOAT_big
, i_RETURN_FLOAT
, i_PACK_FLOAT
, i_UNPACK_FLOAT
, i_VAR_DOUBLE
+ , i_VAR_DOUBLE_big
, i_CONST_DOUBLE
+ , i_CONST_DOUBLE_big
, i_RETURN_DOUBLE
, i_PACK_DOUBLE
, i_UNPACK_DOUBLE
* Copyright (c) 1994-1998.
*
* $RCSfile: Disassembler.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/03/01 14:47:05 $
+ * $Revision: 1.5 $
+ * $Date: 1999/03/09 14:51:23 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
return pc;
}
+static InstrPtr disInt16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoInstr16(bco,pc); pc+=2;
+ ASSERT(pc < bco->n_instrs);
+ fprintf(stderr,"%s %d",i,x);
+ return pc;
+}
+
static InstrPtr disIntInt ( StgBCO *bco, InstrPtr pc, char* i )
{
StgInt x = bcoInstr(bco,pc++);
return pc;
}
+static InstrPtr disIntInt16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x, y;
+ x = bcoInstr16(bco,pc); pc += 2;
+ y = bcoInstr16(bco,pc); pc += 2;
+ fprintf(stderr,"%s %d %d",i,x,y);
+ return pc;
+}
+
static InstrPtr disIntPC ( StgBCO *bco, InstrPtr pc, char* i )
{
- StgInt x = bcoInstr(bco,pc++);
- StgWord y = bcoInstr(bco,pc++);
+ StgInt x;
+ StgWord y;
+ x = bcoInstr(bco,pc++);
+ y = bcoInstr16(bco,pc); pc += 2;
fprintf(stderr,"%s %d %d",i,x,pc+y);
return pc;
}
static InstrPtr disPC ( StgBCO *bco, InstrPtr pc, char* i )
{
- StgWord y = bcoInstr(bco,pc++);
+ StgWord y = bcoInstr16(bco,pc); pc += 2;
fprintf(stderr,"%s %d",i,pc+y);
return pc;
}
return pc;
}
-static InstrPtr disConst2Ptr ( StgBCO *bco, InstrPtr pc, char* i )
+static InstrPtr disConstPtr16 ( StgBCO *bco, InstrPtr pc, char* i )
{
- StgWord o1 = bcoInstr(bco,pc++);
- StgWord o2 = bcoInstr(bco,pc++);
- StgWord o = o1*256 + o2;
- StgPtr x = bcoConstPtr(bco,o);
+ StgInt o;
+ StgPtr x;
+ o = bcoInstr16(bco,pc); pc += 2;
+ x = bcoConstPtr(bco,o);
fprintf(stderr,"%s [%d]=",i,o);
printPtr(x); /* bad way to print it... */
return pc;
return pc;
}
+static InstrPtr disConstInt16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgInt x = bcoConstInt(bco,bcoInstr16(bco,pc)); pc += 2;
+ fprintf(stderr,"%s %d",i,x);
+ return pc;
+}
+
static InstrPtr disConstAddr ( StgBCO *bco, InstrPtr pc, char* i )
{
StgAddr x = bcoConstAddr(bco,bcoInstr(bco,pc++));
return pc;
}
+static InstrPtr disConstAddr16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgAddr x = bcoConstAddr(bco,bcoInstr16(bco,pc)); pc += 2;
+ fprintf(stderr,"%s ",i);
+ printPtr(x);
+ return pc;
+}
+
static InstrPtr disConstChar ( StgBCO *bco, InstrPtr pc, char* i )
{
StgChar x = bcoConstChar(bco,bcoInstr(bco,pc++));
return pc;
}
+static InstrPtr disConstChar16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgChar x = bcoConstChar(bco,bcoInstr16(bco,pc)); pc += 2;
+ if (isprint((int)x))
+ fprintf(stderr,"%s '%c'",i,x); else
+ fprintf(stderr,"%s 0x%x",i,(int)x);
+ return pc;
+}
+
static InstrPtr disConstFloat ( StgBCO *bco, InstrPtr pc, char* i )
{
StgFloat x = bcoConstFloat(bco,bcoInstr(bco,pc++));
return pc;
}
+static InstrPtr disConstFloat16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgFloat x = bcoConstFloat(bco,bcoInstr16(bco,pc)); pc += 2;
+ fprintf(stderr,"%s %f",i,x);
+ return pc;
+}
+
static InstrPtr disConstDouble ( StgBCO *bco, InstrPtr pc, char* i )
{
StgDouble x = bcoConstDouble(bco,bcoInstr(bco,pc++));
return pc;
}
+static InstrPtr disConstDouble16 ( StgBCO *bco, InstrPtr pc, char* i )
+{
+ StgDouble x = bcoConstDouble(bco,bcoInstr16(bco,pc)); pc += 2;
+ fprintf(stderr,"%s %f",i,x);
+ return pc;
+}
+
InstrPtr disInstr( StgBCO *bco, InstrPtr pc )
{
Instr in;
return disNone(bco,pc,"INTERNAL_ERROR");
case i_PANIC:
return disNone(bco,pc,"PANIC");
- case i_HP_CHECK:
- return disInt(bco,pc,"HP_CHECK");
case i_STK_CHECK:
return disInt(bco,pc,"STK_CHECK");
case i_ARG_CHECK:
return disInfo(bco,pc,"ALLOC_CONSTR");
case i_MKAP:
return disIntInt(bco,pc,"MKAP");
+ case i_MKAP_big:
+ return disIntInt16(bco,pc,"MKAP_big");
case i_MKPAP:
return disIntInt(bco,pc,"MKPAP");
case i_PACK:
return disInt(bco,pc,"PACK");
case i_SLIDE:
return disIntInt(bco,pc,"SLIDE");
+ case i_SLIDE_big:
+ return disIntInt16(bco,pc,"SLIDE_big");
case i_ENTER:
return disNone(bco,pc,"ENTER");
case i_RETADDR:
return disConstPtr(bco,pc,"RETADDR");
+ case i_RETADDR_big:
+ return disConstPtr16(bco,pc,"RETADDR_big");
case i_TEST:
return disIntPC(bco,pc,"TEST");
case i_UNPACK:
return disNone(bco,pc,"UNPACK");
case i_VAR:
return disInt(bco,pc,"VAR");
+ case i_VAR_big:
+ return disInt16(bco,pc,"VAR_big");
case i_CONST:
return disConstPtr(bco,pc,"CONST");
- case i_CONST2:
- return disConst2Ptr(bco,pc,"CONST2");
+ case i_CONST_big:
+ return disConstPtr16(bco,pc,"CONST_big");
case i_VOID:
return disNone(bco,pc,"VOID");
case i_VAR_INT:
return disInt(bco,pc,"VAR_INT");
+ case i_VAR_INT_big:
+ return disInt16(bco,pc,"VAR_INT_big");
case i_CONST_INT:
return disConstInt(bco,pc,"CONST_INT");
+ case i_CONST_INT_big:
+ return disConstInt16(bco,pc,"CONST_INT_big");
case i_RETURN_INT:
return disNone(bco,pc,"RETURN_INT");
case i_PACK_INT:
#ifdef PROVIDE_INTEGER
case i_CONST_INTEGER:
return disConstAddr(bco,pc,"CONST_INTEGER");
+ case i_CONST_INTEGER_big:
+ return disConstAddr16(bco,pc,"CONST_INTEGER_big");
#endif
#ifdef PROVIDE_WORD
case i_VAR_WORD:
#ifdef PROVIDE_ADDR
case i_VAR_ADDR:
return disInt(bco,pc,"VAR_ADDR");
+ case i_VAR_ADDR_big:
+ return disInt16(bco,pc,"VAR_ADDR_big");
case i_CONST_ADDR:
return disConstAddr(bco,pc,"CONST_ADDR");
+ case i_CONST_ADDR_big:
+ return disConstAddr16(bco,pc,"CONST_ADDR_big");
case i_RETURN_ADDR:
return disNone(bco,pc,"RETURN_ADDR");
case i_PACK_ADDR:
#endif
case i_VAR_CHAR:
return disInt(bco,pc,"VAR_CHAR");
+ case i_VAR_CHAR_big:
+ return disInt16(bco,pc,"VAR_CHAR_big");
case i_CONST_CHAR:
return disConstChar(bco,pc,"CONST_CHAR");
+ case i_CONST_CHAR_big:
+ return disConstChar16(bco,pc,"CONST_CHAR_big");
case i_RETURN_CHAR:
return disNone(bco,pc,"RETURN_CHAR");
case i_PACK_CHAR:
case i_VAR_FLOAT:
return disInt(bco,pc,"VAR_FLOAT");
+ case i_VAR_FLOAT_big:
+ return disInt16(bco,pc,"VAR_FLOAT_big");
case i_CONST_FLOAT:
return disConstFloat(bco,pc,"CONST_FLOAT");
+ case i_CONST_FLOAT_big:
+ return disConstFloat16(bco,pc,"CONST_FLOAT_big");
case i_RETURN_FLOAT:
return disNone(bco,pc,"RETURN_FLOAT");
case i_PACK_FLOAT:
case i_VAR_DOUBLE:
return disInt(bco,pc,"VAR_DOUBLE");
+ case i_VAR_DOUBLE_big:
+ return disInt16(bco,pc,"VAR_DOUBLE_big");
case i_CONST_DOUBLE:
return disConstDouble(bco,pc,"CONST_DOUBLE");
+ case i_CONST_DOUBLE_big:
+ return disConstDouble16(bco,pc,"CONST_DOUBLE_big");
case i_RETURN_DOUBLE:
return disNone(bco,pc,"RETURN_DOUBLE");
case i_PACK_DOUBLE:
fprintf(stderr, "\n");
}
else
- fprintf(stderr, "\t(handwritten bytecode)\n" );
+ fprintf(stderr, "\t(no associated tree)\n" );
}
#endif /* INTERPRETER */
* Copyright (c) 1994-1998.
*
* $RCSfile: Evaluator.c,v $
- * $Revision: 1.10 $
- * $Date: 1999/03/01 14:47:03 $
+ * $Revision: 1.11 $
+ * $Date: 1999/03/09 14:51:21 $
* ---------------------------------------------------------------------------*/
#include "Rts.h"
* ------------------------------------------------------------------------*/
#ifdef PROVIDE_INTEGER
-static /*inline*/ mpz_ptr mpz_alloc ( void );
-//static /*inline*/ void mpz_free ( mpz_ptr );
+static inline mpz_ptr mpz_alloc ( void );
+//static inline void mpz_free ( mpz_ptr );
-static /*inline*/ mpz_ptr mpz_alloc ( void )
+static inline mpz_ptr mpz_alloc ( void )
{
mpz_ptr r = stgCast(mpz_ptr,stgMallocBytes( sizeof(mpz_t),"mpz_alloc"));
mpz_init(r);
}
#if 0 /* apparently unused */
-static /*inline*/ void mpz_free ( mpz_ptr a )
+static inline void mpz_free ( mpz_ptr a )
{
mpz_clear(a);
free(a);
*
* ------------------------------------------------------------------------*/
-/*static*/ /*inline*/ void PushTag ( StackTag t );
-/*static*/ /*inline*/ void PushPtr ( StgPtr x );
-/*static*/ /*inline*/ void PushCPtr ( StgClosure* x );
-/*static*/ /*inline*/ void PushInt ( StgInt x );
-/*static*/ /*inline*/ void PushWord ( StgWord x );
+/*static*/ inline void PushTag ( StackTag t );
+/*static*/ inline void PushPtr ( StgPtr x );
+/*static*/ inline void PushCPtr ( StgClosure* x );
+/*static*/ inline void PushInt ( StgInt x );
+/*static*/ inline void PushWord ( StgWord x );
-/*static*/ /*inline*/ void PushTag ( StackTag t ) { *(--Sp) = t; }
-/*static*/ /*inline*/ void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
-/*static*/ /*inline*/ void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
-/*static*/ /*inline*/ void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
-/*static*/ /*inline*/ void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
+/*static*/ inline void PushTag ( StackTag t ) { *(--Sp) = t; }
+/*static*/ inline void PushPtr ( StgPtr x ) { *(--stgCast(StgPtr*,Sp)) = x; }
+/*static*/ inline void PushCPtr ( StgClosure* x ) { *(--stgCast(StgClosure**,Sp)) = x; }
+/*static*/ inline void PushInt ( StgInt x ) { *(--stgCast(StgInt*,Sp)) = x; }
+/*static*/ inline void PushWord ( StgWord x ) { *(--stgCast(StgWord*,Sp)) = x; }
-/*static*/ /*inline*/ void checkTag ( StackTag t1, StackTag t2 );
-/*static*/ /*inline*/ void PopTag ( StackTag t );
-/*static*/ /*inline*/ StgPtr PopPtr ( void );
-/*static*/ /*inline*/ StgClosure* PopCPtr ( void );
-/*static*/ /*inline*/ StgInt PopInt ( void );
-/*static*/ /*inline*/ StgWord PopWord ( void );
+/*static*/ inline void checkTag ( StackTag t1, StackTag t2 );
+/*static*/ inline void PopTag ( StackTag t );
+/*static*/ inline StgPtr PopPtr ( void );
+/*static*/ inline StgClosure* PopCPtr ( void );
+/*static*/ inline StgInt PopInt ( void );
+/*static*/ inline StgWord PopWord ( void );
-/*static*/ /*inline*/ void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
-/*static*/ /*inline*/ void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
-/*static*/ /*inline*/ StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
-/*static*/ /*inline*/ StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
-/*static*/ /*inline*/ StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
-/*static*/ /*inline*/ StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
-
-/*static*/ /*inline*/ StgPtr stackPtr ( StgStackOffset i );
-/*static*/ /*inline*/ StgInt stackInt ( StgStackOffset i );
-/*static*/ /*inline*/ StgWord stackWord ( StgStackOffset i );
-
-/*static*/ /*inline*/ StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
-/*static*/ /*inline*/ StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
-/*static*/ /*inline*/ StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
+/*static*/ inline void checkTag ( StackTag t1, StackTag t2 ) { ASSERT(t1 == t2);}
+/*static*/ inline void PopTag ( StackTag t ) { checkTag(t,*(Sp++)); }
+/*static*/ inline StgPtr PopPtr ( void ) { return *stgCast(StgPtr*,Sp)++; }
+/*static*/ inline StgClosure* PopCPtr ( void ) { return *stgCast(StgClosure**,Sp)++; }
+/*static*/ inline StgInt PopInt ( void ) { return *stgCast(StgInt*,Sp)++; }
+/*static*/ inline StgWord PopWord ( void ) { return *stgCast(StgWord*,Sp)++; }
+
+/*static*/ inline StgPtr stackPtr ( StgStackOffset i );
+/*static*/ inline StgInt stackInt ( StgStackOffset i );
+/*static*/ inline StgWord stackWord ( StgStackOffset i );
+
+/*static*/ inline StgPtr stackPtr ( StgStackOffset i ) { return *stgCast(StgPtr*, Sp+i); }
+/*static*/ inline StgInt stackInt ( StgStackOffset i ) { return *stgCast(StgInt*, Sp+i); }
+/*static*/ inline StgWord stackWord ( StgStackOffset i ) { return *stgCast(StgWord*,Sp+i); }
-/*static*/ /*inline*/ void setStackWord ( StgStackOffset i, StgWord w );
+/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w );
-/*static*/ /*inline*/ void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
+/*static*/ inline void setStackWord ( StgStackOffset i, StgWord w ) { Sp[i] = w; }
-/*static*/ /*inline*/ void PushTaggedRealWorld( void );
-/*static*/ /*inline*/ void PushTaggedInt ( StgInt x );
+/*static*/ inline void PushTaggedRealWorld( void );
+/*static*/ inline void PushTaggedInt ( StgInt x );
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ void PushTaggedInt64 ( StgInt64 x );
+/*static*/ inline void PushTaggedInt64 ( StgInt64 x );
#endif
#ifdef PROVIDE_INTEGER
-/*static*/ /*inline*/ void PushTaggedInteger ( mpz_ptr x );
+/*static*/ inline void PushTaggedInteger ( mpz_ptr x );
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ void PushTaggedWord ( StgWord x );
+/*static*/ inline void PushTaggedWord ( StgWord x );
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ void PushTaggedAddr ( StgAddr x );
+/*static*/ inline void PushTaggedAddr ( StgAddr x );
#endif
-/*static*/ /*inline*/ void PushTaggedChar ( StgChar x );
-/*static*/ /*inline*/ void PushTaggedFloat ( StgFloat x );
-/*static*/ /*inline*/ void PushTaggedDouble ( StgDouble x );
-/*static*/ /*inline*/ void PushTaggedStablePtr ( StgStablePtr x );
-/*static*/ /*inline*/ void PushTaggedBool ( int x );
+/*static*/ inline void PushTaggedChar ( StgChar x );
+/*static*/ inline void PushTaggedFloat ( StgFloat x );
+/*static*/ inline void PushTaggedDouble ( StgDouble x );
+/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x );
+/*static*/ inline void PushTaggedBool ( int x );
-/*static*/ /*inline*/ void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
-/*static*/ /*inline*/ void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
+/*static*/ inline void PushTaggedRealWorld( void ) { PushTag(REALWORLD_TAG); }
+/*static*/ inline void PushTaggedInt ( StgInt x ) { Sp -= sizeofW(StgInt); *Sp = x; PushTag(INT_TAG); }
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
+/*static*/ inline void PushTaggedInt64 ( StgInt64 x ) { Sp -= sizeofW(StgInt64); ASSIGN_Int64(Sp,x); PushTag(INT64_TAG); }
#endif
#ifdef PROVIDE_INTEGER
-/*static*/ /*inline*/ void PushTaggedInteger ( mpz_ptr x )
+/*static*/ inline void PushTaggedInteger ( mpz_ptr x )
{
StgForeignObj *result;
//StgWeak *w;
}
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
+/*static*/ inline void PushTaggedWord ( StgWord x ) { Sp -= sizeofW(StgWord); *Sp = x; PushTag(WORD_TAG); }
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
+/*static*/ inline void PushTaggedAddr ( StgAddr x ) { Sp -= sizeofW(StgAddr); *Sp = (W_)x; PushTag(ADDR_TAG); }
#endif
-/*static*/ /*inline*/ void PushTaggedChar ( StgChar x )
+/*static*/ inline void PushTaggedChar ( StgChar x )
{ Sp -= sizeofW(StgChar); *Sp = stgCast(StgWord,x); PushTag(CHAR_TAG); }
-/*static*/ /*inline*/ void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
-/*static*/ /*inline*/ void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
-/*static*/ /*inline*/ void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
-/*static*/ /*inline*/ void PushTaggedBool ( int x ) { PushTaggedInt(x); }
+/*static*/ inline void PushTaggedFloat ( StgFloat x ) { Sp -= sizeofW(StgFloat); ASSIGN_FLT(Sp,x); PushTag(FLOAT_TAG); }
+/*static*/ inline void PushTaggedDouble ( StgDouble x ) { Sp -= sizeofW(StgDouble); ASSIGN_DBL(Sp,x); PushTag(DOUBLE_TAG); }
+/*static*/ inline void PushTaggedStablePtr ( StgStablePtr x ) { Sp -= sizeofW(StgStablePtr); *Sp = x; PushTag(STABLE_TAG); }
+/*static*/ inline void PushTaggedBool ( int x ) { PushTaggedInt(x); }
-/*static*/ /*inline*/ void PopTaggedRealWorld ( void );
-/*static*/ /*inline*/ StgInt PopTaggedInt ( void );
+/*static*/ inline void PopTaggedRealWorld ( void );
+/*static*/ inline StgInt PopTaggedInt ( void );
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ StgInt64 PopTaggedInt64 ( void );
+/*static*/ inline StgInt64 PopTaggedInt64 ( void );
#endif
#ifdef PROVIDE_INTEGER
-/*static*/ /*inline*/ mpz_ptr PopTaggedInteger ( void );
+/*static*/ inline mpz_ptr PopTaggedInteger ( void );
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ StgWord PopTaggedWord ( void );
+/*static*/ inline StgWord PopTaggedWord ( void );
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ StgAddr PopTaggedAddr ( void );
+/*static*/ inline StgAddr PopTaggedAddr ( void );
#endif
-/*static*/ /*inline*/ StgChar PopTaggedChar ( void );
-/*static*/ /*inline*/ StgFloat PopTaggedFloat ( void );
-/*static*/ /*inline*/ StgDouble PopTaggedDouble ( void );
-/*static*/ /*inline*/ StgStablePtr PopTaggedStablePtr ( void );
+/*static*/ inline StgChar PopTaggedChar ( void );
+/*static*/ inline StgFloat PopTaggedFloat ( void );
+/*static*/ inline StgDouble PopTaggedDouble ( void );
+/*static*/ inline StgStablePtr PopTaggedStablePtr ( void );
-/*static*/ /*inline*/ void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
-/*static*/ /*inline*/ StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
+/*static*/ inline void PopTaggedRealWorld ( void ) { PopTag(REALWORLD_TAG); }
+/*static*/ inline StgInt PopTaggedInt ( void ) { StgInt r; PopTag(INT_TAG); r = *stgCast(StgInt*, Sp); Sp += sizeofW(StgInt); return r;}
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
+/*static*/ inline StgInt64 PopTaggedInt64 ( void ) { StgInt64 r; PopTag(INT64_TAG); r = PK_Int64(Sp); Sp += sizeofW(StgInt64); return r;}
#endif
#ifdef PROVIDE_INTEGER
-/*static*/ /*inline*/ mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
+/*static*/ inline mpz_ptr PopTaggedInteger ( void ) { StgForeignObj *r = *stgCast(StgForeignObj**,Sp); Sp += sizeofW(StgPtr); return stgCast(mpz_ptr,r->data);}
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
+/*static*/ inline StgWord PopTaggedWord ( void ) { StgWord r; PopTag(WORD_TAG); r = *stgCast(StgWord*, Sp); Sp += sizeofW(StgWord); return r;}
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
+/*static*/ inline StgAddr PopTaggedAddr ( void ) { StgAddr r; PopTag(ADDR_TAG); r = *stgCast(StgAddr*, Sp); Sp += sizeofW(StgAddr); return r;}
#endif
-/*static*/ /*inline*/ StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;}
-/*static*/ /*inline*/ StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
-/*static*/ /*inline*/ StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
-/*static*/ /*inline*/ StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
+/*static*/ inline StgChar PopTaggedChar ( void ) { StgChar r; PopTag(CHAR_TAG); r = stgCast(StgChar, *Sp); Sp += sizeofW(StgChar); return r;}
+/*static*/ inline StgFloat PopTaggedFloat ( void ) { StgFloat r; PopTag(FLOAT_TAG); r = PK_FLT(Sp); Sp += sizeofW(StgFloat); return r;}
+/*static*/ inline StgDouble PopTaggedDouble ( void ) { StgDouble r; PopTag(DOUBLE_TAG); r = PK_DBL(Sp); Sp += sizeofW(StgDouble); return r;}
+/*static*/ inline StgStablePtr PopTaggedStablePtr ( void ) { StgInt r; PopTag(STABLE_TAG); r = *stgCast(StgStablePtr*, Sp); Sp += sizeofW(StgStablePtr); return r;}
-/*static*/ /*inline*/ StgInt taggedStackInt ( StgStackOffset i );
+/*static*/ inline StgInt taggedStackInt ( StgStackOffset i );
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i );
+/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i );
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ StgWord taggedStackWord ( StgStackOffset i );
+/*static*/ inline StgWord taggedStackWord ( StgStackOffset i );
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i );
+/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i );
#endif
-/*static*/ /*inline*/ StgChar taggedStackChar ( StgStackOffset i );
-/*static*/ /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i );
-/*static*/ /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i );
-/*static*/ /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i );
+/*static*/ inline StgChar taggedStackChar ( StgStackOffset i );
+/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i );
+/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i );
+/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i );
-/*static*/ /*inline*/ StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
+/*static*/ inline StgInt taggedStackInt ( StgStackOffset i ) { checkTag(INT_TAG,Sp[i]); return *stgCast(StgInt*, Sp+1+i); }
#ifdef PROVIDE_INT64
-/*static*/ /*inline*/ StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
+/*static*/ inline StgInt64 taggedStackInt64 ( StgStackOffset i ) { checkTag(INT64_TAG,Sp[i]); return PK_Int64(Sp+1+i); }
#endif
#ifdef PROVIDE_WORD
-/*static*/ /*inline*/ StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
+/*static*/ inline StgWord taggedStackWord ( StgStackOffset i ) { checkTag(WORD_TAG,Sp[i]); return *stgCast(StgWord*, Sp+1+i); }
#endif
#ifdef PROVIDE_ADDR
-/*static*/ /*inline*/ StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
+/*static*/ inline StgAddr taggedStackAddr ( StgStackOffset i ) { checkTag(ADDR_TAG,Sp[i]); return *stgCast(StgAddr*, Sp+1+i); }
#endif
-/*static*/ /*inline*/ StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
+/*static*/ inline StgChar taggedStackChar ( StgStackOffset i ) { checkTag(CHAR_TAG,Sp[i]); return stgCast(StgChar, *(Sp+1+i)) ; }
-/*static*/ /*inline*/ StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
-/*static*/ /*inline*/ StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
-/*static*/ /*inline*/ StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
+/*static*/ inline StgFloat taggedStackFloat ( StgStackOffset i ) { checkTag(FLOAT_TAG,Sp[i]); return PK_FLT(Sp+1+i); }
+/*static*/ inline StgDouble taggedStackDouble ( StgStackOffset i ) { checkTag(DOUBLE_TAG,Sp[i]); return PK_DBL(Sp+1+i); }
+/*static*/ inline StgStablePtr taggedStackStable ( StgStackOffset i ) { checkTag(STABLE_TAG,Sp[i]); return *stgCast(StgStablePtr*, Sp+1+i); }
/* --------------------------------------------------------------------------
* (array ops, gmp ops, etc)
* ------------------------------------------------------------------------*/
-static /*inline*/ StgPtr grabHpUpd( nat size )
+static inline StgPtr grabHpUpd( nat size )
{
ASSERT( size >= MIN_UPD_SIZE + sizeofW(StgHeader) );
return allocate(size);
}
-static /*inline*/ StgPtr grabHpNonUpd( nat size )
+static inline StgPtr grabHpNonUpd( nat size )
{
ASSERT( size >= MIN_NONUPD_SIZE + sizeofW(StgHeader) );
return allocate(size);
* o Stop frames
* ------------------------------------------------------------------------*/
-static /*inline*/ void PopUpdateFrame ( StgClosure* obj );
-static /*inline*/ void PushCatchFrame ( StgClosure* catcher );
-static /*inline*/ void PopCatchFrame ( void );
-static /*inline*/ void PushSeqFrame ( void );
-static /*inline*/ void PopSeqFrame ( void );
+static inline void PopUpdateFrame ( StgClosure* obj );
+static inline void PushCatchFrame ( StgClosure* catcher );
+static inline void PopCatchFrame ( void );
+static inline void PushSeqFrame ( void );
+static inline void PopSeqFrame ( void );
-static /*inline*/ StgClosure* raiseAnError ( StgClosure* errObj );
+static inline StgClosure* raiseAnError ( StgClosure* errObj );
-static /*inline*/ void PopUpdateFrame( StgClosure* obj )
+static inline void PopUpdateFrame( StgClosure* obj )
{
/* NB: doesn't assume that Sp == Su */
IF_DEBUG(evaluator,
Su = Su->link;
}
-static /*inline*/ void PopStopFrame( StgClosure* obj )
+static inline void PopStopFrame( StgClosure* obj )
{
/* Move Su just off the end of the stack, we're about to spam the
* STOP_FRAME with the return value.
*stgCast(StgClosure**,Sp) = obj;
}
-static /*inline*/ void PushCatchFrame( StgClosure* handler )
+static inline void PushCatchFrame( StgClosure* handler )
{
StgCatchFrame* fp;
/* ToDo: stack check! */
Su = stgCast(StgUpdateFrame*,fp);
}
-static /*inline*/ void PopCatchFrame( void )
+static inline void PopCatchFrame( void )
{
/* NB: doesn't assume that Sp == Su */
/* fprintf(stderr,"Popping catch frame\n"); */
Su = stgCast(StgCatchFrame*,Su)->link;
}
-static /*inline*/ void PushSeqFrame( void )
+static inline void PushSeqFrame( void )
{
StgSeqFrame* fp;
/* ToDo: stack check! */
Su = stgCast(StgUpdateFrame*,fp);
}
-static /*inline*/ void PopSeqFrame( void )
+static inline void PopSeqFrame( void )
{
/* NB: doesn't assume that Sp == Su */
Sp = stgCast(StgStackPtr,Su) + sizeofW(StgSeqFrame);
Su = stgCast(StgSeqFrame*,Su)->link;
}
-static /*inline*/ StgClosure* raiseAnError( StgClosure* errObj )
+static inline StgClosure* raiseAnError( StgClosure* errObj )
{
StgClosure *raise_closure;
#endif /* PROVIDE_ARRAY */
+static int enterCountI = 0;
+
+void myStackCheck ( void )
+{
+ StgPtr sp = Sp;
+ StgPtr su = Su;
+ //fprintf(stderr, "myStackCheck\n");
+ if (!(SpLim <= Sp && Sp <= stgCast(StgPtr,Su))) {
+ fprintf(stderr, "myStackCheck: invalid initial Sp/Su \n" );
+ assert(0);
+ }
+ while (1) {
+ if (!(su >= CurrentTSO->stack && su <= CurrentTSO->stack + CurrentTSO->stack_size)) {
+ fprintf ( stderr, "myStackCheck: su out of stack\n" );
+ assert(0);
+ }
+ switch (get_itbl(stgCast(StgClosure*,su))->type) {
+ case CATCH_FRAME:
+ su = ((StgCatchFrame*)(su))->link;
+ break;
+ case UPDATE_FRAME:
+ su = ((StgUpdateFrame*)(su))->link;
+ break;
+ case SEQ_FRAME:
+ su = ((StgSeqFrame*)(su))->link;
+ break;
+ case STOP_FRAME:
+ goto postloop;
+ default:
+ fprintf(stderr, "myStackCheck: invalid activation record\n"); assert(0);
+ }
+ }
+ postloop:
+}
+
/* This is written as one giant function in the hope that gcc will do
* a better job of register allocation.
* iterations.
*/
char enterCount = 0;
- int enterCountI = 0;
+ //fprintf ( stderr, "enter: Sp=%p Su=%p\n", Sp, Su);
enterLoop:
- /* ASSERT(StorageMgrInfo.hp_start <= Hp && Hp < HpLim && HpLim == StorageMgrInfo.hplim); */
+ enterCountI++;// fprintf(stderr, "%d\n", enterCountI);
ASSERT(SpLim <= Sp && Sp <= stgCast(StgPtr,Su));
+
#if DEBUG
- IF_DEBUG(evaluator,
+ IF_DEBUG(evaluator,
fprintf(stderr,
"\n---------------------------------------------------------------\n");
- fprintf(stderr,"(%d) Entering: ",enterCountI++); printObj(obj);
+ fprintf(stderr,"(%d) Entering: ",enterCountI); printObj(obj);
fprintf(stderr,"Sp = %p\tSu = %p\n", Sp, Su);
fprintf(stderr, "\n" );
printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
fprintf(stderr, "\n\n");
- );
-#endif
-#if 0
- IF_DEBUG(sanity,
- {
- /*belch("Starting sanity check");
- *SaveThreadState();
- *checkTSO(CurrentTSO, heap_step);
- * This check fails if we've done any updates because we
- * whack into holes in the heap.
- *checkHeap(?,?);
- *belch("Ending sanity check");
- */
- }
- );
-#endif
-#if 0
- IF_DEBUG(evaluator,
- fprintf(stderr,"Continue?\n");
- getchar()
- );
+ );
#endif
+
if (++enterCount == 0 && context_switch) {
PushCPtr(obj); /* code to restart with */
+ assert(0);
return ThreadYielding;
}
switch ( get_itbl(obj)->type ) {
{
StgBCO* bco = stgCast(StgBCO*,obj);
InstrPtr pc = 0;
-#if 1 /* We don't use an explicit HP_CHECK anymore */
+
if (doYouWantToGC()) {
PushCPtr(obj); /* code to restart with */
return HeapOverflow;
}
-#endif
+
while (1) {
ASSERT(pc < bco->n_instrs);
- if (0 /*enterCountI > 2*/ ) {
- fprintf(stderr, "\n\n-----------------\n" );
- printStack(Sp,CurrentTSO->stack+CurrentTSO->stack_size,Su);
- fprintf(stderr, "\n");
- }
IF_DEBUG(evaluator,
fprintf(stderr,"Sp = %p\tSu = %p\tpc = %d\t", Sp, Su, pc);
disInstr(bco,pc);
barf("INTERNAL_ERROR at %p:%d",bco,pc-1);
case i_PANIC:
barf("PANIC at %p:%d",bco,pc-1);
-#if 0
- case i_HP_CHECK:
- {
- int n = bcoInstr(bco,pc++);
- /* ToDo: we could allocate the whole thing now and
- * slice it up ourselves
- */
- if (doYouWantToGC()) {
- PushCPtr(obj); /* code to restart with */
- return HeapOverflow;
- }
- break;
- }
-#endif
case i_STK_CHECK:
{
int n = bcoInstr(bco,pc++);
);
break;
}
+ case i_MKAP_big:
+ {
+ int x, y;
+ StgAP_UPD* o;
+ x = bcoInstr16(bco,pc); pc += 2; /* ToDo: Word not Int! */
+ y = bcoInstr16(bco,pc); pc += 2;
+ o = stgCast(StgAP_UPD*,stackPtr(x));
+ SET_HDR(o,&AP_UPD_info,??);
+ o->n_args = y;
+ o->fun = stgCast(StgClosure*,PopPtr());
+ for(x=0; x < y; ++x) {
+ payloadWord(o,x) = PopWord();
+ }
+ IF_DEBUG(evaluator,
+ fprintf(stderr,"\tBuilt ");
+ printObj(stgCast(StgClosure*,o));
+ );
+ break;
+ }
case i_MKPAP:
{
int x = bcoInstr(bco,pc++);
Sp += y;
break;
}
+ case i_SLIDE_big:
+ {
+ int x, y;
+ x = bcoInstr16(bco,pc); pc += 2;
+ y = bcoInstr16(bco,pc); pc += 2;
+ ASSERT(Sp+x+y <= stgCast(StgPtr,Su));
+ /* a_1, .. a_x, b_1, .. b_y, s => a_1, .. a_x, s */
+ while(--x >= 0) {
+ setStackWord(x+y,stackWord(x));
+ }
+ Sp += y;
+ break;
+ }
case i_ENTER:
{
obj = PopCPtr();
case i_TEST:
{
int tag = bcoInstr(bco,pc++);
- StgWord offset = bcoInstr(bco,pc++);
+ StgWord offset = bcoInstr16(bco,pc); pc += 2;
if (constrTag(stgCast(StgClosure*,stackPtr(0))) != tag) {
pc += offset;
}
}
break;
}
+ case i_VAR_big:
+ {
+ PushPtr(stackPtr(bcoInstr16(bco,pc))); pc+=2;
+ break;
+ }
case i_VAR:
{
PushPtr(stackPtr(bcoInstr(bco,pc++)));
PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr(bco,pc++))));
break;
}
- case i_CONST2:
+ case i_CONST_big:
{
- StgWord o1 = bcoInstr(bco,pc++);
- StgWord o2 = bcoInstr(bco,pc++);
- StgWord o = o1*256 + o2;
- PushPtr(stgCast(StgPtr,bcoConstPtr(bco,o)));
+ PushPtr(stgCast(StgPtr,bcoConstPtr(bco,bcoInstr16(bco,pc)))); pc += 2;
break;
}
case i_VOID:
}
case i_TEST_INT:
{
- StgWord offset = bcoInstr(bco,pc++);
+ StgWord offset = bcoInstr16(bco,pc);
StgInt x = PopTaggedInt();
StgInt y = PopTaggedInt();
+ pc += 2;
if (x != y) {
pc += offset;
}
break;
#endif /* PROVIDE_INT64 */
#ifdef PROVIDE_INTEGER
- case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x,y)); break;
+ case i_encodeFloatZ: OP_ZI_F(__encodeFloat(x->_mp_size,
+ stgCast(StgByteArray,x->_mp_d),
+ y)); break;
case i_decodeFloatZ: OP_F_ZI(__decodeFloat(r1,&r2,x)); break;
#endif
case i_isNaNFloat: OP_F_B(isFloatNaN(x)); break;
break;
#endif /* PROVIDE_INT64 */
#ifdef PROVIDE_INTEGER
- case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x,y)); break;
+ case i_encodeDoubleZ: OP_ZI_D(__encodeDouble(x->_mp_size,
+ stgCast(StgByteArray,x->_mp_d),
+ y)); break;
case i_decodeDoubleZ: OP_D_ZI(__decodeDouble(r1,&r2,x)); break;
#endif /* PROVIDE_INTEGER */
case i_isNaNDouble: OP_D_B(isDoubleNaN(x)); break;
break;
}
default:
- barf("Unrecognised instruction");
+ pc--;
+ printf ( "\n\n" );
+ disInstr ( bco, pc );
+ barf("\nUnrecognised instruction");
}
}
barf("Ran off the end of bco - yoiks");
}
case CAF_UNENTERED:
{
- StgCAF* caf = stgCast(StgCAF*,obj);
+ StgBlockingQueue* bh;
+ StgCAF* caf = (StgCAF*)obj;
if (Sp - sizeofW(StgUpdateFrame) < SpLim) {
PushCPtr(obj); /* code to restart with */
return StackOverflow;
}
- /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
- {
- /*was StgBlackHole* */
- StgBlockingQueue* bh
- = stgCast(StgBlockingQueue*,grabHpUpd(BLACKHOLE_sizeW()));
- SET_INFO(bh,&CAF_BLACKHOLE_info);
- bh->blocking_queue = EndTSOQueue;
- IF_DEBUG(gccafs,fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
- SET_INFO(caf,&CAF_ENTERED_info);
- caf->value = stgCast(StgClosure*,bh);
- PUSH_UPD_FRAME(bh,0);
- Sp -= sizeofW(StgUpdateFrame);
- }
+ /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME
+ and insert an indirection immediately */
+ bh = (StgBlockingQueue*)grabHpUpd(BLACKHOLE_sizeW());
+ SET_INFO(bh,&CAF_BLACKHOLE_info);
+ bh->blocking_queue = EndTSOQueue;
+ IF_DEBUG(gccafs,
+ fprintf(stderr,"Created CAF_BLACKHOLE %p for CAF %p in evaluator\n",bh,caf));
+ SET_INFO(caf,&CAF_ENTERED_info);
+ caf->value = (StgClosure*)bh;
+ recordOldToNewPtrs(caf);
+ PUSH_UPD_FRAME(bh,0);
+ Sp -= sizeofW(StgUpdateFrame);
caf->link = enteredCAFs;
enteredCAFs = caf;
obj = caf->body;
}
case CAF_ENTERED:
{
- StgCAF* caf = stgCast(StgCAF*,obj);
+ StgCAF* caf = (StgCAF*)obj;
obj = caf->value; /* it's just a fancy indirection */
goto enterLoop;
}
case CAF_BLACKHOLE:
{
/*was StgBlackHole* */
- StgBlockingQueue* bh = stgCast(StgBlockingQueue*,obj);
+ StgBlockingQueue* bh = (StgBlockingQueue*)obj;
/* Put ourselves on the blocking queue for this black hole and block */
CurrentTSO->link = bh->blocking_queue;
bh->blocking_queue = CurrentTSO;
PushCPtr(obj); /* code to restart with */
+ assert(0);
return ThreadBlocked;
}
case AP_UPD:
PushCPtr(obj); /* code to restart with */
return StackOverflow;
}
- /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME and insert an indirection immediately */
+ /* ToDo: look for Sp==Su && stackInt(0) == UPD_FRAME
+ and insert an indirection immediately */
PUSH_UPD_FRAME(ap,0);
Sp -= sizeofW(StgUpdateFrame);
while (--i >= 0) {
obj = stgCast(StgInd*,obj)->indirectee;
goto enterLoop;
}
+ case IND_OLDGEN:
+ {
+ obj = stgCast(StgIndOldGen*,obj)->indirectee;
+ goto enterLoop;
+ }
case CONSTR:
case CONSTR_INTLIKE:
case CONSTR_CHARLIKE:
}
default:
{
+fprintf(stderr, "enterCountI = %d\n", enterCountI);
+fprintf(stderr, "panic: enter: entered unknown closure\n");
+printObj(obj);
+fprintf(stderr, "what it points at is\n");
+printObj( ((StgEvacuated*)obj) ->evacuee);
+exit(1);
CurrentTSO->whatNext = ThreadEnterGHC;
PushCPtr(obj); /* code to restart with */
return ThreadYielding;
}
}
barf("Ran off the end of enter - yoiks");
+ assert(0);
}
/* -----------------------------------------------------------------------------
/* -----------------------------------------------------------------------------
- * $Id: Printer.c,v 1.8 1999/03/03 19:16:29 sof Exp $
+ * $Id: Printer.c,v 1.9 1999/03/09 14:51:23 sewardj Exp $
*
* Copyright (c) 1994-1999.
*
* Printer
* ------------------------------------------------------------------------*/
-#ifdef INTERPRETER
+
extern void* itblNames[];
extern int nItblNames;
char* lookupHugsItblName ( void* v )
if (itblNames[i] == v) return itblNames[i+1];
return NULL;
}
-#endif
extern void printPtr( StgPtr p )
{
#ifdef INTERPRETER
} else if ((raw = lookupHugsName(p)) != 0) {
fprintf(stderr, "%s", raw);
+#endif
} else if ((str = lookupHugsItblName(p)) != 0) {
fprintf(stderr, "%p=%s", p, str);
-#endif
} else {
fprintf(stderr, "%p", p);
}
} else {
StgClosure* c = (StgClosure*)(*sp);
printPtr((StgPtr)*sp);
-#ifdef INTERPRETER
if (c == &ret_bco_info) {
fprintf(stderr, "\t\t");
fprintf(stderr, "ret_bco_info\n" );
} else
-#endif
if (IS_HUGS_CONSTR_INFO(GET_INFO(c))) {
fprintf(stderr, "\t\t\t");
fprintf(stderr, "ConstrInfoTable\n" );
ASSERT(sp <= spBottom);
while (sp < spBottom) {
- if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO((void*)*sp)) {
+ if (!IS_ARG_TAG(*sp) && LOOKS_LIKE_GHC_INFO(*sp)) {
info = get_itbl((StgClosure *)sp);
switch (info->type) {
bfd* abfd;
char **matching;
-#ifndef _WIN32
bfd_init();
abfd = bfd_openr(name, "default");
if (abfd == NULL) {
if (!bfd_check_format_matches (abfd, bfd_object, &matching)) {
barf("mismatch");
}
-#endif
{
long storage_needed;
projects / ghc-hetmet.git / commitdiff