+++ /dev/null
-
-module Dh_Demo where
-
-wurble :: Int -> IO ()
-wurble x = putStr ( "Hello Erik && Daan, today's magic number is: "
- ++ show x
- ++ show (take 100 (repeat 123.456))
- ++ "\n")
+++ /dev/null
-EXPORTS
-DH_GetProcAddress@12
-DH_LoadLibrary@4
+++ /dev/null
-
-# --------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.37 2000/05/26 10:14:33 sewardj Exp $ #
-# --------------------------------------------------------------------------- #
-
-TOP = ..
-include $(TOP)/mk/boilerplate.mk
-SUBDIRS = lib
-
-# --------------------------------------------------------------------- #
-# interpreter and relevant .a/.so files #
-# --------------------------------------------------------------------- #
-
-ifneq "$(TARGETPLATFORM)" "i386-unknown-cygwin32"
- ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
- ## UNIX
- LIB_BFD=-lbfd -liberty
- DYN_EXT=.so
- LIB_DL=-ldl
- M_NO_CYGWIN=
- else
- ## mingw32
- LIB_BFD=
- DYN_EXT=.dll
- LIB_DL=
- M_NO_CYGWIN=-mno-cygwin
- endif
-else
- ## cygwin32
- LIB_BFD=-lbfd -liberty
- DYN_EXT=.dll
- LIB_DL=
- M_NO_CYGWIN=
-endif
-
-ifeq "$(HaveLibGmp)$" "YES"
-LIB_GMP=-lgmp
-else
-LIB_GMP=../rts/gmp/libgmp.a
-endif
-
-YACC = bison -y
-%.c: %.y
- -$(YACC) $<
- mv y.tab.c $@
- rm -f input.o
-
-HS_SRCS =
-
-Y_SRCS = parser.y
-C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
- translate.c codegen.c lift.c free.c stgSubst.c output.c \
- hugs.c dynamic.c stg.c sainteger.c object.c interface.c
-
-SRC_CC_OPTS = -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -DNO_REGS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline $(M_NO_CYGWIN) -g -O
-
-GHC_LIBS_NEEDED = $(GHC_RUNTIME_DIR)/libHSrts.a
-
-all :: parser.c $(GHC_LIBS_NEEDED) nHandle$(DYN_EXT) hugs
-
-### EXTREMELY hacky
-hugs: $(C_OBJS) ../rts/Sanity.o ../rts/Assembler.o ../rts/Disassembler.o \
- ../rts/Evaluator.o ../rts/ForeignCall.o ../rts/GC.o ../rts/Printer.o \
- ../rts/StgCRun.o ../rts/PrimOps.o ../rts/Prelude.o ../rts/Storage.o \
- ../rts/Schedule.o ../rts/libHSrts.a
- $(CC) -o $@ $(CC_OPTS) $^ $(GHC_LIBS_NEEDED) \
- $(LIB_BFD) $(LibsReadline) $(LIB_DL) \
- $(LIB_GMP) -lm
-
-foobar:
- rm -f ../rts/libHSrts.a ../rts/libHSrts_u.a
- rm -f ../rts/StgCRun.o ../rts/StgCRun.u_o
- make all
-
-nHandle$(DYN_EXT): nHandle.c
-ifeq "$(DYN_EXT)" ".dll"
- gcc -mno-cygwin -O -Wall -o nHandle.o -c nHandle.c
- dllwrap -mno-cygwin --target=i386-mingw32 -o nHandle.dll \
- -def nHandle.def nHandle.o
-else
- gcc -O -Wall -shared -fPIC -o nHandle.so nHandle.c
-endif
-
-$(GHC_RUNTIME_DIR)/libHSrts.a:
- (cd $(GHC_RUNTIME_DIR) ; make clean ; make EXTRA_CC_OPTS=-I$(GHC_INTERPRETER_DIR))
-
-cleanish:
- /bin/rm *.o
-rtsclean:
- (cd $(GHC_RUNTIME_DIR) ; make clean)
-
-binaries:
- tar cvzf stghugs.tar.gz hugs$(exeext) nHandle$(DYN_EXT) lib/*lhs lib/Prelude.hs
-
-snapshot:
- /bin/rm -f snapshot.tar
- tar cvf snapshot.tar Makefile *.[chy] \
- ../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \
- ../rts/ForeignCall.c ../rts/Printer.c ../rts/QueueTemplate.h \
- ../includes/options.h ../includes/Assembler.h nHandle.c \
- ../includes/Assembler.h ../rts/Bytecodes.h ../includes/ClosureMacros.h \
- lib/*.hs runnofib runallnofib
-
-
-# --------------------------------------------------------------------- #
-# Testing #
-# --------------------------------------------------------------------- #
-
-check :: all
- ./test/runtests test/static/*.hs
- ./test/runtests test/typechecker/*.hs
- ./test/runtests test/runtime/*.hs
- ./test/runtests test/std/*.hs
- ./test/runtests test/exts/*.hs
-
-checkrun: all
- ./test/runtests test/runtime/*.hs
- ./test/runtests test/std/*.hs
- ./test/runtests test/exts/*.hs
-
-# --------------------------------------------------------------------- #
-# Cleanery & misc #
-# --------------------------------------------------------------------- #
-
-CLEAN_FILES += hugs nHandle.dll
-CLEAN_FILES += $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/*.o
-CLEAN_FILES += parser.c
-
-INSTALL_LIBEXECS = hugs
-
-depend :: parser.c $(LOOPS) $(SRCS_UGNHS)
-
-
-include $(TOP)/mk/target.mk
-
-
+++ /dev/null
-
-# --------------------------------------------------------------------------- #
-# $Id: Makefile-DietHEP,v 1.2 2000/05/26 10:14:34 sewardj Exp $ #
-# --------------------------------------------------------------------------- #
-
-TOP = ..
-include $(TOP)/mk/boilerplate.mk
-SUBDIRS = lib
-
-# --------------------------------------------------------------------- #
-# interpreter and relevant .a/.so files #
-# --------------------------------------------------------------------- #
-
-ifneq "$(TARGETPLATFORM)" "i386-unknown-cygwin32"
- ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32"
- ## UNIX
- LIB_BFD=-lbfd -liberty
- DYN_EXT=.so
- LIB_DL=-ldl
- M_NO_CYGWIN=
- else
- ## mingw32
- LIB_BFD=
- DYN_EXT=.dll
- LIB_DL=
- M_NO_CYGWIN=-mno-cygwin
- endif
-else
- ## cygwin32
- LIB_BFD=-lbfd -liberty
- DYN_EXT=.dll
- LIB_DL=
- M_NO_CYGWIN=
-endif
-
-YACC = bison -y
-%.c: %.y
- -$(YACC) $<
- mv y.tab.c $@
- rm -f input.o
-
-HS_SRCS =
-
-Y_SRCS = parser.y
-C_SRCS = link.c type.c static.c storage.c derive.c input.c compiler.c subst.c \
- translate.c codegen.c lift.c free.c stgSubst.c output.c \
- hugs.c dynamic.c stg.c sainteger.c object.c interface.c
-
-SRC_CC_OPTS = -I$(GHC_INTERPRETER_DIR) -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) -D__HUGS__ -DCOMPILING_RTS -DNO_REGS -Wall -Wstrict-prototypes -Wno-unused -DDEBUG -Winline -g -DDIET_HEP -DBUILDING_DLL
-
-GHC_LIBS_NEEDED = $(GHC_RUNTIME_DIR)/libHSrts.a \
- $(GHC_RUNTIME_DIR)/gmp/libgmp.a
-
-all :: parser.c $(GHC_LIBS_NEEDED) nHandle$(DYN_EXT) dh_demo.exe
-
-dhtarfile: DietHEP.dll
- rm -f DietHEP.h
- ln -s ../includes/DietHEP.h .
- tar cvf dhtarfile.tar --dereference DietHEP.h DietHEP.dll DietHEP_dll.a \
- Dh_Demo.hs dh_demo.c dh_demo.exe \
- lib library nHandle.dll Makefile-DietHEP
- rm -f DietHEP.h
- bzip2 -v dhtarfile.tar
-
-dh_demo.exe: DietHEP.dll dh_demo.c
- gcc -Wall -g -o dh_demo.exe dh_demo.c -L./ -lDietHEP
-
-### EXTREMELY hacky
-DietHEP.dll: $(C_OBJS) $(GHC_LIBS_NEEDED)
- dllwrap -o DietHEP.dll --def DietHEP.def --implib libDietHEP.a \
- $(OBJS) $(GHC_LIBS_NEEDED)
-
-foobar:
- rm -f ../rts/libHSrts.a ../rts/libHSrts_u.a
- rm -f ../rts/StgCRun.o ../rts/StgCRun.u_o
- make all
-
-nHandle$(DYN_EXT): nHandle.c
-ifeq "$(DYN_EXT)" ".dll"
- gcc -mno-cygwin -O -Wall -o nHandle.o -c nHandle.c
- dllwrap -mno-cygwin --target=i386-mingw32 -o nHandle.dll \
- -def nHandle.def nHandle.o
-else
- gcc -O -Wall -shared -fPIC -o nHandle.so nHandle.c
-endif
-
-$(GHC_RUNTIME_DIR)/libHSrts.a:
- (cd $(GHC_RUNTIME_DIR) ; make clean ; make EXTRA_CC_OPTS=-I$(GHC_INTERPRETER_DIR))
-
-cleanish:
- /bin/rm *.o
-rtsclean:
- (cd $(GHC_RUNTIME_DIR) ; make clean)
-
-binaries:
- tar cvzf stghugs.tar.gz hugs$(exeext) nHandle$(DYN_EXT) lib/*lhs lib/Prelude.hs
-
-snapshot:
- /bin/rm -f snapshot.tar
- tar cvf snapshot.tar Makefile *.[chy] \
- ../rts/Assembler.c ../rts/Evaluator.c ../rts/Disassembler.c \
- ../rts/ForeignCall.c ../rts/Printer.c ../rts/QueueTemplate.h \
- ../includes/options.h ../includes/Assembler.h nHandle.c \
- ../includes/Assembler.h ../rts/Bytecodes.h ../includes/ClosureMacros.h \
- lib/*.hs runnofib runallnofib
-
-
-# --------------------------------------------------------------------- #
-# Testing #
-# --------------------------------------------------------------------- #
-
-check :: all
- ./test/runtests test/static/*.hs
- ./test/runtests test/typechecker/*.hs
- ./test/runtests test/runtime/*.hs
- ./test/runtests test/std/*.hs
- ./test/runtests test/exts/*.hs
-
-checkrun: all
- ./test/runtests test/runtime/*.hs
- ./test/runtests test/std/*.hs
- ./test/runtests test/exts/*.hs
-
-# --------------------------------------------------------------------- #
-# Cleanery & misc #
-# --------------------------------------------------------------------- #
-
-CLEAN_FILES += hugs nHandle.dll DietHEP.dll
-CLEAN_FILES += $(TOP)/ghc/rts/libHSrts.a $(TOP)/ghc/rts/*.o
-CLEAN_FILES += parser.c
-
-INSTALL_LIBEXECS = hugs
-
-depend :: parser.c $(LOOPS) $(SRCS_UGNHS)
-
-
-include $(TOP)/mk/target.mk
+++ /dev/null
-
-Configure the rts with --target=i386-unknown-mingw32 (I think).
-Build it with this:
-
- make EXTRA_HC_OPTS=-optc-DHAVE_WIN32_DLL_SUPPORT
-
-I think that will work.
-
-
+++ /dev/null
-
-These insns are for building Hugs on mingw32. We don't want no
-cygwin no more :)
-
-You need to have a fptools/mk/build.mk which looks like this in
-order to build Hugs which has a hope of working in combined mode.
-
-WithGhcHc=ghc-4.06 # or whatever; version not v. important
-GhcLibWays=u # essential
-GhcHcOpts=-DDEBUG -fasm-x86 # -fasm-x86 is optional
-GhcRtsHcOpts=-optc-DDEBUG -optc-D__HUGS__ -unreg -optc-g
-GhcRtsCcOpts=-optc-DDEBUG -optc-g -optc-D__HUGS__
-SplitObjs=NO # essential
-
-
-Then you need to configure like this:
-
- cd ghc
- autoconf
- cd ..
- autoconf
- ./configure --host=i386-unknown-mingw32 --enable-win32-dlls
-
-Then
-
- make boot
-
-Then
-
- cd ghc/rts/gmp/mpn/generic
- for f in *.c *.h ; do echo $f ; rm -f ../$f ; cp $f ../$f ; done
- # because mingw32 doesn't understand the symlinks that GMP makes
- # during make boot
-
- cd ../../..
- make
- cd ../utils
- make boot
- make
- cd ../interpreter
- make
-
-
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Code generator
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: codegen.c,v $
- * $Revision: 1.25 $
- * $Date: 2000/05/10 16:53:35 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h"
-#include "RtsFlags.h"
-
-/*#define DEBUG_CODEGEN*/
-
-/* (JRS, 27 Apr 2000):
-
-A total rewrite of the BCO assembler/linker, and rationalisation of
-the code management and code generation phases of Hugs.
-
-Problems with the old linker:
-
-* Didn't have a clean way to insert a pointer to GHC code into a BCO.
- This meant CAF GC didn't work properly in combined mode.
-
-* Leaked memory. Each BCO, caf and constructor generated by Hugs had
- a corresponding malloc'd record used in its construction. These
- records existed forever. Pointers from the Hugs symbol tables into
- the runtime heap always went via these intermediates, for no apparent
- reason.
-
-* A global variable holding a list of top-level stg trees was used
- during code generation. It was hard to associate trees in this
- list with entries in the name/tycon tables. Just too many
- mechanisms.
-
-The New World Order is as follows:
-
-* The global code list (stgGlobals) is gone.
-
-* Each name in the name table has a .closure field. This points
- to the top-level code for that name. Before bytecode generation
- this points to a STG tree. During bytecode generation but before
- bytecode linking it is a MPtr pointing to a malloc'd intermediate
- structure (an AsmObject). After linking, it is a real live pointer
- into the execution heap (CPtr) which is treated as a root during GC.
-
- Because tuples do not have name table entries, tycons which are
- tuples also have a .closure field, which is treated identically
- to those of name table entries.
-
-* Each module has a code list -- a list of names and tuples. If you
- are a name or tuple and you have something (code, CAF or Con) which
- needs to wind up in the execution heap, you MUST be on your module's
- code list. Otherwise you won't get code generated.
-
-* Lambda lifting generates new name table entries, which of course
- also wind up on the code list.
-
-* The initial phase of code generation for a module m traverses m's
- code list. The stg trees referenced in the .closure fields are
- code generated, creating AsmObject (AsmBCO, AsmCAF, AsmCon) in
- mallocville. The .closure fields then point to these AsmObjects.
- Since AsmObjects can be mutually recursive, they can contain
- references to:
- * Other AsmObjects Asm_RefObject
- * Existing closures Asm_RefNoOp
- * name/tycon table entries Asm_RefHugs
- AsmObjects can also contain BCO insns and non-ptr words.
-
-* A second copy-and-link phase copies the AsmObjects into the
- execution heap, resolves the Asm_Ref* items, and frees up
- the malloc'd entities.
-
-* Minor cleanups in compile-time storage. There are now 3 kinds of
- address-y things available:
- CPtr/mkCPtr/cptrOf -- ptrs to Closures, probably in exec heap
- ie anything which the exec GC knows about
- MPtr/mkMPtr/mptrOf -- ptrs to mallocville, which the exec GC
- knows nothing about
- Addr/mkAddr/addrOf -- literal addresses (like literal ints)
-
-* Many hacky cases removed from codegen.c. Referencing code or
- data during code generation is a lot simpler, since an entity
- is either:
- a CPtr, in which case use it as is
- a MPtr -- stuff it into the AsmObject and the linker will fix it
- a name or tycon
- -- ditto
-
-* I've checked, using Purify that, at least in standalone mode,
- no longer leaks mallocd memory. Prior to this it would leak at
- the rate of about 300k per Prelude.
-
-Still to do:
-
-* Reinstate peephole optimisation for BCOs.
-
-* Nuke magic number headers in AsmObjects, used for debugging.
-
-* Profile and accelerate. Code generation is slower because linking
- is slower. Evaluation GC is slower because markHugsObjects has
- slowed down.
-
-* Make setCurrentModule ignore name table entries created by the
- lambda-lifter.
-*/
-
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-#define getPos(v) intOf(stgVarInfo(v))
-#define setPos(v,sp) stgVarInfo(v) = mkInt(sp)
-#define getObj(v) mptrOf(stgVarInfo(v))
-#define setObj(v,obj) stgVarInfo(v) = mkMPtr(obj)
-
-#define repOf(x) charOf(stgVarRep(x))
-
-static void cgBind ( AsmBCO bco, StgVar v );
-static Void pushAtom ( AsmBCO bco, StgAtom atom );
-static Void alloc ( AsmBCO bco, StgRhs rhs );
-static Void build ( AsmBCO bco, StgRhs rhs );
-static Void cgExpr ( AsmBCO bco, AsmSp root, StgExpr e );
-
-static AsmBCO cgAlts ( AsmSp root, AsmSp sp, List alts );
-static void testPrimPats ( AsmBCO bco, AsmSp root, List pats, StgExpr e );
-static AsmBCO cgLambda ( StgExpr e );
-static AsmBCO cgRhs ( StgRhs rhs );
-static void beginTop ( StgVar v );
-static AsmObject endTop ( StgVar v );
-
-static StgVar currentTop;
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-static void* /* StgClosure*/ cptrFromName ( Name n )
-{
- char buf[1000];
- void* p;
- Module m = name(n).mod;
- Text mt = module(m).text;
- sprintf(buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_closure"),
- textToStr(mt),
- textToStr( enZcodeThenFindText (
- textToStr (name(n).text) ) ) );
- p = lookupOTabName ( m, buf );
- if (!p) {
- ERRMSG(0) "Can't find object symbol %s", buf
- EEND;
- }
- return p;
-}
-
-char* lookupHugsName( void* closure )
-{
- extern Name nameHw;
- Name nm;
- for( nm = NAME_BASE_ADDR;
- nm < NAME_BASE_ADDR+tabNameSz; ++nm )
- if (tabName[nm-NAME_BASE_ADDR].inUse) {
- Cell cl = name(nm).closure;
- if (isCPtr(cl) && cptrOf(cl) == closure)
- return textToStr(name(nm).text);
- }
- return NULL;
-}
-
-static void cgBindRep( AsmBCO bco, StgVar v, AsmRep rep )
-{
- setPos(v,asmBind(bco,rep));
-}
-
-static void cgBind( AsmBCO bco, StgVar v )
-{
- cgBindRep(bco,v,repOf(v));
-}
-
-static void cgAddPtrToObject ( AsmObject obj, Cell ptrish )
-{
- switch (whatIs(ptrish)) {
- case CPTRCELL:
- asmAddRefNoOp ( obj, (StgPtr)cptrOf(ptrish) ); break;
- case MPTRCELL:
- asmAddRefObject ( obj, mptrOf(ptrish) ); break;
- default:
- internal("cgAddPtrToObject");
- }
-}
-
-/* Get a pointer to atom e onto the stack. */
-static Void pushAtom ( AsmBCO bco, StgAtom e )
-{
- Cell info;
- Cell cl;
-# if 0
- printf ( "pushAtom: %d ", e ); fflush(stdout);
- print(e,10);printf("\n");
-# endif
- switch (whatIs(e)) {
- case STGVAR:
- info = stgVarInfo(e);
- if (isInt(info)) {
- asmVar(bco,intOf(info),repOf(e));
- }
- else
- if (isCPtr(info)) {
- asmPushRefNoOp(bco,cptrOf(info));
- }
- else
- if (isMPtr(info)) {
- asmPushRefObject(bco,mptrOf(info));
- }
- else {
- internal("pushAtom: STGVAR");
- }
- break;
- case NAME:
- case TUPLE:
- cl = getNameOrTupleClosure(e);
- if (isStgVar(cl)) {
- /* a stg tree which hasn't yet been translated */
- asmPushRefHugs(bco,e);
- }
- else
- if (isCPtr(cl)) {
- /* a pointer to something in the heap */
- asmPushRefNoOp(bco,(StgPtr)cptrOf(cl));
- }
- else
- if (isMPtr(cl)) {
- /* a pointer to an AsmBCO/AsmCAF/AsmCon object */
- asmPushRefObject(bco,mptrOf(cl));
- }
- else {
- StgClosure* addr;
- ASSERT(isNull(cl));
- addr = cptrFromName(e);
-# if DEBUG_CODEGEN
- fprintf ( stderr, "nativeAtom: name %s\n",
- nameFromOPtr(addr) );
-# endif
- asmPushRefNoOp(bco,(StgPtr)addr);
- }
- break;
- case CHARCELL:
- asmConstChar(bco,charOf(e));
- break;
- case INTCELL:
- asmConstInt(bco,intOf(e));
- break;
- case ADDRCELL:
- asmConstAddr(bco,addrOf(e));
- break;
- case BIGCELL:
- asmConstInteger(bco,bignumToString(e));
- break;
- case FLOATCELL:
- asmConstDouble(bco,floatOf(e));
- break;
- case STRCELL:
-# if USE_ADDR_FOR_STRINGS
- asmConstAddr(bco,textToStr(textOf(e)));
-# else
- asmClosure(bco,asmStringObj(textToStr(textOf(e))));
-# endif
- break;
- case CPTRCELL:
- asmPushRefNoOp(bco,cptrOf(e));
- break;
- case MPTRCELL:
- asmPushRefObject(bco,mptrOf(e));
- break;
- default:
- fprintf(stderr,"\nYoiks1: "); printExp(stderr,e);
- internal("pushAtom");
- }
-}
-
-static AsmBCO cgAlts( AsmSp root, AsmSp sp, List alts )
-{
- AsmBCO bco = asmBeginContinuation(sp, alts);
- Bool omit_test
- = length(alts) == 2 &&
- isDefaultAlt(hd(tl(alts))) &&
- !isDefaultAlt(hd(alts));
- if (omit_test) {
- /* refine the condition */
- Name con;
- Tycon t;
- omit_test = FALSE;
- con = stgCaseAltCon(hd(alts));
-
- /* special case: dictionary constructors */
- if (isName(con) && strncmp(":D",textToStr(name(con).text),2)==0) {
- omit_test = TRUE;
- goto xyzzy;
- }
- /* special case: Tuples */
- if (isTuple(con) || (isName(con) && con==nameUnit)) {
- omit_test = TRUE;
- goto xyzzy;
- }
-
- t = name(con).parent;
- if (tycon(t).what == DATATYPE) {
- if (length(tycon(t).defn) == 1) omit_test = TRUE;
- }
- }
-
- xyzzy:
-
- for(; nonNull(alts); alts=tl(alts)) {
- StgCaseAlt alt = hd(alts);
- if (isDefaultAlt(alt)) {
- cgBind(bco,stgDefaultVar(alt));
- cgExpr(bco,root,stgDefaultBody(alt));
- asmEndContinuation(bco);
- return bco; /* ignore any further alternatives */
- } else {
- StgDiscr con = stgCaseAltCon(alt);
- List vs = stgCaseAltVars(alt);
- AsmSp begin = asmBeginAlt(bco);
- AsmPc fix;
- if (omit_test) fix=-1; else fix = asmTest(bco,stgDiscrTag(con));
-
- asmBind(bco,PTR_REP); /* Adjust simulated sp to acct for return value */
- if (isBoxingCon(con)) {
- setPos(hd(vs),asmUnbox(bco,boxingConRep(con)));
- } else {
- asmBeginUnpack(bco);
- map1Proc(cgBind,bco,reverse(vs));
- asmEndUnpack(bco);
- }
- cgExpr(bco,root,stgCaseAltBody(alt));
- asmEndAlt(bco,begin);
- if (fix != -1) asmFixBranch(bco,fix);
- }
- }
- /* if we got this far and didn't match, panic! */
- asmPanic(bco);
- asmEndContinuation(bco);
- return bco;
-}
-
-static void testPrimPats( AsmBCO bco, AsmSp root, List pats, StgExpr e )
-{
- if (isNull(pats)) {
- cgExpr(bco,root,e);
- } else {
- StgVar pat = hd(pats);
- if (isInt(stgVarBody(pat))) {
- /* asmTestInt leaves stack unchanged - so no need to adjust it */
- AsmPc tst = asmTestInt(bco,getPos(pat),intOf(stgVarBody(pat)));
- assert(repOf(pat) == INT_REP);
- testPrimPats(bco,root,tl(pats),e);
- asmFixBranch(bco,tst);
- } else {
- testPrimPats(bco,root,tl(pats),e);
- }
- }
-}
-
-
-static AsmBCO cgLambda( StgExpr e )
-{
- AsmBCO bco = asmBeginBCO(e);
-
- AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,reverse(stgLambdaArgs(e)));
- asmEndArgCheck(bco,root);
-
- /* ppStgExpr(e); */
- cgExpr(bco,root,stgLambdaBody(e));
-
- asmEndBCO(bco);
- return bco;
-}
-
-static AsmBCO cgRhs( StgRhs rhs )
-{
- AsmBCO bco = asmBeginBCO(rhs );
-
- AsmSp root = asmBeginArgCheck(bco);
- asmEndArgCheck(bco,root);
-
- /* ppStgExpr(rhs); */
- cgExpr(bco,root,rhs);
-
- asmEndBCO(bco);
- return bco;
-}
-
-
-static Void cgExpr( AsmBCO bco, AsmSp root, StgExpr e )
-{
-#if 0
- printf("cgExpr:");ppStgExpr(e);printf("\n");
-#endif
- switch (whatIs(e)) {
- case LETREC:
- {
- List binds = stgLetBinds(e);
- map1Proc(alloc,bco,binds);
- map1Proc(build,bco,binds);
- cgExpr(bco,root,stgLetBody(e));
- break;
- }
- case LAMBDA:
- {
- AsmSp begin = asmBeginEnter(bco);
- asmPushRefObject(bco,cgLambda(e));
- asmEndEnter(bco,begin,root);
- break;
- }
- case CASE:
- {
- List alts = stgCaseAlts(e);
- AsmSp sp = asmBeginCase(bco);
- AsmSp caseroot = asmContinuation(bco,cgAlts(root,sp,alts));
- cgExpr(bco,caseroot,stgCaseScrut(e));
- asmEndCase(bco);
- break;
- }
- case PRIMCASE:
- {
- StgExpr scrut = stgPrimCaseScrut(e);
- List alts = stgPrimCaseAlts(e);
- if (whatIs(scrut) == STGPRIM) { /* this is an optimisation */
-
- /* No need to use return address or to Slide */
- AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,reverse(stgPrimArgs(scrut)));
- asmEndPrim(bco,(AsmPrim*)name(stgPrimOp(scrut)).primop,beginPrim);
-
- for(; nonNull(alts); alts=tl(alts)) {
- StgPrimAlt alt = hd(alts);
- List pats = stgPrimAltVars(alt);
- StgExpr body = stgPrimAltBody(alt);
- AsmSp altBegin = asmBeginAlt(bco);
- map1Proc(cgBind,bco,reverse(pats));
- testPrimPats(bco,root,pats,body);
- asmEndAlt(bco,altBegin);
- }
- /* if we got this far and didn't match, panic! */
- asmPanic(bco);
-
- } else if (whatIs(scrut) == STGVAR) { /* another optimisation */
-
- /* No need to use return address or to Slide */
-
- /* only part different from primop code... todo */
- AsmSp beginCase = asmBeginCase(bco);
- pushAtom /*pushVar*/ (bco,scrut);
- asmEndAlt(bco,beginCase); /* hack, hack - */
-
- for(; nonNull(alts); alts=tl(alts)) {
- StgPrimAlt alt = hd(alts);
- List pats = stgPrimAltVars(alt);
- StgExpr body = stgPrimAltBody(alt);
- AsmSp altBegin = asmBeginAlt(bco);
- map1Proc(cgBind,bco,pats);
- testPrimPats(bco,root,pats,body);
- asmEndAlt(bco,altBegin);
- }
- /* if we got this far and didn't match, panic! */
- asmPanic(bco);
-
- } else {
- /* ToDo: implement this code... */
- assert(0);
- /* asmPushRet(bco,delayPrimAlt( stgPrimCaseVars(e),
- stgPrimCaseBody(e))); */
- /* cgExpr( bco,root,scrut ); */
- }
- break;
- }
- case STGAPP: /* Tail call */
- {
- AsmSp env = asmBeginEnter(bco);
- map1Proc(pushAtom,bco,reverse(stgAppArgs(e)));
- pushAtom(bco,stgAppFun(e));
- asmEndEnter(bco,env,root);
- break;
- }
- case TUPLE:
- case NAME: /* Tail call (with no args) */
- {
- AsmSp env = asmBeginEnter(bco);
- /* JRS 000112: next line used to be: pushVar(bco,name(e).stgVar); */
- pushAtom(bco,e);
- asmEndEnter(bco,env,root);
- break;
- }
- case STGVAR: /* Tail call (with no args), plus unboxed return */
- switch (repOf(e)) {
- case PTR_REP:
- case ALPHA_REP:
- case BETA_REP:
- {
- AsmSp env = asmBeginEnter(bco);
- pushAtom /*pushVar*/ (bco,e);
- asmEndEnter(bco,env,root);
- break;
- }
- case INT_REP:
- assert(0);
- /* cgTailCall(bco,singleton(e)); */
- /* asmReturnInt(bco); */
- break;
- default:
- internal("cgExpr StgVar");
- }
- break;
- case STGPRIM: /* Tail call again */
- {
- AsmSp beginPrim = asmBeginPrim(bco);
- map1Proc(pushAtom,bco,reverse(stgPrimArgs(e)));
- asmEndPrim(bco,(AsmPrim*)name(e).primop,beginPrim);
- /* map1Proc(cgBind,bco,rs_vars); */
- assert(0); /* asmReturn_retty(); */
- break;
- }
- default:
- fprintf(stderr,"\nYoiks2: "); printExp(stderr,e);
- internal("cgExpr");
- }
-}
-
-/* allocate space for top level variable
- * any change requires a corresponding change in 'build'.
- */
-static Void alloc( AsmBCO bco, StgVar v )
-{
- StgRhs rhs = stgVarBody(v);
- assert(isStgVar(v));
-#if 0
- printf("alloc: ");ppStgExpr(v);
-#endif
- switch (whatIs(rhs)) {
- case STGCON:
- {
- StgDiscr con = stgConCon(rhs);
- List args = stgConArgs(rhs);
- if (isBoxingCon(con)) {
- pushAtom(bco,hd(args));
- setPos(v,asmBox(bco,boxingConRep(con)));
- } else {
- setPos(v,asmAllocCONSTR(bco,stgConInfo(con)));
- }
- break;
- }
- case STGAPP: {
- Int totSizeW = 0;
- List bs = stgAppArgs(rhs);
- for (; nonNull(bs); bs=tl(bs)) {
- if (isName(hd(bs))) {
- totSizeW += 1;
- } else {
- ASSERT(whatIs(hd(bs))==STGVAR);
- totSizeW += asmRepSizeW( charOf(stgVarRep(hd(bs))) );
- }
- }
- setPos(v,asmAllocAP(bco,totSizeW));
- break;
- }
- case LAMBDA: /* optimisation */
- setObj(v,cgLambda(rhs));
- break;
- default:
- setPos(v,asmAllocAP(bco,0));
- break;
- }
-}
-
-static Void build( AsmBCO bco, StgVar v )
-{
- StgRhs rhs = stgVarBody(v);
- assert(isStgVar(v));
- //ppStg(v);
- switch (whatIs(rhs)) {
- case STGCON:
- {
- StgDiscr con = stgConCon(rhs);
- List args = stgConArgs(rhs);
- if (isBoxingCon(con)) {
- doNothing(); /* already done in alloc */
- } else {
- AsmSp start = asmBeginPack(bco);
- map1Proc(pushAtom,bco,reverse(args));
- asmEndPack(bco,getPos(v),start,stgConInfo(con));
- }
- return;
- }
- case STGAPP:
- {
- Bool itsaPAP;
- StgVar fun = stgAppFun(rhs);
- List args = stgAppArgs(rhs);
-
- if (isName(fun)) {
- itsaPAP = name(fun).arity > length(args);
- } else
- if (isStgVar(fun)) {
- itsaPAP = FALSE;
- if (nonNull(stgVarBody(fun))
- && whatIs(stgVarBody(fun)) == LAMBDA
- && length(stgLambdaArgs(stgVarBody(fun))) > length(args)
- )
- itsaPAP = TRUE;
- }
- else
- internal("build: STGAPP");
-
- if (itsaPAP) {
- AsmSp start = asmBeginMkPAP(bco);
- map1Proc(pushAtom,bco,reverse(args));
- pushAtom(bco,fun);
- asmEndMkPAP(bco,getPos(v),start); /* optimisation */
- } else {
- AsmSp start = asmBeginMkAP(bco);
- map1Proc(pushAtom,bco,reverse(args));
- pushAtom(bco,fun);
- asmEndMkAP(bco,getPos(v),start);
- }
- return;
- }
- case LAMBDA: /* optimisation */
- doNothing(); /* already pushed in alloc */
- break;
-
- /* These two cases look almost identical to the default but they're really
- * special cases of STGAPP. The essential thing here is that we can't call
- * cgRhs(rhs) because that expects the rhs to have no free variables when,
- * in fact, the rhs is _always_ a free variable.
- *
- * ToDo: a simple optimiser would eliminate all examples
- * of this except "let x = x in ..."
- */
- case NAME:
- case STGVAR:
- {
- AsmSp start = asmBeginMkAP(bco);
- pushAtom(bco,rhs);
- asmEndMkAP(bco,getPos(v),start);
- }
- return;
- default:
- {
- AsmSp start = asmBeginMkAP(bco); /* make it updateable! */
- asmPushRefObject(bco,cgRhs(rhs));
- asmEndMkAP(bco,getPos(v),start);
- return;
- }
- }
-}
-
-/* --------------------------------------------------------------------------
- * Top level variables
- *
- * ToDo: these should be handled by allocating a dynamic unentered CAF
- * for each top level variable - this should be simpler!
- * ------------------------------------------------------------------------*/
-
-/* allocate AsmObject for top level variables
- * any change requires a corresponding change in endTop
- */
-static void beginTop( StgVar v )
-{
- StgRhs rhs;
- assert(isStgVar(v));
- currentTop = v;
- rhs = stgVarBody(v);
- switch (whatIs(rhs)) {
- case STGCON:
- setObj(v,asmBeginCon(stgConInfo(stgConCon(rhs))));
- break;
- case LAMBDA:
- setObj(v,asmBeginBCO(rhs));
- break;
- default:
- setObj(v,asmBeginCAF());
- break;
- }
-}
-
-static AsmObject endTop( StgVar v )
-{
- StgRhs rhs = stgVarBody(v);
- currentTop = v;
- switch (whatIs(rhs)) {
- case STGCON: {
- List as = stgConArgs(rhs);
- AsmCon con = (AsmCon)getObj(v);
- for ( ; nonNull(as); as=tl(as)) {
- StgAtom a = hd(as);
- switch (whatIs(a)) {
- case STGVAR:
- /* should be a delayed combinator! */
- asmAddRefObject(con,(AsmObject)getObj(a));
- break;
- case NAME: {
- StgVar var = name(a).closure;
- cgAddPtrToObject(con,var);
- break;
- }
-# if !USE_ADDR_FOR_STRINGS
- case STRCELL:
- asmAddPtr(con,asmStringObj(textToStr(textOf(a))));
- break;
-# endif
- default:
- /* asmAddPtr(con,??); */
- assert(0);
- break;
- }
- }
- asmEndCon(con);
- return con;
- }
- case LAMBDA: { /* optimisation */
- /* ToDo: merge this code with cgLambda */
- AsmBCO bco = (AsmBCO)getObj(v);
- AsmSp root = asmBeginArgCheck(bco);
- map1Proc(cgBind,bco,reverse(stgLambdaArgs(rhs)));
- asmEndArgCheck(bco,root);
-
- cgExpr(bco,root,stgLambdaBody(rhs));
-
- asmEndBCO(bco);
- return bco;
- }
- default: { /* updateable caf */
- AsmCAF caf = (AsmCAF)getObj(v);
- asmAddRefObject ( caf, cgRhs(rhs) );
- asmEndCAF(caf);
- return caf;
- }
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * The external entry points for the code generator.
- * ------------------------------------------------------------------------*/
-
-Void cgModule ( Module mod )
-{
- List cl;
- Cell c;
- int i;
-
- /* Lambda-lift, by traversing the code list of this module.
- This creates more name-table entries, which are duly added
- to the module's code list.
- */
- liftModule ( mod );
-
- /* Initialise the BCO linker subsystem. */
- asmInitialise();
-
- /* Generate BCOs, CAFs and Constructors into mallocville.
- At this point, the .closure values of the names/tycons on
- the codelist contain StgVars, ie trees. The call to beginTop
- converts them to MPtrs to AsmObjects.
- */
- for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
- c = getNameOrTupleClosure(hd(cl));
- if (isCPtr(c)) continue;
-# if 0
- if (isName(hd(cl))) {
- printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
- }
-# endif
- beginTop ( c );
- }
-
- for (cl=module(mod).codeList; nonNull(cl); cl=tl(cl)) {
- c = getNameOrTupleClosure(hd(cl));
- if (isCPtr(c)) continue;
-# if 0
- if (isName(hd(cl))) {
- printStg( stdout, name(hd(cl)).closure ); printf( "\n\n");
- }
-# endif
- setNameOrTupleClosure ( hd(cl), mkMPtr(endTop(c)) );
- }
-
- //fprintf ( stderr, "\nstarting sanity check\n" );
- for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
- Cell c = hd(cl);
- ASSERT(isName(c) || isTuple(c));
- c = getNameOrTupleClosure(c);
- ASSERT(isMPtr(c) || isCPtr(c));
- }
- //fprintf ( stderr, "completed sanity check\n" );
-
-
- /* Figure out how big each object will be in the evaluator's heap,
- and allocate space to put each in, but don't copy yet. Record
- the heap address in the object. Assumes that GC doesn't happen;
- reasonable since we use allocate().
- */
- asmAllocateHeapSpace();
-
- /* Update name/tycon table closure entries with these new heap addrs. */
- for (cl = module(mod).codeList; nonNull(cl); cl=tl(cl)) {
- c = getNameOrTupleClosure(hd(cl));
- if (isMPtr(c))
- setNameOrTupleClosureCPtr (
- hd(cl), asmGetClosureOfObject(mptrOf(c)) );
- }
-
- /* Copy out of mallocville into the heap, resolving references on
- the way.
- */
- asmCopyAndLink();
-
- /* Free up the malloc'd memory. */
- asmShutdown();
-}
-
-
-/* --------------------------------------------------------------------------
- * Code Generator control:
- * ------------------------------------------------------------------------*/
-
-Void codegen(what)
-Int what; {
- switch (what) {
- case PREPREL: break;
- case RESET: break;
- case MARK: break;
- case POSTPREL: break;
- }
- liftControl(what);
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * This is the Hugs compiler, handling translation of typechecked code to
- * `kernel' language, elimination of pattern matching and translation to
- * super combinators (lambda lifting).
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: compiler.c,v $
- * $Revision: 1.31 $
- * $Date: 2000/05/10 09:00:20 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* for rts_eval and related stuff */
-#include "RtsAPI.h" /* for rts_eval and related stuff */
-#include "SchedAPI.h" /* for RevertCAFs */
-#include "Schedule.h"
-#include "Weak.h" /* for finalizeWeakPointersNow */
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Cell local translate ( Cell );
-static Void local transPair ( Pair );
-static Void local transTriple ( Triple );
-static Void local transAlt ( Cell );
-static Void local transCase ( Cell );
-static List local transBinds ( List );
-static Cell local transRhs ( Cell );
-static Cell local mkConsList ( List );
-static Cell local expandLetrec ( Cell );
-static Cell local transComp ( Cell,List,Cell );
-static Cell local transDo ( Cell,Cell,List );
-static Cell local transConFlds ( Cell,List );
-static Cell local transUpdFlds ( Cell,List,List );
-
-static Cell local refutePat ( Cell );
-static Cell local refutePatAp ( Cell );
-static Cell local matchPat ( Cell );
-static List local remPat ( Cell,Cell,List );
-static List local remPat1 ( Cell,Cell,List );
-
-static Cell local pmcTerm ( Int,List,Cell );
-static Cell local pmcPair ( Int,List,Pair );
-static Cell local pmcTriple ( Int,List,Triple );
-static Cell local pmcVar ( List,Text );
-static Void local pmcLetrec ( Int,List,Pair );
-static Cell local pmcVarDef ( Int,List,List );
-static Void local pmcFunDef ( Int,List,Triple );
-static List local altsMatch ( Int,Int,List,List );
-static Cell local match ( Int,List );
-static Cell local joinMas ( Int,List );
-static Bool local canFail ( Cell );
-static List local addConTable ( Cell,Cell,List );
-static Void local advance ( Int,Int,Cell );
-static Bool local emptyMatch ( Cell );
-static Cell local maDiscr ( Cell );
-static Bool local isNumDiscr ( Cell );
-static Bool local eqNumDiscr ( Cell,Cell );
-#if TREX
-static Bool local isExtDiscr ( Cell );
-static Bool local eqExtDiscr ( Cell,Cell );
-#endif
-
-static Void local compileGlobalFunction ( Pair );
-static Void local compileGenFunction ( Name );
-static Name local compileSelFunction ( Pair );
-static List local addStgVar ( List,Pair );
-
-static Name currentName; /* Top level name being processed */
-static Int lineNumber = 0; /* previously discarded line number */
-
-/* --------------------------------------------------------------------------
- * Translation: Convert input expressions into a less complex language
- * of terms using only LETREC, AP, constants and vars.
- * Also remove pattern definitions on lhs of eqns.
- * ------------------------------------------------------------------------*/
-
-static Cell local translate(e) /* Translate expression: */
-Cell e; {
-#if 0
- printf ( "translate: " );print(e,100);printf("\n");
-#endif
- switch (whatIs(e)) {
- case LETREC : snd(snd(e)) = translate(snd(snd(e)));
- return expandLetrec(e);
-
- case COND : transTriple(snd(e));
- return e;
-
- case AP : fst(e) = translate(fst(e));
-
- /* T [id <exp>] ==> T[<exp>]
- * T [indirect <exp> ] ==> T[<exp>]
- */
- if (fst(e)==nameId || fst(e)==nameInd)
- return translate(snd(e));
- if (isName(fst(e)) &&
- isMfun(fst(e)) &&
- mfunOf(fst(e))==0)
- return translate(snd(e));
-
- snd(e) = translate(snd(e));
-
- return e;
-
- case NAME :
-
- /* T [otherwise] ==> True
- */
-
- if (e==nameOtherwise)
- return nameTrue;
- /* T [assert] ==> T[assertError "<location info>"]
- */
- if (flagAssert && e==nameAssert) {
- Cell str = errAssert(lineNumber);
- return (ap(nameAssertError,str));
- }
-
- if (isCfun(e)) {
- if (isName(name(e).defn))
- return name(e).defn;
- if (isPair(name(e).defn))
- return snd(name(e).defn);
- }
- return e;
-
-#if TREX
- case RECSEL : return nameRecSel;
-
- case EXT :
-#endif
- case TUPLE :
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case INTCELL :
- case FLOATCELL :
- case STRCELL :
- case BIGCELL :
- case CHARCELL : return e;
-#if IPARAM
- case IPVAR : return nameId;
-#endif
- case FINLIST : mapOver(translate,snd(e));
- return mkConsList(snd(e));
-
- case DOCOMP : { Cell m = translate(fst(snd(e)));
- Cell r = translate(fst(snd(snd(e))));
- return transDo(m,r,snd(snd(snd(e))));
- }
-
- case MONADCOMP : { Cell m = translate(fst(snd(e)));
- Cell r = translate(fst(snd(snd(e))));
- Cell qs = snd(snd(snd(e)));
- if (m == nameListMonad)
- return transComp(r,qs,nameNil);
- else {
-#if MONAD_COMPS
- r = ap(ap(nameReturn,m),r);
- return transDo(m,r,qs);
-#else
- internal("translate: monad comps");
-#endif
- }
- }
-
- case CONFLDS : return transConFlds(fst(snd(e)),snd(snd(e)));
-
- case UPDFLDS : return transUpdFlds(fst3(snd(e)),
- snd3(snd(e)),
- thd3(snd(e)));
-
- case CASE : { Cell nv = inventVar();
- mapProc(transCase,snd(snd(e)));
- return ap(LETREC,
- pair(singleton(pair(nv,snd(snd(e)))),
- ap(nv,translate(fst(snd(e))))));
- }
-
- case LAMBDA : { Cell nv = inventVar();
- transAlt(snd(e));
- return ap(LETREC,
- pair(singleton(pair(
- nv,
- singleton(snd(e)))),
- nv));
- }
-
- default : fprintf(stderr, "stuff=%d\n",whatIs(e));
- internal("translate");
- }
- return e;
-}
-
-static Void local transPair(pr) /* Translate each component in a */
-Pair pr; { /* pair of expressions. */
- fst(pr) = translate(fst(pr));
- snd(pr) = translate(snd(pr));
-}
-
-static Void local transTriple(tr) /* Translate each component in a */
-Triple tr; { /* triple of expressions. */
- fst3(tr) = translate(fst3(tr));
- snd3(tr) = translate(snd3(tr));
- thd3(tr) = translate(thd3(tr));
-}
-
-static Void local transAlt(e) /* Translate alt: */
-Cell e; { /* ([Pat], Rhs) ==> ([Pat], Rhs') */
-#if 0
- printf ( "transAlt: " );print(snd(e),100);printf("\n");
-#endif
- snd(e) = transRhs(snd(e));
-}
-
-static Void local transCase(c) /* Translate case: */
-Cell c; { /* (Pat, Rhs) ==> ([Pat], Rhs') */
- fst(c) = singleton(fst(c));
- snd(c) = transRhs(snd(c));
-}
-
-static List local transBinds(bs) /* Translate list of bindings: */
-List bs; { /* eliminating pattern matching on */
- List newBinds = NIL; /* lhs of bindings. */
- for (; nonNull(bs); bs=tl(bs)) {
-#if IPARAM
- Cell v = fst(hd(bs));
- while (isAp(v) && fst(v) == nameInd)
- v = arg(v);
- fst(hd(bs)) = v;
- if (isVar(v)) {
-#else
- if (isVar(fst(hd(bs)))) {
-#endif
- mapProc(transAlt,snd(hd(bs)));
- newBinds = cons(hd(bs),newBinds);
- }
- else
- newBinds = remPat(fst(snd(hd(bs))),
- snd(snd(hd(bs)))=transRhs(snd(snd(hd(bs)))),
- newBinds);
- }
- return newBinds;
-}
-
-static Cell local transRhs(rhs) /* Translate rhs: removing line nos */
-Cell rhs; {
- switch (whatIs(rhs)) {
- case LETREC : snd(snd(rhs)) = transRhs(snd(snd(rhs)));
- return expandLetrec(rhs);
-
- case GUARDED : mapOver(snd,snd(rhs)); /* discard line number */
- mapProc(transPair,snd(rhs));
- return rhs;
-
- default : {
- Cell tmp;
- Int prev = lineNumber;
- lineNumber = intOf(fst(rhs));
- tmp = translate(snd(rhs)); /* discard line number */
- lineNumber = prev;
- return tmp;
- }
- }
-}
-
-static Cell local mkConsList(es) /* Construct expression for list es */
-List es; { /* using nameNil and nameCons */
- if (isNull(es))
- return nameNil;
- else
- return ap(ap(nameCons,hd(es)),mkConsList(tl(es)));
-}
-
-static Cell local expandLetrec(root) /* translate LETREC with list of */
-Cell root; { /* groups of bindings (from depend. */
- Cell e = snd(snd(root)); /* analysis) to use nested LETRECs */
- List bss = fst(snd(root));
- Cell temp;
-
- if (isNull(bss)) /* should never happen, but just in */
- return e; /* case: LETREC [] IN e ==> e */
-
- mapOver(transBinds,bss); /* translate each group of bindings */
-
- for (temp=root; nonNull(tl(bss)); bss=tl(bss)) {
- fst(snd(temp)) = hd(bss);
- snd(snd(temp)) = ap(LETREC,pair(NIL,e));
- temp = snd(snd(temp));
- }
- fst(snd(temp)) = hd(bss);
-
- return root;
-}
-
-/* --------------------------------------------------------------------------
- * Translation of list comprehensions is based on the description in
- * `The Implementation of Functional Programming Languages':
- *
- * [ e | qs ] ++ l => transComp e qs l
- * transComp e [] l => e : l
- * transComp e ((p<-xs):qs) l => LETREC _h [] = l
- * _h (p:_xs) = transComp e qs (_h _xs)
- * _h (_:_xs) = _h _xs --if p !failFree
- * IN _h xs
- * transComp e (b:qs) l => if b then transComp e qs l else l
- * transComp e (decls:qs) l => LETREC decls IN transComp e qs l
- * ------------------------------------------------------------------------*/
-
-static Cell local transComp(e,qs,l) /* Translate [e | qs] ++ l */
-Cell e;
-List qs;
-Cell l; {
- if (nonNull(qs)) {
- Cell q = hd(qs);
- Cell qs1 = tl(qs);
-
- switch (fst(q)) {
- case FROMQUAL : { Cell ld = NIL;
- Cell hVar = inventVar();
- Cell xsVar = inventVar();
-
- if (!failFree(fst(snd(q))))
- ld = cons(pair(singleton(
- ap(ap(nameCons,
- WILDCARD),
- xsVar)),
- ap(hVar,xsVar)),
- ld);
-
- ld = cons(pair(singleton(
- ap(ap(nameCons,
- fst(snd(q))),
- xsVar)),
- transComp(e,
- qs1,
- ap(hVar,xsVar))),
- ld);
- ld = cons(pair(singleton(nameNil),
- l),
- ld);
-
- return ap(LETREC,
- pair(singleton(pair(hVar,
- ld)),
- ap(hVar,
- translate(snd(snd(q))))));
- }
-
- case QWHERE : return
- expandLetrec(ap(LETREC,
- pair(snd(q),
- transComp(e,qs1,l))));
-
- case BOOLQUAL : return ap(COND,
- triple(translate(snd(q)),
- transComp(e,qs1,l),
- l));
- }
- }
-
- return ap(ap(nameCons,e),l);
-}
-
-/* --------------------------------------------------------------------------
- * Translation of monad comprehensions written using do-notation:
- *
- * do { e } => e
- * do { p <- exp; qs } => LETREC _h p = do { qs }
- * _h _ = fail m "match fails"
- * IN bind m exp _h
- * do { LET decls; qs } => LETREC decls IN do { qs }
- * do { IF guard; qs } => if guard then do { qs } else fail m "guard fails"
- * do { e; qs } => LETREC _h _ = [ e | qs ] in bind m exp _h
- *
- * where m :: Monad f
- * ------------------------------------------------------------------------*/
-
-static Cell local transDo(m,e,qs) /* Translate do { qs ; e } */
-Cell m;
-Cell e;
-List qs; {
- if (nonNull(qs)) {
- Cell q = hd(qs);
- Cell qs1 = tl(qs);
-
- switch (fst(q)) {
- case FROMQUAL : { Cell ld = NIL;
- Cell hVar = inventVar();
-
- if (!failFree(fst(snd(q)))) {
- Cell str = mkStr(findText("match fails"));
- ld = cons(pair(singleton(WILDCARD),
- ap2(nameMFail,m,str)),
- ld);
- }
-
- ld = cons(pair(singleton(fst(snd(q))),
- transDo(m,e,qs1)),
- ld);
-
- return ap(LETREC,
- pair(singleton(pair(hVar,ld)),
- ap(ap(ap(nameBind,
- m),
- translate(snd(snd(q)))),
- hVar)));
- }
-
- case DOQUAL : { Cell hVar = inventVar();
- Cell ld = cons(pair(singleton(WILDCARD),
- transDo(m,e,qs1)),
- NIL);
- return ap(LETREC,
- pair(singleton(pair(hVar,ld)),
- ap(ap(ap(nameBind,
- m),
- translate(snd(q))),
- hVar)));
- }
-
- case QWHERE : return
- expandLetrec(ap(LETREC,
- pair(snd(q),
- transDo(m,e,qs1))));
-
- case BOOLQUAL : return
- ap(COND,
- triple(translate(snd(q)),
- transDo(m,e,qs1),
- ap2(nameMFail,m,
- mkStr(findText("guard fails")))));
- }
- }
- return e;
-}
-
-/* --------------------------------------------------------------------------
- * Translation of named field construction and update:
- *
- * Construction is implemented using the following transformation:
- *
- * C{x1=e1, ..., xn=en} = C v1 ... vm
- * where:
- * vi = e1, if the ith component of C is labelled with x1
- * ...
- * = en, if the ith component of C is labelled with xn
- * = undefined, otherwise
- *
- * Update is implemented using the following transformation:
- *
- * e{x1=e1, ..., xn=en}
- * = let nv (C a1 ... am) v1 ... vn = C a1' .. am'
- * nv (D b1 ... bk) v1 ... vn = D b1' .. bk
- * ...
- * nv _ v1 ... vn = error "failed update"
- * in nv e e1 ... en
- * where:
- * nv, v1, ..., vn, a1, ..., am, b1, ..., bk, ... are new variables,
- * C,D,... = { K | K is a constr fun s.t. {x1,...,xn} subset of sels(K)}
- * and:
- * ai' = v1, if the ith component of C is labelled with x1
- * ...
- * = vn, if the ith component of C is labelled with xn
- * = ai, otherwise
- * etc...
- *
- * The error case may be omitted if C,D,... is an enumeration of all of the
- * constructors for the datatype concerned. Strictly speaking, error case
- * isn't needed at all -- the only benefit of including it is that the user
- * will get a "failed update" message rather than a cryptic {v354 ...}.
- * So, for now, we'll go with the second option!
- *
- * For the time being, code for each update operation is generated
- * independently of any other updates. However, if updates are used
- * frequently, then we might want to consider changing the implementation
- * at a later stage to cache definitions of functions like nv above. This
- * would create a shared library of update functions, indexed by a set of
- * constructors {C,D,...}.
- * ------------------------------------------------------------------------*/
-
-static Cell local transConFlds(c,flds) /* Translate C{flds} */
-Name c;
-List flds; {
- Cell e = c;
- Int m = name(c).arity;
- Int i;
- for (i=m; i>0; i--)
- e = ap(e,nameUndefined);
- for (; nonNull(flds); flds=tl(flds)) {
- Cell a = e;
- for (i=m-sfunPos(fst(hd(flds)),c); i>0; i--)
- a = fun(a);
- arg(a) = translate(snd(hd(flds)));
- }
- return e;
-}
-
-static Cell local transUpdFlds(e,cs,flds)/* Translate e{flds} */
-Cell e; /* (cs is corresp list of constrs) */
-List cs;
-List flds; {
- Cell nv = inventVar();
- Cell body = ap(nv,translate(e));
- List fs = flds;
- List args = NIL;
- List alts = NIL;
-
- for (; nonNull(fs); fs=tl(fs)) { /* body = nv e1 ... en */
- Cell b = hd(fs); /* args = [v1, ..., vn] */
- body = ap(body,translate(snd(b)));
- args = cons(inventVar(),args);
- }
-
- for (; nonNull(cs); cs=tl(cs)) { /* Loop through constructors to */
- Cell c = hd(cs); /* build up list of alts. */
- Cell pat = c;
- Cell rhs = c;
- List as = args;
- Int m = name(c).arity;
- Int i;
-
- for (i=m; i>0; i--) { /* pat = C a1 ... am */
- Cell a = inventVar(); /* rhs = C a1 ... am */
- pat = ap(pat,a);
- rhs = ap(rhs,a);
- }
-
- for (fs=flds; nonNull(fs); fs=tl(fs), as=tl(as)) {
- Name s = fst(hd(fs)); /* Replace approp ai in rhs with */
- Cell r = rhs; /* vars from [v1,...,vn] */
- for (i=m-sfunPos(s,c); i>0; i--)
- r = fun(r);
- arg(r) = hd(as);
- }
-
- alts = cons(pair(cons(pat,args),rhs),alts);
- }
- return ap(LETREC,pair(singleton(pair(nv,alts)),body));
-}
-
-/* --------------------------------------------------------------------------
- * Elimination of pattern bindings:
- *
- * The following code adopts the definition of failure free patterns as given
- * in the Haskell 1.3 report; the term "irrefutable" is also used there for
- * a subset of the failure free patterns described here, but has no useful
- * role in this implementation. Basically speaking, the failure free patterns
- * are: variable, wildcard, ~apat
- * var@apat, if apat is failure free
- * C apat1 ... apatn if C is a product constructor
- * (i.e. an only constructor) and
- * apat1,...,apatn are failure free
- * Note that the last case automatically covers the case where C comes from
- * a newtype construction.
- * ------------------------------------------------------------------------*/
-
-Bool failFree(pat) /* is pattern failure free? (do we need */
-Cell pat; { /* a conformality check?) */
- Cell c = getHead(pat);
-
- switch (whatIs(c)) {
- case ASPAT : return failFree(snd(snd(pat)));
-
- case NAME : if (!isCfun(c) || cfunOf(c)!=0)
- return FALSE;
- /*intentional fall-thru*/
- case TUPLE : for (; isAp(pat); pat=fun(pat))
- if (!failFree(arg(pat)))
- return FALSE;
- /*intentional fall-thru*/
- case LAZYPAT :
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case WILDCARD : return TRUE;
-
-#if TREX
- case EXT : return failFree(extField(pat)) &&
- failFree(extRow(pat));
-#endif
-
- case CONFLDS : if (cfunOf(fst(snd(c)))==0) {
- List fs = snd(snd(c));
- for (; nonNull(fs); fs=tl(fs))
- if (!failFree(snd(hd(fs))))
- return FALSE;
- return TRUE;
- }
- /*intentional fall-thru*/
- default : return FALSE;
- }
-}
-
-static Cell local refutePat(pat) /* find pattern to refute in conformality*/
-Cell pat; { /* test with pat. */
- /* e.g. refPat (x:y) == (_:_) */
- /* refPat ~(x:y) == _ etc.. */
-
- switch (whatIs(pat)) {
- case ASPAT : return refutePat(snd(snd(pat)));
-
- case FINLIST : { Cell ys = snd(pat);
- Cell xs = NIL;
- for (; nonNull(ys); ys=tl(ys))
- xs = ap(ap(nameCons,refutePat(hd(ys))),xs);
- return revOnto(xs,nameNil);
- }
-
- case CONFLDS : { Cell ps = NIL;
- Cell fs = snd(snd(pat));
- for (; nonNull(fs); fs=tl(fs)) {
- Cell p = refutePat(snd(hd(fs)));
- ps = cons(pair(fst(hd(fs)),p),ps);
- }
- return pair(CONFLDS,pair(fst(snd(pat)),rev(ps)));
- }
-
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR :
- case WILDCARD :
- case LAZYPAT : return WILDCARD;
-
- case STRCELL :
- case CHARCELL :
- case ADDPAT :
- case TUPLE :
- case NAME : return pat;
-
- case AP : return refutePatAp(pat);
-
- default : internal("refutePat");
- return NIL; /*NOTREACHED*/
- }
-}
-
-static Cell local refutePatAp(p) /* find pattern to refute in conformality*/
-Cell p; {
- Cell h = getHead(p);
- if (h==nameFromInt || h==nameFromInteger || h==nameFromDouble)
- return p;
- else if (whatIs(h)==ADDPAT)
- return ap(fun(p),refutePat(arg(p)));
-#if TREX
- else if (isExt(h)) {
- Cell pf = refutePat(extField(p));
- Cell pr = refutePat(extRow(p));
- return ap(ap(fun(fun(p)),pf),pr);
- }
-#endif
- else {
- List as = getArgs(p);
- mapOver(refutePat,as);
- return applyToArgs(h,as);
- }
-}
-
-static Cell local matchPat(pat) /* find pattern to match against */
-Cell pat; { /* replaces parts of pattern that do not */
- /* include variables with wildcards */
- switch (whatIs(pat)) {
- case ASPAT : { Cell p = matchPat(snd(snd(pat)));
- return (p==WILDCARD) ? fst(snd(pat))
- : ap(ASPAT,
- pair(fst(snd(pat)),p));
- }
-
- case FINLIST : { Cell ys = snd(pat);
- Cell xs = NIL;
- for (; nonNull(ys); ys=tl(ys))
- xs = cons(matchPat(hd(ys)),xs);
- while (nonNull(xs) && hd(xs)==WILDCARD)
- xs = tl(xs);
- for (ys=nameNil; nonNull(xs); xs=tl(xs))
- ys = ap(ap(nameCons,hd(xs)),ys);
- return ys;
- }
-
- case CONFLDS : { Cell ps = NIL;
- Name c = fst(snd(pat));
- Cell fs = snd(snd(pat));
- Bool avar = FALSE;
- for (; nonNull(fs); fs=tl(fs)) {
- Cell p = matchPat(snd(hd(fs)));
- ps = cons(pair(fst(hd(fs)),p),ps);
- if (p!=WILDCARD)
- avar = TRUE;
- }
- return avar ? pair(CONFLDS,pair(c,rev(ps)))
- : WILDCARD;
- }
-
- case VAROPCELL :
- case VARIDCELL :
- case DICTVAR : return pat;
-
- case LAZYPAT : { Cell p = matchPat(snd(pat));
- return (p==WILDCARD) ? WILDCARD : ap(LAZYPAT,p);
- }
-
- case WILDCARD :
- case STRCELL :
- case CHARCELL : return WILDCARD;
-
- case TUPLE :
- case NAME :
- case AP : { Cell h = getHead(pat);
- if (h==nameFromInt ||
- h==nameFromInteger || h==nameFromDouble)
- return WILDCARD;
- else if (whatIs(h)==ADDPAT)
- return pat;
-#if TREX
- else if (isExt(h)) {
- Cell pf = matchPat(extField(pat));
- Cell pr = matchPat(extRow(pat));
- return (pf==WILDCARD && pr==WILDCARD)
- ? WILDCARD
- : ap(ap(fun(fun(pat)),pf),pr);
- }
-#endif
- else {
- List args = NIL;
- Bool avar = FALSE;
- for (; isAp(pat); pat=fun(pat)) {
- Cell p = matchPat(arg(pat));
- if (p!=WILDCARD)
- avar = TRUE;
- args = cons(p,args);
- }
- return avar ? applyToArgs(pat,args)
- : WILDCARD;
- }
- }
-
- default : internal("matchPat");
- return NIL; /*NOTREACHED*/
- }
-}
-
-#define addEqn(v,val,lds) cons(pair(v,singleton(pair(NIL,val))),lds)
-
-static List local remPat(pat,expr,lds)
-Cell pat; /* Produce list of definitions for eqn */
-Cell expr; /* pat = expr, including a conformality */
-List lds; { /* check if required. */
-
- /* Conformality test (if required):
- * pat = expr ==> nv = LETREC confCheck nv@pat = nv
- * IN confCheck expr
- * remPat1(pat,nv,.....);
- */
-
- if (!failFree(pat)) {
- Cell confVar = inventVar();
- Cell nv = inventVar();
- Cell locfun = pair(confVar, /* confVar [([nv@refPat],nv)] */
- singleton(pair(singleton(ap(ASPAT,
- pair(nv,
- refutePat(pat)))),
- nv)));
-
- if (whatIs(expr)==GUARDED) { /* A spanner ... special case */
- lds = addEqn(nv,expr,lds); /* for guarded pattern binding*/
- expr = nv;
- nv = inventVar();
- }
-
- if (whatIs(pat)==ASPAT) { /* avoid using new variable if*/
- nv = fst(snd(pat)); /* a variable is already given*/
- pat = snd(snd(pat)); /* by an as-pattern */
- }
-
- lds = addEqn(nv, /* nv = */
- ap(LETREC,pair(singleton(locfun), /* LETREC [locfun] */
- ap(confVar,expr))), /* IN confVar expr */
- lds);
-
- return remPat1(matchPat(pat),nv,lds);
- }
-
- return remPat1(matchPat(pat),expr,lds);
-}
-
-static List local remPat1(pat,expr,lds)
-Cell pat; /* Add definitions for: pat = expr to */
-Cell expr; /* list of local definitions in lds. */
-List lds; {
- Cell c = getHead(pat);
-
- switch (whatIs(c)) {
- case WILDCARD :
- case STRCELL :
- case CHARCELL : break;
-
- case ASPAT : return remPat1(snd(snd(pat)), /* v@pat = expr */
- fst(snd(pat)),
- addEqn(fst(snd(pat)),expr,lds));
-
- case LAZYPAT : { Cell nv;
-
- if (isVar(expr) || isName(expr))
- nv = expr;
- else {
- nv = inventVar();
- lds = addEqn(nv,expr,lds);
- }
-
- return remPat(snd(pat),nv,lds);
- }
-
- case ADDPAT : return remPat1(arg(pat), /* n + k = expr */
- ap(ap(ap(namePmSub,
- arg(fun(pat))),
- mkInt(snd(fun(fun(pat))))),
- expr),
- lds);
-
- case FINLIST : return remPat1(mkConsList(snd(pat)),expr,lds);
-
- case CONFLDS : { Name h = fst(snd(pat));
- Int m = name(h).arity;
- Cell p = h;
- List fs = snd(snd(pat));
- Int i = m;
- while (0<i--)
- p = ap(p,WILDCARD);
- for (; nonNull(fs); fs=tl(fs)) {
- Cell r = p;
- for (i=m-sfunPos(fst(hd(fs)),h); i>0; i--)
- r = fun(r);
- arg(r) = snd(hd(fs));
- }
- return remPat1(p,expr,lds);
- }
-
- case DICTVAR : /* shouldn't really occur */
- //assert(0); /* so let's test for it then! ADR */
- case VARIDCELL :
- case VAROPCELL : return addEqn(pat,expr,lds);
-
- case NAME : if (c==nameFromInt || c==nameFromInteger
- || c==nameFromDouble) {
- if (argCount==2)
- arg(fun(pat)) = translate(arg(fun(pat)));
- break;
- }
-
- if (argCount==1 && isCfun(c) /* for newtype */
- && cfunOf(c)==0 && name(c).defn==nameId)
- return remPat1(arg(pat),expr,lds);
-
- /* intentional fall-thru */
- case TUPLE : { List ps = getArgs(pat);
-
- /* get rid of leading dictionaries in args */
- if (isName(c) && isCfun(c)) {
- Int i = numQualifiers(name(c).type);
- for (; i > 0; i--) ps = tl(ps);
- }
-
- if (nonNull(ps)) {
- Cell nv, sel;
- Int i;
- if (isVar(expr) || isName(expr))
- nv = expr;
- else {
- nv = inventVar();
- lds = addEqn(nv,expr,lds);
- }
-
- sel = ap(ap(nameSel,c),nv);
- for (i=1; nonNull(ps); ++i, ps=tl(ps))
- lds = remPat1(hd(ps),
- ap(sel,mkInt(i)),
- lds);
- }
- }
- break;
-
-#if TREX
- case EXT : { Cell nv = inventVar();
- arg(fun(fun(pat)))
- = translate(arg(fun(fun(pat))));
- lds = addEqn(nv,
- ap(ap(nameRecBrk,
- arg(fun(fun(pat)))),
- expr),
- lds);
- lds = remPat1(extField(pat),ap(nameFst,nv),lds);
- lds = remPat1(extRow(pat),ap(nameSnd,nv),lds);
- }
- break;
-#endif
-
- default : internal("remPat1");
- break;
- }
- return lds;
-}
-
-/* --------------------------------------------------------------------------
- * Eliminate pattern matching in function definitions -- pattern matching
- * compiler:
- *
- * The original Gofer/Hugs pattern matching compiler was based on Wadler's
- * algorithms described in `Implementation of functional programming
- * languages'. That should still provide a good starting point for anyone
- * wanting to understand this part of the system. However, the original
- * algorithm has been generalized and restructured in order to implement
- * new features added in Haskell 1.3.
- *
- * During the translation, in preparation for later stages of compilation,
- * all local and bound variables are replaced by suitable offsets, and
- * locally defined function symbols are given new names (which will
- * eventually be their names when lifted to make top level definitions).
- * ------------------------------------------------------------------------*/
-
-static Offset freeBegin; /* only variables with offset <= freeBegin are of */
-static List freeVars; /* interest as `free' variables */
-static List freeFuns; /* List of `free' local functions */
-
-static Cell local pmcTerm(co,sc,e) /* apply pattern matching compiler */
-Int co; /* co = current offset */
-List sc; /* sc = scope */
-Cell e; { /* e = expr to transform */
- switch (whatIs(e)) {
- case GUARDED : map2Over(pmcPair,co,sc,snd(e));
- break;
-
- case LETREC : pmcLetrec(co,sc,snd(e));
- break;
-
- case VARIDCELL:
- case VAROPCELL:
- case DICTVAR : return pmcVar(sc,textOf(e));
-
- case COND : return ap(COND,pmcTriple(co,sc,snd(e)));
-
- case AP : return pmcPair(co,sc,e);
-
- case ADDPAT :
-#if TREX
- case EXT :
-#endif
- case TUPLE :
- case NAME :
- case CHARCELL :
- case INTCELL :
- case BIGCELL :
- case FLOATCELL:
- case STRCELL : break;
-
- default : internal("pmcTerm");
- break;
- }
- return e;
-}
-
-static Cell local pmcPair(co,sc,pr) /* apply pattern matching compiler */
-Int co; /* to a pair of exprs */
-List sc;
-Pair pr; {
- return pair(pmcTerm(co,sc,fst(pr)),
- pmcTerm(co,sc,snd(pr)));
-}
-
-static Cell local pmcTriple(co,sc,tr) /* apply pattern matching compiler */
-Int co; /* to a triple of exprs */
-List sc;
-Triple tr; {
- return triple(pmcTerm(co,sc,fst3(tr)),
- pmcTerm(co,sc,snd3(tr)),
- pmcTerm(co,sc,thd3(tr)));
-}
-
-static Cell local pmcVar(sc,t) /* find translation of variable */
-List sc; /* in current scope */
-Text t; {
- List xs;
- Name n;
-
- for (xs=sc; nonNull(xs); xs=tl(xs)) {
- Cell x = hd(xs);
- if (t==textOf(fst(x))) {
- if (isOffset(snd(x))) { /* local variable ... */
- if (snd(x)<=freeBegin && !cellIsMember(snd(x),freeVars))
- freeVars = cons(snd(x),freeVars);
- return snd(x);
- }
- else { /* local function ... */
- if (!cellIsMember(snd(x),freeFuns))
- freeFuns = cons(snd(x),freeFuns);
- return fst3(snd(x));
- }
- }
- }
-
- if (isNull(n=findName(t))) /* Lookup global name - the only way*/
- n = newName(t,currentName); /* this (should be able to happen) */
- /* is with new global var introduced*/
- /* after type check; e.g. remPat1 */
- return n;
-}
-
-static Void local pmcLetrec(co,sc,e) /* apply pattern matching compiler */
-Int co; /* to LETREC, splitting decls into */
-List sc; /* two sections */
-Pair e; {
- List fs = NIL; /* local function definitions */
- List vs = NIL; /* local variable definitions */
- List ds;
-
- for (ds=fst(e); nonNull(ds); ds=tl(ds)) { /* Split decls into two */
- Cell v = fst(hd(ds));
- Int arity = length(fst(hd(snd(hd(ds)))));
-
- if (arity==0) { /* Variable declaration */
- vs = cons(snd(hd(ds)),vs);
- sc = cons(pair(v,mkOffset(++co)),sc);
- }
- else { /* Function declaration */
- fs = cons(triple(inventVar(),mkInt(arity),snd(hd(ds))),fs);
- sc = cons(pair(v,hd(fs)),sc);
- }
- }
- vs = rev(vs); /* Put declaration lists back in */
- fs = rev(fs); /* original order */
- fst(e) = pair(vs,fs); /* Store declaration lists */
- map2Over(pmcVarDef,co,sc,vs); /* Translate variable definitions */
- map2Proc(pmcFunDef,co,sc,fs); /* Translate function definitions */
- snd(e) = pmcTerm(co,sc,snd(e)); /* Translate LETREC body */
- freeFuns = diffList(freeFuns,fs); /* Delete any `freeFuns' bound in fs*/
-}
-
-static Cell local pmcVarDef(co,sc,vd) /* apply pattern matching compiler */
-Int co; /* to variable definition */
-List sc;
-List vd; { /* vd :: [ ([], rhs) ] */
- Cell d = snd(hd(vd));
- if (nonNull(tl(vd)) && canFail(d))
- return ap(FATBAR,pair(pmcTerm(co,sc,d),
- pmcVarDef(co,sc,tl(vd))));
- return pmcTerm(co,sc,d);
-}
-
-static Void local pmcFunDef(co,sc,fd) /* apply pattern matching compiler */
-Int co; /* to function definition */
-List sc;
-Triple fd; { /* fd :: (Var, Arity, [Alt]) */
- Offset saveFreeBegin = freeBegin;
- List saveFreeVars = freeVars;
- List saveFreeFuns = freeFuns;
- Int arity = intOf(snd3(fd));
- Cell temp = altsMatch(co+1,arity,sc,thd3(fd));
- Cell xs;
-
- freeBegin = mkOffset(co);
- freeVars = NIL;
- freeFuns = NIL;
- temp = match(co+arity,temp);
- thd3(fd) = triple(freeVars,freeFuns,temp);
-
- for (xs=freeVars; nonNull(xs); xs=tl(xs))
- if (hd(xs)<=saveFreeBegin && !cellIsMember(hd(xs),saveFreeVars))
- saveFreeVars = cons(hd(xs),saveFreeVars);
-
- for (xs=freeFuns; nonNull(xs); xs=tl(xs))
- if (!cellIsMember(hd(xs),saveFreeFuns))
- saveFreeFuns = cons(hd(xs),saveFreeFuns);
-
- freeBegin = saveFreeBegin;
- freeVars = saveFreeVars;
- freeFuns = saveFreeFuns;
-}
-
-/* ---------------------------------------------------------------------------
- * Main part of pattern matching compiler: convert [Alt] to case constructs
- *
- * This section of Hugs has been almost completely rewritten to be more
- * general, in particular, to allow pattern matching in orders other than the
- * strictly left-to-right approach of the previous version. This is needed
- * for the implementation of the so-called Haskell 1.3 `record' syntax.
- *
- * At each stage, the different branches for the cases to be considered
- * are represented by a list of values of type:
- * Match ::= { maPats :: [Pat], patterns to match
- * maOffs :: [Offs], offsets of corresponding values
- * maSc :: Scope, mapping from vars to offsets
- * maRhs :: Rhs } right hand side
- * [Implementation uses nested pairs, ((pats,offs),(sc,rhs)).]
- *
- * The Scope component has type:
- * Scope ::= [(Var,Expr)]
- * and provides a mapping from variable names to offsets used in the matching
- * process.
- *
- * Matches can be normalized by reducing them to a form in which the list
- * of patterns is empty (in which case the match itself is described as an
- * empty match), or in which the list is non-empty and the first pattern is
- * one that requires either a CASE or NUMCASE (or EXTCASE) to decompose.
- * ------------------------------------------------------------------------*/
-
-#define mkMatch(ps,os,sc,r) pair(pair(ps,os),pair(sc,r))
-#define maPats(ma) fst(fst(ma))
-#define maOffs(ma) snd(fst(ma))
-#define maSc(ma) fst(snd(ma))
-#define maRhs(ma) snd(snd(ma))
-#define extSc(v,o,ma) maSc(ma) = cons(pair(v,o),maSc(ma))
-
-static List local altsMatch(co,n,sc,as) /* Make a list of matches from list*/
-Int co; /* of Alts, with initial offsets */
-Int n; /* reverse (take n [co..]) */
-List sc;
-List as; {
- List mas = NIL;
- List us = NIL;
- for (; n>0; n--)
- us = cons(mkOffset(co++),us);
- for (; nonNull(as); as=tl(as)) /* Each Alt is ([Pat], Rhs) */
- mas = cons(mkMatch(fst(hd(as)),us,sc,snd(hd(as))),mas);
- return rev(mas);
-}
-
-static Cell local match(co,mas) /* Generate case statement for Matches mas */
-Int co; /* at current offset co */
-List mas; { /* N.B. Assumes nonNull(mas). */
- Cell srhs = NIL; /* Rhs for selected matches */
- List smas = mas; /* List of selected matches */
- mas = tl(mas);
- tl(smas) = NIL;
-
- if (emptyMatch(hd(smas))) { /* The case for empty matches: */
- while (nonNull(mas) && emptyMatch(hd(mas))) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- srhs = joinMas(co,rev(smas));
- }
- else { /* Non-empty match */
- Int o = offsetOf(hd(maOffs(hd(smas))));
- Cell d = maDiscr(hd(smas));
- if (isNumDiscr(d)) { /* Numeric match */
- Int da = discrArity(d);
- Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && isNumDiscr(d=maDiscr(hd(mas)))
- && eqNumDiscr(d,d1)) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- smas = rev(smas);
- map2Proc(advance,co,da,smas);
- srhs = ap(NUMCASE,triple(mkOffset(o),d1,match(co+da,smas)));
- }
-#if TREX
- else if (isExtDiscr(d)) { /* Record match */
- Int da = discrArity(d);
- Cell d1 = pmcTerm(co,maSc(hd(smas)),d);
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && isExtDiscr(d=maDiscr(hd(mas)))
- && eqExtDiscr(d,d1)) {
- List temp = tl(mas);
- tl(mas) = smas;
- smas = mas;
- mas = temp;
- }
- smas = rev(smas);
- map2Proc(advance,co,da,smas);
- srhs = ap(EXTCASE,triple(mkOffset(o),d1,match(co+da,smas)));
- }
-#endif
- else { /* Constructor match */
- List tab = addConTable(d,hd(smas),NIL);
- Int da;
- while (nonNull(mas) && !emptyMatch(hd(mas))
- && o==offsetOf(hd(maOffs(hd(mas))))
- && !isNumDiscr(d=maDiscr(hd(mas)))) {
- tab = addConTable(d,hd(mas),tab);
- mas = tl(mas);
- }
- for (tab=rev(tab); nonNull(tab); tab=tl(tab)) {
- d = fst(hd(tab));
- smas = snd(hd(tab));
- da = discrArity(d);
- map2Proc(advance,co,da,smas);
- srhs = cons(pair(d,match(co+da,smas)),srhs);
- }
- srhs = ap(CASE,pair(mkOffset(o),srhs));
- }
- }
- return nonNull(mas) ? ap(FATBAR,pair(srhs,match(co,mas))) : srhs;
-}
-
-static Cell local joinMas(co,mas) /* Combine list of matches into rhs*/
-Int co; /* using FATBARs as necessary */
-List mas; { /* Non-empty list of empty matches */
- Cell ma = hd(mas);
- Cell rhs = pmcTerm(co,maSc(ma),maRhs(ma));
- if (nonNull(tl(mas)) && canFail(rhs))
- return ap(FATBAR,pair(rhs,joinMas(co,tl(mas))));
- else
- return rhs;
-}
-
-static Bool local canFail(rhs) /* Determine if expression (as rhs) */
-Cell rhs; { /* might ever be able to fail */
- switch (whatIs(rhs)) {
- case LETREC : return canFail(snd(snd(rhs)));
- case GUARDED : return TRUE; /* could get more sophisticated ..? */
- default : return FALSE;
- }
-}
-
-/* type Table a b = [(a, [b])]
- *
- * addTable :: a -> b -> Table a b -> Table a b
- * addTable x y [] = [(x,[y])]
- * addTable x y (z@(n,sws):zs)
- * | n == x = (n,sws++[y]):zs
- * | otherwise = (n,sws):addTable x y zs
- */
-
-static List local addConTable(x,y,tab) /* add element (x,y) to table */
-Cell x, y;
-List tab; {
- if (isNull(tab))
- return singleton(pair(x,singleton(y)));
- else if (fst(hd(tab))==x)
- snd(hd(tab)) = appendOnto(snd(hd(tab)),singleton(y));
- else
- tl(tab) = addConTable(x,y,tl(tab));
-
- return tab;
-}
-
-static Void local advance(co,a,ma) /* Advance non-empty match by */
-Int co; /* processing head pattern */
-Int a; /* discriminator arity */
-Cell ma; {
- Cell p = hd(maPats(ma));
- List ps = tl(maPats(ma));
- List us = tl(maOffs(ma));
- if (whatIs(p)==CONFLDS) { /* Special case for record syntax */
- Name c = fst(snd(p));
- List fs = snd(snd(p));
- List qs = NIL;
- List vs = NIL;
- for (; nonNull(fs); fs=tl(fs)) {
- vs = cons(mkOffset(co+a+1-sfunPos(fst(hd(fs)),c)),vs);
- qs = cons(snd(hd(fs)),qs);
- }
- ps = revOnto(qs,ps);
- us = revOnto(vs,us);
- }
- else /* Normally just spool off patterns*/
- for (; a>0; --a) { /* and corresponding offsets ... */
- us = cons(mkOffset(++co),us);
- ps = cons(arg(p),ps);
- p = fun(p);
- }
-
- maPats(ma) = ps;
- maOffs(ma) = us;
-}
-
-/* --------------------------------------------------------------------------
- * Normalize and test for empty match:
- * ------------------------------------------------------------------------*/
-
-static Bool local emptyMatch(ma)/* Normalize and test to see if a given */
-Cell ma; { /* match, ma, is empty. */
-
- while (nonNull(maPats(ma))) {
- Cell p;
-tidyHd: switch (whatIs(p=hd(maPats(ma)))) {
- case LAZYPAT : { Cell nv = inventVar();
- maRhs(ma) = ap(LETREC,
- pair(remPat(snd(p),nv,NIL),
- maRhs(ma)));
- p = nv;
- }
- /* intentional fall-thru */
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR : extSc(p,hd(maOffs(ma)),ma);
- case WILDCARD : maPats(ma) = tl(maPats(ma));
- maOffs(ma) = tl(maOffs(ma));
- continue;
-
- /* So-called "as-patterns"are really just pattern intersections:
- * (p1@p2:ps, o:os, sc, e) ==> (p1:p2:ps, o:o:os, sc, e)
- * (But the input grammar probably doesn't let us take
- * advantage of this, so we stick with the special case
- * when p1 is a variable.)
- */
- case ASPAT : extSc(fst(snd(p)),hd(maOffs(ma)),ma);
- hd(maPats(ma)) = snd(snd(p));
- goto tidyHd;
-
- case FINLIST : hd(maPats(ma)) = mkConsList(snd(p));
- return FALSE;
-
- case STRCELL : { String s = textToStr(textOf(p));
- for (p=NIL; *s!='\0'; ++s) {
- if (*s!='\\' || *++s=='\\')
- p = ap(consChar(*s),p);
- else
- p = ap(consChar('\0'),p);
- }
- hd(maPats(ma)) = revOnto(p,nameNil);
- }
- return FALSE;
-
- case AP : if (isName(fun(p)) && isCfun(fun(p))
- && cfunOf(fun(p))==0
- && name(fun(p)).defn==nameId) {
- hd(maPats(ma)) = arg(p);
- goto tidyHd;
- }
- /* intentional fall-thru */
- case CHARCELL :
- case NAME :
- case CONFLDS :
- return FALSE;
-
- default : internal("emptyMatch");
- }
- }
- return TRUE;
-}
-
-/* --------------------------------------------------------------------------
- * Discriminators:
- * ------------------------------------------------------------------------*/
-
-static Cell local maDiscr(ma) /* Get the discriminator for a non-empty */
-Cell ma; { /* match, ma. */
- Cell p = hd(maPats(ma));
- Cell h = getHead(p);
- switch (whatIs(h)) {
- case CONFLDS : return fst(snd(p));
- case ADDPAT : arg(fun(p)) = translate(arg(fun(p)));
- return fun(p);
-#if TREX
- case EXT : h = fun(fun(p));
- arg(h) = translate(arg(h));
- return h;
-#endif
- case NAME : if (h==nameFromInt || h==nameFromInteger
- || h==nameFromDouble) {
- if (argCount==2)
- arg(fun(p)) = translate(arg(fun(p)));
- return p;
- }
- }
- return h;
-}
-
-static Bool local isNumDiscr(d) /* TRUE => numeric discriminator */
-Cell d; {
- switch (whatIs(d)) {
- case NAME :
- case TUPLE :
- case CHARCELL : return FALSE;
-
-#if TREX
- case AP : return !isExt(fun(d));
-#else
- case AP : return TRUE; /* must be a literal or (n+k) */
-#endif
- }
- internal("isNumDiscr");
- return 0;/*NOTREACHED*/
-}
-
-Int discrArity(d) /* Find arity of discriminator */
-Cell d; {
- switch (whatIs(d)) {
- case NAME : return name(d).arity;
- case TUPLE : return tupleOf(d);
- case CHARCELL : return 0;
-#if TREX
- case AP : switch (whatIs(fun(d))) {
- case ADDPAT : return 1;
- case EXT : return 2;
- default : return 0;
- }
-#else
- case AP : return (whatIs(fun(d))==ADDPAT) ? 1 : 0;
-#endif
- }
- internal("discrArity");
- return 0;/*NOTREACHED*/
-}
-
-static Bool local eqNumDiscr(d1,d2) /* Determine whether two numeric */
-Cell d1, d2; { /* descriptors have same value */
- if (whatIs(fun(d1))==ADDPAT)
- return whatIs(fun(d2))==ADDPAT && snd(fun(d1))==snd(fun(d2));
- if (isInt(arg(d1)))
- return isInt(arg(d2)) && intOf(arg(d1))==intOf(arg(d2));
- if (isFloat(arg(d1)))
- return isFloat(arg(d2)) && floatOf(arg(d1))==floatOf(arg(d2));
- internal("eqNumDiscr");
- return FALSE;/*NOTREACHED*/
-}
-
-#if TREX
-static Bool local isExtDiscr(d) /* Test of extension discriminator */
-Cell d; {
- return isAp(d) && isExt(fun(d));
-}
-
-static Bool local eqExtDiscr(d1,d2) /* Determine whether two extension */
-Cell d1, d2; { /* discriminators have same label */
- return fun(d1)==fun(d2);
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Main entry points to compiler:
- * ------------------------------------------------------------------------*/
-
-Void evalExp ( void ) /* compile and run input expression */
-{
- Cell e;
- Name n = newName(inventText(),NIL);
- StgVar v = mkStgVar(NIL,NIL);
- name(n).closure = v;
- module(currentModule).codeList = singleton(n);
- compiler(RESET);
- e = pmcTerm(0,NIL,translate(inputExpr));
- stgDefn(n,0,e);
- inputExpr = NIL;
- cgModule ( name(n).mod );
-
- /* Run thread (and any other runnable threads) */
-
- /* Re-initialise the scheduler - ToDo: do I need this? */
- /* JRS, 991118: on SM's advice, don't call initScheduler every time.
- This causes an assertion failure in GC.c(revert_dead_cafs)
- unless doRevertCAFs below is permanently TRUE.
- */
- /* initScheduler(); */
-
- /* Further comments, JRS 000411.
- When control returns to Hugs, you have to be pretty careful about
- the state of the heap. In particular, hugs.c may subsequently call
- nukeModule() in storage.c, which removes modules from the system.
- If a module defines a particular data constructor, the relevant
- info table is also free()d. That gives a problem if there are
- still closures hanging round in the heap with references to that
- info table.
-
- The solution is to firstly to revert CAFs, and then force a major
- collection in between transitions from the mutation, ie actually
- running Haskell, and nukeModule. Since major GCs are potentially
- expensive, we don't want to do one at every call to nukeModule,
- so the flag nukeModule_needs_major_gc is used to signal when one
- is needed.
-
- This all also seems to imply that doRevertCAFs should always
- be TRUE.
- */
- {
- HaskellObj result; /* ignored */
- SchedulerStatus status;
- Bool doRevertCAFs = TRUE; /* do not change -- comment above */
- HugsBreakAction brkOld = setBreakAction ( HugsRtsInterrupt );
- nukeModule_needs_major_gc = TRUE;
- status = rts_eval_(cptrOf(name(n).closure),10000,&result);
- setBreakAction ( brkOld );
- fflush (stderr);
- fflush (stdout);
- switch (status) {
- case Deadlock:
- printf("{Deadlock or Blackhole}"); fflush(stdout);
- break;
- case Interrupted:
- printf("{Interrupted}");
- break;
- case Killed:
- printf("{Interrupted or Killed}");
- break;
- case Success:
- break;
- default:
- internal("evalExp: Unrecognised SchedulerStatus");
- }
-
- /* Begin heap cleanup sequence */
- do {
- /* fprintf ( stderr, "finalisation loop START\n" ); */
- finishAllThreads();
- finalizeWeakPointersNow();
- /* fprintf ( stderr, "finalisation loop END %d\n",
- howManyThreadsAvail() ); */
- }
- while (howManyThreadsAvail() > 0);
-
- RevertCAFs();
- performMajorGC();
- if (combined && SPT_size != 0) {
- FPrintf ( stderr,
- "hugs: fatal: stable pointers are not yet allowed in combined mode" );
- internal("evalExp");
- }
- /* End heap cleanup sequence */
-
- fflush(stdout);
- fflush(stderr);
- }
-}
-
-
-Void compileDefns() { /* compile script definitions */
- Target t = length(valDefns) + length(genDefns) + length(selDefns);
- Target i = 0;
-
- {
- List vss;
- List vs;
- for (vs = genDefns; nonNull(vs); vs = tl(vs)) {
- Name n = hd(vs);
- StgVar nv = mkStgVar(NIL,NIL);
- name(n).closure = nv;
- addToCodeList ( currentModule, n );
- }
- for (vss = selDefns; nonNull(vss); vss = tl(vss)) {
- for (vs = hd(vss); nonNull(vs); vs = tl(vs)) {
- Pair p = hd(vs);
- Name n = fst(p);
- StgVar nv = mkStgVar(NIL,NIL);
- name(n).closure = nv;
- addToCodeList ( currentModule, n );
- }
- }
- }
-
- setGoal("Translating",t);
- /* do valDefns before everything else so that all stgVar's get added. */
- for (; nonNull(valDefns); valDefns=tl(valDefns)) {
- List qq;
- hd(valDefns) = transBinds(hd(valDefns));
- for (qq = hd(valDefns); nonNull(qq); qq = tl(qq)) {
- Name n = findName ( textOf(fst(hd(qq))) );
- StgVar nv = mkStgVar(NIL,NIL);
- assert(nonNull(n));
- name(n).closure = nv;
- addToCodeList ( currentModule, n );
- compileGlobalFunction(hd(qq));
- }
- soFar(i++);
- }
- for (; nonNull(genDefns); genDefns=tl(genDefns)) {
- compileGenFunction(hd(genDefns));
- soFar(i++);
- }
- for (; nonNull(selDefns); selDefns=tl(selDefns)) {
- mapOver(compileSelFunction,hd(selDefns));
- soFar(i++);
- }
-
- done();
- setGoal("Generating code",t);
- cgModule ( currentModule );
-
- done();
-}
-
-static Void local compileGlobalFunction(bind)
-Pair bind; {
- Name n = findName(textOf(fst(bind)));
- List defs = snd(bind);
- Int arity = length(fst(hd(defs)));
- assert(isName(n));
- compiler(RESET);
- stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
-}
-
-static Void local compileGenFunction(n) /* Produce code for internally */
-Name n; { /* generated function */
- List defs = name(n).defn;
- Int arity = length(fst(hd(defs)));
-
- compiler(RESET);
- currentName = n;
- mapProc(transAlt,defs);
- stgDefn(n,arity,match(arity,altsMatch(1,arity,NIL,defs)));
- name(n).defn = NIL;
-}
-
-static Name local compileSelFunction(p) /* Produce code for selector func */
-Pair p; { /* Should be merged with genDefns, */
- Name s = fst(p); /* but the name(_).defn field is */
- List defs = snd(p); /* already used for other purposes */
- Int arity = length(fst(hd(defs))); /* in selector functions. */
-
- compiler(RESET);
- mapProc(transAlt,defs);
- stgDefn(s,arity,match(arity,altsMatch(1,arity,NIL,defs)));
- return s;
-}
-
-
-/* --------------------------------------------------------------------------
- * Compiler control:
- * ------------------------------------------------------------------------*/
-
-Void compiler(what)
-Int what; {
- switch (what) {
- case PREPREL :
- case RESET : freeVars = NIL;
- freeFuns = NIL;
- lineNumber = 0;
- freeBegin = mkOffset(0);
- break;
-
- case MARK : mark(freeVars);
- mark(freeFuns);
- break;
-
- case POSTPREL: break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Connections between components of the Hugs system
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: connect.h,v $
- * $Revision: 1.44 $
- * $Date: 2000/06/28 10:42:17 $
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Connections to Prelude entities:
- * Texts, Names, Instances, Classes, Types, Kinds and Modules
- * ------------------------------------------------------------------------*/
-
-extern Text textPrelPrim;
-extern Text textPrelude;
-extern Text textNum; /* used to process default decls */
-extern Text textCcall; /* used to process foreign import */
-extern Text textStdcall; /* ... and foreign export */
-extern Text textPlus; /* Used to recognise n+k patterns */
-
-
-extern Name nameFalse, nameTrue;
-extern Name nameNil, nameCons;
-extern Name nameJust, nameNothing;
-extern Name nameLeft, nameRight;
-extern Name nameUnit;
-extern Name nameLT, nameEQ;
-extern Name nameGT;
-extern Name nameFst, nameSnd; /* standard combinators */
-extern Name nameId, nameOtherwise;
-extern Name nameNegate, nameFlip; /* primitives reqd for parsing */
-extern Name nameFrom, nameFromThen;
-extern Name nameFromTo, nameFromThenTo;
-extern Name nameFatbar, nameFail; /* primitives reqd for translation */
-extern Name nameIf, nameSel;
-extern Name nameCompAux;
-extern Name namePmInt, namePmFlt; /* primitives for pattern matching */
-extern Name namePmInteger;
-extern Name namePmNpk, namePmSub; /* primitives for (n+k) patterns */
-extern Name nameError; /* For runtime error messages */
-extern Name nameUndefined; /* A generic undefined value */
-extern Name nameBlackHole; /* For GC-detected black hole */
-extern Name nameInd; /* For dict indirection */
-extern Name nameAnd, nameOr; /* For optimisation of && and || */
-extern Name nameFromInt, nameFromDouble;/*coercion of numerics */
-extern Name nameFromInteger;
-extern Name nameEq, nameCompare; /* names used for deriving */
-extern Name nameMinBnd, nameMaxBnd;
-extern Name nameIndex, nameInRange;
-extern Name nameRange;
-extern Name nameLe, nameGt;
-extern Name nameShowsPrec, nameReadsPrec;
-extern Name nameMult, namePlus;
-extern Name nameComp, nameApp; /* composition and append */
-extern Name nameShowField; /* display single field */
-extern Name nameShowParen; /* wrap with parens */
-extern Name nameReadField; /* read single field */
-extern Name nameReadParen; /* unwrap from parens */
-extern Name nameLex; /* lexer */
-extern Name nameRangeSize; /* calculate size of index range */
-extern Name nameReturn, nameBind; /* for translating monad comps */
-extern Name nameMFail;
-extern Name nameListMonad; /* builder function for List Monad */
-extern Name namePrint; /* printing primitive */
-extern Name nameCreateAdjThunk; /* f-x-dyn: create adjustor thunk */
-extern Name nameShow;
-extern Name namePutStr;
-extern Name nameRunIO_toplevel;
-
-/* The following data constructors are used to make boxed but
- * unpointed values pointed and require no special treatment
- * by the code generator. */
-extern Name nameMkInteger;
-extern Name nameMkPrimArray;
-extern Name nameMkPrimByteArray;
-extern Name nameMkRef;
-extern Name nameMkPrimMutableArray;
-extern Name nameMkPrimMutableByteArray;
-extern Name nameMkThreadId;
-extern Name nameMkPrimMVar;
-#ifdef PROVIDE_FOREIGN
-extern Name nameMkForeign;
-#endif
-#ifdef PROVIDE_WEAK
-extern Name nameMkWeak;
-#endif
-
-/* The following data constructors are used to box unboxed
- * arguments and are treated differently by the code generator.
- * That is, they have primop `elem` {INT_REP,FLOAT_REP,...}. */
-#define boxingConRep(con) ((AsmRep)(name(con).primop))
-#define isBoxingCon(con) (isName(con) && boxingConRep(con) != 0)
-extern Name nameMkC;
-extern Name nameMkI;
-extern Name nameMkW;
-extern Name nameMkA;
-extern Name nameMkF;
-extern Name nameMkD;
-extern Name nameMkStable;
-
-/* used while desugaring */
-extern Name nameId;
-extern Name nameOtherwise;
-extern Name nameUndefined; /* generic undefined value */
-
-/* used in pattern match */
-extern Name namePmSub;
-extern Name nameSel;
-
-/* used in translation */
-extern Name nameEq;
-extern Name namePMFail;
-extern Name nameEqChar;
-extern Name nameEqInteger;
-extern Name namePmInt;
-extern Name namePmInteger;
-extern Name namePmDouble;
-extern Name namePmLe;
-extern Name namePmSubtract;
-extern Name namePmFromInteger;
-extern Name nameMkIO;
-extern Name nameUnpackString;
-extern Name namePrimSeq;
-extern Name nameMap;
-extern Name nameMinus;
-
-/* assertion and exceptions */
-extern Name nameAssert;
-extern Name nameAssertError;
-extern Name nameTangleMessage;
-extern Name nameIrrefutPatError;
-extern Name nameNoMethodBindingError;
-extern Name nameNonExhaustiveGuardsError;
-extern Name namePatError;
-extern Name nameRecSelError;
-extern Name nameRecConError;
-extern Name nameRecUpdError;
-
-
-extern Class classMonad; /* Monads */
-extern Class classEq; /* `standard' classes */
-extern Class classOrd;
-extern Class classShow;
-extern Class classRead;
-extern Class classIx;
-extern Class classEnum;
-extern Class classBounded;
-extern Class classReal; /* `numeric' classes */
-extern Class classIntegral;
-extern Class classRealFrac;
-extern Class classRealFloat;
-extern Class classFractional;
-extern Class classFloating;
-extern Class classNum;
-
-
-extern Type typeProgIO; /* For the IO monad, IO a */
-extern Type typeArrow; /* Builtin type constructors */
-extern Type typeList;
-extern Type typeUnit;
-extern Type typeInt64;
-extern Type typeWord;
-extern Type typeFloat;
-extern Type typePrimArray;
-extern Type typePrimByteArray;
-extern Type typeRef;
-extern Type typePrimMutableArray;
-extern Type typePrimMutableByteArray;
-extern Type typeStable;
-extern Type typeWeak;
-extern Type typeIO;
-extern Type typeForeign;
-extern Type typeMVar;
-extern Type typeThreadId;
-extern Type typeException;
-extern Type typeIO;
-extern Type typeST;
-extern Type typeOrdering;
-extern List stdDefaults; /* List of standard default types */
-
-/* For every primitive type provided by the runtime system,
- * we construct a Haskell type using a declaration of the form:
- *
- * data Int -- no constructors given
- */
-extern Type typeChar;
-extern Type typeInt;
-extern Type typeInteger;
-extern Type typeWord;
-extern Type typeAddr;
-extern Type typePrimArray;
-extern Type typePrimByteArray;
-extern Type typeRef;
-extern Type typePrimMutableArray;
-extern Type typePrimMutableByteArray;
-extern Type typeFloat;
-extern Type typeDouble;
-extern Type typeStable;
-extern Type typeThreadId;
-extern Type typeMVar;
-#ifdef PROVIDE_WEAK
-extern Type typeWeak;
-#endif
-#ifdef PROVIDE_FOREIGN
-extern Type typeForeign;
-#endif
-
-/* And a smaller number of types defined in plain Haskell */
-extern Type typeList;
-extern Type typeUnit;
-extern Type typeString;
-extern Type typeBool;
-extern Type typeST;
-extern Type typeIO;
-extern Type typeException;
-
-extern Module modulePrelPrim;
-extern Module modulePrelude;
-
-extern Kind starToStar; /* Type -> Type */
-
-
-#if TREX
-extern Name nameRecExt; /* Extend a record */
-extern Name nameRecBrk; /* Break a record */
-extern Name nameAddEv; /* Addition of evidence values */
-extern Name nameRecSel; /* Select a record */
-extern Name nameRecShw; /* Show a record */
-extern Name nameShowRecRow; /* Used to output rows */
-extern Name nameRecEq; /* Compare records */
-extern Name nameEqRecRow; /* Used to compare rows */
-extern Name nameInsFld; /* Field insertion routine */
-extern Name nameNoRec; /* The empty record */
-extern Type typeNoRow; /* The empty row */
-extern Type typeRec; /* Record formation */
-extern Kind extKind; /* Kind of extension, *->row->row */
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Constructions from the above names, types, etc.
- * ------------------------------------------------------------------------*/
-
-
-extern Type arrow; /* mkOffset(0) -> mkOffset(1) */
-extern Type listof; /* [ mkOffset(0) ] */
-extern Cell predNum; /* Num (mkOffset(0)) */
-extern Cell predFractional; /* Fractional (mkOffset(0)) */
-extern Cell predIntegral; /* Integral (mkOffset(0)) */
-extern Cell predMonad; /* Monad (mkOffset(0)) */
-
-extern Type arrow; /* mkOffset(0) -> mkOffset(1) */
-extern Type boundPair; /* (mkOffset(0),mkOffset(0)) */
-extern Type listof; /* [ mkOffset(0) ] */
-extern Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
-
-extern Cell predNum; /* Num (mkOffset(0)) */
-extern Cell predFractional; /* Fractional (mkOffset(0)) */
-extern Cell predIntegral; /* Integral (mkOffset(0)) */
-extern Kind starToStar; /* Type -> Type */
-extern Cell predMonad; /* Monad (mkOffset(0)) */
-
-#define fn(from,to) ap(ap(typeArrow,from),to) /* make type: from -> to */
-
-#define aVar mkOffset(0) /* Simple skeleton for type var */
-extern Type boundPair; /* (mkOffset(0),mkOffset(0)) */
-
-#define consChar(c) ap(nameCons,mkChar(c))
-
-/* --------------------------------------------------------------------------
- * Umm ....
- * ------------------------------------------------------------------------*/
-
-extern Bool haskell98; /* TRUE => Haskell 98 compatibility*/
-extern Bool combined; /* TRUE => combined operation */
-extern Bool debugSC; /* TRUE => print SC to screen */
-extern Bool kindExpert; /* TRUE => display kind errors in */
- /* full detail */
-extern Bool allowOverlap; /* TRUE => allow overlapping insts */
-
-extern String repeatStr; /* Repeat last command string */
-extern String hugsEdit; /* String for editor command */
-extern String hugsPath; /* String for file search path */
-extern String projectPath; /* String for project search path */
-
-extern Cell* CStackBase; /* pointer to base of C stack */
-
-extern List tyconDefns; /* list of type constructor defns */
-extern List typeInDefns; /* list of synonym restrictions */
-extern List valDefns; /* list of value definitions */
-extern List classDefns; /* list of class definitions */
-extern List instDefns; /* list of instance definitions */
-extern List selDefns; /* list of selector lists */
-extern List genDefns; /* list of generated defns */
-extern List primDefns; /* list of primitive definitions */
-extern List unqualImports; /* unqualified import list */
-extern List defaultDefns; /* default definitions (if any) */
-extern Int defaultLine; /* line in which default defs occur*/
-extern List evalDefaults; /* defaults for evaluator */
-extern Cell inputExpr; /* evaluator input expression */
-extern Cell inputContext; /* evaluator input expression */
-
-extern Cell whnfHead; /* head of term in whnf */
-extern Int whnfInt; /* integer value of term in whnf */
-extern Float whnfFloat; /* float value of term in whnf */
-extern Long numCells; /* number of cells allocated */
-extern Int numGcs; /* number of garbage collections */
-extern int numEnters; /* number of enters */
-extern Bool preludeLoaded; /* TRUE => prelude has been loaded */
-extern Bool flagAssert; /* TRUE => assert False <e> causes
- an assertion failure */
-
-extern Bool gcMessages; /* TRUE => print GC messages */
-extern Bool literateScripts; /* TRUE => default lit scripts */
-extern Bool literateErrors; /* TRUE => report errs in lit scrs */
-extern Bool showInstRes; /*TRUE => show instance resolution */
-
-extern Int cutoff; /* Constraint Cutoff depth */
-
-extern List diVars; /* deriving: cache of names */
-extern Int diNum; /* also for deriving */
-extern List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
-
-extern Module moduleBeingParsed; /* so the parser (topModule) knows */
-
-
-#if USE_PREPROCESSOR
-extern String preprocessor; /* preprocessor command */
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Function prototypes etc...
- * ------------------------------------------------------------------------*/
-
-
-
-#define RESET 1 /* reset subsystem */
-#define MARK 2 /* mark parts of graph in use by subsystem */
-#define PREPREL 3 /* do startup actions before Prelude loading */
-#define POSTPREL 4 /* do startup actions after Prelude loading */
-#define EXIT 5 /* Take action immediately before exit() */
-#define BREAK 6 /* Take action after program break */
-#define GCDONE 7 /* Restore subsystem invariants after GC */
-
-/* PREPREL was formerly called INSTALL. POSTPREL doesn't have an analogy
- in the old Hugs.
-*/
-extern Void everybody ( Int );
-extern Void linkControl ( Int );
-extern Void deriveControl ( Int );
-extern Void translateControl ( Int );
-extern Void codegen ( Int );
-extern Void machdep ( Int );
-extern Void liftControl ( Int );
-extern Void substitution ( Int );
-extern Void typeChecker ( Int );
-extern Void interfayce ( Int );
-extern Void storage ( Int );
-
-
-
-typedef long Target;
-extern Void setGoal ( String, Target );
-extern Void soFar ( Target );
-extern Void done ( Void );
-extern String fromEnv ( String,String );
-extern Bool chase ( List );
-
-extern Void input ( Int );
-extern Void consoleInput ( String );
-extern Void projInput ( String );
-extern Void stringInput ( String );
-extern Cell parseModule ( String,Long );
-extern Void parseExp ( Void );
-#if EXPLAIN_INSTANCE_RESOLUTION
-extern Void parseContext ( Void );
-#endif
-extern String readFilename ( Void );
-extern String readLine ( Void );
-extern Syntax defaultSyntax ( Text );
-extern Syntax syntaxOf ( Name );
-extern String unlexChar ( Char,Char );
-extern Void printString ( String );
-
-
-extern Void staticAnalysis ( Int );
-extern Void startModule ( Module );
-extern Void setExportList ( List );
-extern Void setExports ( List );
-extern Void addQualImport ( Text,Text );
-extern Void addUnqualImport ( Text,List );
-
-extern Void tyconDefn ( Int,Cell,Cell,Cell );
-extern Void setTypeIns ( List );
-extern Void clearTypeIns ( Void );
-extern Type fullExpand ( Type );
-extern Bool isAmbiguous ( Type );
-extern Void ambigError ( Int,String,Cell,Type );
-extern Void classDefn ( Int,Cell,List,List );
-extern Void instDefn ( Int,Cell,Cell );
-extern Void addTupInst ( Class,Int );
-extern Name newDSel ( Class,Int );
-#if TREX
-extern Inst addRecShowInst ( Class,Ext );
-extern Inst addRecEqInst ( Class,Ext );
-#endif
-extern List offsetTyvarsIn ( Type,List );
-
-
-extern List typeVarsIn ( Cell,List,List,List );
-extern List oclose ( List,List );
-extern List zonkTyvarsIn ( Type,List );
-extern Type zonkTyvar ( Int );
-extern Type zonkType ( Type,Int );
-extern Void primDefn ( Cell,List,Cell );
-extern Void defaultDefn ( Int,List );
-extern Void checkExp ( Void );
-extern Type conToTagType ( Tycon );
-extern Type tagToConType ( Tycon );
-extern Int visitClass ( Class );
-
-#if EXPLAIN_INSTANCE_RESOLUTION
-extern Void checkContext ( Void );
-#endif
-extern Void checkDefns ( Module );
-extern Bool h98Pred ( Bool,Cell );
-extern Cell h98Context ( Bool,List );
-extern Void h98CheckCtxt ( Int,String,Bool,List,Inst );
-extern Void h98CheckType ( Int,String,Cell,Type );
-extern Void h98DoesntSupport ( Int,String );
-
-extern Int userArity ( Name );
-extern List deriveEq ( Tycon );
-extern List deriveOrd ( Tycon );
-extern List deriveEnum ( Tycon );
-extern List deriveIx ( Tycon );
-extern List deriveShow ( Tycon );
-extern List deriveRead ( Cell );
-extern List deriveBounded ( Tycon );
-extern List checkPrimDefn ( Triple );
-
-extern Void foreignImport ( Cell,Text,Pair,Cell,Cell );
-extern Void foreignExport ( Cell,Text,Cell,Cell,Cell );
-
-extern Void implementForeignImport ( Name );
-extern Text makeTypeDescrText ( Type );
-extern Void implementForeignExport ( Name );
-
-extern List foreignExports; /* foreign export declarations */
-extern List foreignImports; /* foreign import declarations */
-
-extern Type primType ( Int /*AsmMonad*/ monad,
- String a_kinds, String r_kinds );
-
-extern Type typeCheckExp ( Bool );
-extern Void typeCheckDefns ( Void );
-extern Cell provePred ( Kinds,List,Cell );
-extern List simpleContext ( List,Int );
-extern Cell rhsExpr ( Cell );
-extern Int rhsLine ( Cell );
-extern Bool isProgType ( List,Type );
-extern Cell superEvid ( Cell,Class,Class );
-extern Void linkPreludeTC ( Void );
-extern Void linkPreludeCM ( Void );
-extern Void linkPrimNames ( Void );
-
-extern Void compiler ( Int );
-extern Void compileDefns ( Void );
-extern Void compileExp ( Void );
-extern Bool failFree ( Cell );
-extern Int discrArity ( Cell );
-
-extern Addr codeGen ( Name,Int,Cell );
-extern Void evalExp ( Void );
-extern Int shellEsc ( String );
-extern Int getTerminalWidth ( Void );
-extern Void normalTerminal ( Void );
-extern Void noechoTerminal ( Void );
-extern Int readTerminalChar ( Void );
-extern Void gcStarted ( Void );
-extern Void gcScanning ( Void );
-extern Void gcRecovered ( Int );
-extern Void gcCStack ( Void );
-extern Void needPrims ( Int );
-extern List calcFunDepsPreds ( List );
-extern Inst findInstFor ( Cell,Int );
-#if MULTI_INST
-extern List findInstsFor ( Cell,Int );
-#endif
-
-
-/*---------------------------------------------------------------------------
- * Debugging printers, and output-ery
- *-------------------------------------------------------------------------*/
-
-extern Void ppScripts ( Void );
-extern Void ppModules ( Void );
-
-extern Void printStg ( FILE *fp, Cell /*StgVar*/ b);
-
-extern Void ppStg ( Cell /*StgVar*/ v );
-extern Void ppStgExpr ( Cell /*StgExpr*/ e );
-extern Void ppStgRhs ( Cell /*StgRhs*/ rhs );
-extern Void ppStgAlts ( List alts );
-extern Void ppStgPrimAlts ( List alts );
-extern Void ppStgVars ( List vs );
-
-extern Void putChr ( Int );
-extern Void putStr ( String );
-extern Void putInt ( Int );
-extern Void putPtr ( Ptr );
-
-extern Void unlexCharConst ( Cell );
-extern Void unlexStrConst ( Text );
-extern Void unlexVar ( Text );
-extern Void unlexVarStr ( String );
-
-extern FILE *outputStream; /* current output stream */
-extern Int outColumn; /* current output column number */
-
-
-/*---------------------------------------------------------------------------
- * For dynamic.c and general object-related stuff
- *-------------------------------------------------------------------------*/
-
-extern void* getDLLSymbol ( Int,String,String );
-extern Bool stdcallAllowed ( void );
-
-#if LEADING_UNDERSCORE
-#define MAYBE_LEADING_UNDERSCORE(sss) _##sss
-#define MAYBE_LEADING_UNDERSCORE_STR(sss) "_" sss
-#else
-#define MAYBE_LEADING_UNDERSCORE(sss) sss
-#define MAYBE_LEADING_UNDERSCORE_STR(sss) sss
-#endif
-
-
-/*---------------------------------------------------------------------------
- * Interrupting execution (signals, allowBreak):
- *-------------------------------------------------------------------------*/
-
-typedef
- enum { HugsIgnoreBreak, HugsLongjmpOnBreak, HugsRtsInterrupt }
- HugsBreakAction;
-
-extern HugsBreakAction currentBreakAction;
-extern HugsBreakAction setBreakAction ( HugsBreakAction );
-
-
-#ifndef SIGBREAK /* Sigh, not defined in cygwin32 beta release 16 */
-# define SIGBREAK 21
-#endif
-
-/* ctrlbrk: set the interrupt handler.
- Hugs relies on being able to do sigprocmask, since some of
- the signal handlers do longjmps, and this zaps the previous
- signal mask. So setHandler needs to do sigprocmask in order
- to get the signal mask to a sane state each time.
-*/
-#include <signal.h>
-
-#if !defined(mingw32_TARGET_OS)
-
-#define setHandler(bh) { sigset_t mask; \
- signal(SIGINT,bh); \
- sigemptyset(&mask); \
- sigaddset(&mask, SIGINT); \
- sigprocmask(SIG_UNBLOCK, &mask, NULL); \
- }
-
-#else
-
-#define setHandler(bh) { void* old_hdlr = signal(SIGINT,bh);\
- if (old_hdlr == SIG_ERR) internal("setHandler"); \
- }
-
-#endif /* !defined(mingw32_TARGET_OS) */
-
-/*---------------------------------------------------------------------------
- * Environment variables and the registry
- *-------------------------------------------------------------------------*/
-
-#define N_INSTALLDIR 200
-extern char installDir[N_INSTALLDIR];
-
-
-/*---------------------------------------------------------------------------
- * File operations:
- *-------------------------------------------------------------------------*/
-
-#if HAVE_UNISTD_H
-# include <sys/types.h>
-# include <unistd.h>
-#endif
-
-extern int chdir ( const char* );
-
-#if HAVE_STDLIB_H
-# include <stdlib.h>
-#else
-extern int system ( const char * );
-extern double atof ( const char * );
-extern void exit ( int );
-#endif
-
-#ifndef FILENAME_MAX /* should already be defined in an ANSI compiler*/
-#define FILENAME_MAX 256
-#else
-#if FILENAME_MAX < 256
-#undef FILENAME_MAX
-#define FILENAME_MAX 256
-#endif
-#endif
-
-/* Hack, hack: if you have dos.h, you probably have a DOS filesystem */
-#define DOS_FILENAMES HAVE_DOS_H
-/* ToDo: can we replace this with a feature test? */
-#define MAC_FILENAMES SYMANTEC_C
-
-#define CASE_INSENSITIVE_FILENAMES (DOS_FILENAMES | RISCOS)
-
-#if CASE_INSENSITIVE_FILENAMES
-# if HAVE_STRCASECMP
-# define filenamecmp(s1,s2) strcasecmp(s1,s2)
-# elif HAVE__STRICMP
-# define filenamecmp(s1,s2) _stricmp(s1,s2)
-# elif HAVE_STRICMP
-# define filenamecmp(s1,s2) stricmp(s1,s2)
-# elif HAVE_STRCMPI
-# define filenamecmp(s1,s2) strcmpi(s1,s2)
-# endif
-#else
-# define filenamecmp(s1,s2) strcmp(s1,s2)
-#endif
-
-#define HI_ENDING ".u_hi"
-
-
-/*---------------------------------------------------------------------------
- * Pipe-related operations:
- *
- * On Windows, many standard Unix names acquire a leading underscore.
- * Irritating, but easy to work around.
- *-------------------------------------------------------------------------*/
-
-#if !defined(HAVE_POPEN) && defined(HAVE__POPEN)
-#define popen(x,y) _popen(x,y)
-#endif
-#if !defined(HAVE_PCLOSE) && defined(HAVE__PCLOSE)
-#define pclose(x) _pclose(x)
-#endif
-
-
-/*---------------------------------------------------------------------------
- * Bit manipulation:
- *-------------------------------------------------------------------------*/
-
-#define bitArraySize(n) ((n)/bitsPerWord + 1)
-#define placeInSet(n) ((-(n)-1)>>wordShift)
-#define maskInSet(n) (1<<((-(n)-1)&wordMask))
-
-
-/*---------------------------------------------------------------------------
- * Function prototypes for code in machdep.c
- *-------------------------------------------------------------------------*/
-
-extern String findMPathname ( String,String,String );
-extern String findPathname ( String,String );
-extern Int shellEsc ( String );
-extern Int getTerminalWidth ( Void );
-extern Void normalTerminal ( Void );
-extern Void noechoTerminal ( Void );
-extern Int readTerminalChar ( Void );
-extern Void gcStarted ( Void );
-extern Void gcScanning ( Void );
-extern Void gcRecovered ( Int );
-extern Void gcCStack ( Void );
-
-
-/*---------------------------------------------------------------------------
- * To do with reading interface and object files
- *-------------------------------------------------------------------------*/
-
-extern Cell parseInterface ( String,Long );
-extern List getInterfaceImports ( Cell );
-extern void processInterfaces ( List );
-extern Void getFileSize ( String, Long * );
-extern Void ifLinkConstrItbl ( Name n );
-extern Void hi_o_namesFromSrcName ( String,String*,String* oName );
-extern void* lookupObjName ( char* );
-
-extern String getExtraObjectInfo ( String primaryObjectName,
- String extraFileName,
- Int* extraFileSize );
-
-extern List /* of ZTriple(I_INTERFACE,
- Text--name of obj file,
- Int--size of obj file) */
- ifaces_outstanding;
-
-
-/* --------------------------------------------------------------------------
- * Interpreter command structure
- * ------------------------------------------------------------------------*/
-
-typedef Int Command;
-
-struct cmd {
- String cmdString;
- Command cmdCode;
-};
-
-extern Command readCommand ( struct cmd *, Char, Char );
-
-#define EDIT 0
-#define FIND 1
-#define LOAD 2
-#define ALSO 3
-#define PROJECT 4
-#define RELOAD 5
-#define EVAL 6
-#define TYPEOF 7
-#define HELP 8
-#define NAMES 9
-#define BADCMD 10
-#define SET 11
-#define QUIT 12
-#define SYSTEM 13
-#define CHGDIR 14
-#define INFO 15
-#define COLLECT 16
-#define SETMODULE 17
-#define DUMP 18
-#define STATS 19
-#define BROWSE 20
-#define XPLAIN 21
-#define PNTVER 22
-#define NOCMD 23
-
-
-/* --------------------------------------------------------------------------
- * STG Syntax:
- *
- * Rhs -> STGCON (Con, [Atom])
- * | STGAPP (Var, [Atom]) -- delayed application
- * | Expr
- *
- * Expr -> LETREC ([Var],Expr) -- Vars contain their bound value
- * | LAMBDA ([Var],Expr) -- all vars bound to NIL
- * | CASE (Expr,[Alt]) -- algebraic case
- * | PRIMCASE (Expr,[PrimAlt]) -- primitive case
- * | STGPRIM (Prim,[Atom])
- * | STGAPP (Var, [Atom]) -- tail call
- * | Var -- Abbreviation for STGAPP(Var,[])
- *
- * Atom -> Var
- * | CHAR -- unboxed
- * | INT -- unboxed
- * | BIGNUM -- unboxed
- * | FLOAT -- unboxed
- * | ADDR -- unboxed
- * | STRING -- boxed
- *
- * Var -> STGVAR (Rhs,StgRep,info) -- let, case or lambda bound
- * | Name -- let-bound (effectively)
- * -- always unboxed (PTR_REP)
- *
- * Alt -> DEEFALT (Var,Expr) -- var bound to NIL
- * | CASEALT (Con,[Var],Expr) -- vars bound to NIL;
- * -- Con is Name or TUPLE
- * PrimAlt -> PRIMALT ([Var],Expr) -- vars bound to NIL or int
- *
- * We use pointer equality to distinguish variables.
- * The info field of a Var is used as follows in various phases:
- *
- * Translation: unused (set to NIL on output)
- * Freevar analysis: list of free vars after
- * Lambda lifting: freevar list or UNIT on input, discarded after
- * Code generation: unused
- * ------------------------------------------------------------------------*/
-
-typedef Cell StgRhs;
-typedef Cell StgExpr;
-typedef Cell StgAtom;
-typedef Cell StgVar; /* Could be a Name or an STGVAR */
-typedef Cell StgCaseAlt;
-typedef Cell StgPrimAlt;
-typedef Cell StgDiscr;
-typedef Cell StgRep; /* PTR_REP | .. DOUBLE_REP */
-
-#define mkStgLet(binds,body) ap(LETREC,pair(binds,body))
-#define stgLetBinds(e) fst(snd(e))
-#define stgLetBody(e) snd(snd(e))
-
-#define mkStgPrimVar(rhs,rep,info) ap(STGVAR,triple(rhs,rep,info))
-#define stgVarBody(e) fst3(snd(e))
-#define stgVarRep(e) snd3(snd(e))
-#define stgVarInfo(e) thd3(snd(e))
-
-#define mkStgCase(scrut,alts) ap(CASE,pair(scrut,alts))
-#define stgCaseScrut(e) fst(snd(e))
-#define stgCaseAlts(e) snd(snd(e))
-
-#define mkStgCaseAlt(con,vs,e) ap(CASEALT,triple(con,vs,e))
-#define stgCaseAltCon(alt) fst3(snd(alt))
-#define stgCaseAltVars(alt) snd3(snd(alt))
-#define stgCaseAltBody(alt) thd3(snd(alt))
-
-#define mkStgDefault(v,e) ap(DEEFALT,pair(v,e))
-#define stgDefaultVar(alt) fst(snd(alt))
-#define stgDefaultBody(alt) snd(snd(alt))
-#define isDefaultAlt(alt) (fst(alt)==DEEFALT)
-
-#define mkStgPrimCase(scrut,alts) ap(PRIMCASE,pair(scrut,alts))
-#define stgPrimCaseScrut(e) fst(snd(e))
-#define stgPrimCaseAlts(e) snd(snd(e))
-
-#define mkStgPrimAlt(vs,body) ap(PRIMALT,pair(vs,body))
-#define stgPrimAltVars(alt) fst(snd(alt))
-#define stgPrimAltBody(alt) snd(snd(alt))
-
-#define mkStgApp(fun,args) ap(STGAPP,pair(fun,args))
-#define stgAppFun(e) fst(snd(e))
-#define stgAppArgs(e) snd(snd(e))
-
-#define mkStgPrim(op,args) ap(STGPRIM,pair(op,args))
-#define stgPrimOp(e) fst(snd(e))
-#define stgPrimArgs(e) snd(snd(e))
-
-#define mkStgCon(con,args) ap(STGCON,pair(con,args))
-#define stgConCon(e) fst(snd(e))
-#define stgConArgs(e) snd(snd(e))
-
-#define mkStgLambda(args,body) ap(LAMBDA,pair(args,body))
-#define stgLambdaArgs(e) fst(snd(e))
-#define stgLambdaBody(e) snd(snd(e))
-
-
-/* --------------------------------------------------------------------------
- * Utility functions for manipulating STG syntax trees.
- * ------------------------------------------------------------------------*/
-
-extern int stgConTag ( StgDiscr d );
-extern void* stgConInfo ( StgDiscr d );
-extern int stgDiscrTag ( StgDiscr d );
-
-extern List makeArgs ( Int );
-extern StgExpr makeStgLambda ( List args, StgExpr body );
-extern StgExpr makeStgApp ( StgVar fun, List args );
-extern StgExpr makeStgLet ( List binds, StgExpr body );
-extern StgExpr makeStgIf ( StgExpr cond, StgExpr e1, StgExpr e2 );
-extern Bool isStgVar ( StgRhs rhs );
-extern Bool isAtomic ( StgRhs rhs );
-extern StgVar mkStgVar ( StgRhs rhs, Cell info );
-
-#define mkStgRep(c) mkChar(c)
-
-
-/* --------------------------------------------------------------------------
- * STG/backendish functions
- * ------------------------------------------------------------------------*/
-
-extern Void stgDefn ( Name n, Int arity, Cell e );
-
-extern Void implementForeignImport ( Name );
-extern Void implementForeignExport ( Name );
-extern Void implementCfun ( Name, List );
-extern Void implementConToTag ( Tycon );
-extern Void implementTagToCon ( Tycon );
-extern Void implementPrim ( Name );
-extern Void implementTuple ( Int );
-#if TREX
-extern Name implementRecShw ( Text );
-extern Name implementRecEq ( Text );
-#endif
-
-extern void liftModule ( Module );
-extern StgExpr substExpr ( List sub, StgExpr e );
-extern List freeVarsBind ( List, StgVar );
-
-
-extern Void cgModule ( Module );
-extern char* lookupHugsName ( void* );
-
-
-/* --------------------------------------------------------------------------
- * Definitions for substitution data structure and operations.
- * ------------------------------------------------------------------------*/
-
-typedef struct { /* Each type variable contains: */
- Type bound; /* A type skeleton (unbound==NIL) */
- Int offs; /* Offset for skeleton */
- Kind kind; /* kind annotation */
-} Tyvar;
-
-extern Tyvar *tyvars; /* storage for type variables */
-extern Int typeOff; /* offset of result type */
-extern Type typeIs; /* skeleton of result type */
-extern Int typeFree; /* freedom in instantiated type */
-extern List predsAre; /* list of predicates in type */
-extern List genericVars; /* list of generic vars */
-extern List btyvars; /* explicitly scoped type vars */
-
-#define tyvar(n) (tyvars+(n)) /* nth type variable */
-#define tyvNum(t) ((t)-tyvars) /* and the corresp. inverse funct. */
-#define isBound(t) (((t)->bound) && ((t)->bound!=SKOLEM))
-#define aVar mkOffset(0) /* Simple skeletons for type vars */
-#define bVar mkOffset(1)
-#define enterBtyvs() btyvars = cons(NIL,btyvars)
-#define leaveBtyvs() btyvars = tl(btyvars)
-
-#define deRef(tyv,t,o) while ((tyv=getTypeVar(t,o)) && isBound(tyv)) { \
- t = tyv->bound; \
- o = tyv->offs; \
- }
-
- /* offs values when isNull(bound): */
-#define FIXED_TYVAR 0 /* fixed in current assumption */
-#define UNUSED_GENERIC 1 /* not fixed, not yet encountered */
-#define GENERIC 2 /* GENERIC+n==nth generic var found*/
-
-extern char *unifyFails; /* Unification error message */
-
-extern Void emptySubstitution ( Void );
-extern Int newTyvars ( Int );
-#define newKindvars(n) newTyvars(n)
-extern Int newKindedVars ( Kind );
-extern Kind simpleKind ( Int );
-extern Void instantiate ( Type );
-
-extern Pair findBtyvs ( Text );
-extern Void markBtyvs ( Void );
-extern Type localizeBtyvs ( Type );
-
-extern Tyvar *getTypeVar ( Type,Int );
-extern Void tyvarType ( Int );
-extern Void bindTv ( Int,Type,Int );
-extern Cell getDerefHead ( Type,Int );
-extern Void expandSyn ( Tycon, Int, Type *, Int * );
-
-extern Void clearMarks ( Void );
-extern Void markAllVars ( Void );
-extern Void resetGenerics ( Void );
-extern Void markTyvar ( Int );
-extern Void markType ( Type,Int );
-extern Void markPred ( Cell );
-
-extern Type copyTyvar ( Int );
-extern Type copyType ( Type,Int );
-extern Cell copyPred ( Cell,Int );
-extern Type dropRank2 ( Type,Int,Int );
-extern Type dropRank1 ( Type,Int,Int );
-extern Void liftRank2Args ( List,Int,Int );
-extern Type liftRank2 ( Type,Int,Int );
-extern Type liftRank1 ( Type,Int,Int );
-#ifdef DEBUG_TYPES
-extern Type debugTyvar ( Int );
-extern Type debugType ( Type,Int );
-#endif
-extern Kind copyKindvar ( Int );
-extern Kind copyKind ( Kind,Int );
-
-extern Bool eqKind ( Kind,Kind );
-extern Kind getKind ( Cell,Int );
-
-extern List genvarTyvar ( Int,List );
-extern List genvarType ( Type,Int,List );
-
-extern Bool doesntOccurIn ( Tyvar*,Type,Int );
-extern Bool unify ( Type,Int,Type,Int );
-extern Bool kunify ( Kind,Int,Kind,Int );
-
-extern Void typeTuple ( Cell );
-extern Void varKind ( Int );
-
-extern Bool samePred ( Cell,Int,Cell,Int );
-extern Bool matchPred ( Cell,Int,Cell,Int );
-extern Bool unifyPred ( Cell,Int,Cell,Int );
-extern Inst findInstFor ( Cell,Int );
-
-extern Void improve ( Int,List,List );
-extern Void improve1 ( Int,List,Cell,Int );
-
-extern Bool sameSchemes ( Type,Type );
-extern Bool sameType ( Type,Int,Type,Int );
-extern Bool matchType ( Type,Int,Type,Int );
-extern Bool typeMatches ( Type,Type );
-
-#ifdef DEBUG
-extern Void checkBytecodeCount ( Void );
-#endif
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Deriving
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: derive.c,v $
- * $Revision: 1.15 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h"
-
-List cfunSfuns; /* List of (Cfun,[SelectorVar]) */
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static List local getDiVars ( Int );
-static Cell local mkBind ( String,List );
-static Cell local mkVarAlts ( Int,Cell );
-static List local makeDPats2 ( Cell,Int );
-static Bool local isEnumType ( Tycon );
-static Pair local mkAltEq ( Int,List );
-static Pair local mkAltOrd ( Int,List );
-static Cell local prodRange ( Int,List,Cell,Cell,Cell );
-static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
-static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
-static List local mkIxBinds ( Int,Cell,Int );
-static Cell local mkAltShow ( Int,Cell,Int );
-static Cell local showsPrecRhs ( Cell,Cell,Int );
-static Cell local mkReadCon ( Name,Cell,Cell );
-static Cell local mkReadPrefix ( Cell );
-static Cell local mkReadInfix ( Cell );
-static Cell local mkReadTuple ( Cell );
-static Cell local mkReadRecord ( Cell,List );
-static List local mkBndBinds ( Int,Cell,Int );
-
-
-/* --------------------------------------------------------------------------
- * Deriving Utilities
- * ------------------------------------------------------------------------*/
-
-List diVars = NIL; /* Acts as a cache of invented vars*/
-Int diNum = 0;
-
-static List local getDiVars(n) /* get list of at least n vars for */
-Int n; { /* derived instance generation */
- for (; diNum<n; diNum++) {
- diVars = cons(inventVar(),diVars);
- }
- return diVars;
-}
-
-static Cell local mkBind(s,alts) /* make a binding for a variable */
-String s;
-List alts; {
- return pair(mkVar(findText(s)),pair(NIL,alts));
-}
-
-static Cell local mkVarAlts(line,r) /* make alts for binding a var to */
-Int line; /* a simple expression */
-Cell r; {
- return singleton(pair(NIL,pair(mkInt(line),r)));
-}
-
-static List local makeDPats2(h,n) /* generate pattern list */
-Cell h; /* by putting two new patterns with*/
-Int n; { /* head h and new var components */
- List us = getDiVars(2*n);
- List vs = NIL;
- Cell p;
- Int i;
-
- for (i=0, p=h; i<n; ++i) { /* make first version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- vs = cons(p,vs);
-
- for (i=0, p=h; i<n; ++i) { /* make second version of pattern */
- p = ap(p,hd(us));
- us = tl(us);
- }
- return cons(p,vs);
-}
-
-static Bool local isEnumType(t) /* Determine whether t is an enumeration */
-Tycon t; { /* type (i.e. all constructors arity == 0) */
- if (isTycon(t) && (tycon(t).what==DATATYPE || tycon(t).what==NEWTYPE)) {
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- if (name(hd(cs)).arity!=0) {
- return FALSE;
- }
- }
- /* ToDo: correct? addCfunTable(t); */
- return TRUE;
- }
- return FALSE;
-}
-
-
-/* --------------------------------------------------------------------------
- * Given a datatype: data T a b = A a b | B Int | C deriving (Eq, Ord)
- * The derived definitions of equality and ordering are given by:
- *
- * A a b == A x y = a==x && b==y
- * B a == B x = a==x
- * C == C = True
- * _ == _ = False
- *
- * compare (A a b) (A x y) = primCompAux a x (compare b y)
- * compare (B a) (B x) = compare a x
- * compare C C = EQ
- * compare a x = cmpConstr a x
- *
- * In each case, the last line is only needed if there are multiple
- * constructors in the datatype definition.
- * ------------------------------------------------------------------------*/
-
-static Pair local mkAltEq ( Int,List );
-
-List deriveEq(t) /* generate binding for derived == */
-Type t; { /* for some TUPLE or DATATYPE t */
- List alts = NIL;
- if (isTycon(t)) { /* deal with type constrs */
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- alts = cons(mkAltEq(tycon(t).line,
- 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),nameFalse)),alts);
- }
- alts = rev(alts);
- } else { /* special case for tuples */
- alts = singleton(mkAltEq(0,makeDPats2(t,tupleOf(t))));
- }
- return singleton(mkBind("==",alts));
-}
-
-static Pair local mkAltEq(line,pats) /* make alt for an equation for == */
-Int line; /* using patterns in pats for lhs */
-List pats; { /* arguments */
- Cell p = hd(pats);
- Cell q = hd(tl(pats));
- Cell e = nameTrue;
-
- if (isAp(p)) {
- e = ap2(nameEq,arg(p),arg(q));
- for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap2(nameAnd,ap2(nameEq,arg(p),arg(q)),e);
- }
- }
- return pair(pats,pair(mkInt(line),e));
-}
-
-
-static Pair local mkAltOrd ( Int,List );
-
-List deriveOrd(t) /* make binding for derived compare*/
-Type t; { /* for some TUPLE or DATATYPE t */
- List alts = NIL;
- if (isEnumType(t)) { /* special case for enumerations */
- Cell u = inventVar();
- Cell w = inventVar();
- Cell rhs = NIL;
- if (cfunOf(hd(tycon(t).defn))!=0) {
- implementConToTag(t);
- rhs = ap2(nameCompare,
- ap(tycon(t).conToTag,u),
- ap(tycon(t).conToTag,w));
- } else {
- 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),userArity(hd(cs)))),
- alts);
- }
- if (cfunOf(hd(tycon(t).defn))!=0) {
- Cell u = inventVar();
- Cell w = inventVar();
- implementConToTag(t);
- alts = cons(pair(doubleton(u,w),
- pair(mkInt(tycon(t).line),
- ap2(nameCompare,
- ap(tycon(t).conToTag,u),
- ap(tycon(t).conToTag,w)))),
- alts);
- }
- alts = rev(alts);
- } else { /* special case for tuples */
- alts = singleton(mkAltOrd(0,makeDPats2(t,tupleOf(t))));
- }
- return singleton(mkBind("compare",alts));
-}
-
-static Pair local mkAltOrd(line,pats) /* make alt for eqn for compare */
-Int line; /* using patterns in pats for lhs */
-List pats; { /* arguments */
- Cell p = hd(pats);
- Cell q = hd(tl(pats));
- Cell e = nameEQ;
-
- if (isAp(p)) {
- e = ap2(nameCompare,arg(p),arg(q));
- for (p=fun(p), q=fun(q); isAp(p); p=fun(p), q=fun(q)) {
- e = ap3(nameCompAux,arg(p),arg(q),e);
- }
- }
-
- return pair(pats,pair(mkInt(line),e));
-}
-
-
-/* --------------------------------------------------------------------------
- * Deriving Ix and Enum:
- * ------------------------------------------------------------------------*/
-
-List deriveEnum(t) /* Construct definition of enumeration */
-Tycon t; {
- Int l = tycon(t).line;
- Cell x = inventVar();
- Cell y = inventVar();
- Cell first = hd(tycon(t).defn);
- Cell last = tycon(t).defn;
-
- if (!isEnumType(t)) {
- ERRMSG(l) "Can only derive instances of Enum for enumeration types"
- EEND;
- }
- while (hasCfun(tl(last))) {
- last = tl(last);
- }
- last = hd(last);
- implementConToTag(t);
- implementTagToCon(t);
- return cons(mkBind("toEnum", mkVarAlts(l,tycon(t).tagToCon)),
- cons(mkBind("fromEnum", mkVarAlts(l,tycon(t).conToTag)),
- NIL));
-}
-
-
-static List local mkIxBindsEnum ( Tycon );
-static List local mkIxBinds ( Int,Cell,Int );
-static Cell local prodRange ( Int,List,Cell,Cell,Cell );
-static Cell local prodIndex ( Int,List,Cell,Cell,Cell );
-static Cell local prodInRange ( Int,List,Cell,Cell,Cell );
-
-List deriveIx(t) /* Construct definition of indexing */
-Tycon t; {
- if (isEnumType(t)) { /* Definitions for enumerations */
- implementConToTag(t);
- implementTagToCon(t);
- return mkIxBindsEnum(t);
- } else if (isTuple(t)) { /* Definitions for product types */
- return mkIxBinds(0,t,tupleOf(t));
- } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
- return mkIxBinds(tycon(t).line,
- hd(tycon(t).defn),
- userArity(hd(tycon(t).defn)));
- }
- ERRMSG(tycon(t).line)
- "Can only derive instances of Ix for enumeration or product types"
- EEND;
- return NIL;/* NOTREACHED*/
-}
-
-/* instance Ix T where
- * range (c1,c2) = map tagToCon [conToTag c1 .. conToTag c2]
- * index b@(c1,c2) ci
- * | inRange b ci = conToTag ci - conToTag c1
- * | otherwise = error "Ix.index.T: Index out of range."
- * inRange (c1,c2) ci = conToTag c1 <= i && i <= conToTag c2
- * where i = conToTag ci
- */
-static List local mkIxBindsEnum(t)
-Tycon t; {
- Int l = tycon(t).line;
- Name tagToCon = tycon(t).tagToCon;
- Name conToTag = tycon(t).conToTag;
- Cell b = inventVar();
- Cell c1 = inventVar();
- Cell c2 = inventVar();
- Cell ci = inventVar();
- return cons(mkBind("range", singleton(pair(singleton(ap2(mkTuple(2),
- 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(nameInRange,b,ci),
- ap2(nameMinus,ap(conToTag,ci),
- ap(conToTag,c1)),
- 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(nameAnd,
- ap2(nameLe,ap(conToTag,c1),ap(conToTag,ci)),
- ap2(nameLe,ap(conToTag,ci),
- ap(conToTag,c2))))))),
- /* ToDo: share conToTag ci */
- NIL)));
-}
-
-static List local mkIxBinds(line,h,n) /* build bindings for derived Ix on*/
-Int line; /* a product type */
-Cell h;
-Int n; {
- List vs = getDiVars(3*n);
- Cell ls = h;
- Cell us = h;
- Cell is = h;
- Cell js = h;
- Cell pr = NIL;
- Cell pats = NIL;
-
- Int i;
-
- for (i=0; i<n; ++i, vs=tl(vs)) { /* build three patterns for values */
- ls = ap(ls,hd(vs)); /* of the datatype concerned */
- us = ap(us,hd(vs=tl(vs)));
- is = ap(is,hd(vs=tl(vs)));
- js = ap(js,hd(vs)); /* ... and one expression */
- }
- pr = ap2(mkTuple(2),ls,us); /* Build (ls,us) */
- pats = cons(pr,cons(is,NIL)); /* Build [(ls,us),is] */
-
- return cons(prodRange(line,singleton(pr),ls,us,js),
- cons(prodIndex(line,pats,ls,us,is),
- cons(prodInRange(line,pats,ls,us,is),
- NIL)));
-}
-
-static Cell local prodRange(line,pats,ls,us,is)
-Int line; /* Make definition of range for a */
-List pats; /* product type */
-Cell ls, us, is; {
- /* range :: (a,a) -> [a]
- * range (X a b c, X p q r)
- * = [ X x y z | x <- range (a,p), y <- range (b,q), z <- range (c,r) ]
- */
- Cell is1 = is;
- List e = NIL;
- for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
- e = cons(ap(FROMQUAL,pair(arg(is),
- ap(nameRange,ap2(mkTuple(2),
- arg(ls),
- arg(us))))),e);
- }
- e = ap(COMP,pair(is1,e));
- e = singleton(pair(pats,pair(mkInt(line),e)));
- return mkBind("range",e);
-}
-
-static Cell local prodIndex(line,pats,ls,us,is)
-Int line; /* Make definition of index for a */
-List pats; /* product type */
-Cell ls, us, is; {
- /* index :: (a,a) -> a -> Bool
- * index (X a b c, X p q r) (X x y z)
- * = index (c,r) z + rangeSize (c,r) * (
- * index (b,q) y + rangeSize (b,q) * (
- * index (a,x) x))
- */
- List xs = NIL;
- Cell e = NIL;
- for (; isAp(ls); ls=fun(ls), us=fun(us), is=fun(is)) {
- 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(namePlus,x,ap2(nameMult,ap(nameRangeSize,arg(fun(x))),e));
- }
- e = singleton(pair(pats,pair(mkInt(line),e)));
- return mkBind("index",e);
-}
-
-static Cell local prodInRange(line,pats,ls,us,is)
-Int line; /* Make definition of inRange for a*/
-List pats; /* product type */
-Cell ls, us, is; {
- /* inRange :: (a,a) -> a -> Bool
- * 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(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is));
- while (ls=fun(ls), us=fun(us), is=fun(is), isAp(ls)) {
- e = ap2(nameAnd,
- ap2(nameInRange,ap2(mkTuple(2),arg(ls),arg(us)),arg(is)),
- e);
- }
- e = singleton(pair(pats,pair(mkInt(line),e)));
- return mkBind("inRange",e);
-}
-
-
-/* --------------------------------------------------------------------------
- * Deriving Show:
- * ------------------------------------------------------------------------*/
-
-List deriveShow(t) /* Construct definition of text conversion */
-Tycon t; {
- List alts = NIL;
- if (isTycon(t)) { /* deal with type constrs */
- List cs = tycon(t).defn;
- for (; hasCfun(cs); cs=tl(cs)) {
- alts = cons(mkAltShow(tycon(t).line,hd(cs),userArity(hd(cs))),
- alts);
- }
- alts = rev(alts);
- } else { /* special case for tuples */
- alts = singleton(mkAltShow(0,t,tupleOf(t)));
- }
- return singleton(mkBind("showsPrec",alts));
-}
-
-static Cell local mkAltShow(line,h,a) /* make alt for showsPrec eqn */
-Int line;
-Cell h;
-Int a; {
- List vs = getDiVars(a+1);
- Cell d = hd(vs);
- Cell pat = h;
- List pats = NIL;
- Int i = 0;
- for (vs=tl(vs); i<a; i++) {
- pat = ap(pat,hd(vs));
- vs = tl(vs);
- }
- pats = cons(d,cons(pat,NIL));
- return pair(pats,pair(mkInt(line),showsPrecRhs(d,pat,a)));
-}
-
-#define shows0 ap(nameShowsPrec,mkInt(0))
-#define shows10 ap(nameShowsPrec,mkInt(10))
-#define showsOP ap(nameComp,consChar('('))
-#define showsOB ap(nameComp,consChar('{'))
-#define showsCM ap(nameComp,consChar(','))
-#define showsSP ap(nameComp,consChar(' '))
-#define showsBQ ap(nameComp,consChar('`'))
-#define showsCP consChar(')')
-#define showsCB consChar('}')
-
-static Cell local showsPrecRhs(d,pat,a) /* build a rhs for showsPrec for a */
-Cell d, pat; /* given pattern, pat */
-Int a; {
- Cell h = getHead(pat);
- List cfs = cfunSfuns;
-
- if (isTuple(h)) {
- /* To display a tuple:
- * showsPrec d (a,b,c,d) = showChar '(' . showsPrec 0 a .
- * showChar ',' . showsPrec 0 b .
- * showChar ',' . showsPrec 0 c .
- * showChar ',' . showsPrec 0 d .
- * showChar ')'
- */
- Int i = tupleOf(h);
- Cell rhs = showsCP;
- for (; i>1; --i) {
- rhs = ap(showsCM,ap2(nameComp,ap(shows0,arg(pat)),rhs));
- pat = fun(pat);
- }
- return ap(showsOP,ap2(nameComp,ap(shows0,arg(pat)),rhs));
- }
-
- for (; nonNull(cfs) && h!=fst(hd(cfs)); cfs=tl(cfs)) {
- }
- if (nonNull(cfs)) {
- /* To display a value using record syntax:
- * showsPrec d C{x=e, y=f, z=g} = showString "C" . showChar '{' .
- * showField "x" e . showChar ',' .
- * showField "y" f . showChar ',' .
- * showField "z" g . showChar '}'
- * showField lab val
- * = showString lab . showChar '=' . shows val
- */
- Cell rhs = showsCB;
- List vs = dupOnto(snd(hd(cfs)),NIL);
- if (isAp(pat)) {
- for (;;) {
- rhs = ap2(nameComp,
- ap2(nameShowField,
- mkStr(textOf(hd(vs))),
- arg(pat)),
- rhs);
- pat = fun(pat);
- vs = tl(vs);
- if (isAp(pat)) {
- rhs = ap(showsCM,rhs);
- } else {
- break;
- }
- }
- }
- rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),ap(showsOB,rhs));
- return rhs;
- }
- else if (a==0) {
- /* To display a nullary constructor:
- * showsPrec d Foo = showString "Foo"
- */
- return ap(nameApp,mkStr(name(h).text));
- } else {
- Syntax s = syntaxOf(h);
- if (a==2 && assocOf(s)!=APPLIC) {
- /* For a binary constructor with prec p:
- * showsPrec d (a :* b) = showParen (d > p)
- * (showsPrec lp a . showChar ' ' .
- * showsString s . showChar ' ' .
- * showsPrec rp b)
- */
- Int p = precOf(s);
- Int lp = (assocOf(s)==LEFT_ASS) ? p : (p+1);
- Int rp = (assocOf(s)==RIGHT_ASS) ? p : (p+1);
- Cell rhs = ap(showsSP,ap2(nameShowsPrec,mkInt(rp),arg(pat)));
- if (defaultSyntax(name(h).text)==APPLIC) {
- rhs = ap(showsBQ,
- ap2(nameComp,
- ap(nameApp,mkStr(fixLitText(name(h).text))),
- ap(showsBQ,rhs)));
- } else {
- rhs = ap2(nameComp,
- ap(nameApp,mkStr(fixLitText(name(h).text))),rhs);
- }
-
- rhs = ap2(nameComp,
- ap2(nameShowsPrec,mkInt(lp),arg(fun(pat))),
- ap(showsSP,rhs));
- rhs = ap2(nameShowParen,ap2(nameLe,mkInt(p+1),d),rhs);
- return rhs;
- }
- else {
- /* To display a non-nullary constructor with applicative syntax:
- * showsPrec d (Foo x y) = showParen (d>=10)
- * (showString "Foo" .
- * showChar ' ' . showsPrec 10 x .
- * showChar ' ' . showsPrec 10 y)
- */
- Cell rhs = ap(showsSP,ap(shows10,arg(pat)));
- for (pat=fun(pat); isAp(pat); pat=fun(pat)) {
- rhs = ap(showsSP,ap2(nameComp,ap(shows10,arg(pat)),rhs));
- }
- rhs = ap2(nameComp,ap(nameApp,mkStr(name(h).text)),rhs);
- rhs = ap2(nameShowParen,ap2(nameLe,mkInt(10),d),rhs);
- return rhs;
- }
- }
-}
-#undef shows10
-#undef shows0
-#undef showsOP
-#undef showsOB
-#undef showsCM
-#undef showsSP
-#undef showsBQ
-#undef showsCP
-#undef showsCB
-
-/* --------------------------------------------------------------------------
- * Deriving Read:
- * ------------------------------------------------------------------------*/
-
-#define Tuple2(f,s) ap2(mkTuple(2),f,s)
-#define Lex(r) ap(nameLex,r)
-#define ZFexp(h,q) ap(FROMQUAL, pair(h,q))
-#define ReadsPrec(n,e) ap2(nameReadsPrec,n,e)
-#define Lambda(v,e) ap(LAMBDA,pair(v, pair(mkInt(0),e)))
-#define ReadParen(a,b,c) ap(ap2(nameReadParen,a,b),c)
-#define ReadField(f,s) ap2(nameReadField,f,s)
-#define GT(l,r) ap2(nameGt,l,r)
-#define Append(a,b) ap2(nameApp,a,b)
-
-/* Construct the readsPrec function of the form:
- *
- * readsPrec d r = (readParen (d>p1) (\r -> [ (C1 ...,s) | ... ]) r ++
- * (readParen (d>p2) (\r -> [ (C2 ...,s) | ... ]) r ++
- * ...
- * (readParen (d>pn) (\r -> [ (Cn ...,s) | ... ]) r) ... ))
- */
-List deriveRead(t) /* construct definition of text reader */
-Cell t; {
- Cell alt = NIL;
- Cell exp = NIL;
- Cell d = inventVar();
- Cell r = inventVar();
- List pat = cons(d,cons(r,NIL));
- Int line = 0;
-
- if (isTycon(t)) {
- List cs = tycon(t).defn;
- List exps = NIL;
- for (; hasCfun(cs); cs=tl(cs)) {
- exps = cons(mkReadCon(hd(cs),d,r),exps);
- }
- /* reverse concatenate list of subexpressions */
- exp = hd(exps);
- for (exps=tl(exps); nonNull(exps); exps=tl(exps)) {
- exp = ap2(nameApp,hd(exps),exp);
- }
- line = tycon(t).line;
- }
- else { /* Tuples */
- exp = ap(mkReadTuple(t),r);
- }
- /* printExp(stdout,exp); putc('\n',stdout); */
- alt = pair(pat,pair(mkInt(line),exp));
- return singleton(mkBind("readsPrec",singleton(alt)));
-}
-
-/* Generate an expression of the form:
- *
- * readParen (d > p) <derived expression> r
- *
- * for a (non-tuple) constructor "con" of precedence "p".
- */
-
-static Cell local mkReadCon(con, d, r) /* generate reader for a constructor */
-Name con;
-Cell d;
-Cell r; {
- Cell exp = NIL;
- Int p = 0;
- Syntax s = syntaxOf(con);
- List cfs = cfunSfuns;
- for (; nonNull(cfs) && con!=fst(hd(cfs)); cfs=tl(cfs)) {
- }
- if (nonNull(cfs)) {
- exp = mkReadRecord(con,snd(hd(cfs)));
- return ReadParen(nameFalse, exp, r);
- }
-
- if (userArity(con)==2 && assocOf(s)!=APPLIC) {
- exp = mkReadInfix(con);
- p = precOf(s);
- } else {
- exp = mkReadPrefix(con);
- p = 9;
- }
- return ReadParen(userArity(con)==0 ? nameFalse : GT(d,mkInt(p)), exp, r);
-}
-
-/* Given an n-ary prefix constructor, generate a single lambda
- * expression, such that
- *
- * data T ... = Constr a1 a2 .. an | ....
- *
- * derives
- *
- * \ r -> [ (Constr t1 t2 ... tn, sn) | ("Constr",s0) <- lex r,
- * (t1,s1) <- readsPrec 10 s0,
- * (t2,s2) <- readsPrec 10 s1,
- * ...,
- * (tn,sn) <- readsPrec 10 sn-1 ]
- *
- */
-static Cell local mkReadPrefix(con) /* readsPrec for prefix constructor */
-Cell con; {
- Int arity = userArity(con);
- Cell cn = mkStr(name(con).text);
- Cell r = inventVar();
- Cell prev_s = inventVar();
- Cell exp = con;
- List quals = NIL;
- Int i;
-
- /* build (reversed) list of qualifiers and constructor */
- quals = cons(ZFexp(Tuple2(cn,prev_s),Lex(r)),quals);
- for(i=0; i<arity; i++) {
- Cell t = inventVar();
- Cell s = inventVar();
- quals = cons(ZFexp(Tuple2(t,s),ReadsPrec(mkInt(10),prev_s)), quals);
- exp = ap(exp,t);
- prev_s = s;
- }
-
- /* \r -> [ (exp, prev_s) | quals ] */
- return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp, prev_s), rev(quals))));
-}
-
-/* Given a binary infix constructor of precedence p
- *
- * ... | T1 `con` T2 | ...
- *
- * generate the lambda expression
- *
- * \ r -> [ (u `con` v, s2) | (u,s0) <- readsPrec lp r,
- * ("con",s1) <- lex s0,
- * (v,s2) <- readsPrec rp s1 ]
- *
- * where lp and rp are either p or p+1 depending on associativity
- */
-static Cell local mkReadInfix( con )
-Cell con;
-{
- Syntax s = syntaxOf(con);
- Int p = precOf(s);
- Int lp = assocOf(s)==LEFT_ASS ? p : (p+1);
- Int rp = assocOf(s)==RIGHT_ASS ? p : (p+1);
- Cell cn = mkStr(name(con).text);
- Cell r = inventVar();
- Cell s0 = inventVar();
- Cell s1 = inventVar();
- Cell s2 = inventVar();
- Cell u = inventVar();
- Cell v = inventVar();
- List quals = NIL;
-
- quals = cons(ZFexp(Tuple2(u, s0), ReadsPrec(mkInt(lp),r)), quals);
- quals = cons(ZFexp(Tuple2(cn,s1), Lex(s0)), quals);
- quals = cons(ZFexp(Tuple2(v, s2), ReadsPrec(mkInt(rp),s1)), quals);
-
- return Lambda(singleton(r),
- ap(COMP,pair(Tuple2(ap2(con,u,v),s2),rev(quals))));
-}
-
-/* Given the n-ary tuple constructor return a lambda expression:
- *
- * \ r -> [ ((t1,t2,...tn),s(2n+1)) | ("(",s0) <- lex r,
- * (t1, s1) <- readsPrec 0 s0,
- * ...
- * (",",s(2n-1)) <- lex s(2n-2),
- * (tn, s(2n)) <- readsPrec 0 s(2n-1),
- * (")",s(2n+1)) <- lex s(2n) ]
- */
-static Cell local mkReadTuple( tup ) /* readsPrec for n-tuple */
-Cell tup; {
- Int arity = tupleOf(tup);
- Cell lp = mkStr(findText("("));
- Cell rp = mkStr(findText(")"));
- Cell co = mkStr(findText(","));
- Cell sep = lp;
- Cell r = inventVar();
- Cell prev_s = r;
- Cell s = inventVar();
- Cell exp = tup;
- List quals = NIL;
- Int i;
-
- /* build (reversed) list of qualifiers and constructor */
- for(i=0; i<arity; i++) {
- Cell t = inventVar();
- Cell si = inventVar();
- Cell sj = inventVar();
- quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)),quals);
- quals = cons(ZFexp(Tuple2(t,sj),ReadsPrec(mkInt(0),si)), quals);
- exp = ap(exp,t);
- prev_s = sj;
- sep = co;
- }
- quals = cons(ZFexp(Tuple2(rp,s),Lex(prev_s)),quals);
-
- /* \ r -> [ (exp,s) | quals ] */
- return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
-}
-
-/* Given a record constructor
- *
- * ... | C { f1 :: T1, ... fn :: Tn } | ...
- *
- * generate the expression:
- *
- * \ r -> [(C t1 t2 ... tn,s(2n+1)) | ("C", s0) <- lex r,
- * ("{", s1) <- lex s0,
- * (t1, s2) <- readField "f1" s1,
- * ...
- * (",", s(2n-1)) <- lex s(2n),
- * (tn, s(2n)) <- readField "fn" s(2n+1),
- * ("}", s(2n+1)) <- lex s(2n+2) ]
- *
- * where
- *
- * readField :: Read a => String -> ReadS a
- * readField m s0 = [ r | (t, s1) <- lex s0, t == m,
- * ("=",s2) <- lex s1,
- * r <- readsPrec 10 s2 ]
- */
-static Cell local mkReadRecord(con, fs) /* readsPrec for record constructor */
-Cell con;
-List fs; {
- Cell cn = mkStr(name(con).text);
- Cell lb = mkStr(findText("{"));
- Cell rb = mkStr(findText("}"));
- Cell co = mkStr(findText(","));
- Cell sep = lb;
- Cell r = inventVar();
- Cell s0 = inventVar();
- Cell prev_s = s0;
- Cell s = inventVar();
- Cell exp = con;
- List quals = NIL;
-
- /* build (reversed) list of qualifiers and constructor */
- quals = cons(ZFexp(Tuple2(cn,s0),Lex(r)), quals);
- for(; nonNull(fs); fs=tl(fs)) {
- Cell f = mkStr(textOf(hd(fs)));
- Cell t = inventVar();
- Cell si = inventVar();
- Cell sj = inventVar();
- quals = cons(ZFexp(Tuple2(sep,si),Lex(prev_s)), quals);
- quals = cons(ZFexp(Tuple2(t, sj),ReadField(f,si)), quals);
- exp = ap(exp,t);
- prev_s = sj;
- sep = co;
- }
- quals = cons(ZFexp(Tuple2(rb,s),Lex(prev_s)),quals);
-
- /* \ r -> [ (exp,s) | quals ] */
- return Lambda(singleton(r),ap(COMP,pair(Tuple2(exp,s),rev(quals))));
-}
-
-#undef Tuple2
-#undef Lex
-#undef ZFexp
-#undef ReadsPrec
-#undef Lambda
-#undef ReadParen
-#undef ReadField
-#undef GT
-#undef Append
-
-/* --------------------------------------------------------------------------
- * Deriving Bounded:
- * ------------------------------------------------------------------------*/
-
-List deriveBounded(t) /* construct definition of bounds */
-Tycon t; {
- if (isEnumType(t)) {
- Cell last = tycon(t).defn;
- Cell first = hd(last);
- while (hasCfun(tl(last))) {
- last = tl(last);
- }
- return cons(mkBind("minBound",mkVarAlts(tycon(t).line,first)),
- cons(mkBind("maxBound",mkVarAlts(tycon(t).line,hd(last))),
- NIL));
- } else if (isTuple(t)) { /* Definitions for product types */
- return mkBndBinds(0,t,tupleOf(t));
- } else if (isTycon(t) && cfunOf(hd(tycon(t).defn))==0) {
- return mkBndBinds(tycon(t).line,
- hd(tycon(t).defn),
- userArity(hd(tycon(t).defn)));
- }
- ERRMSG(tycon(t).line)
- "Can only derive instances of Bounded for enumeration and product types"
- EEND;
- return NIL;
-}
-
-static List local mkBndBinds(line,h,n) /* build bindings for derived */
-Int line; /* Bounded on a product type */
-Cell h;
-Int n; {
- Cell minB = h;
- Cell maxB = h;
- while (n-- > 0) {
- minB = ap(minB,nameMinBnd);
- maxB = ap(maxB,nameMaxBnd);
- }
- return cons(mkBind("minBound",mkVarAlts(line,minB)),
- cons(mkBind("maxBound",mkVarAlts(line,maxB)),
- NIL));
-}
-
-
-/* --------------------------------------------------------------------------
- * Helpers: conToTag and tagToCon
- * ------------------------------------------------------------------------*/
-
-/* \ v -> case v of { ...; Ci _ _ -> i; ... } */
-Void implementConToTag(t)
-Tycon t; {
- if (isNull(tycon(t).conToTag)) {
- List cs = tycon(t).defn;
- Name nm = newName(inventText(),NIL);
- StgVar v = mkStgVar(NIL,NIL);
- List alts = NIL; /* can't fail */
-
- assert(isTycon(t) && (tycon(t).what==DATATYPE
- || tycon(t).what==NEWTYPE));
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar r = mkStgVar(mkStgCon(nameMkI,singleton(mkInt(num))),
- NIL);
- StgExpr tag = mkStgLet(singleton(r),r);
- List vs = NIL;
- Int i;
- for(i=0; i < name(c).arity; ++i) {
- vs = cons(mkStgVar(NIL,NIL),vs);
- }
- alts = cons(mkStgCaseAlt(c,vs,tag),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = conToTagType(t);
- name(nm).arity = 1;
- name(nm).closure = mkStgVar(mkStgLambda(singleton(v),mkStgCase(v,alts)),
- NIL);
- tycon(t).conToTag = nm;
- addToCodeList ( currentModule, nm );
- }
-}
-
-/* \ v -> case v of { ...; i -> Ci; ... } */
-Void implementTagToCon(t)
-Tycon t; {
- if (isNull(tycon(t).tagToCon)) {
- String tyconname;
- List cs;
- Name nm;
- StgVar v1;
- StgVar v2;
- Cell txt0;
- StgVar bind1;
- StgVar bind2;
- StgVar bind3;
- List alts;
- char etxt[200];
-
- assert(nameMkA);
- assert(nameUnpackString);
- assert(nameError);
- assert(isTycon(t) && (tycon(t).what==DATATYPE
- || tycon(t).what==NEWTYPE));
-
- tyconname = textToStr(tycon(t).text);
- if (strlen(tyconname) > 100)
- internal("implementTagToCon: tycon name too long");
-
- sprintf(etxt,
- "out-of-range arg for `toEnum' "
- "in derived `instance Enum %s'",
- tyconname);
-
- cs = tycon(t).defn;
- nm = newName(inventText(),NIL);
- v1 = mkStgVar(NIL,NIL);
- v2 = mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL);
-
- txt0 = mkStr(findText(etxt));
- bind1 = mkStgVar(mkStgCon(nameMkA,singleton(txt0)),NIL);
- bind2 = mkStgVar(mkStgApp(nameUnpackString,singleton(bind1)),NIL);
- bind3 = mkStgVar(mkStgApp(nameError,singleton(bind2)),NIL);
-
- alts = singleton(
- mkStgPrimAlt(
- singleton(
- mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)
- ),
- makeStgLet ( tripleton(bind1,bind2,bind3), bind3 )
- )
- );
-
- for (; hasCfun(cs); cs=tl(cs)) {
- Name c = hd(cs);
- Int num = cfunOf(c) == 0 ? 0 : cfunOf(c)-1;
- StgVar pat = mkStgPrimVar(mkInt(num),mkStgRep(INT_REP),NIL);
- assert(name(c).arity==0);
- alts = cons(mkStgPrimAlt(singleton(pat),c),alts);
- }
-
- name(nm).line = tycon(t).line;
- name(nm).type = tagToConType(t);
- name(nm).arity = 1;
- name(nm).closure = mkStgVar(
- mkStgLambda(
- singleton(v1),
- mkStgCase(
- v1,
- singleton(
- mkStgCaseAlt(
- nameMkI,
- singleton(v2),
- mkStgPrimCase(v2,alts))))),
- NIL
- );
- tycon(t).tagToCon = nm;
- addToCodeList ( currentModule, nm );
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Derivation control:
- * ------------------------------------------------------------------------*/
-
-Void deriveControl(what)
-Int what; {
- switch (what) {
- case PREPREL :
- case RESET :
- diVars = NIL;
- diNum = 0;
- cfunSfuns = NIL;
- break;
-
- case MARK :
- mark(diVars);
- mark(cfunSfuns);
- break;
-
- case POSTPREL: break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-
-#include <stdio.h>
-#include <assert.h>
-#include <windows.h>
-//#include "../includes/DietHEP.h"
-
-
-typedef enum { dh_stdcall, dh_ccall } DH_CALLCONV;
-typedef int DH_MODULE;
-typedef char* DH_LPCSTR;
-
-__declspec(dllimport)
-extern __stdcall
- DH_MODULE DH_LoadLibrary ( DH_LPCSTR modname );
-__declspec(dllimport)
-extern __stdcall
- void* DH_GetProcAddress ( DH_CALLCONV cconv,
- DH_MODULE hModule,
- DH_LPCSTR lpProcName );
-
-
-int main ( int argc, char** argv )
-{
- {
- DH_MODULE hModule;
- void(*proc)(int);
-
- hModule = DH_LoadLibrary("Dh_Demo"); /* note no .hs */
- assert(hModule != 0);
- proc = DH_GetProcAddress ( dh_ccall, hModule, "wurble" );
- assert(proc);
-
- proc(44);
- proc(45);
- proc(46);
- }
- return 0;
-}
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Dynamic loading (of .dll or .so files) for Hugs
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: dynamic.c,v $
- * $Revision: 1.15 $
- * $Date: 2000/03/23 14:54:21 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "errors.h"
-#include "connect.h"
-
-#if HAVE_WINDOWS_H && !defined(__MSDOS__)
-
-#include <windows.h>
-
-void* getDLLSymbol(line,dll0,symbol0) /* load dll and lookup symbol */
-Int line;
-String dll0;
-String symbol0; {
- void* sym;
- char dll[1000];
- char symbol[100];
- ObjectFile instance;
-
- if (strlen(dll0) > 996-strlen(installDir)) {
- ERRMSG(line) "Excessively long library name:\n%s\n",dll0
- EEND;
- }
- dll[0] = 0;
- if (strcmp("nHandle",dll0)==0) strcat(dll,installDir);
- strcat(dll,dll0);
- strcat(dll, ".dll");
-
- if (strlen(symbol0) > 96) {
- ERRMSG(line) "Excessively long symbol name:\n%s\n",symbol0
- EEND;
- }
- strcpy(&(symbol[1]),symbol0);
- symbol[0] = '_';
-
- instance = LoadLibrary(dll);
- if (NULL == instance) {
- /* GetLastError allegedly provides more detail - in practice,
- * it tells you nothing more.
- */
- ERRMSG(line) "Can't open library \"%s\"", dll
- EEND;
- }
- sym = GetProcAddress(instance,symbol0);
- return sym;
-}
-
-Bool stdcallAllowed ( void )
-{
- return TRUE;
-}
-
-
-
-
-
-
-#elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
-
-#include <stdio.h>
-#include <dlfcn.h>
-
-void* getDLLSymbol(line,dll0,symbol) /* load dll and lookup symbol */
-Int line;
-String dll0;
-String symbol; {
- void* sym;
- char dll[1000];
- ObjectFile instance;
- if (strlen(dll0) > 996-strlen(installDir)) {
- ERRMSG(line) "Excessively long library name:\n%s\n",dll0
- EEND;
- }
- dll[0] = 0;
- if (strcmp("nHandle",dll0)==0) strcat(dll,installDir);
- strcat(dll,dll0);
- strcat(dll, ".so");
-#ifdef RTLD_NOW
- instance = dlopen(dll,RTLD_NOW);
-#elif defined RTLD_LAZY /* eg SunOS4 doesn't have RTLD_NOW */
- instance = dlopen(dll,RTLD_LAZY);
-#else /* eg FreeBSD doesn't have RTLD_LAZY */
- instance = dlopen(dll,1);
-#endif
-
- if (NULL == instance) {
- ERRMSG(line) "Can't open library \"%s\":\n %s\n",dll,dlerror()
- EEND;
- }
- if ((sym = dlsym(instance,symbol)))
- return sym;
-
- ERRMSG(line) "Can't find symbol \"%s\" in library \"%s\"",symbol,dll
- EEND;
-}
-
-Bool stdcallAllowed ( void )
-{
- return FALSE;
-}
-
-
-
-
-
-
-#elif HAVE_DL_H /* eg HPUX */
-
-#include <dl.h>
-
-void* getDLLSymbol(line,dll0,symbol) /* load dll and lookup symbol */
-Int line;
-String dll0;
-String symbol; {
- ObjectFile instance = shl_load(dll,BIND_IMMEDIATE,0L);
- void* r;
- if (NULL == instance) {
- ERRMSG(line) "Error while importing DLL \"%s\"", dll0
- EEND;
- }
- return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0;
-}
-
-Bool stdcallAllowed ( void )
-{
- return FALSE;
-}
-
-
-
-
-
-
-#else /* Dynamic loading not available */
-
-void* getDLLSymbol(line,dll0,symbol) /* load dll and lookup symbol */
-Int line;
-String dll0;
-String symbol; {
-#if 1 /* very little to choose between these options */
- return 0;
-#else
- ERRMSG(line) "This Hugs build does not support dynamic loading\n"
- EEND;
-#endif
-}
-
-Bool stdcallAllowed ( void )
-{
- return FALSE;
-}
-
-#endif /* Dynamic loading not available */
-
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Error handling support functions
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: errors.h,v $
- * $Revision: 1.9 $
- * $Date: 2000/03/24 14:32:03 $
- * ------------------------------------------------------------------------*/
-
-extern Void internal ( String) HUGS_noreturn;
-extern Void fatal ( String) HUGS_noreturn;
-
-#define Hilite() doNothing()
-#define Lolite() doNothing()
-#define errorStream stdout
-
-#define ERRMSG(l) Hilite(); errHead(l); FPrintf(errorStream,
-#define EEND ); Lolite(); errFail()
-#define EEND_NO_LONGJMP ); Lolite(); errFail_no_longjmp()
-#define ETHEN );
-#define ERRTEXT Hilite(); FPrintf(errorStream,
-#define ERREXPR(e) Hilite(); printExp(errorStream,e); Lolite()
-#define ERRTYPE(e) Hilite(); printType(errorStream,e); Lolite()
-#define ERRCONTEXT(qs) Hilite(); printContext(errorStream,qs); Lolite()
-#define ERRPRED(pi) Hilite(); printPred(errorStream,pi); Lolite()
-#define ERRKIND(k) Hilite(); printKind(errorStream,k); Lolite()
-#define ERRKINDS(ks) Hilite(); printKinds(errorStream,ks); Lolite()
-#define ERRFD(fd) Hilite(); printFD(errorStream,fd); Lolite()
-
-extern Void errHead ( Int ); /* in main.c */
-extern Void errFail ( Void ) HUGS_noreturn;
-extern Void errFail_no_longjmp ( Void );
-extern Void errAbort ( Void );
-extern Cell errAssert ( Int );
-
-extern Void printExp ( FILE *,Cell ); /* in output.c */
-extern Void printType ( FILE *,Cell );
-extern Void printContext ( FILE *,List );
-extern Void printPred ( FILE *,Cell );
-extern Void printKind ( FILE *,Kind );
-extern Void printKinds ( FILE *,Kinds );
-extern Void printFD ( FILE *,Pair );
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Free variable analysis
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: free.c,v $
- * $Revision: 1.12 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-
-/* --------------------------------------------------------------------------
- * Local functions
- * ------------------------------------------------------------------------*/
-
-static List freeVarsAlt ( List, StgCaseAlt );
-static List freeVarsPrimAlt ( List, StgPrimAlt );
-static List freeVarsExpr ( List, StgExpr );
-static List freeVarsAtom ( List, StgAtom );
-static List freeVarsVar ( List, StgVar );
-
-/* --------------------------------------------------------------------------
- * Free variable analysis
- * ------------------------------------------------------------------------*/
-
-static List freeVarsAtom( List acc, StgAtom a)
-{
- switch (whatIs(a)) {
- case STGVAR:
- return freeVarsVar(acc,a);
- /* Note that NAMEs have no free vars. */
- default:
- return acc;
- }
-}
-
-static List freeVarsVar( List acc, StgVar v)
-{
- if (cellIsMember(v,acc)) {
- return acc;
- } else {
- return cons(v,acc);
- }
-}
-
-List freeVarsBind( List acc, StgVar v )
-{
- StgRhs rhs = stgVarBody(v);
- List fvs = NIL;
- switch (whatIs(rhs)) {
- case STGCON:
- mapAccum(freeVarsAtom,fvs,stgConArgs(rhs));
- break;
- default:
- fvs = freeVarsExpr(fvs,rhs);
- break;
- }
- /* fvs = rev(fvs); */ /* todo might cause less stack rearrangement? */
- stgVarInfo(v) = fvs;
- mapAccum(freeVarsVar,acc,fvs); /* copy onto acc */
- return acc;
-}
-
-static List freeVarsAlt( List acc, StgCaseAlt alt )
-{
- if (isDefaultAlt(alt)) {
- acc = freeVarsExpr(acc,stgDefaultBody(alt));
- return deleteCell(acc,stgDefaultVar(alt));
- } else {
- acc = freeVarsExpr(acc,stgCaseAltBody(alt));
- return diffList(acc,stgCaseAltVars(alt));
- }
-}
-
-static List freeVarsPrimAlt( List acc, StgPrimAlt alt )
-{
- List vs = stgPrimAltVars(alt);
- acc = freeVarsExpr(acc,stgPrimAltBody(alt));
- return diffList(acc,vs);
-}
-
-static List freeVarsExpr( List acc, StgExpr e )
-{
-#if 0
- printf( "freeVarsExpr: " );ppStgExpr(e);printf("\n");
-#endif
- switch (whatIs(e)) {
- case LETREC:
- mapAccum(freeVarsBind,acc,stgLetBinds(e));
- return diffList(freeVarsExpr(acc,stgLetBody(e)),stgLetBinds(e));
- case LAMBDA:
- return diffList(freeVarsExpr(acc,stgLambdaBody(e)),stgLambdaArgs(e));
- case CASE:
- mapAccum(freeVarsAlt,acc,stgCaseAlts(e));
- return freeVarsExpr(acc,stgCaseScrut(e));
- case PRIMCASE:
- mapAccum(freeVarsPrimAlt,acc,stgPrimCaseAlts(e));
- return freeVarsExpr(acc,stgPrimCaseScrut(e));
- case STGPRIM:
- mapAccum(freeVarsAtom,acc,stgPrimArgs(e));
- /* primop is not a var */
- return acc;
- case STGAPP:
- /* Doing fun first causes slightly less stack rearrangement. */
- acc = freeVarsExpr(acc,stgAppFun(e));
- mapAccum(freeVarsAtom,acc,stgAppArgs(e));
- return acc;
- case STGVAR:
- return freeVarsVar(acc, e);
- case NAME:
- case TUPLE:
- return acc; /* Names are never free vars */
- default:
- printf("\n");
- ppStgExpr(e);
- printf("\n");
- internal("freeVarsExpr");
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Command interpreter
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: hugs.c,v $
- * $Revision: 1.78 $
- * $Date: 2000/06/28 10:42:17 $
- * ------------------------------------------------------------------------*/
-
-#include <setjmp.h>
-#include <ctype.h>
-#include <stdio.h>
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "version.h"
-
-#include "Rts.h"
-#include "RtsAPI.h"
-#include "Schedule.h"
-#include "Assembler.h" /* DEBUG_LoadSymbols */
-#include "ForeignCall.h" /* createAdjThunk */
-
-
-Bool haskell98 = TRUE; /* TRUE => Haskell 98 compatibility*/
-Bool initDone = FALSE;
-
-#if EXPLAIN_INSTANCE_RESOLUTION
-Bool showInstRes = FALSE;
-#endif
-#if MULTI_INST
-Bool multiInstRes = FALSE;
-#endif
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static List local initialize ( Int,String [] );
-static Void local promptForInput ( String );
-static Void local interpreter ( Int,String [] );
-static Void local menu ( Void );
-static Void local guidance ( Void );
-static Void local forHelp ( Void );
-static Void local set ( Void );
-static Void local changeDir ( Void );
-static Void local load ( Void );
-static Void local project ( Void );
-static Void local editor ( Void );
-static Void local find ( Void );
-static Bool local startEdit ( Int,String );
-static Void local runEditor ( Void );
-static Void local setModule ( Void );
-static Void local evaluator ( Void );
-static Void local stopAnyPrinting ( Void );
-static Void local showtype ( Void );
-static String local objToStr ( Module, Cell );
-static Void local info ( Void );
-static Void local printSyntax ( Name );
-static Void local showInst ( Inst );
-static Void local describe ( Text );
-static Void local listNames ( Void );
-
-static Void local toggleSet ( Char,Bool );
-static Void local togglesIn ( Bool );
-static Void local optionInfo ( Void );
-static Void local readOptions ( String );
-static Bool local processOption ( String );
-static Void local setHeapSize ( String );
-static Int local argToInt ( String );
-
-static Void local setLastEdit ( String,Int );
-static Void local failed ( Void );
-static String local strCopy ( String );
-static Void local browseit ( Module,String,Bool );
-static Void local browse ( Void );
-static void local clearCurrentFile ( void );
-
-static void loadActions ( List loadModules /* :: [CONID] */ );
-static void addActions ( List extraModules /* :: [CONID] */ );
-static Bool loadThePrelude ( void );
-
-
-/* --------------------------------------------------------------------------
- * Machine dependent code for Hugs interpreter:
- * ------------------------------------------------------------------------*/
-
-#include "machdep.c"
-
-/* --------------------------------------------------------------------------
- * Local data areas:
- * ------------------------------------------------------------------------*/
-
-static Bool printing = FALSE; /* TRUE => currently printing value*/
-static Bool showStats = FALSE; /* TRUE => print stats after eval */
-static Bool listScripts = TRUE; /* TRUE => list scripts after loading*/
-static Bool addType = FALSE; /* TRUE => print type with value */
-static Bool quiet = FALSE; /* TRUE => don't show progress */
-static Bool lastWasObject = FALSE;
-
- Bool flagAssert = FALSE; /* TRUE => assert False <e> causes
- an assertion failure */
- Bool preludeLoaded = FALSE;
- Bool debugSC = FALSE;
- Bool combined = FALSE;
-
- Module moduleBeingParsed; /* so the parser (topModule) knows */
-static char* currentFile; /* Name of current file, or NULL */
-static char currentFileName[1000]; /* name is stored here if it exists*/
-
-static Bool autoMain = FALSE;
-static String lastEdit = 0; /* Name of script to edit (if any) */
-static Int lastEdLine = 0; /* Editor line number (if possible)*/
-static String prompt = 0; /* Prompt string */
-static Int hpSize = DEFAULTHEAP; /* Desired heap size */
-static Bool disableOutput = FALSE; /* TRUE => quiet */
- String hugsEdit = 0; /* String for editor command */
- String hugsPath = 0; /* String for file search path */
-
- List ifaces_outstanding = NIL;
-
-static ConId currentModule_failed = NIL; /* Remember failed module from :r */
-
-
-
-/* --------------------------------------------------------------------------
- * Hugs entry point:
- * ------------------------------------------------------------------------*/
-
-#ifdef DIET_HEP
-
-#include "StgDLL.h"
-#include "DietHEP.h"
-
-extern void setRtsFlags ( int );
-
-static int diet_hep_initialised = 0;
-static FILE* dh_logfile;
-
-static
-void printf_now ( void )
-{
- time_t now = time(NULL);
- printf("\n=== DietHEP event at %s",ctime(&now));
-}
-
-static
-void diet_hep_initialise ( void* cstackbase )
-{
- List modConIds; /* :: [CONID] */
- Bool prelOK;
- String s;
- String fakeargv[] = { "diet_hep", "+RTS",
- "-D0", "-RTS", NULL };
- // GC = 32
- // sanity = 128
- if (diet_hep_initialised) return;
- diet_hep_initialised = 1;
-
- CStackBase = cstackbase;
-
- dh_logfile = freopen("diet_hep_logfile.txt","a",stdout);
- assert(dh_logfile);
-
- printf_now();
- printf("===---===---=== DietHEP initialisation ===---===---===\n\n");
- fflush(stdout);
-
- EnableOutput(1);
- setInstallDir ( "diet_hep" );
-
- /* The following copied from interpreter() */
- setBreakAction ( HugsIgnoreBreak );
- modConIds = initialize(sizeof(fakeargv)/sizeof(String)-1,fakeargv);
- //setRtsFlags(4 | 128 | 32);
- assert(isNull(modConIds));
- setBreakAction ( HugsIgnoreBreak );
- prelOK = loadThePrelude();
-
- if (!prelOK) {
- printf("diet_hep_initialise: fatal error: "
- "can't load the Prelude.\n" );
- exit(1);
- }
-
- loadActions(NIL);
-
- if (combined) everybody(POSTPREL);
- /* we now leave, and wait for requests */
-}
-
-
-static
-DH_MODULE DH_LoadLibrary_wrk ( DH_LPCSTR modname )
-{
- Text t;
- Module m;
- t = findText(modname);
- addActions ( singleton(mkCon(t)) );
- m = findModule(t);
- if (isModule(m)) return m; else return 0;
-}
-
-static
-void* DH_GetProcAddress_wrk ( DH_CALLCONV cconv,
- DH_MODULE hModule,
- DH_LPCSTR lpProcName )
-{
- Name n;
- Text typedescr;
- void* adj_thunk;
- StgStablePtr stableptr;
-
- if (!isModule(hModule)) return NULL;
- setCurrModule(hModule);
- n = findName ( findText(lpProcName) );
- if (!isName(n)) return NULL;
- assert(isCPtr(name(n).closure));
-
- /* n is the function which we want to f-x-d,
- n :: prim_arg* -> IO prim_result.
- Assume that name(n).closure is a cptr which points to n's BCO.
-
- Make ns a stable pointer to n.
- Manufacture a type descriptor string for n's type.
- use createAdjThunk to build the adj thunk.
- */
- typedescr = makeTypeDescrText ( name(n).type );
- if (!isText(typedescr)) return NULL;
- if (cconv != dh_stdcall && cconv != dh_ccall) return NULL;
-
- stableptr = getStablePtr( cptrOf(name(n).closure) );
- adj_thunk = createAdjThunk ( stableptr,
- textToStr(typedescr),
- cconv==dh_stdcall ? 's' : 'c' );
- return adj_thunk;
-}
-
-/*----------- EXPORTS -------------*/
- __attribute__((__stdcall__))
-DH_MODULE
-DH_LoadLibrary ( DH_LPCSTR modname )
-{
- int xxx;
- DH_MODULE hdl;
- diet_hep_initialise ( &xxx );
- printf_now();
- printf("=== DH_LoadLibrary: request to load `%s'\n\n", modname );
- fflush(stdout);
- hdl = DH_LoadLibrary_wrk ( modname );
- return hdl;
-}
-
-
- __attribute__((__stdcall__))
-void*
-DH_GetProcAddress ( DH_CALLCONV cconv,
- DH_MODULE hModule,
- DH_LPCSTR lpProcName )
-{
- int xxx;
- diet_hep_initialise ( &xxx );
- printf_now();
- printf("=== DH_GetProcAddress: request for `%s'\n\n", lpProcName );
- fflush(stdout);
- return DH_GetProcAddress_wrk ( cconv, hModule, lpProcName );
-}
-
-
-#if 0
-BOOL APIENTRY
-DllMain (
- HINSTANCE hInst /* Library instance handle. */ ,
- DWORD reason /* Reason this function is being called. */ ,
- LPVOID reserved /* Not used. */ )
-{
-
- switch (reason)
- {
- case DLL_PROCESS_ATTACH:
- break;
-
- case DLL_PROCESS_DETACH:
- break;
-
- case DLL_THREAD_ATTACH:
- break;
-
- case DLL_THREAD_DETACH:
- break;
- }
- return TRUE;
-}
-#endif
-
-//---------------------------------
-//--- testing it ...
-#if 0
-int main ( int argc, char** argv )
-{
- void* proc;
- DH_MODULE hdl;
- hdl = DH_LoadLibrary("FooBar");
- assert(isModule(hdl));
- proc = DH_GetProcAddress ( dh_ccall, hdl, "wurble" );
-fprintf ( stderr, "just before calling it\n");
- ((void(*)(int)) proc) (33);
- ((void(*)(int)) proc) (34);
- ((void(*)(int)) proc) (35);
- fprintf ( stderr, "exiting safely\n");
- return 0;
-}
-#endif
-
-#else
-
-Main main ( Int, String [] ); /* now every func has a prototype */
-
-Main main(argc,argv)
-int argc;
-char *argv[]; {
- CStackBase = &argc; /* Save stack base for use in gc */
-
-# ifdef DEBUG
-# if 0
- checkBytecodeCount(); /* check for too many bytecodes */
-# endif
-# endif
-
- /* If first arg is +Q or -Q, be entirely silent, and automatically run
- main after loading scripts. Useful for running the nofib suite. */
- if (argc > 1 && (strcmp(argv[1],"+Q") == 0 || strcmp(argv[1],"-Q")==0)) {
- autoMain = TRUE;
- if (strcmp(argv[1],"-Q") == 0) {
- EnableOutput(0);
- }
- }
-
- Printf("__ __ __ __ ____ ___ _________________________________________\n");
- Printf("|| || || || || || ||__ STGHugs: Based on the Haskell 98 standard\n");
- Printf("||___|| ||__|| ||__|| __|| Copyright (c) 1994-2000\n");
- Printf("||---|| ___|| World Wide Web: http://haskell.org/hugs\n");
- Printf("|| || Report bugs to: hugs-bugs@haskell.org\n");
- Printf("|| || Version: %s _________________________________________\n\n",HUGS_VERSION);
-
- /* Get the absolute path to the directory containing the hugs
- executable, so that we know where the Prelude and nHandle.so/.dll are.
- We do this by reading env var STGHUGSDIR. This needs to succeed, so
- setInstallDir won't return unless it succeeds.
- */
- setInstallDir ( argv[0] );
-
- FlushStdout();
- interpreter(argc,argv);
- Printf("[Leaving Hugs]\n");
- everybody(EXIT);
- shutdownHaskell();
- FlushStdout();
- fflush(stderr);
- exit(0);
- MainDone();
-}
-
-#endif /* DIET_HEP */
-
-/* --------------------------------------------------------------------------
- * Initialization, interpret command line args and read prelude:
- * ------------------------------------------------------------------------*/
-
-static List /*CONID*/ initialize ( Int argc, String argv[] )
-{
- Int i, j;
- List initialModules;
-
- setLastEdit((String)0,0);
- lastEdit = 0;
- currentFile = NULL;
-
-#if SYMANTEC_C
- hugsEdit = "";
-#else
- hugsEdit = strCopy(fromEnv("EDITOR",NULL));
-#endif
- hugsPath = strCopy(HUGSPATH);
- readOptions("-p\"%s> \" -r$$");
- readOptions(fromEnv("STGHUGSFLAGS",""));
-
-# ifdef DEBUG
- {
- char exe_name[N_INSTALLDIR + 6];
- strcpy(exe_name, installDir);
- strcat(exe_name, "hugs");
- DEBUG_LoadSymbols(exe_name);
- }
-# endif
-
- /* startupHaskell extracts args between +RTS ... -RTS, and sets
- prog_argc/prog_argv to the rest. We want to further process
- the rest, so we then get hold of them again.
- */
- startupHaskell ( argc, argv, NULL );
- getProgArgv ( &argc, &argv );
-
- /* Find out early on if we're in combined mode or not.
- everybody(PREPREL) needs to know this. Also, establish the
- heap size;
- */
- for (i = 1; i < argc; ++i) {
- if (strcmp(argv[i], "--")==0) break;
- if (strcmp(argv[i], "-c")==0) combined = FALSE;
- if (strcmp(argv[i], "+c")==0) combined = TRUE;
-
- if (strncmp(argv[i],"+h",2)==0 || strncmp(argv[i],"-h",2)==0)
- setHeapSize(&(argv[i][2]));
- }
-
- everybody(PREPREL);
- initialModules = NIL;
-
- for (i = 1; i < argc; ++i) { /* process command line arguments */
- if (strcmp(argv[i], "--")==0)
- { argv[i] = NULL; break; }
- if (argv[i] && argv[i][0]/* workaround for /bin/sh silliness*/) {
- if (!processOption(argv[i]))
- initialModules
- = cons ( mkCon(findText(argv[i])), initialModules );
- argv[i] = NULL;
- }
- }
-
- if (haskell98) {
- Printf("Haskell 98 mode: Restart with command line option -98"
- " to enable extensions\n");
- } else {
- Printf("Hugs mode: Restart with command line option +98 for"
- " Haskell 98 mode\n");
- }
-
- if (combined) {
- Printf("Combined mode: Restart with command line -c for"
- " standalone mode\n\n" );
- } else {
- Printf("Standalone mode: Restart with command line +c for"
- " combined mode\n\n" );
- }
-
- /* slide args back over the deleted ones. */
- j = 1;
- for (i = 1; i < argc; i++)
- if (argv[i])
- argv[j++] = argv[i];
-
- argc = j;
-
- setProgArgv ( argc, argv );
-
- initDone = TRUE;
- return initialModules;
-}
-
-/* --------------------------------------------------------------------------
- * Command line options:
- * ------------------------------------------------------------------------*/
-
-struct options { /* command line option toggles */
- char c; /* table defined in main app. */
- int h98;
- String description;
- Bool *flag;
-};
-extern struct options toggle[];
-
-static Void local toggleSet(c,state) /* Set command line toggle */
-Char c;
-Bool state; {
- Int i;
- for (i=0; toggle[i].c; ++i)
- if (toggle[i].c == c) {
- *toggle[i].flag = state;
- return;
- }
- clearCurrentFile();
- ERRMSG(0) "Unknown toggle `%c'", c
- EEND_NO_LONGJMP;
-}
-
-static Void local togglesIn(state) /* Print current list of toggles in*/
-Bool state; { /* given state */
- Int count = 0;
- Int i;
- for (i=0; toggle[i].c; ++i)
- if (*toggle[i].flag == state && (!haskell98 || toggle[i].h98)) {
- if (count==0)
- Putchar((char)(state ? '+' : '-'));
- Putchar(toggle[i].c);
- count++;
- }
- if (count>0)
- Putchar(' ');
-}
-
-static Void local optionInfo() { /* Print information about command */
- static String fmts = "%-5s%s\n"; /* line settings */
- static String fmtc = "%-5c%s\n";
- Int i;
-
- Printf("TOGGLES: groups begin with +/- to turn options on/off resp.\n");
- for (i=0; toggle[i].c; ++i) {
- if (!haskell98 || toggle[i].h98) {
- Printf(fmtc,toggle[i].c,toggle[i].description);
- }
- }
-
- Printf("\nOTHER OPTIONS: (leading + or - makes no difference)\n");
- Printf(fmts,"hnum","Set heap size (cannot be changed within Hugs)");
- Printf(fmts,"pstr","Set prompt string to str");
- Printf(fmts,"rstr","Set repeat last expression string to str");
- Printf(fmts,"Pstr","Set search path for modules to str");
- Printf(fmts,"Estr","Use editor setting given by str");
- Printf(fmts,"cnum","Set constraint cutoff limit");
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
- Printf(fmts,"Fstr","Set preprocessor filter to str");
-#endif
-
- Printf("\nCurrent settings: ");
- togglesIn(TRUE);
- togglesIn(FALSE);
- Printf("-h%d",heapSize);
- Printf(" -p");
- printString(prompt);
- Printf(" -r");
- printString(repeatStr);
- Printf(" -c%d",cutoff);
- Printf("\nSearch path : -P");
- printString(hugsPath);
-#if 0
-ToDo
- if (projectPath!=NULL) {
- Printf("\nProject Path : %s",projectPath);
- }
-#endif
- Printf("\nEditor setting : -E");
- printString(hugsEdit);
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
- Printf("\nPreprocessor : -F");
- printString(preprocessor);
-#endif
- Printf("\nCompatibility : %s", haskell98 ? "Haskell 98 (+98)"
- : "Hugs Extensions (-98)");
- Putchar('\n');
-}
-
-#undef PUTC
-#undef PUTS
-#undef PUTInt
-#undef PUTStr
-
-static Void local readOptions(options) /* read options from string */
-String options; {
- String s;
- if (options) {
- stringInput(options);
- while ((s=readFilename())!=0) {
- if (*s && !processOption(s)) {
- ERRMSG(0) "Option string must begin with `+' or `-'"
- EEND;
- }
- }
- }
-}
-
-static Bool local processOption(s) /* process string s for options, */
-String s; { /* return FALSE if none found. */
- Bool state;
-
- if (s[0]=='-')
- state = FALSE;
- else if (s[0]=='+')
- state = TRUE;
- else
- return FALSE;
-
- while (*++s)
- switch (*s) {
- case 'Q' : break; /* already handled */
-
- case 'p' : if (s[1]) {
- if (prompt) free(prompt);
- prompt = strCopy(s+1);
- }
- return TRUE;
-
- case 'r' : if (s[1]) {
- if (repeatStr) free(repeatStr);
- repeatStr = strCopy(s+1);
- }
- return TRUE;
-
- case 'P' : {
- String p = substPath(s+1,hugsPath ? hugsPath : "");
- if (hugsPath) free(hugsPath);
- hugsPath = p;
- return TRUE;
- }
-
- case 'E' : if (hugsEdit) free(hugsEdit);
- hugsEdit = strCopy(s+1);
- return TRUE;
-
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
- case 'F' : if (preprocessor) free(preprocessor);
- preprocessor = strCopy(s+1);
- return TRUE;
-#endif
-
- case 'h' : /* don't do anything, since pre-scan of args
- will have got it already */
- return TRUE;
-
- case 'c' : /* don't do anything, since pre-scan of args
- will have got it already */
- return TRUE;
-
- case 'D' : /* hack */
- {
- extern void setRtsFlags( int x );
- setRtsFlags(argToInt(s+1));
- return TRUE;
- }
-
- default : if (strcmp("98",s)==0) {
- if (initDone && ((state && !haskell98) ||
- (!state && haskell98))) {
- FPrintf(stderr,
- "Haskell 98 compatibility cannot be changed"
- " while the interpreter is running\n");
- } else {
- haskell98 = state;
- }
- return TRUE;
- } else {
- toggleSet(*s,state);
- }
- break;
- }
- return TRUE;
-}
-
-static Void local setHeapSize(s)
-String s; {
- if (s) {
- hpSize = argToInt(s);
- if (hpSize < MINIMUMHEAP)
- hpSize = MINIMUMHEAP;
- else if (MAXIMUMHEAP && hpSize > MAXIMUMHEAP)
- hpSize = MAXIMUMHEAP;
- if (initDone && hpSize != heapSize) {
- /* ToDo: should this use a message box in winhugs? */
- FPrintf(stderr,"You cannot change heap size from inside Hugs\n");
- } else {
- heapSize = hpSize;
- }
- }
-}
-
-static Int local argToInt(s) /* read integer from argument str */
-String s; {
- Int n = 0;
- String t = s;
-
- if (*s=='\0' || !isascii((int)(*s)) || !isdigit((int)(*s))) {
- ERRMSG(0) "Missing integer in option setting \"%s\"", t
- EEND;
- }
-
- do {
- Int d = (*s++) - '0';
- if (n > ((MAXPOSINT - d)/10)) {
- ERRMSG(0) "Option setting \"%s\" is too large", t
- EEND;
- }
- n = 10*n + d;
- } while (isascii((int)(*s)) && isdigit((int)(*s)));
-
- if (*s=='K' || *s=='k') {
- if (n > (MAXPOSINT/1000)) {
- ERRMSG(0) "Option setting \"%s\" is too large", t
- EEND;
- }
- n *= 1000;
- s++;
- }
-
-#if MAXPOSINT > 1000000 /* waste of time on 16 bit systems */
- if (*s=='M' || *s=='m') {
- if (n > (MAXPOSINT/1000000)) {
- ERRMSG(0) "Option setting \"%s\" is too large", t
- EEND;
- }
- n *= 1000000;
- s++;
- }
-#endif
-
-#if MAXPOSINT > 1000000000
- if (*s=='G' || *s=='g') {
- if (n > (MAXPOSINT/1000000000)) {
- ERRMSG(0) "Option setting \"%s\" is too large", t
- EEND;
- }
- n *= 1000000000;
- s++;
- }
-#endif
-
- if (*s!='\0') {
- ERRMSG(0) "Unwanted characters after option setting \"%s\"", t
- EEND;
- }
-
- return n;
-}
-
-/* --------------------------------------------------------------------------
- * Print Menu of list of commands:
- * ------------------------------------------------------------------------*/
-
-static struct cmd cmds[] = {
- {":?", HELP}, {":cd", CHGDIR}, {":also", ALSO},
- {":type", TYPEOF}, {":!", SYSTEM}, {":load", LOAD},
- {":reload", RELOAD}, {":gc", COLLECT}, {":edit", EDIT},
- {":quit", QUIT}, {":set", SET}, {":find", FIND},
- {":names", NAMES}, {":info", INFO}, {":project", PROJECT},
- {":dump", DUMP},
- {":module", SETMODULE},
- {":browse", BROWSE},
-#if EXPLAIN_INSTANCE_RESOLUTION
- {":xplain", XPLAIN},
-#endif
- {":version", PNTVER},
- {"", EVAL},
- {0,0}
-};
-
-static Void local menu() {
- Printf("LIST OF COMMANDS: Any command may be abbreviated to :c where\n");
- Printf("c is the first character in the full name.\n\n");
- Printf(":load <filenames> load modules from specified files\n");
- Printf(":load clear all files except prelude\n");
- Printf(":also <filenames> read additional modules\n");
- Printf(":reload repeat last load command\n");
- Printf(":project <filename> use project file\n");
- Printf(":edit <filename> edit file\n");
- Printf(":edit edit last module\n");
- Printf(":module <module> set module for evaluating expressions\n");
- Printf("<expr> evaluate expression\n");
- Printf(":type <expr> print type of expression\n");
- Printf(":? display this list of commands\n");
- Printf(":set <options> set command line options\n");
- Printf(":set help on command line options\n");
- Printf(":names [pat] list names currently in scope\n");
- Printf(":info <names> describe named objects\n");
- Printf(":browse <modules> browse names defined in <modules>\n");
-#if EXPLAIN_INSTANCE_RESOLUTION
- Printf(":xplain <context> explain instance resolution for <context>\n");
-#endif
- Printf(":find <name> edit module containing definition of name\n");
- Printf(":!command shell escape\n");
- Printf(":cd dir change directory\n");
- Printf(":gc force garbage collection\n");
- Printf(":version print Hugs version\n");
- Printf(":dump <name> print STG code for named fn\n");
- Printf(":quit exit Hugs interpreter\n");
-}
-
-static Void local guidance() {
- Printf("Command not recognised. ");
- forHelp();
-}
-
-static Void local forHelp() {
- Printf("Type :? for help\n");
-}
-
-/* --------------------------------------------------------------------------
- * Setting of command line options:
- * ------------------------------------------------------------------------*/
-
-struct options toggle[] = { /* List of command line toggles */
- {'s', 1, "Print no. reductions/cells after eval", &showStats},
- {'t', 1, "Print type after evaluation", &addType},
- {'g', 1, "Print no. cells recovered after gc", &gcMessages},
- {'l', 1, "Literate modules as default", &literateScripts},
- {'e', 1, "Warn about errors in literate modules", &literateErrors},
- {'q', 1, "Print nothing to show progress", &quiet},
- {'w', 1, "Always show which modules are loaded", &listScripts},
- {'k', 1, "Show kind errors in full", &kindExpert},
- {'o', 0, "Allow overlapping instances", &allowOverlap},
- {'S', 1, "Debug: show generated SC code", &debugSC},
- {'a', 1, "Raise exception on assert failure", &flagAssert},
-#if EXPLAIN_INSTANCE_RESOLUTION
- {'x', 1, "Explain instance resolution", &showInstRes},
-#endif
-#if MULTI_INST
- {'m', 0, "Use multi instance resolution", &multiInstRes},
-#endif
- {0, 0, 0, 0}
-};
-
-static Void local set() { /* change command line options from*/
- String s; /* Hugs command line */
-
- if ((s=readFilename())!=0) {
- do {
- if (!processOption(s)) {
- ERRMSG(0) "Option string must begin with `+' or `-'"
- EEND_NO_LONGJMP;
- }
- } while ((s=readFilename())!=0);
- }
- else
- optionInfo();
-}
-
-/* --------------------------------------------------------------------------
- * Change directory command:
- * ------------------------------------------------------------------------*/
-
-static Void local changeDir() { /* change directory */
- String s = readFilename();
- if (s && chdir(s)) {
- ERRMSG(0) "Unable to change to directory \"%s\"", s
- EEND_NO_LONGJMP;
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Interrupt handling
- * ------------------------------------------------------------------------*/
-
-static jmp_buf catch_error; /* jump buffer for error trapping */
-
-HugsBreakAction currentBreakAction = HugsIgnoreBreak;
-
-static void handler_IgnoreBreak ( int sig )
-{
- setHandler ( handler_IgnoreBreak );
-}
-
-static void handler_LongjmpOnBreak ( int sig )
-{
- setHandler ( handler_LongjmpOnBreak );
- Printf("{Interrupted!}\n");
- longjmp(catch_error,1);
-}
-
-static void handler_RtsInterrupt ( int sig )
-{
- setHandler ( handler_RtsInterrupt );
- interruptStgRts();
-}
-
-HugsBreakAction setBreakAction ( HugsBreakAction newAction )
-{
- HugsBreakAction tmp = currentBreakAction;
- currentBreakAction = newAction;
-
-# if defined(mingw32_TARGET_OS)
- /* Be wierd. You can't longjmp in a signal handler,
- and posix signals are not supported.
- */
- if (newAction == HugsRtsInterrupt) {
- setHandler ( handler_RtsInterrupt );
- } else {
- signal(SIGINT,SIG_IGN);
- }
-# else
- /* do it Right */
- switch (newAction) {
- case HugsIgnoreBreak:
- setHandler ( handler_IgnoreBreak ); break;
- case HugsLongjmpOnBreak:
- setHandler ( handler_LongjmpOnBreak ); break;
- case HugsRtsInterrupt:
- setHandler ( handler_RtsInterrupt ); break;
- default:
- internal("setBreakAction");
- }
-# endif
-
- return tmp;
-}
-
-
-/* --------------------------------------------------------------------------
- * The new module chaser, loader, etc
- * ------------------------------------------------------------------------*/
-
-List moduleGraph = NIL;
-List prelModules = NIL;
-List targetModules = NIL;
-
-static String modeToString ( Cell mode )
-{
- switch (mode) {
- case FM_SOURCE: return "source";
- case FM_OBJECT: return "object";
- case FM_EITHER: return "source or object";
- default: internal("modeToString");
- }
-}
-
-static Cell childMode ( Cell modeMeRequest, Cell modeMeActual )
-{
- assert(modeMeActual == FM_SOURCE ||
- modeMeActual == FM_OBJECT);
- assert(modeMeRequest == FM_SOURCE ||
- modeMeRequest == FM_OBJECT ||
- modeMeRequest == FM_EITHER);
- if (modeMeRequest == FM_SOURCE) return modeMeRequest;
- if (modeMeRequest == FM_OBJECT) return modeMeRequest;
- if (modeMeActual == FM_OBJECT) return FM_OBJECT;
- if (modeMeActual == FM_SOURCE) return FM_EITHER;
- internal("childMode");
-}
-
-static Bool compatibleNewMode ( Cell modeNew, Cell modeExisting )
-{
- if (modeNew == FM_OBJECT && modeExisting == FM_OBJECT) return TRUE;
- if (modeNew == FM_SOURCE && modeExisting == FM_SOURCE) return TRUE;
- if (modeNew == FM_EITHER && modeExisting == FM_OBJECT) return TRUE;
- if (modeNew == FM_EITHER && modeExisting == FM_SOURCE) return TRUE;
- return FALSE;
-}
-
-static void setCurrentFile ( Module mod )
-{
- assert(isModule(mod));
- strncpy(currentFileName, textToStr(module(mod).text), 990);
- strcat(currentFileName, textToStr(module(mod).srcExt));
- currentFile = currentFileName;
- moduleBeingParsed = mod;
-}
-
-static void clearCurrentFile ( void )
-{
- currentFile = NULL;
- moduleBeingParsed = NIL;
-}
-
-static void ppMG ( void )
-{
- List t,u,v;
- for (t = moduleGraph; nonNull(t); t=tl(t)) {
- u = hd(t);
- switch (whatIs(u)) {
- case GRP_NONREC:
- Printf ( " %s\n", textToStr(textOf(snd(u))));
- break;
- case GRP_REC:
- Printf ( " {" );
- for (v = snd(u); nonNull(v); v=tl(v))
- Printf ( "%s ", textToStr(textOf(hd(v))) );
- Printf ( "}\n" );
- break;
- default:
- internal("ppMG");
- }
- }
-}
-
-
-static Bool elemMG ( ConId mod )
-{
- List gs;
- for (gs = moduleGraph; nonNull(gs); gs=tl(gs))
- switch (whatIs(hd(gs))) {
- case GRP_NONREC:
- if (textOf(mod)==textOf(snd(hd(gs)))) return TRUE;
- break;
- case GRP_REC:
- if (varIsMember(textOf(mod),snd(hd(gs)))) return TRUE;
- break;
- default:
- internal("elemMG");
- }
- return FALSE;
-}
-
-
-static ConId selectArbitrarilyFromGroup ( Cell group )
-{
- switch (whatIs(group)) {
- case GRP_NONREC: return snd(group);
- case GRP_REC: return hd(snd(group));
- default: internal("selectArbitrarilyFromGroup");
- }
-}
-
-static ConId selectLatestMG ( void )
-{
- List gs = moduleGraph;
- if (isNull(gs)) internal("selectLatestMG(1)");
- while (nonNull(gs) && nonNull(tl(gs))) gs = tl(gs);
- return selectArbitrarilyFromGroup(hd(gs));
-}
-
-
-static List /* of CONID */ listFromSpecifiedMG ( List mg )
-{
- List gs;
- List cs = NIL;
- for (gs = mg; nonNull(gs); gs=tl(gs)) {
- switch (whatIs(hd(gs))) {
- case GRP_REC: cs = appendOnto(cs,snd(hd(gs))); break;
- case GRP_NONREC: cs = cons(snd(hd(gs)),cs); break;
- default: internal("listFromSpecifiedMG");
- }
- }
- return cs;
-}
-
-static List /* of CONID */ listFromMG ( void )
-{
- return listFromSpecifiedMG ( moduleGraph );
-}
-
-
-/* Calculate the strongly connected components of modgList
- and assign them to moduleGraph. Uses the .uses field of
- each of the modules to build the graph structure.
-*/
-#define SCC modScc /* make scc algorithm for StgVars */
-#define LOWLINK modLowlink
-#define DEPENDS(t) snd(t)
-#define SETDEPENDS(c,v) snd(c)=v
-#include "scc.c"
-#undef SETDEPENDS
-#undef DEPENDS
-#undef LOWLINK
-#undef SCC
-
-static void mgFromList ( List /* of CONID */ modgList )
-{
- List t;
- List u;
- Text mT;
- List usesT;
- List adjList; /* :: [ (Text, [Text]) ] */
- Module mod;
- List scc;
- Bool isRec;
-
- adjList = NIL;
- for (t = modgList; nonNull(t); t=tl(t)) {
- mT = textOf(hd(t));
- mod = findModule(mT);
- assert(nonNull(mod));
- usesT = NIL;
- for (u = module(mod).uses; nonNull(u); u=tl(u))
- usesT = cons(textOf(hd(u)),usesT);
-
- /* artificially give all modules a dependency on Prelude */
- if (mT != textPrelude && mT != textPrelPrim)
- usesT = cons(textPrelude,usesT);
- adjList = cons(pair(mT,usesT),adjList);
- }
-
- /* adjList is now [ (module-text, [modules-which-i-import-text]) ].
- Modify this so that the adjacency list is a list of pointers
- back to bits of adjList -- that's what modScc needs.
- */
- for (t = adjList; nonNull(t); t=tl(t)) {
- List adj = NIL;
- /* for each elem of the adjacency list ... */
- for (u = snd(hd(t)); nonNull(u); u=tl(u)) {
- List v;
- Text a = hd(u);
- /* find the element of adjList whose fst is a */
- for (v = adjList; nonNull(v); v=tl(v)) {
- assert(isText(a));
- assert(isText(fst(hd(v))));
- if (fst(hd(v))==a) break;
- }
- if (isNull(v)) internal("mgFromList");
- adj = cons(hd(v),adj);
- }
- snd(hd(t)) = adj;
- }
-
- adjList = modScc ( adjList );
- /* adjList is now [ [(module-text, aux-info-field)] ] */
-
- moduleGraph = NIL;
-
- for (t = adjList; nonNull(t); t=tl(t)) {
-
- scc = hd(t);
- /* scc :: [ (module-text, aux-info-field) ] */
- for (u = scc; nonNull(u); u=tl(u))
- hd(u) = mkCon(fst(hd(u)));
-
- /* scc :: [CONID] */
- if (length(scc) > 1) {
- isRec = TRUE;
- } else {
- /* singleton module in scc; does it import itself? */
- mod = findModule ( textOf(hd(scc)) );
- assert(nonNull(mod));
- isRec = FALSE;
- for (u = module(mod).uses; nonNull(u); u=tl(u))
- if (textOf(hd(u))==textOf(hd(scc)))
- isRec = TRUE;
- }
-
- if (isRec)
- moduleGraph = cons( ap(GRP_REC,scc), moduleGraph ); else
- moduleGraph = cons( ap(GRP_NONREC,hd(scc)), moduleGraph );
- }
- moduleGraph = reverse(moduleGraph);
-}
-
-
-static List /* of CONID */ getModuleImports ( Cell tree )
-{
- Cell te;
- List tes;
- ConId use;
- List uses = NIL;
- for (tes = zthd3(unap(M_MODULE,tree)); nonNull(tes); tes=tl(tes)) {
- te = hd(tes);
- switch(whatIs(te)) {
- case M_IMPORT_Q:
- use = zfst(unap(M_IMPORT_Q,te));
- assert(isCon(use));
- if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
- break;
- case M_IMPORT_UNQ:
- use = zfst(unap(M_IMPORT_UNQ,te));
- assert(isCon(use));
- if (!varIsMember(textOf(use),uses)) uses = cons ( use, uses );
- break;
- default:
- break;
- }
- }
- return uses;
-}
-
-
-static void processModule ( Module m )
-{
- Cell tree;
- ConId modNm;
- List topEnts;
- List tes;
- Cell te;
- Cell te2;
-
- tyconDefns = NIL;
- typeInDefns = NIL;
- valDefns = NIL;
- classDefns = NIL;
- instDefns = NIL;
- selDefns = NIL;
- genDefns = NIL;
- unqualImports = NIL;
- foreignImports = NIL;
- foreignExports = NIL;
- defaultDefns = NIL;
- defaultLine = 0;
- inputExpr = NIL;
-
- setCurrentFile(m);
- startModule(m);
- tree = unap(M_MODULE,module(m).tree);
- modNm = zfst3(tree);
-
- if (textOf(modNm) != module(m).text) {
- ERRMSG(0) "Module name \"%s\" does not match file name \"%s%s\"",
- textToStr(textOf(modNm)),
- textToStr(module(m).text),
- textToStr(module(m).srcExt)
- EEND;
- }
-
- setExportList(zsnd3(tree));
- topEnts = zthd3(tree);
-
- for (tes = topEnts; nonNull(tes); tes=tl(tes)) {
- te = hd(tes);
- assert(isGenPair(te));
- te2 = snd(te);
- switch(whatIs(te)) {
- case M_IMPORT_Q:
- addQualImport(zfst(te2),zsnd(te2));
- break;
- case M_IMPORT_UNQ:
- addUnqualImport(zfst(te2),zsnd(te2));
- break;
- case M_TYCON:
- tyconDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
- break;
- case M_CLASS:
- classDefn(intOf(zsel14(te2)),zsel24(te2),zsel34(te2),zsel44(te2));
- break;
- case M_INST:
- instDefn(intOf(zfst3(te2)),zsnd3(te2),zthd3(te2));
- break;
- case M_DEFAULT:
- defaultDefn(intOf(zfst(te2)),zsnd(te2));
- break;
- case M_FOREIGN_IM:
- foreignImport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
- zsel45(te2),zsel55(te2));
- break;
- case M_FOREIGN_EX:
- foreignExport(intOf(zsel15(te2)),zsel25(te2),zsel35(te2),
- zsel45(te2),zsel55(te2));
- case M_VALUE:
- valDefns = cons(te2,valDefns);
- break;
- default:
- internal("processModule");
- }
- }
- checkDefns(m);
- typeCheckDefns();
- compileDefns();
-}
-
-
-static Module parseModuleOrInterface ( ConId mc, Cell modeRequest )
-{
- /* Allocate a module-table entry. */
- /* Parse the entity and fill in the .tree and .uses entries. */
- String path;
- String sExt;
- Bool sAvail; Time sTime; Long sSize;
- Bool oiAvail; Time oiTime; Long oSize; Long iSize;
- Bool ok;
- Bool useSource;
- char name[10000];
-
- Text mt = textOf(mc);
- Module mod = findModule ( mt );
-
- /* fprintf ( stderr, "parseModuleOrInterface `%s' == %d\n",
- textToStr(mt),mod); */
- if (nonNull(mod) && !module(mod).fake)
- internal("parseModuleOrInterface");
- if (nonNull(mod))
- module(mod).fake = FALSE;
-
- if (isNull(mod))
- mod = newModule(mt);
-
- /* This call malloc-ates path; we should deallocate it. */
- ok = findFilesForModule (
- textToStr(module(mod).text),
- &path,
- &sExt,
- &sAvail, &sTime, &sSize,
- &oiAvail, &oiTime, &oSize, &iSize
- );
-
- if (!ok) goto cant_find;
- if (!sAvail && !oiAvail) goto cant_find;
-
- /* Find out whether to use source or object. */
- switch (modeRequest) {
- case FM_SOURCE:
- if (!sAvail) goto cant_find;
- useSource = TRUE;
- break;
- case FM_OBJECT:
- if (!oiAvail) goto cant_find;
- useSource = FALSE;
- break;
- case FM_EITHER:
- if ( sAvail && !oiAvail) { useSource = TRUE; break; }
- if (!sAvail && oiAvail) { useSource = FALSE; break; }
- useSource = firstTimeIsLater ( sTime, oiTime ) ? TRUE : FALSE;
- break;
- default:
- internal("parseModuleOrInterface");
- }
-
- /* Actually do the parsing. */
- if (useSource) {
- module(mod).srcExt = findText(sExt);
- setCurrentFile(mod);
- strcpy(name, path);
- strcat(name, textToStr(mt));
- strcat(name, sExt);
- module(mod).tree = parseModule(name,sSize);
- module(mod).uses = getModuleImports(module(mod).tree);
- module(mod).mode = FM_SOURCE;
- module(mod).lastStamp = sTime;
- } else {
- module(mod).srcExt = findText(HI_ENDING);
- setCurrentFile(mod);
- strcpy(name, path);
- strcat(name, textToStr(mt));
- strcat(name, DLL_ENDING);
- module(mod).objName = findText(name);
- module(mod).objSize = oSize;
- strcpy(name, path);
- strcat(name, textToStr(mt));
- strcat(name, ".u_hi");
- module(mod).tree = parseInterface(name,iSize);
- module(mod).uses = getInterfaceImports(module(mod).tree);
- module(mod).mode = FM_OBJECT;
- module(mod).lastStamp = oiTime;
- }
-
- if (path) free(path);
- return mod;
-
- cant_find:
- if (path) free(path);
- clearCurrentFile();
- ERRMSG(0)
- "Can't find %s for module \"%s\"",
- modeToString(modeRequest), textToStr(mt)
- EEND;
-}
-
-
-static void tryLoadGroup ( Cell grp )
-{
- Module m;
- List t;
- switch (whatIs(grp)) {
- case GRP_NONREC:
- m = findModule(textOf(snd(grp)));
- assert(nonNull(m));
- if (module(m).mode == FM_SOURCE) {
- processModule ( m );
- module(m).tree = NIL;
- } else {
- processInterfaces ( singleton(snd(grp)) );
- m = findModule(textOf(snd(grp)));
- assert(nonNull(m));
- module(m).tree = NIL;
- }
- break;
- case GRP_REC:
- for (t = snd(grp); nonNull(t); t=tl(t)) {
- m = findModule(textOf(hd(t)));
- assert(nonNull(m));
- if (module(m).mode == FM_SOURCE) {
- ERRMSG(0) "Source module \"%s\" imports itself recursively",
- textToStr(textOf(hd(t)))
- EEND;
- }
- }
- processInterfaces ( snd(grp) );
- for (t = snd(grp); nonNull(t); t=tl(t)) {
- m = findModule(textOf(hd(t)));
- assert(nonNull(m));
- module(m).tree = NIL;
- }
- break;
- default:
- internal("tryLoadGroup");
- }
-}
-
-
-static void fallBackToPrelModules ( void )
-{
- Module m;
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++)
- if (module(m).inUse
- && !varIsMember(module(m).text, prelModules))
- nukeModule(m);
-}
-
-
-/* This function catches exceptions in most of the system.
- So it's only ok for procedures called from this one
- to do EENDs (ie, write error messages). Others should use
- EEND_NO_LONGJMP.
-*/
-static void achieveTargetModules ( Bool loadingThePrelude )
-{
- volatile List ood;
- volatile List modgList;
- volatile List t;
- volatile Module mod;
- volatile Bool ok;
-
- String path = NULL;
- String sExt = NULL;
- Bool sAvail; Time sTime; Long sSize;
- Bool oiAvail; Time oiTime; Long oSize; Long iSize;
-
- volatile Time oisTime;
- volatile Bool out_of_date;
- volatile List ood_new;
- volatile List us;
- volatile List modgList_new;
- volatile List parsedButNotLoaded;
- volatile List toChase;
- volatile List trans_cl;
- volatile List trans_cl_new;
- volatile List u;
- volatile List mg;
- volatile List mg2;
- volatile Cell grp;
- volatile List badMods;
-
- setBreakAction ( HugsIgnoreBreak );
-
- /* First, examine timestamps to find out which modules are
- out of date with respect to the source/interface/object files.
- */
- ood = NIL;
- modgList = listFromMG();
-
- for (t = modgList; nonNull(t); t=tl(t)) {
-
- if (varIsMember(textOf(hd(t)),prelModules))
- continue;
-
- mod = findModule(textOf(hd(t)));
- if (isNull(mod)) internal("achieveTargetSet(1)");
-
- /* In standalone mode, only succeeds for source modules. */
- ok = findFilesForModule (
- textToStr(module(mod).text),
- &path,
- &sExt,
- &sAvail, &sTime, &sSize,
- &oiAvail, &oiTime, &oSize, &iSize
- );
-
- if (!combined && !sAvail) ok = FALSE;
- if (!ok) {
- fallBackToPrelModules();
- ERRMSG(0)
- "Can't find source or object+interface for module \"%s\"",
- textToStr(module(mod).text)
- EEND_NO_LONGJMP;
- if (path) free(path);
- return;
- }
-
- if (sAvail && oiAvail) {
- oisTime = whicheverIsLater(sTime,oiTime);
- }
- else if (sAvail && !oiAvail) {
- oisTime = sTime;
- }
- else if (!sAvail && oiAvail) {
- oisTime = oiTime;
- }
- else {
- internal("achieveTargetSet(2)");
- }
-
- out_of_date = firstTimeIsLater(oisTime,module(mod).lastStamp);
- if (out_of_date) {
- assert(!varIsMember(textOf(hd(t)),ood));
- ood = cons(hd(t),ood);
- }
-
- if (path) { free(path); path = NULL; };
- }
-
- /* Second, form a simplistic transitive closure of the out-of-date
- modules: a module is out of date if it imports an out-of-date
- module.
- */
- while (1) {
- ood_new = NIL;
- for (t = modgList; nonNull(t); t=tl(t)) {
- mod = findModule(textOf(hd(t)));
- assert(nonNull(mod));
- for (us = module(mod).uses; nonNull(us); us=tl(us))
- if (varIsMember(textOf(hd(us)),ood))
- break;
- if (nonNull(us)) {
- if (varIsMember(textOf(hd(t)),prelModules))
- Printf ( "warning: prelude module \"%s\" is out-of-date\n",
- textToStr(textOf(hd(t))) );
- else
- if (!varIsMember(textOf(hd(t)),ood_new) &&
- !varIsMember(textOf(hd(t)),ood))
- ood_new = cons(hd(t),ood_new);
- }
- }
- if (isNull(ood_new)) break;
- ood = appendOnto(ood_new,ood);
- }
-
- /* Now ood holds the entire set of modules which are out-of-date.
- Throw them out of the system, yielding a "reduced system",
- in which the remaining modules are in-date.
- */
- for (t = ood; nonNull(t); t=tl(t)) {
- mod = findModule(textOf(hd(t)));
- assert(nonNull(mod));
- nukeModule(mod);
- }
- modgList_new = NIL;
- for (t = modgList; nonNull(t); t=tl(t))
- if (!varIsMember(textOf(hd(t)),ood))
- modgList_new = cons(hd(t),modgList_new);
- modgList = modgList_new;
-
- /* Update the module group list to reflect the reduced system.
- We do this so that if the following parsing phases fail, we can
- safely fall back to the reduced system.
- */
- mgFromList ( modgList );
-
- /* Parse modules/interfaces, collecting parse trees and chasing
- imports, starting from the target set.
- */
- toChase = dupList(targetModules);
- for (t = toChase; nonNull(t); t=tl(t)) {
- Cell mode = (!combined)
- ? FM_SOURCE
- : ( (loadingThePrelude && combined)
- ? FM_OBJECT
- : FM_EITHER );
- hd(t) = zpair(hd(t), mode);
- }
-
- /* toChase :: [ ((ConId, {FM_SOURCE|FM_OBJECT|FM_EITHER} )) ] */
-
- parsedButNotLoaded = NIL;
-
-
- while (nonNull(toChase)) {
- ConId mc = zfst(hd(toChase));
- Cell mode = zsnd(hd(toChase));
- toChase = tl(toChase);
- if (varIsMember(textOf(mc),modgList)
- || varIsMember(textOf(mc),parsedButNotLoaded)) {
- /* either exists fully, or is at least parsed */
- mod = findModule(textOf(mc));
- assert(nonNull(mod));
- if (!compatibleNewMode(mode,module(mod).mode)) {
- clearCurrentFile();
- ERRMSG(0)
- "module %s: %s required, but %s is more recent",
- textToStr(textOf(mc)), modeToString(mode),
- modeToString(module(mod).mode)
- EEND_NO_LONGJMP;
- goto parseException;
- }
- } else {
-
- setBreakAction ( HugsLongjmpOnBreak );
- if (setjmp(catch_error)==0) {
- /* try this; it may throw an exception */
- mod = parseModuleOrInterface ( mc, mode );
- } else {
- /* here's the exception handler, if parsing fails */
- /* A parse error (or similar). Clean up and abort. */
- parseException:
- setBreakAction ( HugsIgnoreBreak );
- mod = findModule(textOf(mc));
- if (nonNull(mod)) nukeModule(mod);
- for (t = parsedButNotLoaded; nonNull(t); t=tl(t)) {
- mod = findModule(textOf(hd(t)));
- assert(nonNull(mod));
- if (nonNull(mod)) nukeModule(mod);
- }
- return;
- /* end of the exception handler */
- }
- setBreakAction ( HugsIgnoreBreak );
-
- parsedButNotLoaded = cons(mc, parsedButNotLoaded);
- for (t = module(mod).uses; nonNull(t); t=tl(t))
- toChase = cons(
- zpair( hd(t), childMode(mode,module(mod).mode) ),
- toChase);
- }
- }
-
- modgList = dupOnto(parsedButNotLoaded, modgList);
-
- /* We successfully parsed all modules reachable from the target
- set which were not part of the reduced system. However, there
- may be modules in the reduced system which are not reachable from
- the target set. We detect these now by building the transitive
- closure of the target set, and nuking modules in the reduced
- system which are not part of that closure.
- */
- trans_cl = dupList(targetModules);
- while (1) {
- trans_cl_new = NIL;
- for (t = trans_cl; nonNull(t); t=tl(t)) {
- mod = findModule(textOf(hd(t)));
- assert(nonNull(mod));
- for (u = module(mod).uses; nonNull(u); u=tl(u))
- if (!varIsMember(textOf(hd(u)),trans_cl)
- && !varIsMember(textOf(hd(u)),trans_cl_new)
- && !varIsMember(textOf(hd(u)),prelModules))
- trans_cl_new = cons(hd(u),trans_cl_new);
- }
- if (isNull(trans_cl_new)) break;
- trans_cl = appendOnto(trans_cl_new,trans_cl);
- }
- modgList_new = NIL;
- for (t = modgList; nonNull(t); t=tl(t)) {
- if (varIsMember(textOf(hd(t)),trans_cl)) {
- modgList_new = cons(hd(t),modgList_new);
- } else {
- mod = findModule(textOf(hd(t)));
- assert(nonNull(mod));
- nukeModule(mod);
- }
- }
- modgList = modgList_new;
-
- /* Now, the module symbol tables hold exactly the set of
- modules reachable from the target set, and modgList holds
- their names. Calculate the scc-ified module graph,
- since we need that to guide the next stage, that of
- Actually Loading the modules.
-
- If no errors occur, moduleGraph will reflect the final graph
- loaded. If an error occurs loading a group, we nuke
- that group, truncate the moduleGraph just prior to that
- group, and exit. That leaves the system having successfully
- loaded all groups prior to the one which failed.
- */
- mgFromList ( modgList );
-
- for (mg = moduleGraph; nonNull(mg); mg=tl(mg)) {
- grp = hd(mg);
-
- if (!varIsMember(textOf(selectArbitrarilyFromGroup(grp)),
- parsedButNotLoaded)) continue;
-
- setBreakAction ( HugsLongjmpOnBreak );
- if (setjmp(catch_error)==0) {
- /* try this; it may throw an exception */
- tryLoadGroup(grp);
- } else {
- /* here's the exception handler, if static/typecheck etc fails */
- /* nuke the entire rest (ie, the unloaded part)
- of the module graph */
- setBreakAction ( HugsIgnoreBreak );
- badMods = listFromSpecifiedMG ( mg );
- for (t = badMods; nonNull(t); t=tl(t)) {
- mod = findModule(textOf(hd(t)));
- if (nonNull(mod)) nukeModule(mod);
- }
- /* truncate the module graph just prior to this group. */
- mg2 = NIL;
- mg = moduleGraph;
- while (TRUE) {
- if (isNull(mg)) break;
- if (hd(mg) == grp) break;
- mg2 = cons ( hd(mg), mg2 );
- mg = tl(mg);
- }
- moduleGraph = reverse(mg2);
- return;
- /* end of the exception handler */
- }
- setBreakAction ( HugsIgnoreBreak );
- }
-
- /* Err .. I think that's it. If we get here, we've successfully
- achieved the target set. Phew!
- */
- setBreakAction ( HugsIgnoreBreak );
-}
-
-
-static Bool loadThePrelude ( void )
-{
- Bool ok;
- ConId conPrelude;
- ConId conPrelHugs;
- moduleGraph = prelModules = NIL;
-
- if (combined) {
- conPrelude = mkCon(findText("Prelude"));
- conPrelHugs = mkCon(findText("PrelHugs"));
- targetModules = doubleton(conPrelude,conPrelHugs);
- achieveTargetModules(TRUE);
- ok = elemMG(conPrelude) && elemMG(conPrelHugs);
- } else {
- conPrelude = mkCon(findText("Prelude"));
- targetModules = singleton(conPrelude);
- achieveTargetModules(TRUE);
- ok = elemMG(conPrelude);
- }
-
- if (ok) prelModules = listFromMG();
- return ok;
-}
-
-
-/* Refresh the current target modules, and attempt to set the
- current module to what it was before (ie currentModule):
- if currentModule_failed is different from currentModule,
- use that instead
- if nextCurrMod is non null, try to set it to that instead
- if the one we're after insn't available, select a target
- from the end of the module group list.
-*/
-static void refreshActions ( ConId nextCurrMod, Bool cleanAfter )
-{
- List t;
- ConId tryFor;
-
- /* Remember what the old current module was. */
- tryFor = mkCon(module(currentModule).text);
-
- /* Do the Real Work. */
- achieveTargetModules(FALSE);
-
- /* Remember if the current module was invalidated by this
- refresh, so later refreshes can attempt to reload it. */
- if (!elemMG(tryFor))
- currentModule_failed = tryFor;
-
- /* If a previous refresh failed to get an old current module,
- try for that instead. */
- if (nonNull(currentModule_failed)
- && textOf(currentModule_failed) != textOf(tryFor)
- && elemMG(currentModule_failed))
- tryFor = currentModule_failed;
- /* If our caller specified a new current module, that overrides
- all historical settings. */
- if (nonNull(nextCurrMod))
- tryFor = nextCurrMod;
- /* Finally, if we can't actually get hold of whatever it was we
- were after, select something which is possible. */
- if (!elemMG(tryFor))
- tryFor = selectLatestMG();
-
- /* combined mode kludge, to get Prelude rather than PrelHugs */
- if (combined && textOf(tryFor)==findText("PrelHugs"))
- tryFor = mkCon(findText("Prelude"));
-
- if (cleanAfter) {
- /* delete any targetModules which didn't actually get loaded */
- t = targetModules;
- targetModules = NIL;
- for (; nonNull(t); t=tl(t))
- if (elemMG(hd(t)))
- targetModules = cons(hd(t),targetModules);
- }
-
- setCurrModule ( findModule(textOf(tryFor)) );
- Printf("Hugs session for:\n");
- ppMG();
-}
-
-
-static void addActions ( List extraModules /* :: [CONID] */ )
-{
- List t;
- for (t = extraModules; nonNull(t); t=tl(t)) {
- ConId extra = hd(t);
- if (!varIsMember(textOf(extra),targetModules))
- targetModules = cons(extra,targetModules);
- }
- refreshActions ( isNull(extraModules)
- ? NIL
- : hd(reverse(extraModules)),
- TRUE
- );
-}
-
-
-static void loadActions ( List loadModules /* :: [CONID] */ )
-{
- List t;
- targetModules = dupList ( prelModules );
-
- for (t = loadModules; nonNull(t); t=tl(t)) {
- ConId load = hd(t);
- if (!varIsMember(textOf(load),targetModules))
- targetModules = cons(load,targetModules);
- }
- refreshActions ( isNull(loadModules)
- ? NIL
- : hd(reverse(loadModules)),
- TRUE
- );
-}
-
-
-/* --------------------------------------------------------------------------
- * Access to external editor:
- * ------------------------------------------------------------------------*/
-
-/* ToDo: All this editor stuff needs fixing. */
-
-static Void local editor() { /* interpreter-editor interface */
-#if 0
- String newFile = readFilename();
- if (newFile) {
- setLastEdit(newFile,0);
- if (readFilename()) {
- ERRMSG(0) "Multiple filenames not permitted"
- EEND;
- }
- }
- runEditor();
-#endif
-}
-
-static Void local find() { /* edit file containing definition */
-#if 0
-ToDo: Fix!
- String nm = readFilename(); /* of specified name */
- if (!nm) {
- ERRMSG(0) "No name specified"
- EEND;
- }
- else if (readFilename()) {
- ERRMSG(0) "Multiple names not permitted"
- EEND;
- }
- else {
- Text t;
- Cell c;
- setCurrModule(findEvalModule());
- startNewScript(0);
- if (nonNull(c=findTycon(t=findText(nm)))) {
- if (startEdit(tycon(c).line,scriptName[scriptThisTycon(c)])) {
- readScripts(N_PRELUDE_SCRIPTS);
- }
- } else if (nonNull(c=findName(t))) {
- if (startEdit(name(c).line,scriptName[scriptThisName(c)])) {
- readScripts(N_PRELUDE_SCRIPTS);
- }
- } else {
- ERRMSG(0) "No current definition for name \"%s\"", nm
- EEND;
- }
- }
-#endif
-}
-
-static Void local runEditor() { /* run editor on script lastEdit */
-#if 0
- if (startEdit(lastEdLine,lastEdit)) /* at line lastEdLine */
- readScripts(N_PRELUDE_SCRIPTS);
-#endif
-}
-
-static Void local setLastEdit(fname,line)/* keep name of last file to edit */
-String fname;
-Int line; {
-#if 0
- if (lastEdit)
- free(lastEdit);
- lastEdit = strCopy(fname);
- lastEdLine = line;
-#endif
-}
-
-/* --------------------------------------------------------------------------
- * Read and evaluate an expression:
- * ------------------------------------------------------------------------*/
-
-static Void setModule ( void ) {
- /*set module in which to evaluate expressions*/
- Module m;
- ConId mc = NIL;
- String s = readFilename();
- if (!s) {
- mc = selectLatestMG();
- if (combined && textOf(mc)==findText("PrelHugs"))
- mc = mkCon(findText("Prelude"));
- m = findModule(textOf(mc));
- assert(nonNull(m));
- } else {
- m = findModule(findText(s));
- if (isNull(m)) {
- ERRMSG(0) "Cannot find module \"%s\"", s
- EEND_NO_LONGJMP;
- return;
- }
- }
- setCurrModule(m);
-}
-
-static Module allocEvalModule ( void )
-{
- Module evalMod = newModule( findText("_Eval_Module_") );
- module(evalMod).names = module(currentModule).names;
- module(evalMod).tycons = module(currentModule).tycons;
- module(evalMod).classes = module(currentModule).classes;
- module(evalMod).qualImports
- = singleton(pair(mkCon(textPrelude),modulePrelude));
- return evalMod;
-}
-
-static Void local evaluator() { /* evaluate expr and print value */
- volatile Type type;
- volatile Type bd;
- volatile Kinds ks = NIL;
- volatile Module evalMod = allocEvalModule();
- volatile Module currMod = currentModule;
- setCurrModule(evalMod);
- currentFile = NULL;
-
- defaultDefns = combined ? stdDefaults : evalDefaults;
-
- setBreakAction ( HugsLongjmpOnBreak );
- if (setjmp(catch_error)==0) {
- /* try this */
- parseExp();
- checkExp();
- type = typeCheckExp(TRUE);
- } else {
- /* if an exception happens, we arrive here */
- setBreakAction ( HugsIgnoreBreak );
- goto cleanup_and_return;
- }
-
- setBreakAction ( HugsIgnoreBreak );
- if (isPolyType(type)) {
- ks = polySigOf(type);
- bd = monotypeOf(type);
- }
- else
- bd = type;
-
- if (whatIs(bd)==QUAL) {
- printing = FALSE;
- clearCurrentFile();
- ERRMSG(0) "Unresolved overloading" ETHEN
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n"
- EEND_NO_LONGJMP;
- goto cleanup_and_return;
- }
-
-#if 1
- printing = TRUE;
- numEnters = 0;
- if (isProgType(ks,bd)) {
- inputExpr = ap(nameRunIO_toplevel,inputExpr);
- evalExp();
- Putchar('\n');
- } else {
- Cell d = provePred(ks,NIL,ap(classShow,bd));
- if (isNull(d)) {
- clearCurrentFile();
- printing = FALSE;
- ERRMSG(0) "Cannot find \"show\" function for:" ETHEN
- ERRTEXT "\n*** expression : " ETHEN ERREXPR(inputExpr);
- ERRTEXT "\n*** of type : " ETHEN ERRTYPE(type);
- ERRTEXT "\n"
- EEND_NO_LONGJMP;
- goto cleanup_and_return;
- }
- inputExpr = ap2(nameShow, d,inputExpr);
- inputExpr = ap (namePutStr, inputExpr);
- inputExpr = ap (nameRunIO_toplevel, inputExpr);
-
- evalExp(); printf("\n");
- if (addType) {
- printf(" :: ");
- printType(stdout,type);
- Putchar('\n');
- }
- }
-
-#else
-
- printf ( "result type is " );
- printType ( stdout, type );
- printf ( "\n" );
- evalExp();
- printf ( "\n" );
-
-#endif
-
- cleanup_and_return:
- setBreakAction ( HugsIgnoreBreak );
- nukeModule(evalMod);
- setCurrModule(currMod);
- setCurrentFile(currMod);
- stopAnyPrinting();
-}
-
-
-
-/* --------------------------------------------------------------------------
- * Print type of input expression:
- * ------------------------------------------------------------------------*/
-
-static Void showtype ( void ) { /* print type of expression (if any)*/
-
- volatile Cell type;
- volatile Module evalMod = allocEvalModule();
- volatile Module currMod = currentModule;
- setCurrModule(evalMod);
-
- if (setjmp(catch_error)==0) {
- /* try this */
- parseExp();
- checkExp();
- defaultDefns = evalDefaults;
- type = typeCheckExp(FALSE);
- printExp(stdout,inputExpr);
- Printf(" :: ");
- printType(stdout,type);
- Putchar('\n');
- } else {
- /* if an exception happens, we arrive here */
- }
-
- nukeModule(evalMod);
- setCurrModule(currMod);
-}
-
-
-static Void local browseit(mod,t,all)
-Module mod;
-String t;
-Bool all; {
- if (nonNull(mod)) {
- Cell cs;
- if (nonNull(t))
- Printf("module %s where\n",textToStr(module(mod).text));
- for (cs = module(mod).names; nonNull(cs); cs=tl(cs)) {
- Name nm = hd(cs);
- /* only look at things defined in this module,
- unless `all' flag is set */
- if (all || name(nm).mod == mod) {
- /* unwanted artifacts, like lambda lifted values,
- are in the list of names, but have no types */
- if (nonNull(name(nm).type)) {
- printExp(stdout,nm);
- Printf(" :: ");
- printType(stdout,name(nm).type);
- if (isCfun(nm)) {
- Printf(" -- data constructor");
- } else if (isMfun(nm)) {
- Printf(" -- class member");
- } else if (isSfun(nm)) {
- Printf(" -- selector function");
- }
- Printf("\n");
- }
- }
- }
- } else {
- if (isNull(mod)) {
- Printf("Unknown module %s\n",t);
- }
- }
-}
-
-static Void local browse() { /* browse modules */
- Int count = 0; /* or give menu of commands */
- String s;
- Bool all = FALSE;
-
- for (; (s=readFilename())!=0; count++)
- if (strcmp(s,"all") == 0) {
- all = TRUE;
- --count;
- } else
- browseit(findModule(findText(s)),s,all);
- if (count == 0) {
- browseit(currentModule,NULL,all);
- }
-}
-
-#if EXPLAIN_INSTANCE_RESOLUTION
-static Void local xplain() { /* print type of expression (if any)*/
- Cell d;
- Bool sir = showInstRes;
-
- setCurrModule(findEvalModule());
- startNewScript(0); /* Enables recovery of storage */
- /* allocated during evaluation */
- parseContext();
- checkContext();
- showInstRes = TRUE;
- d = provePred(NIL,NIL,hd(inputContext));
- if (isNull(d)) {
- fprintf(stdout, "not Sat\n");
- } else {
- fprintf(stdout, "Sat\n");
- }
- showInstRes = sir;
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * Enhanced help system: print current list of scripts or give information
- * about an object.
- * ------------------------------------------------------------------------*/
-
-static String local objToStr(m,c)
-Module m;
-Cell c; {
-#if 1 || DISPLAY_QUANTIFIERS
- static char newVar[60];
- switch (whatIs(c)) {
- case NAME : if (m == name(c).mod) {
- sprintf(newVar,"%s", textToStr(name(c).text));
- } else {
- sprintf(newVar,"%s.%s",
- textToStr(module(name(c).mod).text),
- textToStr(name(c).text));
- }
- break;
-
- case TYCON : if (m == tycon(c).mod) {
- sprintf(newVar,"%s", textToStr(tycon(c).text));
- } else {
- sprintf(newVar,"%s.%s",
- textToStr(module(tycon(c).mod).text),
- textToStr(tycon(c).text));
- }
- break;
-
- case CLASS : if (m == cclass(c).mod) {
- sprintf(newVar,"%s", textToStr(cclass(c).text));
- } else {
- sprintf(newVar,"%s.%s",
- textToStr(module(cclass(c).mod).text),
- textToStr(cclass(c).text));
- }
- break;
-
- default : internal("objToStr");
- }
- return newVar;
-#else
- static char newVar[33];
- switch (whatIs(c)) {
- case NAME : sprintf(newVar,"%s", textToStr(name(c).text));
- break;
-
- case TYCON : sprintf(newVar,"%s", textToStr(tycon(c).text));
- break;
-
- case CLASS : sprintf(newVar,"%s", textToStr(cclass(c).text));
- break;
-
- default : internal("objToStr");
- }
- return newVar;
-#endif
-}
-
-extern Name nameHw;
-
-static Void dumpStg ( void )
-{
- String s;
- Int i;
-#if 0
- Whats this for?
- setCurrModule(findEvalModule());
- startNewScript(0);
-#endif
- s = readFilename();
-
- /* request to locate a symbol by name */
- if (s && (*s == '?')) {
- Text t = findText(s+1);
- locateSymbolByName(t);
- return;
- }
-
- /* request to dump a bit of the heap */
- if (s && (*s == '-' || isdigit(*s))) {
- int i = atoi(s);
- print(i,100);
- printf("\n");
- return;
- }
-
- /* request to dump a symbol table entry */
- if (!s
- || !(*s == 't' || *s == 'n' || *s == 'c' || *s == 'i')
- || !isdigit(s[1])) {
- fprintf(stderr, ":d -- bad request `%s'\n", s );
- return;
- }
- i = atoi(s+1);
- switch (*s) {
- case 't': dumpTycon(i); break;
- case 'n': dumpName(i); break;
- case 'c': dumpClass(i); break;
- case 'i': dumpInst(i); break;
- default: fprintf(stderr, ":d -- `%c' not implemented\n", *s );
- }
-}
-
-
-#if 0
-static Void local dumpStg( void ) { /* print STG stuff */
- String s;
- Text t;
- Name n;
- Int i;
- Cell v; /* really StgVar */
- setCurrModule(findEvalModule());
- startNewScript(0);
- for (; (s=readFilename())!=0;) {
- t = findText(s);
- v = n = NIL;
- /* find the name while ignoring module scopes */
- for (i=NAMEMIN; i<nameHw; i++)
- if (name(i).text == t) n = i;
-
- /* perhaps it's an "idNNNNNN" thing? */
- if (isNull(n) &&
- strlen(s) >= 3 &&
- s[0]=='i' && s[1]=='d' && isdigit(s[2])) {
- v = 0;
- i = 2;
- while (isdigit(s[i])) {
- v = v * 10 + (s[i]-'0');
- i++;
- }
- v = -v;
- n = nameFromStgVar(v);
- }
-
- if (isNull(n) && whatIs(v)==STGVAR) {
- Printf ( "\n{- `%s' has no nametable entry -}\n", s );
- printStg(stderr, v );
- } else
- if (isNull(n)) {
- Printf ( "Unknown reference `%s'\n", s );
- } else
- if (!isName(n)) {
- Printf ( "Not a Name: `%s'\n", s );
- } else
- if (isNull(name(n).stgVar)) {
- Printf ( "Doesn't have a STG tree: %s\n", s );
- } else {
- Printf ( "\n{- stgVar of `%s' is id%d -}\n", s, -name(n).stgVar);
- printStg(stderr, name(n).stgVar);
- }
- }
-}
-#endif
-
-static Void local info() { /* describe objects */
- Int count = 0; /* or give menu of commands */
- String s;
-
- for (; (s=readFilename())!=0; count++) {
- describe(findText(s));
- }
- if (count == 0) {
- /* whatScripts(); */
- }
-}
-
-
-static Void local describe(t) /* describe an object */
-Text t; {
- Tycon tc = findTycon(t);
- Class cl = findClass(t);
- Name nm = findName(t);
-
- if (nonNull(tc)) { /* as a type constructor */
- Type t = tc;
- Int i;
- Inst in;
- for (i=0; i<tycon(tc).arity; ++i) {
- t = ap(t,mkOffset(i));
- }
- Printf("-- type constructor");
- if (kindExpert) {
- Printf(" with kind ");
- printKind(stdout,tycon(tc).kind);
- }
- Putchar('\n');
- switch (tycon(tc).what) {
- case SYNONYM : Printf("type ");
- printType(stdout,t);
- Printf(" = ");
- printType(stdout,tycon(tc).defn);
- break;
-
- case NEWTYPE :
- case DATATYPE : { List cs = tycon(tc).defn;
- if (tycon(tc).what==DATATYPE) {
- Printf("data ");
- } else {
- Printf("newtype ");
- }
- printType(stdout,t);
- Putchar('\n');
- mapProc(printSyntax,cs);
- if (hasCfun(cs)) {
- Printf("\n-- constructors:");
- }
- for (; hasCfun(cs); cs=tl(cs)) {
- Putchar('\n');
- printExp(stdout,hd(cs));
- Printf(" :: ");
- printType(stdout,name(hd(cs)).type);
- }
- if (nonNull(cs)) {
- Printf("\n-- selectors:");
- }
- for (; nonNull(cs); cs=tl(cs)) {
- Putchar('\n');
- printExp(stdout,hd(cs));
- Printf(" :: ");
- printType(stdout,name(hd(cs)).type);
- }
- }
- break;
-
- case RESTRICTSYN : Printf("type ");
- printType(stdout,t);
- Printf(" = <restricted>");
- break;
- }
- Putchar('\n');
- if (nonNull(in=findFirstInst(tc))) {
- Printf("\n-- instances:\n");
- do {
- showInst(in);
- in = findNextInst(tc,in);
- } while (nonNull(in));
- }
- Putchar('\n');
- }
-
- if (nonNull(cl)) { /* as a class */
- List ins = cclass(cl).instances;
- Kinds ks = cclass(cl).kinds;
- if (nonNull(ks) && isNull(tl(ks)) && hd(ks)==STAR) {
- Printf("-- type class");
- } else {
- Printf("-- constructor class");
- if (kindExpert) {
- Printf(" with arity ");
- printKinds(stdout,ks);
- }
- }
- Putchar('\n');
- mapProc(printSyntax,cclass(cl).members);
- Printf("class ");
- if (nonNull(cclass(cl).supers)) {
- printContext(stdout,cclass(cl).supers);
- Printf(" => ");
- }
- printPred(stdout,cclass(cl).head);
-
- if (nonNull(cclass(cl).fds)) {
- List fds = cclass(cl).fds;
- String pre = " | ";
- for (; nonNull(fds); fds=tl(fds)) {
- Printf(pre);
- printFD(stdout,hd(fds));
- pre = ", ";
- }
- }
-
- if (nonNull(cclass(cl).members)) {
- List ms = cclass(cl).members;
- Printf(" where");
- do {
- Type t = name(hd(ms)).type;
- if (isPolyType(t)) {
- t = monotypeOf(t);
- }
- Printf("\n ");
- printExp(stdout,hd(ms));
- Printf(" :: ");
- if (isNull(tl(fst(snd(t))))) {
- t = snd(snd(t));
- } else {
- t = ap(QUAL,pair(tl(fst(snd(t))),snd(snd(t))));
- }
- printType(stdout,t);
- ms = tl(ms);
- } while (nonNull(ms));
- }
- Putchar('\n');
- if (nonNull(ins)) {
- Printf("\n-- instances:\n");
- do {
- showInst(hd(ins));
- ins = tl(ins);
- } while (nonNull(ins));
- }
- Putchar('\n');
- }
-
- if (nonNull(nm)) { /* as a function/name */
- printSyntax(nm);
- printExp(stdout,nm);
- Printf(" :: ");
- if (nonNull(name(nm).type)) {
- printType(stdout,name(nm).type);
- } else {
- Printf("<unknown type>");
- }
- if (isCfun(nm)) {
- Printf(" -- data constructor");
- } else if (isMfun(nm)) {
- Printf(" -- class member");
- } else if (isSfun(nm)) {
- Printf(" -- selector function");
- }
- Printf("\n\n");
- }
-
-
- if (isNull(tc) && isNull(cl) && isNull(nm)) {
- Printf("Unknown reference `%s'\n",textToStr(t));
- }
-}
-
-static Void local printSyntax(nm)
-Name nm; {
- Syntax sy = syntaxOf(nm);
- Text t = name(nm).text;
- String s = textToStr(t);
- if (sy != defaultSyntax(t)) {
- Printf("infix");
- switch (assocOf(sy)) {
- case LEFT_ASS : Putchar('l'); break;
- case RIGHT_ASS : Putchar('r'); break;
- case NON_ASS : break;
- }
- Printf(" %i ",precOf(sy));
- if (isascii((int)(*s)) && isalpha((int)(*s))) {
- Printf("`%s`",s);
- } else {
- Printf("%s",s);
- }
- Putchar('\n');
- }
-}
-
-static Void local showInst(in) /* Display instance decl header */
-Inst in; {
- Printf("instance ");
- if (nonNull(inst(in).specifics)) {
- printContext(stdout,inst(in).specifics);
- Printf(" => ");
- }
- printPred(stdout,inst(in).head);
- Putchar('\n');
-}
-
-/* --------------------------------------------------------------------------
- * List all names currently in scope:
- * ------------------------------------------------------------------------*/
-
-static Void local listNames() { /* list names matching optional pat*/
- String pat = readFilename();
- List names = NIL;
- Int width = 72;
- Int count = 0;
- Int termPos;
- Module mod = currentModule;
-
- if (pat) { /* First gather names to list */
- do {
- names = addNamesMatching(pat,names);
- } while ((pat=readFilename())!=0);
- } else {
- names = addNamesMatching((String)0,names);
- }
- if (isNull(names)) { /* Then print them out */
- clearCurrentFile();
- ERRMSG(0) "No names selected"
- EEND_NO_LONGJMP;
- return;
- }
- for (termPos=0; nonNull(names); names=tl(names)) {
- String s = objToStr(mod,hd(names));
- Int l = strlen(s);
- if (termPos+1+l>width) {
- Putchar('\n');
- termPos = 0;
- } else if (termPos>0) {
- Putchar(' ');
- termPos++;
- }
- Printf("%s",s);
- termPos += l;
- count++;
- }
- Printf("\n(%d names listed)\n", count);
-}
-
-/* --------------------------------------------------------------------------
- * print a prompt and read a line of input:
- * ------------------------------------------------------------------------*/
-
-static Void local promptForInput(moduleName)
-String moduleName; {
- char promptBuffer[1000];
-#if 1
- /* This is portable but could overflow buffer */
- sprintf(promptBuffer,prompt,moduleName);
-#else
- /* Works on ANSI C - but pre-ANSI compilers return a pointer to
- * promptBuffer instead.
- */
- if (sprintf(promptBuffer,prompt,moduleName) >= 1000) {
- /* Reset prompt to a safe default to avoid an infinite loop */
- free(prompt);
- prompt = strCopy("? ");
- internal("Combined prompt and evaluation module name too long");
- }
-#endif
- if (autoMain)
- stringInput("main\0"); else
- consoleInput(promptBuffer);
-}
-
-/* --------------------------------------------------------------------------
- * main read-eval-print loop, with error trapping:
- * ------------------------------------------------------------------------*/
-
-static Void local interpreter(argc,argv)/* main interpreter loop */
-Int argc;
-String argv[]; {
-
- List modConIds; /* :: [CONID] */
- Bool prelOK;
- String s;
-
- setBreakAction ( HugsIgnoreBreak );
- modConIds = initialize(argc,argv); /* the initial modules to load */
- setBreakAction ( HugsIgnoreBreak );
- prelOK = loadThePrelude();
-
- if (!prelOK) {
- if (autoMain)
- fprintf(stderr, "hugs +Q: fatal error: can't load the Prelude.\n" );
- else
- fprintf(stderr, "hugs: fatal error: can't load the Prelude.\n" );
- exit(1);
- }
-
- if (combined) everybody(POSTPREL);
- loadActions(modConIds);
-
- if (autoMain) {
- for (; nonNull(modConIds); modConIds=tl(modConIds))
- if (!elemMG(hd(modConIds))) {
- fprintf(stderr,
- "hugs +Q: compilation failed -- can't run `main'\n" );
- exit(1);
- }
- }
-
- modConIds = NIL;
-
- /* initialize calls startupHaskell, which trashes our signal handlers */
- setBreakAction ( HugsIgnoreBreak );
- forHelp();
-
- for (;;) {
- Command cmd;
- everybody(RESET); /* reset to sensible initial state */
-
- promptForInput(textToStr(module(currentModule).text));
-
- cmd = readCommand(cmds, (Char)':', (Char)'!');
- switch (cmd) {
- case EDIT : editor();
- break;
- case FIND : find();
- break;
- case LOAD : modConIds = NIL;
- while ((s=readFilename())!=0) {
- modConIds = cons(mkCon(findText(s)),modConIds);
-
- }
- loadActions(modConIds);
- modConIds = NIL;
- break;
- case ALSO : modConIds = NIL;
- while ((s=readFilename())!=0)
- modConIds = cons(mkCon(findText(s)),modConIds);
- addActions(modConIds);
- modConIds = NIL;
- break;
- case RELOAD : refreshActions(NIL,FALSE);
- break;
- case SETMODULE :
- setModule();
- break;
- case EVAL : evaluator();
- break;
- case TYPEOF : showtype();
- break;
- case BROWSE : browse();
- break;
-#if EXPLAIN_INSTANCE_RESOLUTION
- case XPLAIN : xplain();
- break;
-#endif
- case NAMES : listNames();
- break;
- case HELP : menu();
- break;
- case BADCMD : guidance();
- break;
- case SET : set();
- break;
- case SYSTEM : if (shellEsc(readLine()))
- Printf("Warning: Shell escape terminated abnormally\n");
- break;
- case CHGDIR : changeDir();
- break;
- case INFO : info();
- break;
- case PNTVER: Printf("-- Hugs Version %s\n",
- HUGS_VERSION);
- break;
- case DUMP : dumpStg();
- break;
- case QUIT : return;
- case COLLECT: consGC = FALSE;
- garbageCollect();
- consGC = TRUE;
- Printf("Garbage collection recovered %d cells\n",
- cellsRecovered);
- break;
- case NOCMD : break;
- }
-
- if (autoMain) break;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Display progress towards goal:
- * ------------------------------------------------------------------------*/
-
-static Target currTarget;
-static Bool aiming = FALSE;
-static Int currPos;
-static Int maxPos;
-static Int charCount;
-
-Void setGoal(what, t) /* Set goal for what to be t */
-String what;
-Target t; {
- if (quiet)
- return;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- return;
-#endif
- currTarget = (t?t:1);
- aiming = TRUE;
- for (charCount=0; *what; charCount++)
- Putchar(*what++);
- FlushStdout();
-}
-
-Void soFar(t) /* Indicate progress towards goal */
-Target t; { /* has now reached t */
- if (quiet)
- return;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- return;
-#endif
-}
-
-Void done() { /* Goal has now been achieved */
- if (quiet)
- return;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- return;
-#endif
- for (; charCount>0; charCount--) {
- Putchar('\b');
- Putchar(' ');
- Putchar('\b');
- }
- aiming = FALSE;
- FlushStdout();
-}
-
-static Void local failed() { /* Goal cannot be reached due to */
- if (aiming) { /* errors */
- aiming = FALSE;
- Putchar('\n');
- FlushStdout();
- }
-}
-
-/* --------------------------------------------------------------------------
- * Error handling:
- * ------------------------------------------------------------------------*/
-
-static Void local stopAnyPrinting() { /* terminate printing of expression,*/
- if (printing) { /* after successful termination or */
- printing = FALSE; /* runtime error (e.g. interrupt) */
- Putchar('\n');
- if (showStats) {
-#define plural(v) v, (v==1?"":"s")
- Printf("(%lu enter%s)\n",plural(numEnters));
-#undef plural
- }
- FlushStdout();
- garbageCollect();
- }
-}
-
-Cell errAssert(l) /* message to use when raising asserts, etc */
-Int l; {
- Cell str;
- if (currentFile) {
- str = mkStr(findText(currentFile));
- } else {
- str = mkStr(findText(""));
- }
- return (ap2(nameTangleMessage,str,mkInt(l)));
-}
-
-Void errHead(l) /* print start of error message */
-Int l; {
- failed(); /* failed to reach target ... */
- stopAnyPrinting();
- FPrintf(errorStream,"ERROR");
-
- if (currentFile) {
- FPrintf(errorStream," \"%s\"", currentFile);
- setLastEdit(currentFile,l);
- if (l) FPrintf(errorStream," (line %d)",l);
- currentFile = NULL;
- }
- FPrintf(errorStream,": ");
- FFlush(errorStream);
-}
-
-Void errFail() { /* terminate error message and */
- Putc('\n',errorStream); /* produce exception to return to */
- FFlush(errorStream); /* main command loop */
- longjmp(catch_error,1);
-}
-
-Void errFail_no_longjmp() { /* terminate error message but */
- Putc('\n',errorStream); /* don't produce an exception */
- FFlush(errorStream);
-}
-
-Void errAbort() { /* altern. form of error handling */
- failed(); /* used when suitable error message*/
- stopAnyPrinting(); /* has already been printed */
- errFail();
-}
-
-Void internal(msg) /* handle internal error */
-String msg; {
- failed();
- stopAnyPrinting();
- Printf("INTERNAL ERROR: %s\n",msg);
- FlushStdout();
-exit(9);
- longjmp(catch_error,1);
-}
-
-Void fatal(msg) /* handle fatal error */
-String msg; {
- FlushStdout();
- Printf("\nFATAL ERROR: %s\n",msg);
- everybody(EXIT);
- exit(1);
-}
-
-
-/* --------------------------------------------------------------------------
- * Read value from environment variable or registry:
- * ------------------------------------------------------------------------*/
-
-String fromEnv(var,def) /* return value of: */
-String var; /* environment variable named by var */
-String def; { /* or: default value given by def */
- String s = getenv(var);
- return (s ? s : def);
-}
-
-/* --------------------------------------------------------------------------
- * String manipulation routines:
- * ------------------------------------------------------------------------*/
-
-static String local strCopy(s) /* make malloced copy of a string */
-String s; {
- if (s && *s) {
- char *t, *r;
- if ((t=(char *)malloc(strlen(s)+1))==0) {
- ERRMSG(0) "String storage space exhausted"
- EEND;
- }
- for (r=t; (*r++ = *s++)!=0; ) {
- }
- return t;
- }
- return NULL;
-}
-
-
-/* --------------------------------------------------------------------------
- * Compiler output
- * We can redirect compiler output (prompts, error messages, etc) by
- * tweaking these functions.
- * ------------------------------------------------------------------------*/
-
-#ifdef HAVE_STDARG_H
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-
-Void hugsEnableOutput(f)
-Bool f; {
- disableOutput = !f;
-}
-
-#ifdef HAVE_STDARG_H
-Void hugsPrintf(const char *fmt, ...) {
- va_list ap; /* pointer into argument list */
- va_start(ap, fmt); /* make ap point to first arg after fmt */
- if (!disableOutput) {
- vprintf(fmt, ap);
- } else {
- }
- va_end(ap); /* clean up */
-}
-#else
-Void hugsPrintf(fmt, va_alist)
-const char *fmt;
-va_dcl {
- va_list ap; /* pointer into argument list */
- va_start(ap); /* make ap point to first arg after fmt */
- if (!disableOutput) {
- vprintf(fmt, ap);
- } else {
- }
- va_end(ap); /* clean up */
-}
-#endif
-
-Void hugsPutchar(c)
-int c; {
- if (!disableOutput) {
- putchar(c);
- } else {
- }
-}
-
-Void hugsFlushStdout() {
- if (!disableOutput) {
- fflush(stdout);
- }
-}
-
-Void hugsFFlush(fp)
-FILE* fp; {
- if (!disableOutput) {
- fflush(fp);
- }
-}
-
-#ifdef HAVE_STDARG_H
-Void hugsFPrintf(FILE *fp, const char* fmt, ...) {
- va_list ap;
- va_start(ap, fmt);
- if (!disableOutput) {
- vfprintf(fp, fmt, ap);
- } else {
- }
- va_end(ap);
-}
-#else
-Void hugsFPrintf(FILE *fp, const char* fmt, va_list)
-FILE* fp;
-const char* fmt;
-va_dcl {
- va_list ap;
- va_start(ap);
- if (!disableOutput) {
- vfprintf(fp, fmt, ap);
- } else {
- }
- va_end(ap);
-}
-#endif
-
-Void hugsPutc(c, fp)
-int c;
-FILE* fp; {
- if (!disableOutput) {
- putc(c,fp);
- } else {
- }
-}
-
-/* --------------------------------------------------------------------------
- * Send message to each component of system:
- * ------------------------------------------------------------------------*/
-
-Void everybody(what) /* send command `what' to each component of*/
-Int what; { /* system to respond as appropriate ... */
-#if 0
- fprintf ( stderr, "EVERYBODY %d\n", what );
-#endif
- machdep(what); /* The order of calling each component is */
- storage(what); /* important for the PREPREL command */
- substitution(what);
- input(what);
- translateControl(what);
- linkControl(what);
- staticAnalysis(what);
- deriveControl(what);
- typeChecker(what);
- compiler(what);
- codegen(what);
- interfayce(what);
-
- if (what == MARK) {
- mark(moduleGraph);
- mark(prelModules);
- mark(targetModules);
- mark(daSccs);
- mark(currentModule_failed);
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Basic data type definitions, prototypes and standard macros including
- * machine dependent variations...
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: hugsbasictypes.h,v $
- * $Revision: 1.3 $
- * $Date: 2000/04/05 14:13:58 $
- * ------------------------------------------------------------------------*/
-
-#define NON_POSIX_SOURCE
-/* AJG: machdep.h needs this, for S_IREAD and S_IFREG in cygwin? */
-
-#include "config.h"
-#include "options.h"
-#include <stdio.h>
-
-/*---------------------------------------------------------------------------
- * Most of the configuration code from earlier versions of Hugs has been moved
- * into config.h (which is usually automatically generated).
- *
- * Most of the configuration code is "feature based". That is, the
- * configure script looks to see if a particular feature (or misfeature)
- * is present on the compiler/OS.
- *
- * A small amount of configuration code is still "system based": it tests
- * flags to determine what kind of compiler/system it's running on - from
- * which it infers what features the compiler/system has. Use of system
- * based tests generally indicates that we can't remember/figure out
- * what the original problem was and so we can't add an appropriate feature
- * test to the configure script.
- *-------------------------------------------------------------------------*/
-
-#ifdef __RISCOS__ /* Acorn DesktopC running RISCOS2 or 3 */
-# define RISCOS 1
-#else
-# define RISCOS 0
-#endif
-
-#if defined __DJGPP__ && __DJGPP__==2
-# define DJGPP2 1
-#else
-# define DJGPP2 0
-#endif
-
-#if defined __MSDOS__ && __MSDOS__ && !DJGPP2
-# define DOS 1
-#else
-# define DOS 0
-#endif
-
-#if defined _WIN32 | defined __WIN32__
-# define IS_WIN32 1
-#else
-# define IS_WIN32 0
-#endif
-
-/*---------------------------------------------------------------------------
- * Platform-dependent settings:
- *-------------------------------------------------------------------------*/
-
-/*---------------------------------------------------------------------------
- * Include windows.h and friends:
- *-------------------------------------------------------------------------*/
-
-#if HAVE_WINDOWS_H
-#include <windows.h> /* Misc. Windows hackery */
-#endif
-
-
-/*---------------------------------------------------------------------------
- * Macros used in declarations:
- * function prototypes
- * local/far declarations
- * HUGS_noreturn/HUGS_unused (prevent spurious warnings)
- * result type of main
- * dynamic linking declarations
- *-------------------------------------------------------------------------*/
-
-/* local = prefix for locally defined functions */
-/* far = prefix for far pointers */
-#if DOS
-# define local near pascal
-#else
-# define local
-# define far
-#endif
-
-#ifdef __GNUC__ /* Avoid spurious warnings */
-#if __GNUC__ >= 2 && __GNUC_MINOR__ >= 7
-#define HUGS_noreturn __attribute__ ((noreturn))
-#define HUGS_unused __attribute__ ((unused))
-#else
-#define HUGS_noreturn
-#define HUGS_unused
-#endif
-#else
-#define HUGS_noreturn
-#define HUGS_unused
-#endif
-
-/* result type of main function */
-/* Hugs 1.01 could be configured to return void on Unix-like systems
- * but I don't think this is necessary. ADR
- */
-#define Main int
-#define MainDone() return 0/*NOTUSED*/
-
-/*---------------------------------------------------------------------------
- * String operations:
- *-------------------------------------------------------------------------*/
-
-#if HAVE_STRING_H
-# include <string.h>
-#else
-extern int strcmp Args((const char*, const char*));
-extern int strncmp Args((const char*, const char*, int));
-extern char *strchr Args((const char*, int));
-extern char *strrchr Args((const char*, int));
-extern size_t strlen Args((const char *));
-extern char *strcpy Args((char *, const char*));
-extern char *strcat Args((char *, const char*));
-#endif
-#if HAVE_STRCMP
-#define strCompare strcmp
-#else /* probably only used for DOS - ADR */
-extern int stricmp Args((const char *, const char*));
-#define strCompare stricmp
-#endif
-
-#if HAVE_CTYPE_H
-# include <ctype.h>
-#endif
-#ifndef isascii
-#define isascii(c) (((unsigned)(c))<128)
-#endif
-
-/*---------------------------------------------------------------------------
- * Memory allocation
- *-------------------------------------------------------------------------*/
-
-#if HAVE_FARCALLOC
-# include <alloc.h>
-# define farCalloc(n,s) farcalloc((unsigned long)n,(unsigned long)s)
-#elif HAVE_VALLOC
-# include <stdlib.h>
-# include <malloc.h>
-# define farCalloc(n,s) (Void *)valloc(((unsigned)n)*((unsigned)s))
-#else
-# define farCalloc(n,s) (Void *)calloc(((unsigned)n),((unsigned)s))
-#endif
-
-/* bison-generated parsers like to have alloca - so try to define it */
-#if HAVE__ALLOCA
-#include <malloc.h>
-#ifndef alloca
-#define alloca _alloca
-#endif
-#endif
-
-/*---------------------------------------------------------------------------
- * Assertions
- *-------------------------------------------------------------------------*/
-
-#if HAVE_ASSERT_H
-#include <assert.h>
-#else
-#define assert(x) doNothing()
-#endif
-
-/*---------------------------------------------------------------------------
- * General settings:
- *-------------------------------------------------------------------------*/
-
-#define Void void /* older compilers object to: typedef void Void; */
-typedef unsigned Bool;
-#define TRUE 1
-#define FALSE 0
-
-typedef char *String;
-typedef int Int;
-typedef long Long;
-typedef int Char;
-typedef unsigned int Unsigned; /* at least 32 bits */
-typedef void* Ptr;
-typedef void* Addr;
-typedef void* HpPtr;
-
-#define FloatImpType double
-#define FloatPro double
-#define FloatFMT "%.9g"
-
-
-/* ToDo: this should probably go in dynamic.h - but then
- * storage.h has to include dynamic.h!
- */
-#if HAVE_WINDOWS_H && !defined(__MSDOS__)
-typedef HINSTANCE ObjectFile;
-#elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
-typedef void* ObjectFile;
-#elif HAVE_DL_H /* eg HPUX */
-typedef shl_t ObjectFile;
-#else
-#warning GHC file loading not available on this machine
-#endif
-
-#define doNothing() do { } while (0) /* Null statement */
-
-#ifndef STD_PRELUDE
-#if RISCOS
-#define STD_PRELUDE "prelude"
-#else
-#define STD_PRELUDE "Prelude.hs"
-#endif
-#endif
-
-/*---------------------------------------------------------------------------
- * Printf-related operations:
- *-------------------------------------------------------------------------*/
-
-#ifdef HAVE_STDARG_H
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-
-#if !defined(HAVE_SNPRINTF)
-extern int snprintf ( char*, int, const char*, ... );
-#endif
-
-#if !defined(HAVE_VSNPRINTF)
-extern int vsnprintf ( char*, int, const char*, va_list );
-#endif
-
-/*---------------------------------------------------------------------------
- * Compiler output
- * Tweaking this lets us redirect prompts, error messages, etc - but has no
- * effect on output of Haskell programs (which should use hPutStr and friends).
- *-------------------------------------------------------------------------*/
-
-extern Void hugsPrintf (const char *, ...);
-extern Void hugsPutchar (int);
-extern Void hugsFlushStdout (Void);
-extern Void hugsEnableOutput (Bool);
-
-extern Void hugsFFlush (FILE*);
-extern Void hugsFPrintf (FILE*, const char*, ...);
-extern Void hugsPutc (int, FILE*);
-
-#define Printf hugsPrintf
-#define Putchar hugsPutchar
-#define FlushStdout hugsFlushStdout
-#define EnableOutput hugsEnableOutput
-#define ClearOutputBuffer hugsClearOutputBuffer
-
-#define FFlush hugsFFlush
-#define FPrintf hugsFPrintf
-#define Putc hugsPutc
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* --------------------------------------------------------------------------
- * Input functions, lexical analysis parsing etc...
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: input.c,v $
- * $Revision: 1.30 $
- * $Date: 2000/04/25 17:43:49 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include <ctype.h>
-#if HAVE_GETDELIM_H
-#include "getdelim.h"
-#endif
-
-#if IS_WIN32
-#include <windows.h>
-#endif
-
-#if IS_WIN32
-#undef IN
-#endif
-
-#if HAVE_READLINE_LIBS && HAVE_READLINE_HEADERS
-#define USE_READLINE 1
-#else
-#define USE_READLINE 0
-#endif
-
-#if USE_READLINE
-#include <readline/readline.h>
-#include <readline/history.h>
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Global data:
- * ------------------------------------------------------------------------*/
-
-List tyconDefns = NIL; /* type constructor definitions */
-List typeInDefns = NIL; /* type synonym restrictions */
-List valDefns = NIL; /* value definitions in script */
-List classDefns = NIL; /* class defns in script */
-List instDefns = NIL; /* instance defns in script */
-List selDefns = NIL; /* list of selector lists */
-List genDefns = NIL; /* list of generated names */
-List unqualImports = NIL; /* unqualified import list */
-List foreignImports = NIL; /* foreign imports */
-List foreignExports = NIL; /* foreign exportsd */
-List defaultDefns = NIL; /* default definitions (if any) */
-Int defaultLine = 0; /* line in which default defs occur*/
-List evalDefaults = NIL; /* defaults for evaluator */
-
-Cell inputExpr = NIL; /* input expression */
-Cell inputContext = NIL; /* input context */
-Bool literateScripts = FALSE; /* TRUE => default to lit scripts */
-Bool literateErrors = TRUE; /* TRUE => report errs in lit scrs */
-Bool offsideON = TRUE; /* TRUE => implement offside rule */
-Bool readingInterface = FALSE;
-
-String repeatStr = 0; /* Repeat last expr */
-
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
-String preprocessor = 0;
-#endif
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local initCharTab ( Void );
-static Void local fileInput ( String,Long );
-static Bool local literateMode ( String );
-static Bool local linecmp ( String,String );
-static Int local nextLine ( Void );
-static Void local skip ( Void );
-static Void local thisLineIs ( Int );
-static Void local newlineSkip ( Void );
-static Void local closeAnyInput ( Void );
-
- Int yyparse ( Void ); /* can't stop yacc making this */
- /* public, but don't advertise */
- /* it in a header file. */
-
-static Void local endToken ( Void );
-static Text local readOperator ( Void );
-static Text local readIdent ( Void );
-static Cell local readRadixNumber ( Int );
-static Cell local readNumber ( Void );
-static Cell local readChar ( Void );
-static Cell local readString ( Void );
-static Void local saveStrChr ( Char );
-static Cell local readAChar ( Bool );
-
-static Bool local lazyReadMatches ( String );
-static Cell local readEscapeChar ( Bool );
-static Void local skipGap ( Void );
-static Cell local readCtrlChar ( Void );
-static Cell local readOctChar ( Void );
-static Cell local readHexChar ( Void );
-static Int local readHexDigit ( Char );
-static Cell local readDecChar ( Void );
-
-static Void local goOffside ( Int );
-static Void local unOffside ( Void );
-static Bool local canUnOffside ( Void );
-
-static Void local skipWhitespace ( Void );
-static Int local yylex ( Void );
-static Int local repeatLast ( Void );
-
-static Cell local parseInput ( Int );
-
-static Bool local doesNotExceed ( String,Int,Int );
-static Int local stringToInt ( String,Int );
-
-
-/* --------------------------------------------------------------------------
- * Text values for reserved words and special symbols:
- * ------------------------------------------------------------------------*/
-
-static Text textCase, textOfK, textData, textType, textIf;
-static Text textThen, textElse, textWhere, textLet, textIn;
-static Text textInfix, textInfixl, textInfixr, textForeign, textNewtype;
-static Text textDefault, textDeriving, textDo, textClass, textInstance;
-static Text textMdo;
-#if IPARAM
-static Text textWith, textDlet;
-#endif
-
-static Text textCoco, textEq, textUpto, textAs, textLambda;
-static Text textBar, textMinus, textFrom, textArrow, textLazy;
-static Text textBang, textDot, textAll, textImplies;
-static Text textWildcard;
-
-static Text textModule, textImport, textInterface, textInstImport;
-static Text textHiding, textQualified, textAsMod, textPrivileged;
-static Text textExport, textDynamic, textUUExport;
-static Text textUnsafe, textUUAll, textUUUsage;
-
-Text textCcall; /* ccall */
-Text textStdcall; /* stdcall */
-
-Text textNum; /* Num */
-Text textPrelPrim; /* PrelPrim */
-Text textPrelude; /* Prelude */
-Text textPlus; /* (+) */
-
-static Cell conMain; /* Main */
-static Cell varMain; /* main */
-
-static Cell varMinus; /* (-) */
-static Cell varPlus; /* (+) */
-static Cell varBang; /* (!) */
-static Cell varDot; /* (.) */
-static Cell varHiding; /* hiding */
-static Cell varQualified; /* qualified */
-static Cell varAsMod; /* as */
-
-static List imps; /* List of imports to be chased */
-
-
-/* --------------------------------------------------------------------------
- * Character set handling:
- *
- * Hugs follows Haskell 1.3 in assuming that input uses the ISO-8859-1
- * character set. The following code provides methods for classifying
- * input characters according to the lexical structure specified by the
- * report. Hugs should still accept older programs because ASCII is
- * essentially just a subset of the ISO character set.
- *
- * Notes: If you want to port Hugs to a machine that uses something
- * substantially different from the ISO character set, then you will need
- * to insert additional code to map between character sets.
- *
- * At some point, the following data structures may be exported in a .h
- * file to allow the information contained here to be picked up in the
- * implementation of LibChar is* primitives.
- *
- * Relies, implicitly but for this comment, on assumption that NUM_CHARS=256.
- * ------------------------------------------------------------------------*/
-
-static Bool charTabBuilt;
-static unsigned char ctable[NUM_CHARS];
-#define isIn(c,x) (ctable[(unsigned char)(c)]&(x))
-#define isISO(c) (0<=(c) && (c)<NUM_CHARS)
-
-#define DIGIT 0x01
-#define SMALL 0x02
-#define LARGE 0x04
-#define SYMBOL 0x08
-#define IDAFTER 0x10
-#define ZPACE 0x20
-#define PRINT 0x40
-
-static Void local initCharTab() { /* Initialize char decode table */
-#define setRange(x,f,t) {Int i=f; while (i<=t) ctable[i++] |=x;}
-#define setChar(x,c) ctable[c] |= (x)
-#define setChars(x,s) {char *p=s; while (*p) ctable[(Int)*p++]|=x;}
-#define setCopy(x,c) {Int i; \
- for (i=0; i<NUM_CHARS; ++i) \
- if (isIn(i,c)) \
- ctable[i]|=x; \
- }
-
- setRange(DIGIT, '0','9'); /* ASCII decimal digits */
-
- setRange(SMALL, 'a','z'); /* ASCII lower case letters */
- setRange(SMALL, 223,246); /* ISO lower case letters */
- setRange(SMALL, 248,255); /* (omits division symbol, 247) */
- setChar (SMALL, '_');
-
- setRange(LARGE, 'A','Z'); /* ASCII upper case letters */
- setRange(LARGE, 192,214); /* ISO upper case letters */
- setRange(LARGE, 216,222); /* (omits multiplication, 215) */
-
- setRange(SYMBOL, 161,191); /* Symbol characters + ':' */
- setRange(SYMBOL, 215,215);
- setChar (SYMBOL, 247);
- setChars(SYMBOL, ":!#$%&*+./<=>?@\\^|-~");
-
- setChar (IDAFTER, '\''); /* Characters in identifier */
- setCopy (IDAFTER, (DIGIT|SMALL|LARGE));
-
- setChar (ZPACE, ' '); /* ASCII space character */
- setChar (ZPACE, 160); /* ISO non breaking space */
- setRange(ZPACE, 9,13); /* special whitespace: \t\n\v\f\r */
-
- setChars(PRINT, "(),;[]_`{}"); /* Special characters */
- setChars(PRINT, " '\""); /* Space and quotes */
- setCopy (PRINT, (DIGIT|SMALL|LARGE|SYMBOL));
-
- charTabBuilt = TRUE;
-#undef setRange
-#undef setChar
-#undef setChars
-#undef setCopy
-}
-
-
-/* --------------------------------------------------------------------------
- * Single character input routines:
- *
- * At the lowest level of input, characters are read one at a time, with the
- * current character held in c0 and the following (lookahead) character in
- * c1. The coordinates of c0 within the file are held in (column,row).
- * The input stream is advanced by one character using the skip() function.
- * ------------------------------------------------------------------------*/
-
-#define TABSIZE 8 /* spacing between tabstops */
-
-#define NOTHING 0 /* what kind of input is being read?*/
-#define KEYBOARD 1 /* - keyboard/console? */
-#define SCRIPTFILE 2 /* - script file */
-#define PROJFILE 3 /* - project file */
-#define STRING 4 /* - string buffer? */
-
-static Int reading = NOTHING;
-
-static Target readSoFar;
-static Int row, column, startColumn;
-static int c0, c1;
-static FILE *inputStream = 0;
-static Bool thisLiterate;
-static String nextStringChar; /* next char in string buffer */
-
-#if USE_READLINE /* for command line editors */
-static String currentLine; /* editline or GNU readline */
-static String nextChar;
-#define nextConsoleChar() \
- (unsigned char)(*nextChar=='\0' ? '\n' : *nextChar++)
-#else
-#define nextConsoleChar() getc(stdin)
-#endif
-
-static Int litLines; /* count defn lines in lit script */
-#define DEFNCHAR '>' /* definition lines begin with this */
-static Int lastLine; /* records type of last line read: */
-#define STARTLINE 0 /* - at start of file, none read */
-#define BLANKLINE 1 /* - blank (may preceed definition) */
-#define TEXTLINE 2 /* - text comment */
-#define DEFNLINE 3 /* - line containing definition */
-#define CODELINE 4 /* - line inside code block */
-
-#define BEGINCODE "\\begin{code}"
-#define ENDCODE "\\end{code}"
-
-#if HAVE_GETDELIM_H
-static char *lineBuffer = NULL; /* getline() does the initial allocation */
-#else
-#define LINEBUFFER_SIZE 1000
-static char lineBuffer[LINEBUFFER_SIZE];
-#endif
-static int lineLength = 0;
-static int inCodeBlock = FALSE; /* Inside \begin{code}..\end{code} */
-static int linePtr = 0;
-
-Void consoleInput(prompt) /* prepare to input characters from */
-String prompt; { /* standard in (i.e. console/kbd) */
- reading = KEYBOARD; /* keyboard input is Line oriented, */
- c0 = /* i.e. input terminated by '\n' */
- c1 = ' ';
- column = (-1);
- row = 0;
-
-#if USE_READLINE
- /* Paranoid freeing code supplied by Sverker Nilsson (sverker@opq.se)
- * avoids accidentally freeing currentLine twice.
- */
- if (currentLine) {
- String oldCurrentLine = currentLine;
- currentLine = 0; /* We may lose the space of currentLine */
- free(oldCurrentLine); /* if interrupted here - unlikely */
- }
- currentLine = readline(prompt);
- nextChar = currentLine;
- if (currentLine) {
- if (*currentLine)
- add_history(currentLine);
- }
- else
- c0 = c1 = EOF;
-#else
- Printf("%s",prompt);
- FlushStdout();
-#endif
-}
-
-Void projInput(nm) /* prepare to input characters from */
-String nm; { /* from named project file */
- if ((inputStream = fopen(nm,"r"))!=0) {
- reading = PROJFILE;
- c0 = ' ';
- c1 = '\n';
- column = 1;
- row = 0;
- }
- else {
- ERRMSG(0) "Unable to open project file \"%s\"", nm
- EEND;
- }
-}
-
-static Void local fileInput(nm,len) /* prepare to input characters from*/
-String nm; /* named file (specified length is */
-Long len; { /* used to set target for reading) */
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
- if (preprocessor) {
- Int reallen = strlen(preprocessor) + 1 + strlen(nm) + 1;
- char *cmd = malloc(reallen);
- if (cmd == NULL) {
- ERRMSG(0) "Unable to allocate memory for filter command."
- EEND;
- }
- strcpy(cmd,preprocessor);
- strcat(cmd," ");
- strcat(cmd,nm);
- inputStream = popen(cmd,"r");
- free(cmd);
- } else {
- inputStream = fopen(nm,"r");
- }
-#else
- inputStream = fopen(nm,"r");
-#endif
- if (inputStream) {
- reading = SCRIPTFILE;
- c0 = ' ';
- c1 = '\n';
- column = 1;
- row = 0;
-
- lastLine = STARTLINE; /* literate file processing */
- litLines = 0;
- linePtr = 0;
- lineLength = 0;
- thisLiterate = literateMode(nm);
- inCodeBlock = FALSE;
-
- readSoFar = 0;
- setGoal("Parsing", (Target)len);
- }
- else {
- ERRMSG(0) "Unable to open file \"%s\"", nm
- EEND;
- }
-}
-
-Void stringInput(s) /* prepare to input characters from string */
-String s; {
- reading = STRING;
- c0 = EOF;
- c1 = EOF;
- if (*s) c0 = *s++;
- if (*s) c1 = *s++;
- column = 1;
- row = 1;
-
- nextStringChar = s;
- if (!charTabBuilt)
- initCharTab();
-}
-
-static Bool local literateMode(nm) /* Select literate mode for file */
-String nm; {
- char *dot = strrchr(nm,'.'); /* look for last dot in file name */
- if (dot) {
- if (filenamecmp(dot+1,"hs")==0) /* .hs files are never literate */
- return FALSE;
- if (filenamecmp(dot+1,"lhs") ==0 || /* .lhs, .verb files are always*/
- filenamecmp(dot+1,"verb")==0) /* literate scripts */
- return TRUE;
- }
- return literateScripts; /* otherwise, use the default */
-}
-
-
-Void hi_o_namesFromSrcName ( String srcName, String* hiName, String* oName )
-{
- Int len;
- String dot;
- len = 1 + strlen ( srcName );
- *hiName = malloc(len);
- *oName = malloc(len);
- if (!(*hiName && *oName)) internal("hi_o_namesFromSource");
- (*hiName)[0] = (*oName)[0] = 0;
- dot = strrchr(srcName, '.');
- if (!dot) return;
- if (filenamecmp(dot+1, "hs")==0 &&
- filenamecmp(dot+1, "lhs")==0 &&
- filenamecmp(dot+1, "verb")==0) return;
-
- strcpy(*hiName, srcName);
- dot = strrchr(*hiName, '.');
- dot[1] = 'h';
- dot[2] = 'i';
- dot[3] = 0;
-
- strcpy(*oName, srcName);
- dot = strrchr(*oName, '.');
- dot[1] = 'o';
- dot[2] = 0;
-}
-
-
-
-/* This code originally came from Sigbjorn Finne (sof@dcs.gla.ac.uk).
- * I've removed the loop (since newLineSkip contains a loop too) and
- * replaced the warnings with errors. ADR
- */
-/*
- * To deal with literate \begin{code}...\end{code} blocks,
- * add a line buffer that rooms the current line. The old c0 and c1
- * stream pointers are used as before within that buffer -- sof
- *
- * Upon reading a new line into the line buffer, we check to see if
- * we're reading in a line containing \begin{code} or \end{code} and
- * take appropriate action.
- */
-
-static Bool local linecmp(s,line) /* compare string with line */
-String s; /* line may end in whitespace */
-String line; {
- Int i=0;
- while (s[i] != '\0' && s[i] == line[i]) {
- ++i;
- }
- /* s[0..i-1] == line[0..i-1] */
- if (s[i] != '\0') { /* check s `isPrefixOf` line */
- return FALSE;
- }
- while (isIn(line[i], ZPACE)) { /* allow whitespace at end of line */
- ++i;
- }
- return (line[i] == '\0');
-}
-
-/* Returns line length (including \n) or 0 upon EOF. */
-static Int local nextLine()
-{
-#if HAVE_GETDELIM_H
- /*
- Forget about fgets(), it is utterly braindead.
- (Assumes \NUL free streams and does not gracefully deal
- with overflow.) Instead, use GNU libc's getline().
- */
- lineLength = getline(&lineBuffer, &lineLength, inputStream);
-#else
- if (NULL != fgets(lineBuffer, LINEBUFFER_SIZE, inputStream))
- lineLength = strlen(lineBuffer);
- else
- lineLength = 0;
-#endif
- /* printf("Read: \"%s\"", lineBuffer); */
- if (lineLength <= 0) { /* EOF / IO error, who knows.. */
- return lineLength;
- }
- else if (lineLength >= 2 && lineBuffer[0] == '#' &&
- lineBuffer[1] == '!') {
- lineBuffer[0]='\n'; /* pretend it's a blank line */
- lineBuffer[1]='\0';
- lineLength=1;
- } else if (thisLiterate) {
- if (linecmp(BEGINCODE, lineBuffer)) {
- if (!inCodeBlock) { /* Entered a code block */
- inCodeBlock = TRUE;
- lineBuffer[0]='\n'; /* pretend it's a blank line */
- lineBuffer[1]='\0';
- lineLength=1;
- }
- else {
- ERRMSG(row) "\\begin{code} encountered inside code block"
- EEND;
- }
- }
- else if (linecmp(ENDCODE, lineBuffer)) {
- if (inCodeBlock) { /* Finished code block */
- inCodeBlock = FALSE;
- lineBuffer[0]='\n'; /* pretend it's a blank line */
- lineBuffer[1]='\0';
- lineLength=1;
- }
- else {
- ERRMSG(row) "\\end{code} encountered outside code block"
- EEND;
- }
- }
- }
- /* printf("Read: \"%s\"", lineBuffer); */
- return lineLength;
-}
-
-static Void local skip() { /* move forward one char in input */
- if (c0!=EOF) { /* stream, updating c0, c1, ... */
- if (c0=='\n') { /* Adjusting cursor coords as nec. */
- row++;
- column=1;
- if (reading==SCRIPTFILE)
- soFar(readSoFar);
- }
- else if (c0=='\t')
- column += TABSIZE - ((column-1)%TABSIZE);
- else
- column++;
-
- c0 = c1;
- readSoFar++;
-
- if (c0==EOF) {
- column = 0;
- if (reading==SCRIPTFILE)
- done();
- closeAnyInput();
- }
- else if (reading==KEYBOARD) {
- /* allowBreak(); */
- if (c0=='\n')
- c1 = EOF;
- else {
- c1 = nextConsoleChar();
-#if IS_WIN32
- Sleep(0);
-#endif
- /* On Win32, hitting ctrl-C causes the next getchar to
- * fail - returning "-1" to indicate an error.
- * This is one of the rare cases where "-1" does not mean EOF.
- */
- if (EOF == c1 && (!feof(stdin) /* || broken==TRUE */)) {
- c1 = ' ';
- }
- }
- }
- else if (reading==STRING) {
- c1 = (unsigned char) *nextStringChar++;
- if (c1 == '\0')
- c1 = EOF;
- }
- else {
- if (lineLength <=0 || linePtr == lineLength) {
- /* Current line, exhausted - get new one */
- if (nextLine() <= 0) { /* EOF */
- c1 = EOF;
- }
- else {
- linePtr = 0;
- c1 = (unsigned char)lineBuffer[linePtr++];
- }
- }
- else {
- c1 = (unsigned char)lineBuffer[linePtr++];
- }
- }
-
- }
-}
-
-static Void local thisLineIs(kind) /* register kind of current line */
-Int kind; { /* & check for literate script errs */
- if (literateErrors) {
- if ((kind==DEFNLINE && lastLine==TEXTLINE) ||
- (kind==TEXTLINE && lastLine==DEFNLINE)) {
- ERRMSG(row) "Program line next to comment"
- EEND;
- }
- lastLine = kind;
- }
-}
-
-static Void local newlineSkip() { /* skip `\n' (supports lit scripts) */
- /* assert(c0=='\n'); */
- if (reading==SCRIPTFILE && thisLiterate) {
- do {
- skip();
- if (inCodeBlock) { /* pass chars on definition lines */
- thisLineIs(CODELINE); /* to lexer (w/o leading DEFNCHAR) */
- litLines++;
- return;
- }
- if (c0==DEFNCHAR) { /* pass chars on definition lines */
- thisLineIs(DEFNLINE); /* to lexer (w/o leading DEFNCHAR) */
- skip();
- litLines++;
- return;
- }
- while (c0 != '\n' && isIn(c0,ZPACE)) /* maybe line is blank? */
- skip();
- if (c0=='\n' || c0==EOF)
- thisLineIs(BLANKLINE);
- else {
- thisLineIs(TEXTLINE); /* otherwise it must be a comment */
- while (c0!='\n' && c0!=EOF)
- skip();
- } /* by now, c0=='\n' or c0==EOF */
- } while (c0!=EOF); /* if new line, start again */
-
- if (litLines==0 && literateErrors) {
- ERRMSG(row) "Empty script - perhaps you forgot the `%c's?",
- DEFNCHAR
- EEND;
- }
- return;
- }
- skip();
-}
-
-static Void local closeAnyInput() { /* Close input stream, if open, */
- switch (reading) { /* or skip to end of console line */
- case PROJFILE :
- case SCRIPTFILE : if (inputStream) {
-#if USE_PREPROCESSOR && (defined(HAVE_POPEN) || defined(HAVE__POPEN))
- if (preprocessor) {
- pclose(inputStream);
- } else {
- fclose(inputStream);
- }
-#else
- fclose(inputStream);
-#endif
- inputStream = 0;
- }
- break;
- case KEYBOARD : while (c0!=EOF)
- skip();
- break;
- }
- reading=NOTHING;
-}
-
-/* --------------------------------------------------------------------------
- * Parser: Uses table driven parser generated from parser.y using yacc
- * ------------------------------------------------------------------------*/
-
-#include "parser.c"
-
-/* --------------------------------------------------------------------------
- * Single token input routines:
- *
- * The following routines read the values of particular kinds of token given
- * that the first character of the token has already been located in c0 on
- * entry to the routine.
- * ------------------------------------------------------------------------*/
-
-#define MAX_TOKEN 4000
-#define startToken() tokPos = 0
-#define saveTokenChar(c) if (tokPos<=MAX_TOKEN) saveChar(c); else ++tokPos
-#define saveChar(c) tokenStr[tokPos++]=(char)(c)
-#define overflows(n,b,d,m) (n > ((m)-(d))/(b))
-
-static char tokenStr[MAX_TOKEN+1]; /* token buffer */
-static Int tokPos; /* input position in buffer */
-static Int identType; /* identifier type: CONID / VARID */
-static Int opType; /* operator type : CONOP / VAROP */
-
-static Void local endToken() { /* check for token overflow */
- if (tokPos>MAX_TOKEN) {
- ERRMSG(row) "Maximum token length (%d) exceeded", MAX_TOKEN
- EEND;
- }
- tokenStr[tokPos] = '\0';
-}
-
-static Text local readOperator() { /* read operator symbol */
- startToken();
- do {
- saveTokenChar(c0);
- skip();
- } while (isISO(c0) && isIn(c0,SYMBOL));
- opType = (tokenStr[0]==':' ? CONOP : VAROP);
- endToken();
- return findText(tokenStr);
-}
-
-static Text local readIdent() { /* read identifier */
- startToken();
- do {
- saveTokenChar(c0);
- skip();
- } while (isISO(c0) && isIn(c0,IDAFTER));
- endToken();
- identType = isIn(tokenStr[0],LARGE) ? CONID : VARID;
- if (readingInterface)
- return unZcodeThenFindText(tokenStr); else
- return findText(tokenStr);
-}
-
-
-static Bool local doesNotExceed(s,radix,limit)
-String s;
-Int radix;
-Int limit; {
- Int n = 0;
- Int p = 0;
- while (TRUE) {
- if (s[p] == 0) return TRUE;
- if (overflows(n,radix,s[p]-'0',limit)) return FALSE;
- n = radix*n + (s[p]-'0');
- p++;
- }
-}
-
-static Int local stringToInt(s,radix)
-String s;
-Int radix; {
- Int n = 0;
- Int p = 0;
- while (TRUE) {
- if (s[p] == 0) return n;
- n = radix*n + (s[p]-'0');
- p++;
- }
-}
-
-static Cell local readRadixNumber(r) /* Read literal in specified radix */
-Int r; { /* from input of the form 0c{digs} */
- Int d;
- startToken();
- skip(); /* skip leading zero */
- if ((d=readHexDigit(c1))<0 || d>=r) {
- /* Special case; no digits, lex as */
- /* if it had been written "0 c..." */
- saveTokenChar('0');
- } else {
- skip();
- do {
- saveTokenChar('0'+readHexDigit(c0));
- skip();
- d = readHexDigit(c0);
- } while (d>=0 && d<r);
- }
- endToken();
-
- if (doesNotExceed(tokenStr,r,MAXPOSINT))
- return mkInt(stringToInt(tokenStr,r));
- else
- if (r == 10)
- return stringToBignum(tokenStr);
- else {
- ERRMSG(row) "Hexadecimal or octal constant exceeds `Int' range"
- EEND;
- }
-}
-
-static Cell local readNumber() { /* read numeric constant */
-
- if (c0=='0') {
- if (c1=='x' || c1=='X') /* Maybe a hexadecimal literal? */
- return readRadixNumber(16);
- if (c1=='o' || c1=='O') /* Maybe an octal literal? */
- return readRadixNumber(8);
- }
-
- startToken();
- do {
- saveTokenChar(c0);
- skip();
- } while (isISO(c0) && isIn(c0,DIGIT));
-
- if (c0!='.' || !isISO(c1) || !isIn(c1,DIGIT)) {
- endToken();
- if (doesNotExceed(tokenStr,10,MAXPOSINT))
- return mkInt(stringToInt(tokenStr,10)); else
- return stringToBignum(tokenStr);
- }
-
- saveTokenChar(c0); /* save decimal point */
- skip();
- do { /* process fractional part ... */
- saveTokenChar(c0);
- skip();
- } while (isISO(c0) && isIn(c0,DIGIT));
-
- if (c0=='e' || c0=='E') { /* look for exponent part... */
- saveTokenChar('e');
- skip();
- if (c0=='-') {
- saveTokenChar('-');
- skip();
- }
- else if (c0=='+')
- skip();
-
- if (!isISO(c0) || !isIn(c0,DIGIT)) {
- ERRMSG(row) "Missing digits in exponent"
- EEND;
- }
- else {
- do {
- saveTokenChar(c0);
- skip();
- } while (isISO(c0) && isIn(c0,DIGIT));
- }
- }
-
- endToken();
- return mkFloat(stringToFloat(tokenStr));
-}
-
-
-
-
-
-
-
-static Cell local readChar() { /* read character constant */
- Cell charRead;
-
- skip(/* '\'' */);
- if (c0=='\'' || c0=='\n' || c0==EOF) {
- ERRMSG(row) "Illegal character constant"
- EEND;
- }
-
- charRead = readAChar(FALSE);
-
- if (c0=='\'')
- skip(/* '\'' */);
- else {
- ERRMSG(row) "Improperly terminated character constant"
- EEND;
- }
- return charRead;
-}
-
-static Cell local readString() { /* read string literal */
- Cell c;
-
- startToken();
- skip(/* '\"' */);
- while (c0!='\"' && c0!='\n' && c0!=EOF) {
- c = readAChar(TRUE);
- if (nonNull(c))
- saveStrChr(charOf(c));
- }
-
- if (c0=='\"')
- skip(/* '\"' */);
- else {
- ERRMSG(row) "Improperly terminated string"
- EEND;
- }
- endToken();
- return mkStr(findText(tokenStr));
-}
-
-static Void local saveStrChr(c) /* save character in string */
-Char c; {
- if (c!='\0' && c!='\\') { /* save non null char as single char*/
- saveTokenChar(c);
- }
- else { /* save null char as TWO null chars */
- if (tokPos+1<MAX_TOKEN) {
- saveChar('\\');
- if (c=='\\')
- saveChar('\\');
- else
- saveChar('0');
- }
- }
-}
-
-static Cell local readAChar(isStrLit) /* read single char constant */
-Bool isStrLit; { /* TRUE => enable \& and gaps */
- Cell c = mkChar(c0);
-
- if (c0=='\\') /* escape character? */
- return readEscapeChar(isStrLit);
- if (!isISO(c0)) {
- ERRMSG(row) "Non ISO character `\\%d' in constant", ((int)c0)
- EEND;
- }
- skip(); /* normal character? */
- return c;
-}
-
-/* --------------------------------------------------------------------------
- * Character escape code sequences:
- * ------------------------------------------------------------------------*/
-
-static struct { /* table of special escape codes */
- char *codename;
- int codenumber;
-} escapes[] = {
- {"a", 7}, {"b", 8}, {"f", 12}, {"n", 10}, /* common escapes */
- {"r", 13}, {"t", 9}, {"\\",'\\'}, {"\"",'\"'},
- {"\'",'\''}, {"v", 11},
- {"NUL", 0}, {"SOH", 1}, {"STX", 2}, {"ETX", 3}, /* ascii codenames */
- {"EOT", 4}, {"ENQ", 5}, {"ACK", 6}, {"BEL", 7},
- {"BS", 8}, {"HT", 9}, {"LF", 10}, {"VT", 11},
- {"FF", 12}, {"CR", 13}, {"SO", 14}, {"SI", 15},
- {"DLE", 16}, {"DC1", 17}, {"DC2", 18}, {"DC3", 19},
- {"DC4", 20}, {"NAK", 21}, {"SYN", 22}, {"ETB", 23},
- {"CAN", 24}, {"EM", 25}, {"SUB", 26}, {"ESC", 27},
- {"FS", 28}, {"GS", 29}, {"RS", 30}, {"US", 31},
- {"SP", 32}, {"DEL", 127},
- {0,0}
-};
-
-static Int alreadyMatched; /* Record portion of input stream */
-static char alreadyRead[10]; /* that has been read w/o a match */
-
-static Bool local lazyReadMatches(s) /* compare input stream with string */
-String s; { /* possibly using characters that */
- int i; /* have already been read */
-
- for (i=0; i<alreadyMatched; ++i)
- if (alreadyRead[i]!=s[i])
- return FALSE;
-
- while (s[i] && s[i]==c0) {
- alreadyRead[alreadyMatched++]=(char)c0;
- skip();
- i++;
- }
-
- return s[i]=='\0';
-}
-
-static Cell local readEscapeChar(isStrLit)/* read escape character */
-Bool isStrLit; {
- int i=0;
-
- skip(/* '\\' */);
- switch (c0) {
- case '&' : if (isStrLit) {
- skip();
- return NIL;
- }
- ERRMSG(row) "Illegal use of `\\&' in character constant"
- EEND;
- break;/*NOTREACHED*/
-
- case '^' : return readCtrlChar();
-
- case 'o' : return readOctChar();
- case 'x' : return readHexChar();
-
- default : if (!isISO(c0)) {
- ERRMSG(row) "Illegal escape sequence"
- EEND;
- }
- else if (isIn(c0,ZPACE)) {
- if (isStrLit) {
- skipGap();
- return NIL;
- }
- ERRMSG(row) "Illegal use of gap in character constant"
- EEND;
- break;
- }
- else if (isIn(c0,DIGIT))
- return readDecChar();
- }
-
- for (alreadyMatched=0; escapes[i].codename; i++)
- if (lazyReadMatches(escapes[i].codename))
- return mkChar(escapes[i].codenumber);
-
- alreadyRead[alreadyMatched++] = (char)c0;
- alreadyRead[alreadyMatched++] = '\0';
- ERRMSG(row) "Illegal character escape sequence \"\\%s\"",
- alreadyRead
- EEND;
- return NIL;/*NOTREACHED*/
-}
-
-static Void local skipGap() { /* skip over gap in string literal */
- do /* (simplified in Haskell 1.1) */
- if (c0=='\n')
- newlineSkip();
- else
- skip();
- while (isISO(c0) && isIn(c0,ZPACE));
- if (c0!='\\') {
- ERRMSG(row) "Missing `\\' terminating string literal gap"
- EEND;
- }
- skip(/* '\\' */);
-}
-
-static Cell local readCtrlChar() { /* read escape sequence \^x */
- static String controls = "@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_";
- String which;
-
- skip(/* '^' */);
- if ((which = strchr(controls,c0))==NULL) {
- ERRMSG(row) "Unrecognised escape sequence `\\^%c'", c0
- EEND;
- }
- skip();
- return mkChar(which-controls);
-}
-
-static Cell local readOctChar() { /* read octal character constant */
- Int n = 0;
- Int d;
-
- skip(/* 'o' */);
- if ((d = readHexDigit(c0))<0 || d>=8) {
- ERRMSG(row) "Empty octal character escape"
- EEND;
- }
- do {
- if (overflows(n,8,d,MAXCHARVAL)) {
- ERRMSG(row) "Octal character escape out of range"
- EEND;
- }
- n = 8*n + d;
- skip();
- } while ((d = readHexDigit(c0))>=0 && d<8);
-
- return mkChar(n);
-}
-
-static Cell local readHexChar() { /* read hex character constant */
- Int n = 0;
- Int d;
-
- skip(/* 'x' */);
- if ((d = readHexDigit(c0))<0) {
- ERRMSG(row) "Empty hexadecimal character escape"
- EEND;
- }
- do {
- if (overflows(n,16,d,MAXCHARVAL)) {
- ERRMSG(row) "Hexadecimal character escape out of range"
- EEND;
- }
- n = 16*n + d;
- skip();
- } while ((d = readHexDigit(c0))>=0);
-
- return mkChar(n);
-}
-
-static Int local readHexDigit(c) /* read single hex digit */
-Char c; {
- if ('0'<=c && c<='9')
- return c-'0';
- if ('A'<=c && c<='F')
- return 10 + (c-'A');
- if ('a'<=c && c<='f')
- return 10 + (c-'a');
- return -1;
-}
-
-static Cell local readDecChar() { /* read decimal character constant */
- Int n = 0;
-
- do {
- if (overflows(n,10,(c0-'0'),MAXCHARVAL)) {
- ERRMSG(row) "Decimal character escape out of range"
- EEND;
- }
- n = 10*n + (c0-'0');
- skip();
- } while (c0!=EOF && isIn(c0,DIGIT));
-
- return mkChar(n);
-}
-
-/* --------------------------------------------------------------------------
- * Produce printable representation of character:
- * ------------------------------------------------------------------------*/
-
-String unlexChar(c,quote) /* return string representation of */
-Char c; /* character... */
-Char quote; { /* protect quote character */
- static char buffer[12];
-
- if (c<0) /* deal with sign extended chars.. */
- c += NUM_CHARS;
-
- if (isISO(c) && isIn(c,PRINT)) { /* normal printable character */
- if (c==quote || c=='\\') { /* look for quote of approp. kind */
- buffer[0] = '\\';
- buffer[1] = (char)c;
- buffer[2] = '\0';
- }
- else {
- buffer[0] = (char)c;
- buffer[1] = '\0';
- }
- }
- else { /* look for escape code */
- Int escs;
- for (escs=0; escapes[escs].codename; escs++)
- if (escapes[escs].codenumber==c) {
- sprintf(buffer,"\\%s",escapes[escs].codename);
- return buffer;
- }
- sprintf(buffer,"\\%d",c); /* otherwise use numeric escape */
- }
- return buffer;
-}
-
-Void printString(s) /* print string s, using quotes and */
-String s; { /* escapes if any parts need them */
- if (s) {
- String t = s;
- Char c;
- while ((c = *t)!=0 && isISO(c)
- && isIn(c,PRINT) && c!='"' && !isIn(c,ZPACE)) {
- t++;
- }
- if (*t) {
- Putchar('"');
- for (t=s; *t; t++)
- Printf("%s",unlexChar(*t,'"'));
- Putchar('"');
- }
- else
- Printf("%s",s);
- }
-}
-
-/* -------------------------------------------------------------------------
- * Handle special types of input for use in interpreter:
- * -----------------------------------------------------------------------*/
-
-Command readCommand(cmds,start,sys) /* read command at start of input */
-struct cmd *cmds; /* line in interpreter */
-Char start; /* characters introducing a cmd */
-Char sys; { /* character for shell escape */
- while (c0==' ' || c0 =='\t')
- skip();
-
- if (c0=='\n') /* look for blank command lines */
- return NOCMD;
- if (c0==EOF) /* look for end of input stream */
- return QUIT;
- if (c0==sys) { /* single character system escape */
- skip();
- return SYSTEM;
- }
- if (c0==start && c1==sys) { /* two character system escape */
- skip();
- skip();
- return SYSTEM;
- }
-
- startToken(); /* All cmds start with start */
- if (c0==start) /* except default (usually EVAL) */
- do { /* which is empty */
- saveTokenChar(c0);
- skip();
- } while (c0!=EOF && !isIn(c0,ZPACE));
- endToken();
-
- for (; cmds->cmdString; ++cmds)
- if (strcmp((cmds->cmdString),tokenStr)==0 ||
- (tokenStr[0]==start &&
- tokenStr[1]==(cmds->cmdString)[1] &&
- tokenStr[2]=='\0'))
- return (cmds->cmdCode);
- return BADCMD;
-}
-
-String readFilename() { /* Read filename from input (if any)*/
- if (reading==PROJFILE)
- skipWhitespace();
- else
- while (c0==' ' || c0=='\t')
- skip();
-
- if (c0=='\n' || c0==EOF) /* return null string at end of line*/
- return 0;
-
- startToken();
- while (c0!=EOF && !isIn(c0,ZPACE)) {
- if (c0=='"') {
- skip();
- while (c0!=EOF && c0!='\"') {
- Cell c = readAChar(TRUE);
- if (nonNull(c)) {
- saveTokenChar(charOf(c));
- }
- }
- if (c0=='"')
- skip();
- else {
- ERRMSG(row) "a closing quote, '\"', was expected"
- EEND;
- }
- }
- else {
- saveTokenChar(c0);
- skip();
- }
- }
- endToken();
- return tokenStr;
-}
-
-String readLine() { /* Read command line from input */
- while (c0==' ' || c0=='\t') /* skip leading whitespace */
- skip();
-
- startToken();
- while (c0!='\n' && c0!=EOF) {
- saveTokenChar(c0);
- skip();
- }
- endToken();
-
- return tokenStr;
-}
-
-/* --------------------------------------------------------------------------
- * This lexer supports the Haskell layout rule:
- *
- * - Layout area bounded by { ... }, with `;'s in between.
- * - A `{' is a HARD indentation and can only be matched by a corresponding
- * HARD '}'
- * - Otherwise, if no `{' follows the keywords WHERE/LET or OF, a SOFT `{'
- * is inserted with the column number of the first token after the
- * WHERE/LET/OF keyword.
- * - When a soft indentation is uppermost on the indentation stack with
- * column col' we insert:
- * `}' in front of token with column<col' and pop indentation off stack,
- * `;' in front of token with column==col'.
- * ------------------------------------------------------------------------*/
-
-#define MAXINDENT 100 /* maximum nesting of layout rule */
-static Int layout[MAXINDENT+1];/* indentation stack */
-#define HARD (-1) /* indicates hard indentation */
-static Int indentDepth = (-1); /* current indentation nesting */
-
-static Void local goOffside(col) /* insert offside marker */
-Int col; { /* for specified column */
- assert(offsideON);
- if (indentDepth>=MAXINDENT) {
- ERRMSG(row) "Too many levels of program nesting"
- EEND;
- }
- layout[++indentDepth] = col;
-}
-
-static Void local unOffside() { /* leave layout rule area */
- assert(offsideON);
- indentDepth--;
-}
-
-static Bool local canUnOffside() { /* Decide if unoffside permitted */
- assert(offsideON);
- return indentDepth>=0 && layout[indentDepth]!=HARD;
-}
-
-/* --------------------------------------------------------------------------
- * Main tokeniser:
- * ------------------------------------------------------------------------*/
-
-static Void local skipWhitespace() { /* Skip over whitespace/comments */
- for (;;) /* Strictly speaking, this code is */
- if (c0==EOF) /* a little more liberal than the */
- return; /* report allows ... */
- else if (c0=='\n')
- newlineSkip();
- else if (isIn(c0,ZPACE))
- skip();
- else if (c0=='{' && c1=='-') { /* (potentially) nested comment */
- Int nesting = 1;
- Int origRow = row; /* Save original row number */
- skip();
- skip();
- while (nesting>0 && c0!=EOF)
- if (c0=='{' && c1=='-') {
- skip();
- skip();
- nesting++;
- }
- else if (c0=='-' && c1=='}') {
- skip();
- skip();
- nesting--;
- }
- else if (c0=='\n')
- newlineSkip();
- else
- skip();
- if (nesting>0) {
- ERRMSG(origRow) "Unterminated nested comment {- ..."
- EEND;
- }
- }
- else if (c0=='-' && c1=='-') { /* One line comment */
- do
- skip();
- while (c0!='\n' && c0!=EOF);
- if (c0=='\n')
- newlineSkip();
- }
- else
- return;
-}
-
-static Bool firstToken; /* Set to TRUE for first token */
-static Int firstTokenIs; /* ... with token value stored here */
-
-static Int local yylex() { /* Read next input token ... */
- static Bool insertOpen = FALSE;
- static Bool insertedToken = FALSE;
- static Text textRepeat;
-
-#define lookAhead(t) {skipWhitespace(); insertOpen = (c0!='{'); return t;}
-
- if (firstToken) { /* Special case for first token */
- indentDepth = (-1);
- firstToken = FALSE;
- insertOpen = FALSE;
- insertedToken = FALSE;
- if (reading==KEYBOARD)
- textRepeat = findText(repeatStr);
- return firstTokenIs;
- }
-
- if (offsideON && insertOpen) { /* insert `soft' opening brace */
- insertOpen = FALSE;
- insertedToken = TRUE;
- goOffside(column);
- push(yylval = mkInt(row));
- return '{';
- }
-
- /* ----------------------------------------------------------------------
- * Skip white space, and insert tokens to support layout rules as reqd.
- * --------------------------------------------------------------------*/
-
- skipWhitespace();
- startColumn = column;
- push(yylval = mkInt(row)); /* default token value is line no. */
- /* subsequent changes to yylval must also set top() to the same value */
-
- if (indentDepth>=0) { /* layout rule(s) active ? */
- if (insertedToken) /* avoid inserting multiple `;'s */
- insertedToken = FALSE; /* or putting `;' after `{' */
- else
- if (offsideON && layout[indentDepth]!=HARD) {
- if (column<layout[indentDepth]) {
- unOffside();
- return '}';
- }
- else if (column==layout[indentDepth] && c0!=EOF) {
- insertedToken = TRUE;
- return ';';
- }
- }
- }
-
- /* ----------------------------------------------------------------------
- * Now try to identify token type:
- * --------------------------------------------------------------------*/
-
- if (readingInterface) {
- if (c0 == '(' && c1 == '#') { skip(); skip(); return UTL; };
- if (c0 == '#' && c1 == ')') { skip(); skip(); return UTR; };
- }
-
- switch (c0) {
- case EOF : return 0; /* End of file/input */
-
- /* The next 10 characters make up the `special' category in 1.3 */
- case '(' : skip(); return '(';
- case ')' : skip(); return ')';
- case ',' : skip(); return ',';
- case ';' : skip(); return ';';
- case '[' : skip(); return '[';
- case ']' : skip(); return ']';
- case '`' : skip(); return '`';
- case '{' : if (offsideON) goOffside(HARD);
- skip();
- return '{';
- case '}' : if (offsideON && indentDepth<0) {
- ERRMSG(row) "Misplaced `}'"
- EEND;
- }
- if (!(offsideON && layout[indentDepth]!=HARD))
- skip(); /* skip over hard }*/
- if (offsideON)
- unOffside(); /* otherwise, we have to insert a }*/
- return '}'; /* to (try to) avoid an error... */
-
- /* Character and string literals */
- case '\'' : top() = yylval = readChar();
- return CHARLIT;
-
- case '\"' : top() = yylval = readString();
- return STRINGLIT;
- }
-
-#if IPARAM
- if (c0=='?' && isIn(c1,SMALL) && !haskell98) {
- Text it; /* Look for implicit param name */
- skip();
- it = readIdent();
- top() = yylval = ap(IPVAR,it);
- return identType=IPVARID;
- }
-#endif
-#if TREX
- if (c0=='#' && isIn(c1,SMALL) && !haskell98) {
- Text it; /* Look for record selector name */
- skip();
- it = readIdent();
- top() = yylval = ap(RECSEL,mkExt(it));
- return identType=RECSELID;
- }
-#endif
- if (isIn(c0,LARGE)) { /* Look for qualified name */
- Text it = readIdent(); /* No keyword begins with LARGE ...*/
- if (c0=='.' && isIn(c1,(SMALL|LARGE|SYMBOL))) {
- Text it2 = NIL;
- skip(); /* Skip qualifying dot */
- if (isIn(c0,SYMBOL)) { /* Qualified operator */
- it2 = readOperator();
- if (opType==CONOP) {
- top() = yylval = mkQConOp(it,it2);
- return QCONOP;
- } else {
- top() = yylval = mkQVarOp(it,it2);
- return QVAROP;
- }
- } else { /* Qualified identifier */
- it2 = readIdent();
- if (identType==CONID) {
- top() = yylval = mkQCon(it,it2);
- return QCONID;
- } else {
- top() = yylval = mkQVar(it,it2);
- return QVARID;
- }
- }
- } else {
- top() = yylval = mkCon(it);
- return identType;
- }
- }
- if (isIn(c0,(SMALL|LARGE))) {
- Text it = readIdent();
-
- if (it==textCase) return CASEXP;
- if (it==textOfK) lookAhead(OF);
- if (it==textData) return DATA;
- if (it==textType) return TYPE;
- if (it==textIf) return IF;
- if (it==textThen) return THEN;
- if (it==textElse) return ELSE;
- if (it==textWhere) lookAhead(WHERE);
- if (it==textLet) lookAhead(LET);
- if (it==textIn) return IN;
- if (it==textInfix) return INFIXN;
- if (it==textInfixl) return INFIXL;
- if (it==textInfixr) return INFIXR;
- if (it==textForeign) return FOREIGN;
- if (it==textUnsafe) return UNSAFE;
- if (it==textNewtype) return TNEWTYPE;
- if (it==textDefault) return DEFAULT;
- if (it==textDeriving) return DERIVING;
- if (it==textDo) lookAhead(DO);
- if (it==textClass) return TCLASS;
- if (it==textInstance) return TINSTANCE;
- if (it==textModule) return TMODULE;
- if (it==textInterface) return INTERFACE;
- if (it==textInstImport) return INSTIMPORT;
- if (it==textImport) return IMPORT;
- if (it==textExport) return EXPORT;
- if (it==textDynamic) return DYNAMIC;
- if (it==textCcall) return CCALL;
- if (it==textStdcall) return STDKALL;
- if (it==textUUExport) return UUEXPORT;
- if (it==textHiding) return HIDING;
- if (it==textQualified) return QUALIFIED;
- if (it==textAsMod) return ASMOD;
- if (it==textWildcard) return '_';
- if (it==textAll && !haskell98) return ALL;
-#if IPARAM
- if (it==textWith && !haskell98) lookAhead(WITH);
- if (it==textDlet && !haskell98) lookAhead(DLET);
- if (it==textMdo && !haskell98) lookAhead(MDO);
-#endif
- if (it==textUUAll) return ALL;
- if (it==textUUUsage) return UUUSAGE;
- if (it==textRepeat && reading==KEYBOARD)
- return repeatLast();
-
- top() = yylval = ap((identType==CONID ? CONIDCELL : VARIDCELL),it);
- return identType;
- }
-
- if (isIn(c0,SYMBOL)) {
- Text it = readOperator();
-
- if (it==textCoco) return COCO;
- if (it==textEq) return '=';
- if (it==textUpto) return UPTO;
- if (it==textAs) return '@';
- if (it==textLambda) return '\\';
- if (it==textBar) return '|';
- if (it==textFrom) return FROM;
- if (it==textMinus) return '-';
- if (it==textPlus) return '+';
- if (it==textBang) return '!';
- if (it==textDot) return '.';
- if (it==textArrow) return ARROW;
- if (it==textLazy) return '~';
- if (it==textImplies) return IMPLIES;
- if (it==textRepeat && reading==KEYBOARD)
- return repeatLast();
-
- top() = yylval = ap((opType==CONOP ? CONOPCELL : VAROPCELL),it);
- return opType;
- }
-
- if (isIn(c0,DIGIT)) {
- top() = yylval = readNumber();
- return NUMLIT;
- }
-
- ERRMSG(row) "Unrecognised character `\\%d' in column %d",
- ((int)c0), column
- EEND;
- return 0; /*NOTREACHED*/
-}
-
-static Int local repeatLast() { /* Obtain last expression entered */
- if (isNull(yylval=getLastExpr())) {
- ERRMSG(row) "Cannot use %s without any previous input", repeatStr
- EEND;
- }
- return REPEAT;
-}
-
-Syntax defaultSyntax(t) /* Find default syntax of var named*/
-Text t; { /* by t ... */
- String s = textToStr(t);
- return isIn(s[0],SYMBOL) ? DEF_OPSYNTAX : APPLIC;
-}
-
-Syntax syntaxOf(n) /* Find syntax for name */
-Name n; {
- if (name(n).syntax==NO_SYNTAX) /* Return default if no syntax set */
- return defaultSyntax(name(n).text);
- return name(n).syntax;
-}
-
-/* --------------------------------------------------------------------------
- * main entry points to parser/lexer:
- * ------------------------------------------------------------------------*/
-
-static Cell local parseInput(startWith)/* Parse input with given first tok,*/
-Int startWith; { /* determining whether to read a */
- Cell final = NIL; /* script or an expression */
- firstToken = TRUE;
- firstTokenIs = startWith;
- if (startWith==INTERFACE) {
- offsideON = FALSE; readingInterface = TRUE;
- } else {
- offsideON = TRUE; readingInterface = FALSE;
- }
-
- clearStack();
- if (yyparse()) { /* This can only be parser overflow */
- ERRMSG(row) "Parser overflow" /* as all syntax errors are caught */
- EEND; /* in the parser... */
- }
-
- if (startWith==SCRIPT) pop(); /* zap spurious closing } token */
- final = pop();
-
- if (!stackEmpty()) /* stack should now be empty */
- internal("parseInput");
- return final;
-}
-
-Void parseExp() { /* Read an expression to evaluate */
- parseInput(EXPR);
- setLastExpr(inputExpr);
-}
-
-#if EXPLAIN_INSTANCE_RESOLUTION
-Void parseContext() { /* Read a context to prove */
- parseInput(CONTEXT);
-}
-#endif
-
-Cell parseInterface(nm,len) /* Read a GHC interface file */
-String nm;
-Long len; { /* Used to set a target for reading */
- input(RESET);
- Printf("Reading interface \"%s\"\n", nm );
- fileInput(nm,len);
- return parseInput(INTERFACE);
-}
-
-Cell parseModule(nm,len) /* Read a module */
-String nm;
-Long len; { /* Used to set a target for reading */
- input(RESET);
- Printf("Reading source file \"%s\"\n", nm );
- fileInput(nm,len);
- return parseInput(SCRIPT);
-}
-
-
-/* --------------------------------------------------------------------------
- * Input control:
- * ------------------------------------------------------------------------*/
-
-Void input(what)
-Int what; {
- switch (what) {
- case POSTPREL: break;
-
- case PREPREL : initCharTab();
- textCase = findText("case");
- textOfK = findText("of");
- textData = findText("data");
- textType = findText("type");
- textIf = findText("if");
- textThen = findText("then");
- textElse = findText("else");
- textWhere = findText("where");
- textLet = findText("let");
- textIn = findText("in");
- textInfix = findText("infix");
- textInfixl = findText("infixl");
- textInfixr = findText("infixr");
- textForeign = findText("foreign");
- textUnsafe = findText("unsafe");
- textNewtype = findText("newtype");
- textDefault = findText("default");
- textDeriving = findText("deriving");
- textDo = findText("do");
- textMdo = findText("mdo");
- textClass = findText("class");
-#if IPARAM
- textWith = findText("with");
- textDlet = findText("dlet");
-#endif
- textInstance = findText("instance");
- textCoco = findText("::");
- textEq = findText("=");
- textUpto = findText("..");
- textAs = findText("@");
- textLambda = findText("\\");
- textBar = findText("|");
- textMinus = findText("-");
- textPlus = findText("+");
- textFrom = findText("<-");
- textArrow = findText("->");
- textLazy = findText("~");
- textBang = findText("!");
- textDot = findText(".");
- textImplies = findText("=>");
- textPrelPrim = findText("PrelPrim");
- textPrelude = findText("Prelude");
- textNum = findText("Num");
- textModule = findText("module");
- textInterface = findText("__interface");
- textInstImport = findText("__instimport");
- textExport = findText("export");
- textDynamic = findText("dynamic");
- textCcall = findText("ccall");
- textStdcall = findText("stdcall");
- textUUExport = findText("__export");
- textImport = findText("import");
- textHiding = findText("hiding");
- textQualified = findText("qualified");
- textAsMod = findText("as");
- textWildcard = findText("_");
- textAll = findText("forall");
- textUUAll = findText("__forall");
- textUUUsage = findText("__u");
- varMinus = mkVar(textMinus);
- varPlus = mkVar(textPlus);
- varBang = mkVar(textBang);
- varDot = mkVar(textDot);
- varHiding = mkVar(textHiding);
- varQualified = mkVar(textQualified);
- varAsMod = mkVar(textAsMod);
- conMain = mkCon(findText("Main"));
- varMain = mkVar(findText("main"));
- evalDefaults = NIL;
-
- input(RESET);
- break;
-
- case RESET : tyconDefns = NIL;
- typeInDefns = NIL;
- valDefns = NIL;
- classDefns = NIL;
- instDefns = NIL;
- selDefns = NIL;
- genDefns = NIL;
- unqualImports= NIL;
- foreignImports= NIL;
- foreignExports= NIL;
- defaultDefns = NIL;
- defaultLine = 0;
- inputExpr = NIL;
- imps = NIL;
- closeAnyInput();
- break;
-
- case BREAK : if (reading==KEYBOARD)
- c0 = EOF;
- break;
-
- case MARK : mark(tyconDefns);
- mark(typeInDefns);
- mark(valDefns);
- mark(classDefns);
- mark(instDefns);
- mark(selDefns);
- mark(genDefns);
- mark(unqualImports);
- mark(foreignImports);
- mark(foreignExports);
- mark(defaultDefns);
- mark(evalDefaults);
- mark(inputExpr);
- mark(varMinus);
- mark(varPlus);
- mark(varBang);
- mark(varDot);
- mark(varHiding);
- mark(varQualified);
- mark(varAsMod);
- mark(varMain);
- mark(conMain);
- mark(imps);
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * GHC interface file processing for Hugs
- *
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
- *
- * $RCSfile: interface.c,v $
- * $Revision: 1.59 $
- * $Date: 2000/05/26 10:14:33 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "object.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h" /* for wrapping GHC objects */
-
-/*#define DEBUG_IFACE*/
-#define VERBOSE FALSE
-
-/* --------------------------------------------------------------------------
- * (This comment is now out of date. JRS, 991216).
- * The "addGHC*" functions act as "impedence matchers" between GHC
- * interface files and Hugs. Their main job is to convert abstract
- * syntax trees into Hugs' internal representations.
- *
- * The main trick here is how we deal with mutually recursive interface
- * files:
- *
- * o As we read an import decl, we add it to a list of required imports
- * (unless it's already loaded, of course).
- *
- * o Processing of declarations is split into two phases:
- *
- * 1) While reading the interface files, we construct all the Names,
- * Tycons, etc declared in the interface file but we don't try to
- * resolve references to any entities the declaration mentions.
- *
- * This is done by the "addGHC*" functions.
- *
- * 2) After reading all the interface files, we finish processing the
- * declarations by resolving any references in the declarations
- * and doing any other processing that may be required.
- *
- * This is done by the "finishGHC*" functions which use the
- * "fixup*" functions to assist them.
- *
- * The interface between these two phases are the "ghc*Decls" which
- * contain lists of decls that haven't been completed yet.
- *
- * ------------------------------------------------------------------------*/
-
-
-/*
-New comment, 991216, explaining roughly how it all works.
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-Interfaces can contain references to unboxed types, and these need to
-be handled carefully. The following is a summary of how the interface
-loader now works. It is applied to groups of interfaces simultaneously,
-viz, the entire Prelude at once:
-
-0. Parse interfaces, chasing imports until a complete
- strongly-connected-component of ifaces has been parsed.
- All interfaces in this scc are processed together, in
- steps 1 .. 8 below.
-
-1. Throw away any entity not mentioned in the export lists.
-
-2. Delete type (not data or newtype) definitions which refer to
- unknown types in their right hand sides. Because Hugs doesn't
- know of any unboxed types, this has the side effect of removing
- all type defns referring to unboxed types. Repeat step 2 until
- a fixed point is reached.
-
-3. Make abstract all data/newtype defns which refer to an unknown
- type. eg, data Word = MkW Word# becomes data Word, because
- Word# is unknown. Hugs is happy to know about abstract boxed
- Words, but not about Word#s.
-
-4. Step 2 could delete types referred to by values, instances and
- classes. So filter all entities, and delete those referring to
- unknown types _or_ classes. This could cause other entities
- to become invalid, so iterate step 4 to a fixed point.
-
- After step 4, the interfaces no longer contain anything
- unpalatable to Hugs.
-
-5. Steps 1-4 operate purely on the iface syntax trees. We now start
- creating symbol table entries. First, create a module table
- entry for each interface, and locate and read in the corresponding
- object file. This is done by the startGHCModule function.
-
-6. Traverse all interfaces. For each entity, create an entry in
- the name, tycon, class or instance table, and fill in relevant
- fields, but do not attempt to link tycon/class/instance/name uses
- to their symbol table entries. This is done by the startGHC*
- functions.
-
-7. Revisit all symbol table entries created in step 6. We should
- now be able to replace all references to tycons/classes/instances/
- names with the relevant symbol table entries. This is done by
- the finishGHC* functions.
-
-8. Traverse all interfaces. For each iface, examine the export lists
- and use it to build export lists in the module table. Do the
- implicit 'import Prelude' thing if necessary. Finally, resolve
- references in the object code for this module. This is done
- by the finishGHCModule function.
-*/
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void startGHCValue ( Int,VarId,Type );
-static Void finishGHCValue ( VarId );
-
-static Void startGHCSynonym ( Int,Cell,List,Type );
-static Void finishGHCSynonym ( Tycon );
-
-static Void startGHCClass ( Int,List,Cell,List,List );
-static Class finishGHCClass ( Class );
-
-static Inst startGHCInstance ( Int,List,Pair,VarId );
-static Void finishGHCInstance ( Inst );
-
-static Void startGHCImports ( ConId,List );
-static Void finishGHCImports ( ConId,List );
-
-static Void startGHCExports ( ConId,List );
-static Void finishGHCExports ( ConId,List );
-
-static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name );
-
-static Void finishGHCModule ( Cell );
-static Void startGHCModule ( Text );
-
-static Void startGHCDataDecl ( Int,List,Cell,List,List );
-static List finishGHCDataDecl ( ConId tyc );
-/* Supporting stuff for {start|finish}GHCDataDecl */
-static List startGHCConstrs ( Int,List,List );
-static Name startGHCSel ( Int,Pair );
-static Name startGHCConstr ( Int,Int,Triple );
-
-static Void startGHCNewType ( Int,List,Cell,List,Cell );
-static Void finishGHCNewType ( ConId tyc );
-
-
-
-static Kinds tvsToKind ( List );
-static Int arityFromType ( Type );
-static Int arityInclDictParams ( Type );
-static Bool allTypesKnown ( Type type,
- List aktys /* [QualId] */,
- ConId thisMod );
-
-static List ifTyvarsIn ( Type );
-static Type tvsToOffsets ( Int,Type,List );
-static Type conidcellsToTycons ( Int,Type );
-
-
-
-
-
-/* --------------------------------------------------------------------------
- * Top-level interface processing
- * ------------------------------------------------------------------------*/
-
-/* getIEntityName :: I_IMPORT..I_VALUE -> ConVarId | NIL */
-static ConVarId getIEntityName ( Cell c )
-{
- switch (whatIs(c)) {
- case I_IMPORT: return NIL;
- case I_INSTIMPORT: return NIL;
- case I_EXPORT: return NIL;
- case I_FIXDECL: return zthd3(unap(I_FIXDECL,c));
- case I_INSTANCE: return NIL;
- case I_TYPE: return zsel24(unap(I_TYPE,c));
- case I_DATA: return zsel35(unap(I_DATA,c));
- case I_NEWTYPE: return zsel35(unap(I_NEWTYPE,c));
- case I_CLASS: return zsel35(unap(I_CLASS,c));
- case I_VALUE: return zsnd3(unap(I_VALUE,c));
- default: internal("getIEntityName");
- }
-}
-
-
-/* Filter the contents of an interface, using the supplied predicate.
- For flexibility, the predicate is passed as a second arg the value
- extraArgs. This is a hack to get round the lack of partial applications
- in C. Pred should not have any side effects. The dumpaction param
- gives us the chance to print a message or some such for dumped items.
- When a named entity is deleted, filterInterface also deletes the name
- in the export lists.
-*/
-static Cell filterInterface ( Cell root,
- Bool (*pred)(Cell,Cell),
- Cell extraArgs,
- Void (*dumpAction)(Cell) )
-{
- List tops;
- Cell iface = unap(I_INTERFACE,root);
- List tops2 = NIL;
- List deleted_ids = NIL; /* :: [ConVarId] */
-
- for (tops = zsnd(iface); nonNull(tops); tops=tl(tops)) {
- if (pred(hd(tops),extraArgs)) {
- tops2 = cons( hd(tops), tops2 );
- } else {
- ConVarId deleted_id = getIEntityName ( hd(tops) );
- if (nonNull(deleted_id))
- deleted_ids = cons ( deleted_id, deleted_ids );
- if (dumpAction)
- dumpAction ( hd(tops) );
- }
- }
- tops2 = reverse(tops2);
-
- /* Clean up the export list now. */
- for (tops=tops2; nonNull(tops); tops=tl(tops)) {
- if (whatIs(hd(tops))==I_EXPORT) {
- Cell exdecl = unap(I_EXPORT,hd(tops));
- List exlist = zsnd(exdecl);
- List exlist2 = NIL;
- for (; nonNull(exlist); exlist=tl(exlist)) {
- Cell ex = hd(exlist);
- ConVarId exid = isZPair(ex) ? zfst(ex) : ex;
- assert (isCon(exid) || isVar(exid));
- if (!varIsMember(textOf(exid),deleted_ids))
- exlist2 = cons(ex, exlist2);
- }
- hd(tops) = ap(I_EXPORT,zpair(zfst(exdecl),exlist2));
- }
- }
-
- return ap(I_INTERFACE, zpair(zfst(iface),tops2));
-}
-
-
-List /* of CONID */ getInterfaceImports ( Cell iface )
-{
- List tops;
- List imports = NIL;
-
- for (tops = zsnd(unap(I_INTERFACE,iface)); nonNull(tops); tops=tl(tops))
- if (whatIs(hd(tops)) == I_IMPORT) {
- ZPair imp_decl = unap(I_IMPORT,hd(tops));
- ConId m_to_imp = zfst(imp_decl);
- if (textOf(m_to_imp) != findText("PrelGHC")) {
- imports = cons(m_to_imp,imports);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "add iface %s\n",
- textToStr(textOf(m_to_imp)));
-# endif
- }
- }
- return imports;
-}
-
-
-/* getExportDeclsInIFace :: I_INTERFACE -> [I_EXPORT] */
-static List getExportDeclsInIFace ( Cell root )
-{
- Cell iface = unap(I_INTERFACE,root);
- List decls = zsnd(iface);
- List exports = NIL;
- List ds;
- for (ds=decls; nonNull(ds); ds=tl(ds))
- if (whatIs(hd(ds))==I_EXPORT)
- exports = cons(hd(ds), exports);
- return exports;
-}
-
-
-/* Does t start with "$dm" ? */
-static Bool isIfaceDefaultMethodName ( Text t )
-{
- String s = textToStr(t);
- return (s && s[0]=='$' && s[1]=='d' && s[2]=='m' && s[3]);
-}
-
-
-static Bool isExportedIFaceEntity ( Cell ife, List exlist_list )
-{
- /* ife :: I_IMPORT..I_VALUE */
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
- Text tnm;
- List exlist;
- List t;
- String s;
-
- ConVarId ife_id = getIEntityName ( ife );
-
- if (isNull(ife_id)) return TRUE;
-
- tnm = textOf(ife_id);
-
- /* Don't junk default methods, even tho the export list doesn't
- mention them.
- */
- if (isIfaceDefaultMethodName(tnm)) goto retain;
-
- /* for each export list ... */
- for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
- exlist = hd(exlist_list);
-
- /* for each entity in an export list ... */
- for (t=exlist; nonNull(t); t=tl(t)) {
- if (isZPair(hd(t))) {
- /* A pair, which means an export entry
- of the form ClassName(foo,bar). */
- List subents = cons(zfst(hd(t)),zsnd(hd(t)));
- for (; nonNull(subents); subents=tl(subents))
- if (textOf(hd(subents)) == tnm) goto retain;
- } else {
- /* Single name in the list. */
- if (textOf(hd(t)) == tnm) goto retain;
- }
- }
-
- }
-# ifdef DEBUG_IFACE
- fprintf ( stderr, " dump %s\n", textToStr(tnm) );
-# endif
- return FALSE;
-
- retain:
-# ifdef DEBUG_IFACE
- fprintf ( stderr, " retain %s\n", textToStr(tnm) );
-# endif
- return TRUE;
-}
-
-
-static Bool isExportedAbstractly ( ConId ife_id, List exlist_list )
-{
- /* ife_id :: ConId */
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
- Text tnm;
- List exlist;
- List t;
-
- assert (isCon(ife_id));
- tnm = textOf(ife_id);
-
- /* for each export list ... */
- for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
- exlist = hd(exlist_list);
-
- /* for each entity in an export list ... */
- for (t=exlist; nonNull(t); t=tl(t)) {
- if (isZPair(hd(t))) {
- /* A pair, which means an export entry
- of the form ClassName(foo,bar). */
- if (textOf(zfst(hd(t))) == tnm) return FALSE;
- } else {
- if (textOf(hd(t)) == tnm) return TRUE;
- }
- }
- }
- internal("isExportedAbstractly");
- return FALSE; /*notreached*/
-}
-
-
-/* Remove entities not mentioned in any of the export lists. */
-static Cell deleteUnexportedIFaceEntities ( Cell root )
-{
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- List decls = zsnd(iface);
- List decls2 = NIL;
- List exlist_list = NIL;
- List t;
-
-# ifdef DEBUG_IFACE
- fprintf(stderr, "\ncleanIFace: %s\n", textToStr(textOf(iname)));
-# endif
-
- exlist_list = getExportDeclsInIFace ( root );
- /* exlist_list :: [I_EXPORT] */
-
- for (t=exlist_list; nonNull(t); t=tl(t))
- hd(t) = zsnd(unap(I_EXPORT,hd(t)));
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
-
-#if 0
- if (isNull(exlist_list)) {
- ERRMSG(0) "Can't find any export lists in interface file"
- EEND;
- }
-#endif
-
- return filterInterface ( root, isExportedIFaceEntity,
- exlist_list, NULL );
-}
-
-
-/* addTyconsAndClassesFromIFace :: I_INTERFACE -> [QualId] -> [QualId] */
-static List addTyconsAndClassesFromIFace ( Cell root, List aktys )
-{
- Cell iface = unap(I_INTERFACE,root);
- Text mname = textOf(zfst(iface));
- List defns = zsnd(iface);
- for (; nonNull(defns); defns = tl(defns)) {
- Cell defn = hd(defns);
- Cell what = whatIs(defn);
- if (what==I_TYPE || what==I_DATA
- || what==I_NEWTYPE || what==I_CLASS) {
- QualId q = mkQCon ( mname, textOf(getIEntityName(defn)) );
- if (!qualidIsMember ( q, aktys ))
- aktys = cons ( q, aktys );
- }
- }
- return aktys;
-}
-
-
-static Void ifentityAllTypesKnown_dumpmsg ( Cell entity )
-{
- ConVarId id = getIEntityName ( entity );
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "dumping %s because of unknown type(s)\n",
- isNull(id) ? "(nameless entity?!)" : textToStr(textOf(id)) );
-# endif
-}
-
-
-/* ifentityAllTypesKnown :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
-/* mod is the current module being processed -- so we can qualify unqual'd
- names. Strange calling convention for aktys and mod is so we can call this
- from filterInterface.
-*/
-static Bool ifentityAllTypesKnown ( Cell entity, ZPair aktys_mod )
-{
- List t, u;
- List aktys = zfst ( aktys_mod );
- ConId mod = zsnd ( aktys_mod );
- switch (whatIs(entity)) {
- case I_IMPORT:
- case I_INSTIMPORT:
- case I_EXPORT:
- case I_FIXDECL:
- return TRUE;
- case I_INSTANCE: {
- Cell inst = unap(I_INSTANCE,entity);
- List ctx = zsel25 ( inst ); /* :: [((QConId,VarId))] */
- Type cls = zsel35 ( inst ); /* :: Type */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
- if (!allTypesKnown(cls, aktys,mod)) return FALSE;
- return TRUE;
- }
- case I_TYPE:
- return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
- case I_DATA: {
- Cell data = unap(I_DATA,entity);
- List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
- List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
- for (t = constrs; nonNull(t); t=tl(t))
- for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
- if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) return FALSE;
- return TRUE;
- }
- case I_NEWTYPE: {
- Cell newty = unap(I_NEWTYPE,entity);
- List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
- ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
- if (nonNull(constr)
- && !allTypesKnown(zsnd(constr),aktys,mod)) return FALSE;
- return TRUE;
- }
- case I_CLASS: {
- Cell klass = unap(I_CLASS,entity);
- List ctx = zsel25(klass); /* :: [((QConId,VarId))] */
- List sigs = zsel55(klass); /* :: [((VarId,Type))] */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) return FALSE;
- for (t = sigs; nonNull(t); t=tl(t))
- if (!allTypesKnown(zsnd(hd(t)),aktys,mod)) return FALSE;
- return TRUE;
- }
- case I_VALUE:
- return allTypesKnown( zthd3(unap(I_VALUE,entity)), aktys,mod );
- default:
- internal("ifentityAllTypesKnown");
- }
-}
-
-
-/* ifTypeDoesntRefUnknownTycon :: I_IMPORT..I_VALUE -> (([QualId], ConId)) -> Bool */
-/* mod is the current module being processed -- so we can qualify unqual'd
- names. Strange calling convention for aktys and mod is so we can call this
- from filterInterface.
-*/
-static Bool ifTypeDoesntRefUnknownTycon ( Cell entity, ZPair aktys_mod )
-{
- List t, u;
- List aktys = zfst ( aktys_mod );
- ConId mod = zsnd ( aktys_mod );
- if (whatIs(entity) != I_TYPE) {
- return TRUE;
- } else {
- return allTypesKnown( zsel44(unap(I_TYPE,entity)), aktys,mod );
- }
-}
-
-
-static Void ifTypeDoesntRefUnknownTycon_dumpmsg ( Cell entity )
-{
- ConVarId id = getIEntityName ( entity );
- assert (whatIs(entity)==I_TYPE);
- assert (isCon(id));
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "dumping type %s because of unknown tycon(s)\n",
- textToStr(textOf(id)) );
-# endif
-}
-
-
-/* abstractifyExport :: I_EXPORT -> ConId -> I_EXPORT
-*/
-static List abstractifyExDecl ( Cell root, ConId toabs )
-{
- ZPair exdecl = unap(I_EXPORT,root);
- List exlist = zsnd(exdecl);
- List res = NIL;
- for (; nonNull(exlist); exlist = tl(exlist)) {
- if (isZPair(hd(exlist))
- && textOf(toabs) == textOf(zfst(hd(exlist)))) {
- /* it's toabs, exported non-abstractly */
- res = cons ( zfst(hd(exlist)), res );
- } else {
- res = cons ( hd(exlist), res );
- }
- }
- return ap(I_EXPORT,zpair(zfst(exdecl),reverse(res)));
-}
-
-
-static Void ppModule ( Text modt )
-{
-# ifdef DEBUG_IFACE
- fflush(stderr); fflush(stdout);
- fprintf(stderr, "---------------- MODULE %s ----------------\n",
- textToStr(modt) );
-# endif
-}
-
-
-static void* ifFindItblFor ( Name n )
-{
- /* n is a constructor for which we want to find the GHC info table.
- First look for a _con_info symbol. If that doesn't exist, _and_
- this is a nullary constructor, then it's safe to look for the
- _static_info symbol instead.
- */
- void* p;
- char buf[1000];
- Text t;
-
- sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_con_info"),
- textToStr( module(name(n).mod).text ),
- textToStr( name(n).text ) );
- t = enZcodeThenFindText(buf);
- p = lookupOTabName ( name(n).mod, textToStr(t) );
-
- if (p) return p;
-
- if (name(n).arity == 0) {
- sprintf ( buf, MAYBE_LEADING_UNDERSCORE_STR("%s_%s_static_info"),
- textToStr( module(name(n).mod).text ),
- textToStr( name(n).text ) );
- t = enZcodeThenFindText(buf);
- p = lookupOTabName ( name(n).mod, textToStr(t) );
- if (p) return p;
- }
-
- ERRMSG(0) "Can't find info table %s", textToStr(t)
- EEND;
-}
-
-
-void ifLinkConstrItbl ( Name n )
-{
- /* name(n) is either a constructor or a field name.
- If the latter, ignore it. If it is a non-nullary constructor,
- find its info table in the object code. If it's nullary,
- we can skip the info table, since all accesses will go via
- the _closure label.
- */
- if (islower(textToStr(name(n).text)[0])) return;
- if (name(n).arity == 0) return;
- name(n).itbl = ifFindItblFor(n);
-}
-
-
-static void ifSetClassDefaultsAndDCon ( Class c )
-{
- char buf[100];
- char buf2[1000];
- String s;
- Name n;
- Text t;
- void* p;
- List defs; /* :: [Name] */
- List mems; /* :: [Name] */
- Module m;
- assert(isNull(cclass(c).defaults));
-
- /* Create the defaults list by more-or-less cloning the members list. */
- defs = NIL;
- for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
- strcpy(buf, "$dm");
- s = textToStr( name(hd(mems)).text );
- assert(strlen(s) < 95);
- strcat(buf, s);
- n = findNameInAnyModule(findText(buf));
- assert (nonNull(n));
- defs = cons(n,defs);
- }
- defs = rev(defs);
- cclass(c).defaults = defs;
-
- /* Create a name table entry for the dictionary datacon.
- Interface files don't mention them, so it had better not
- already be present.
- */
- strcpy(buf, ":D");
- s = textToStr( cclass(c).text );
- assert( strlen(s) < 96 );
- strcat(buf, s);
- t = findText(buf);
- n = findNameInAnyModule(t);
- assert(isNull(n));
-
- m = cclass(c).mod;
- n = newName(t,NIL);
- name(n).mod = m;
- name(n).arity = cclass(c).numSupers + cclass(c).numMembers;
- name(n).number = cfunNo(0);
- cclass(c).dcon = n;
-
- /* And finally ... set name(n).itbl to Mod_:DClass_con_info.
- Because this happens right at the end of loading, we know
- that we should actually be able to find the symbol in this
- module's object symbol table. Except that if the dictionary
- has arity 1, we don't bother, since it will be represented as
- a newtype and not as a data, so its itbl can remain NULL.
- */
- if (name(n).arity == 1) {
- name(n).itbl = NULL;
- name(n).defn = nameId;
- } else {
- p = ifFindItblFor ( n );
- name(n).itbl = p;
- }
-}
-
-
-void processInterfaces ( List /* of CONID */ iface_modnames )
-{
- List tmp;
- List xs;
- ZTriple tr;
- Cell iface;
- Int sizeObj;
- Text nameObj;
- Text mname;
- List decls;
- Module mod;
- List all_known_types;
- Int num_known_types;
- List cls_list; /* :: List Class */
- List constructor_list; /* :: List Name */
-
- List ifaces = NIL; /* :: List I_INTERFACE */
-
- if (isNull(iface_modnames)) return;
-
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "processInterfaces: %d interfaces to process\n",
- length(ifaces_outstanding) );
-# endif
-
- for (xs = iface_modnames; nonNull(xs); xs=tl(xs)) {
- mod = findModule(textOf(hd(xs)));
- assert(nonNull(mod));
- assert(module(mod).mode == FM_OBJECT);
- ifaces = cons ( module(mod).tree, ifaces );
- }
- ifaces = reverse(ifaces);
-
- /* Clean up interfaces -- dump non-exported value, class, type decls */
- for (xs = ifaces; nonNull(xs); xs = tl(xs))
- hd(xs) = deleteUnexportedIFaceEntities(hd(xs));
-
-
- /* Iteratively delete any type declarations which refer to unknown
- tycons.
- */
- num_known_types = 999999999;
- while (TRUE) {
- Int i;
-
- /* Construct a list of all known tycons. This is a list of QualIds.
- Unfortunately it also has to contain all known class names, since
- allTypesKnown cannot distinguish between tycons and classes -- a
- deficiency of the iface abs syntax.
- */
- all_known_types = getAllKnownTyconsAndClasses();
- for (xs = ifaces; nonNull(xs); xs=tl(xs))
- all_known_types
- = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
-
- /* Have we reached a fixed point? */
- i = length(all_known_types);
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "\n============= %d known types =============\n", i );
-# endif
- if (num_known_types == i) break;
- num_known_types = i;
-
- /* Delete all entities which refer to unknown tycons. */
- for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
- ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
- assert(nonNull(mod));
- hd(xs) = filterInterface ( hd(xs),
- ifTypeDoesntRefUnknownTycon,
- zpair(all_known_types,mod),
- ifTypeDoesntRefUnknownTycon_dumpmsg );
- }
- }
-
- /* Now abstractify any datas and newtypes which refer to unknown tycons
- -- including, of course, the type decls just deleted.
- */
- for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
- List absify = NIL; /* :: [ConId] */
- ZPair iface = unap(I_INTERFACE,hd(xs)); /* ((ConId, [I_IMPORT..I_VALUE])) */
- ConId mod = zfst(iface);
- List aktys = all_known_types; /* just a renaming */
- List es,t,u;
- List exlist_list;
-
- /* Compute into absify the list of all ConIds (tycons) we need to
- abstractify.
- */
- for (es = zsnd(iface); nonNull(es); es=tl(es)) {
- Cell ent = hd(es);
- Bool allKnown = TRUE;
-
- if (whatIs(ent)==I_DATA) {
- Cell data = unap(I_DATA,ent);
- List ctx = zsel25 ( data ); /* :: [((QConId,VarId))] */
- List constrs = zsel55 ( data ); /* :: [ ((ConId, [((Type,VarId,Int))] )) ] */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
- for (t = constrs; nonNull(t); t=tl(t))
- for (u = zsnd(hd(t)); nonNull(u); u=tl(u))
- if (!allTypesKnown(zfst3(hd(u)),aktys,mod)) allKnown = FALSE;
- }
- else if (whatIs(ent)==I_NEWTYPE) {
- Cell newty = unap(I_NEWTYPE,ent);
- List ctx = zsel25(newty); /* :: [((QConId,VarId))] */
- ZPair constr = zsel55 ( newty ); /* :: ((ConId,Type)) */
- for (t = ctx; nonNull(t); t=tl(t))
- if (!allTypesKnown(zfst(hd(t)),aktys,mod)) allKnown = FALSE;
- if (!allTypesKnown(zsnd(constr),aktys,mod)) allKnown = FALSE;
- }
-
- if (!allKnown) {
- absify = cons ( getIEntityName(ent), absify );
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "abstractifying %s because it uses an unknown type\n",
- textToStr(textOf(getIEntityName(ent))) );
-# endif
- }
- }
-
- /* mark in exports as abstract all names in absify (modifies iface) */
- for (; nonNull(absify); absify=tl(absify)) {
- ConId toAbs = hd(absify);
- for (es = zsnd(iface); nonNull(es); es=tl(es)) {
- if (whatIs(hd(es)) != I_EXPORT) continue;
- hd(es) = abstractifyExDecl ( hd(es), toAbs );
- }
- }
-
- /* For each data/newtype in the export list marked as abstract,
- remove the constructor lists. This catches all abstractification
- caused by the code above, and it also catches tycons which really
- were exported abstractly.
- */
-
- exlist_list = getExportDeclsInIFace ( ap(I_INTERFACE,iface) );
- /* exlist_list :: [I_EXPORT] */
- for (t=exlist_list; nonNull(t); t=tl(t))
- hd(t) = zsnd(unap(I_EXPORT,hd(t)));
- /* exlist_list :: [[ ConVarId | ((ConId, [ConVarId])) ]] */
-
- for (es = zsnd(iface); nonNull(es); es=tl(es)) {
- Cell ent = hd(es);
- if (whatIs(ent)==I_DATA
- && isExportedAbstractly ( getIEntityName(ent),
- exlist_list )) {
- Cell data = unap(I_DATA,ent);
- data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
- zsel45(data), NIL /* the constr list */ );
- hd(es) = ap(I_DATA,data);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "abstractify data %s\n",
- textToStr(textOf(getIEntityName(ent))) );
-# endif
- }
- else if (whatIs(ent)==I_NEWTYPE
- && isExportedAbstractly ( getIEntityName(ent),
- exlist_list )) {
- Cell data = unap(I_NEWTYPE,ent);
- data = z5ble ( zsel15(data), zsel25(data), zsel35(data),
- zsel45(data), NIL /* the constr-type pair */ );
- hd(es) = ap(I_NEWTYPE,data);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "abstractify newtype %s\n",
- textToStr(textOf(getIEntityName(ent))) );
-# endif
- }
- }
-
- /* We've finally finished mashing this iface. Update the iface list. */
- hd(xs) = ap(I_INTERFACE,iface);
- }
-
-
- /* At this point, the interfaces are cleaned up so that no type, data or
- newtype defn refers to a non-existant type. However, there still may
- be value defns, classes and instances which refer to unknown types.
- Delete iteratively until a fixed point is reached.
- */
-# ifdef DEBUG_IFACE
- fprintf(stderr,"\n");
-# endif
- num_known_types = 999999999;
- while (TRUE) {
- Int i;
-
- /* Construct a list of all known tycons. This is a list of QualIds.
- Unfortunately it also has to contain all known class names, since
- allTypesKnown cannot distinguish between tycons and classes -- a
- deficiency of the iface abs syntax.
- */
- all_known_types = getAllKnownTyconsAndClasses();
- for (xs = ifaces; nonNull(xs); xs=tl(xs))
- all_known_types = addTyconsAndClassesFromIFace ( hd(xs), all_known_types );
-
- /* Have we reached a fixed point? */
- i = length(all_known_types);
-# ifdef DEBUG_IFACE
- fprintf ( stderr,
- "\n------------- %d known types -------------\n", i );
-# endif
- if (num_known_types == i) break;
- num_known_types = i;
-
- /* Delete all entities which refer to unknown tycons. */
- for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
- ConId mod = zfst(unap(I_INTERFACE,hd(xs)));
- assert(nonNull(mod));
-
- hd(xs) = filterInterface ( hd(xs),
- ifentityAllTypesKnown,
- zpair(all_known_types,mod),
- ifentityAllTypesKnown_dumpmsg );
- }
- }
-
-
- /* Allocate module table entries and read in object code. */
- for (xs=ifaces; nonNull(xs); xs=tl(xs))
- startGHCModule ( textOf(zfst(unap(I_INTERFACE,hd(xs)))) );
-
-
- /* Now work through the decl lists of the modules, and call the
- startGHC* functions on the entities. This creates names in
- various tables but doesn't bind them to anything.
- */
-
- for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
- iface = unap(I_INTERFACE,hd(xs));
- mname = textOf(zfst(iface));
- mod = findModule(mname);
- if (isNull(mod)) internal("processInterfaces(4)");
- setCurrModule(mod);
- ppModule ( module(mod).text );
-
- for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
- Cell decl = hd(decls);
- switch(whatIs(decl)) {
- case I_EXPORT: {
- Cell exdecl = unap(I_EXPORT,decl);
- startGHCExports ( zfst(exdecl), zsnd(exdecl) );
- break;
- }
- case I_IMPORT: {
- Cell imdecl = unap(I_IMPORT,decl);
- startGHCImports ( zfst(imdecl), zsnd(imdecl) );
- break;
- }
- case I_FIXDECL: {
- break;
- }
- case I_INSTANCE: {
- /* Trying to find the instance table location allocated by
- startGHCInstance in subsequent processing is a nightmare, so
- cache it on the tree.
- */
- Cell instance = unap(I_INSTANCE,decl);
- Inst in = startGHCInstance ( zsel15(instance), zsel25(instance),
- zsel35(instance), zsel45(instance) );
- hd(decls) = ap(I_INSTANCE,
- z5ble( zsel15(instance), zsel25(instance),
- zsel35(instance), zsel45(instance), in ));
- break;
- }
- case I_TYPE: {
- Cell tydecl = unap(I_TYPE,decl);
- startGHCSynonym ( zsel14(tydecl), zsel24(tydecl),
- zsel34(tydecl), zsel44(tydecl) );
- break;
- }
- case I_DATA: {
- Cell ddecl = unap(I_DATA,decl);
- startGHCDataDecl ( zsel15(ddecl), zsel25(ddecl),
- zsel35(ddecl), zsel45(ddecl), zsel55(ddecl) );
- break;
- }
- case I_NEWTYPE: {
- Cell ntdecl = unap(I_NEWTYPE,decl);
- startGHCNewType ( zsel15(ntdecl), zsel25(ntdecl),
- zsel35(ntdecl), zsel45(ntdecl),
- zsel55(ntdecl) );
- break;
- }
- case I_CLASS: {
- Cell klass = unap(I_CLASS,decl);
- startGHCClass ( zsel15(klass), zsel25(klass),
- zsel35(klass), zsel45(klass),
- zsel55(klass) );
- break;
- }
- case I_VALUE: {
- Cell value = unap(I_VALUE,decl);
- startGHCValue ( zfst3(value), zsnd3(value), zthd3(value) );
- break;
- }
- default:
- internal("processInterfaces(1)");
- }
- }
- }
-
-# ifdef DEBUG_IFACE
- fprintf(stderr, "\n============================"
- "=============================\n");
- fprintf(stderr, "=============================="
- "===========================\n");
-# endif
-
- /* Traverse again the decl lists of the modules, this time
- calling the finishGHC* functions. But don't process
- the export lists; those must wait for later.
- */
- cls_list = NIL;
- constructor_list = NIL;
- for (xs = ifaces; nonNull(xs); xs = tl(xs)) {
- iface = unap(I_INTERFACE,hd(xs));
- mname = textOf(zfst(iface));
- mod = findModule(mname);
- if (isNull(mod)) internal("processInterfaces(3)");
- setCurrModule(mod);
- ppModule ( module(mod).text );
-
- for (decls = zsnd(iface); nonNull(decls); decls = tl(decls)) {
- Cell decl = hd(decls);
- switch(whatIs(decl)) {
- case I_EXPORT: {
- break;
- }
- case I_IMPORT: {
- break;
- }
- case I_FIXDECL: {
- Cell fixdecl = unap(I_FIXDECL,decl);
- finishGHCFixdecl ( zfst3(fixdecl), zsnd3(fixdecl), zthd3(fixdecl) );
- break;
- }
- case I_INSTANCE: {
- Cell instance = unap(I_INSTANCE,decl);
- finishGHCInstance ( zsel55(instance) );
- break;
- }
- case I_TYPE: {
- Cell tydecl = unap(I_TYPE,decl);
- finishGHCSynonym ( zsel24(tydecl) );
- break;
- }
- case I_DATA: {
- Cell ddecl = unap(I_DATA,decl);
- List constrs = finishGHCDataDecl ( zsel35(ddecl) );
- constructor_list = dupOnto ( constrs, constructor_list );
- break;
- }
- case I_NEWTYPE: {
- Cell ntdecl = unap(I_NEWTYPE,decl);
- finishGHCNewType ( zsel35(ntdecl) );
- break;
- }
- case I_CLASS: {
- Cell klass = unap(I_CLASS,decl);
- Class cls = finishGHCClass ( zsel35(klass) );
- cls_list = cons(cls,cls_list);
- break;
- }
- case I_VALUE: {
- Cell value = unap(I_VALUE,decl);
- finishGHCValue ( zsnd3(value) );
- break;
- }
- default:
- internal("processInterfaces(2)");
- }
- }
- }
-# ifdef DEBUG_IFACE
- fprintf(stderr, "\n+++++++++++++++++++++++++++++"
- "++++++++++++++++++++++++++++\n");
- fprintf(stderr, "+++++++++++++++++++++++++++++++"
- "++++++++++++++++++++++++++\n");
-# endif
-
- /* Build the module(m).export lists for each module, by running
- through the export lists in the iface. Also, do the implicit
- 'import Prelude' thing. And finally, do the object code
- linking.
- */
- for (xs = ifaces; nonNull(xs); xs = tl(xs))
- finishGHCModule(hd(xs));
-
- mapProc(visitClass,cls_list);
- mapProc(ifSetClassDefaultsAndDCon,cls_list);
- mapProc(ifLinkConstrItbl,constructor_list);
-
- /* Finished! */
- ifaces_outstanding = NIL;
-}
-
-
-/* --------------------------------------------------------------------------
- * Modules
- * ------------------------------------------------------------------------*/
-
-static void startGHCModule_errMsg ( char* msg )
-{
- fprintf ( stderr, "object error: %s\n", msg );
-}
-
-static void* startGHCModule_clientLookup ( char* sym )
-{
-# ifdef DEBUG_IFACE
- /* fprintf ( stderr, "CLIENTLOOKUP %s\n", sym ); */
-# endif
- return lookupObjName ( sym );
-}
-
-static int /*Bool*/ startGHCModule_clientWantsSymbol ( char* sym )
-{
- if (strcmp(sym,"ghc_cc_ID")==0) return 0;
- return 1;
-}
-
-static ObjectCode* startGHCModule_partial_load ( String objNm, Int objSz )
-{
- ObjectCode* oc
- = ocNew ( startGHCModule_errMsg,
- startGHCModule_clientLookup,
- startGHCModule_clientWantsSymbol,
- objNm, objSz );
-
- if (!oc) {
- ERRMSG(0) "Storage allocation for object file \"%s\" failed", objNm
- EEND;
- }
- if (!ocLoadImage(oc,VERBOSE)) {
- ERRMSG(0) "Reading of object file \"%s\" failed", objNm
- EEND;
- }
- if (!ocVerifyImage(oc,VERBOSE)) {
- ERRMSG(0) "Validation of object file \"%s\" failed", objNm
- EEND;
- }
- if (!ocGetNames(oc,VERBOSE)) {
- ERRMSG(0) "Reading of symbol names in object file \"%s\" failed", objNm
- EEND;
- }
- return oc;
-}
-
-static Void startGHCModule ( Text mname )
-{
- List xts;
- Module m = findModule(mname);
- assert(nonNull(m));
-
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "startGHCIface: name %16s objsize %d\n",
- textToStr(mname), module(m).objSize );
-# endif
- if (module(m).fake)
- module(m).fake = FALSE;
-
- /* Get hold of the primary object for the module. */
- module(m).object
- = startGHCModule_partial_load ( textToStr(module(m).objName),
- module(m).objSize );
-
- /* and any extras ... */
- for (xts = module(m).objectExtraNames; nonNull(xts); xts=tl(xts)) {
- Int size;
- ObjectCode* oc;
- Text xtt = hd(xts);
- String nm = getExtraObjectInfo (
- textToStr(module(m).objName),
- textToStr(xtt),
- &size
- );
- if (size == -1) {
- ERRMSG(0) "Can't find extra object file \"%s\"", nm
- EEND;
- }
- oc = startGHCModule_partial_load ( nm, size );
- oc->next = module(m).objectExtras;
- module(m).objectExtras = oc;
- }
-}
-
-
-/* For the module mod, augment both the export environment (.exports)
- and the eval environment (.names, .tycons, .classes)
- with the symbols mentioned in exlist. We don't actually need
- to modify the names, tycons, classes or instances in the eval
- environment, since previous processing of the
- top-level decls in the iface should have done this already.
-
- mn is the module mentioned in the export list; it is the "original"
- module for the symbols in the export list. We should also record
- this info with the symbols, since references to object code need to
- refer to the original module in which a symbol was defined, rather
- than to some module it has been imported into and then re-exported.
-
- We take the policy that if something mentioned in an export list
- can't be found in the symbol tables, it is simply ignored. After all,
- previous processing of the iface syntax trees has already removed
- everything which Hugs can't handle, so if there is mention of these
- things still lurking in export lists somewhere, about the only thing
- to do is to ignore it.
-
- Also do an implicit 'import Prelude' thingy for the module,
- if appropriate.
-*/
-
-
-static Void finishGHCModule ( Cell root )
-{
- /* root :: I_INTERFACE */
- Cell iface = unap(I_INTERFACE,root);
- ConId iname = zfst(iface);
- Module mod = findModule(textOf(iname));
- List exlist_list = NIL;
- List t;
- ObjectCode* oc;
-
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin finishGHCModule %s\n", textToStr(textOf(iname)));
-# endif
-
- if (isNull(mod)) internal("finishExports(1)");
- setCurrModule(mod);
-
- exlist_list = getExportDeclsInIFace ( root );
- /* exlist_list :: [I_EXPORT] */
-
- for (; nonNull(exlist_list); exlist_list=tl(exlist_list)) {
- ZPair exdecl = unap(I_EXPORT,hd(exlist_list));
- ConId exmod = zfst(exdecl);
- List exlist = zsnd(exdecl);
- /* exlist :: [ ConVarId | ((ConId, [ConVarId])) ] */
-
- for (; nonNull(exlist); exlist=tl(exlist)) {
- Bool abstract;
- List subents;
- Cell c;
- QualId q;
- Cell ex = hd(exlist);
-
- switch (whatIs(ex)) {
-
- case VARIDCELL: /* variable */
- q = mkQualId(exmod,ex);
- c = findQualNameWithoutConsultingExportList ( q );
- if (isNull(c)) goto notfound;
-# ifdef DEBUG_IFACE
- fprintf(stderr, " var %s\n", textToStr(textOf(ex)) );
-# endif
- module(mod).exports = cons(c, module(mod).exports);
- addName(c);
- break;
-
- case CONIDCELL: /* non data tycon */
- q = mkQualId(exmod,ex);
- c = findQualTyconWithoutConsultingExportList ( q );
- if (isNull(c)) goto notfound;
-# ifdef DEBUG_IFACE
- fprintf(stderr, " type %s\n", textToStr(textOf(ex)) );
-# endif
- module(mod).exports = cons(pair(c,NIL), module(mod).exports);
- addTycon(c);
- break;
-
- case ZTUP2: /* data T = C1 ... Cn or class C where f1 ... fn */
- subents = zsnd(ex); /* :: [ConVarId] */
- ex = zfst(ex); /* :: ConId */
- q = mkQualId(exmod,ex);
- c = findQualTyconWithoutConsultingExportList ( q );
-
- if (nonNull(c)) { /* data */
-# ifdef DEBUG_IFACE
- fprintf(stderr, " data/newtype %s = { ",
- textToStr(textOf(ex)) );
-# endif
- assert(tycon(c).what == DATATYPE || tycon(c).what==NEWTYPE);
- abstract = isNull(tycon(c).defn);
- /* This data/newtype could be abstract even tho the export list
- says to export it non-abstractly. That happens if it was
- imported from some other module and is now being re-exported,
- and previous cleanup phases have abstractified it in the
- original (defining) module.
- */
- if (abstract) {
- module(mod).exports = cons(pair(c,NIL), module(mod).exports);
- addTycon(c);
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "(abstract) ");
-# endif
- } else {
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
- addTycon(c);
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isCon(ent2) || isVar(ent2));
- /* isVar since could be a field name */
- q = mkQualId(exmod,ent2);
- c = findQualNameWithoutConsultingExportList ( q );
-# ifdef DEBUG_IFACE
- fprintf(stderr, "%s ", textToStr(name(c).text));
-# endif
- assert(nonNull(c));
- /* module(mod).exports = cons(c, module(mod).exports); */
- addName(c);
- }
- }
-# ifdef DEBUG_IFACE
- fprintf(stderr, "}\n" );
-# endif
- } else { /* class */
- q = mkQualId(exmod,ex);
- c = findQualClassWithoutConsultingExportList ( q );
- if (isNull(c)) goto notfound;
-# ifdef DEBUG_IFACE
- fprintf(stderr, " class %s { ", textToStr(textOf(ex)) );
-# endif
- module(mod).exports = cons(pair(c,DOTDOT), module(mod).exports);
- addClass(c);
- for (; nonNull(subents); subents = tl(subents)) {
- Cell ent2 = hd(subents);
- assert(isVar(ent2));
- q = mkQualId(exmod,ent2);
- c = findQualNameWithoutConsultingExportList ( q );
-# ifdef DEBUG_IFACE
- fprintf(stderr, "%s ", textToStr(name(c).text));
-# endif
- if (isNull(c)) goto notfound;
- /* module(mod).exports = cons(c, module(mod).exports); */
- addName(c);
- }
-# ifdef DEBUG_IFACE
- fprintf(stderr, "}\n" );
-# endif
- }
- break;
-
- default:
- internal("finishExports(2)");
-
- } /* switch */
- continue; /* so notfound: can be placed after this */
-
- notfound:
- /* q holds what ain't found */
- assert(whatIs(q)==QUALIDENT);
-# ifdef DEBUG_IFACE
- fprintf( stderr, " ------ IGNORED: %s.%s\n",
- textToStr(qmodOf(q)), textToStr(qtextOf(q)) );
-# endif
- continue;
- }
- }
-
-#if 0
- if (preludeLoaded) {
- /* do the implicit 'import Prelude' thing */
- List pxs = module(modulePrelude).exports;
- for (; nonNull(pxs); pxs=tl(pxs)) {
- Cell px = hd(pxs);
- again:
- switch (whatIs(px)) {
- case AP:
- px = fst(px);
- goto again;
- case NAME:
- module(mod).names = cons ( px, module(mod).names );
- break;
- case TYCON:
- module(mod).tycons = cons ( px, module(mod).tycons );
- break;
- case CLASS:
- module(mod).classes = cons ( px, module(mod).classes );
- break;
- default:
- fprintf(stderr, "finishGHCModule: unknown tag %d\n", whatIs(px));
- internal("finishGHCModule -- implicit import Prelude");
- break;
- }
- }
- }
-#endif
-
- /* Last, but by no means least ... */
- if (!ocResolve(module(mod).object,VERBOSE))
- internal("finishGHCModule: object resolution failed");
-
- for (oc=module(mod).objectExtras; oc; oc=oc->next) {
- if (!ocResolve(oc, VERBOSE))
- internal("finishGHCModule: extra object resolution failed");
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Exports
- * ------------------------------------------------------------------------*/
-
-static Void startGHCExports ( ConId mn, List exlist )
-{
-# ifdef DEBUG_IFACE
- fprintf(stderr,"startGHCExports %s\n", textToStr(textOf(mn)) );
-# endif
- /* Nothing to do. */
-}
-
-static Void finishGHCExports ( ConId mn, List exlist )
-{
-# ifdef DEBUG_IFACE
- fprintf(stderr,"finishGHCExports %s\n", textToStr(textOf(mn)) );
-# endif
- /* Nothing to do. */
-}
-
-
-/* --------------------------------------------------------------------------
- * Imports
- * ------------------------------------------------------------------------*/
-
-static Void startGHCImports ( ConId mn, List syms )
-/* nm the module to import from */
-/* syms [ConId | VarId] -- the names to import */
-{
-# ifdef DEBUG_IFACE
- fprintf(stderr,"startGHCImports %s\n", textToStr(textOf(mn)) );
-# endif
- /* Nothing to do. */
-}
-
-
-static Void finishGHCImports ( ConId nm, List syms )
-/* nm the module to import from */
-/* syms [ConId | VarId] -- the names to import */
-{
-# ifdef DEBUG_IFACE
- fprintf(stderr,"finishGHCImports %s\n", textToStr(textOf(nm)) );
-# endif
- /* Nothing to do. */
-}
-
-
-/* --------------------------------------------------------------------------
- * Fixity decls
- * ------------------------------------------------------------------------*/
-
-static Void finishGHCFixdecl ( Cell prec, Cell assoc, ConVarId name )
-{
- Int p = intOf(prec);
- Int a = intOf(assoc);
- Name n = findName(textOf(name));
- assert (nonNull(n));
- name(n).syntax = mkSyntax ( a, p );
-}
-
-
-/* --------------------------------------------------------------------------
- * Vars (values)
- * ------------------------------------------------------------------------*/
-
-/* convert a leading run of DICTAPs into Hugs' internal Qualtype form, viz:
- { C1 a } -> { C2 b } -> T into
- ap(QUALTYPE, ( [(C1,a),(C2,b)], T ))
-*/
-static Type dictapsToQualtype ( Type ty )
-{
- List pieces = NIL;
- List preds, dictaps;
-
- /* break ty into pieces at the top-level arrows */
- while (isAp(ty) && isAp(fun(ty)) && fun(fun(ty))==typeArrow) {
- pieces = cons ( arg(fun(ty)), pieces );
- ty = arg(ty);
- }
- pieces = cons ( ty, pieces );
- pieces = reverse ( pieces );
-
- dictaps = NIL;
- while (nonNull(pieces) && whatIs(hd(pieces))==DICTAP) {
- dictaps = cons ( hd(pieces), dictaps );
- pieces = tl(pieces);
- }
-
- /* dictaps holds the predicates, backwards */
- /* pieces holds the remainder of the type, forwards */
- assert(nonNull(pieces));
- pieces = reverse(pieces);
- ty = hd(pieces);
- pieces = tl(pieces);
- for (; nonNull(pieces); pieces=tl(pieces))
- ty = fn(hd(pieces),ty);
-
- preds = NIL;
- for (; nonNull(dictaps); dictaps=tl(dictaps)) {
- Cell da = hd(dictaps);
- QualId cl = fst(unap(DICTAP,da));
- Cell arg = snd(unap(DICTAP,da));
- preds = cons ( pair(cl,arg), preds );
- }
-
- if (nonNull(preds)) ty = ap(QUAL, pair(preds,ty));
- return ty;
-}
-
-
-
-static void startGHCValue ( Int line, VarId vid, Type ty )
-{
- Name n;
- List tmp, tvs;
- Text v = textOf(vid);
-
-# ifdef DEBUG_IFACE
- fprintf(stderr,"begin startGHCValue %s\n", textToStr(v));
-# endif
-
- line = intOf(line);
- n = findName(v);
- if (nonNull(n) && name(n).defn != PREDEFINED) {
- ERRMSG(line) "Attempt to redefine variable \"%s\"", textToStr(v)
- EEND;
- }
- if (isNull(n)) n = newName(v,NIL);
-
- ty = dictapsToQualtype(ty);
-
- tvs = ifTyvarsIn(ty);
- for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- hd(tmp) = zpair(hd(tmp),STAR);
- if (nonNull(tvs))
- ty = mkPolyType(tvsToKind(tvs),ty);
-
- ty = tvsToOffsets(line,ty,tvs);
- name(n).type = ty;
- name(n).arity = arityInclDictParams(ty);
- name(n).line = line;
- name(n).defn = NIL;
-}
-
-
-static void finishGHCValue ( VarId vid )
-{
- Name n = findName ( textOf(vid) );
- Int line = name(n).line;
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin finishGHCValue %s\n", textToStr(name(n).text) );
-# endif
- assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
-
- if (isIfaceDefaultMethodName(name(n).text)) {
- /* ... we need to set .parent to point to the class
- ... once we figure out what the class actually is :-)
- */
- Type t = name(n).type;
- assert(isPolyType(t));
- if (isPolyType(t)) t = monotypeOf(t);
- assert(isQualType(t));
- t = fst(snd(t)); /* t :: [(Class,Offset)] */
- assert(nonNull(t));
- assert(nonNull(hd(t)));
- assert(isPair(hd(t)));
- t = fst(hd(t)); /* t :: Class */
- assert(isClass(t));
-
- name(n).parent = t; /* phew! */
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Type synonyms
- * ------------------------------------------------------------------------*/
-
-static Void startGHCSynonym ( Int line, ConId tycon, List tvs, Type ty )
-{
- /* tycon :: ConId */
- /* tvs :: [((VarId,Kind))] */
- /* ty :: Type */
- Text t = textOf(tycon);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin startGHCSynonym %s\n", textToStr(t) );
-# endif
- line = intOf(line);
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).line = line;
- tycon(tc).arity = length(tvs);
- tycon(tc).what = SYNONYM;
- tycon(tc).kind = tvsToKind(tvs);
-
- /* prepare for finishGHCSynonym */
- tycon(tc).defn = tvsToOffsets(line,ty,tvs);
- }
-}
-
-
-static Void finishGHCSynonym ( ConId tyc )
-{
- Tycon tc = findTycon(textOf(tyc));
- Int line = tycon(tc).line;
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin finishGHCSynonym %s\n", textToStr(textOf(tyc)) );
-# endif
-
- assert (currentModule == tycon(tc).mod);
- // setCurrModule(tycon(tc).mod);
- tycon(tc).defn = conidcellsToTycons(line,tycon(tc).defn);
-
- /* (ADR) ToDo: can't really do this until I've done all synonyms
- * and then I have to do them in order
- * tycon(tc).defn = fullExpand(ty);
- * (JRS) What?!?! i don't understand
- */
-}
-
-
-/* --------------------------------------------------------------------------
- * Data declarations
- * ------------------------------------------------------------------------*/
-
-static Type qualifyIfaceType ( Type unqual, List ctx )
-{
- /* ctx :: [((QConId,VarId))] */
- /* ctx is a list of (class name, tyvar) pairs.
- Attach to unqual qualifiers taken from ctx
- for each tyvar which appears in unqual.
- */
- List tyvarsMentioned; /* :: [VarId] */
- List ctx2 = NIL;
- Cell kinds = NIL;
-
- if (isPolyType(unqual)) {
- kinds = polySigOf(unqual);
- unqual = monotypeOf(unqual);
- }
-
- assert(!isQualType(unqual));
- tyvarsMentioned = ifTyvarsIn ( unqual );
- for (; nonNull(ctx); ctx=tl(ctx)) {
- ZPair ctxElem = hd(ctx); /* :: ((QConId, VarId)) */
- if (nonNull(varIsMember(textOf(zsnd(ctxElem)),tyvarsMentioned)))
- ctx2 = cons(ctxElem, ctx2);
- }
- if (nonNull(ctx2))
- unqual = ap(QUAL,pair(reverse(ctx2),unqual));
- if (nonNull(kinds))
- unqual = mkPolyType(kinds,unqual);
- return unqual;
-}
-
-
-static Void startGHCDataDecl(line,ctx0,tycon,ktyvars,constrs0)
-Int line;
-List ctx0; /* [((QConId,VarId))] */
-Cell tycon; /* ConId */
-List ktyvars; /* [((VarId,Kind))] */
-List constrs0; /* [((ConId,[((Type,VarId,Int))]))] */
- /* The Text is an optional field name
- The Int indicates strictness */
- /* ToDo: worry about being given a decl for (->) ?
- * and worry about qualidents for ()
- */
-{
- Type ty, resTy, selTy, conArgTy;
- List tmp, conArgs, sels, constrs, fields;
- Triple constr;
- Cell conid;
- Pair conArg, ctxElem;
- Text conArgNm;
- Int conArgStrictness;
- Int conStrictCompCount;
-
- Text t = textOf(tycon);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin startGHCDataDecl %s\n",textToStr(t));
-# endif
-
- line = intOf(line);
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).text = t;
- tycon(tc).line = line;
- tycon(tc).arity = length(ktyvars);
- tycon(tc).kind = tvsToKind(ktyvars);
- tycon(tc).what = DATATYPE;
-
- /* a list to accumulate selectors in :: [((VarId,Type))] */
- sels = NIL;
-
- /* make resTy the result type of the constr, T v1 ... vn */
- resTy = tycon;
- for (tmp=ktyvars; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,zfst(hd(tmp)));
-
- /* for each constructor ... */
- for (constrs=constrs0; nonNull(constrs); constrs=tl(constrs)) {
- constr = hd(constrs);
- conid = zfst(constr);
- fields = zsnd(constr);
-
- /* Build type of constr and handle any selectors found. */
- ty = resTy;
-
- conStrictCompCount = 0;
- conArgs = reverse(fields);
- for (; nonNull(conArgs); conArgs=tl(conArgs)) {
- conArg = hd(conArgs); /* (Type,Text) */
- conArgTy = zfst3(conArg);
- conArgNm = zsnd3(conArg);
- conArgStrictness = intOf(zthd3(conArg));
- if (conArgStrictness > 0) conStrictCompCount++;
- ty = fn(conArgTy,ty);
- if (nonNull(conArgNm)) {
- /* a field name is mentioned too */
- selTy = fn(resTy,conArgTy);
- if (whatIs(tycon(tc).kind) != STAR)
- selTy = pair(POLYTYPE,pair(tycon(tc).kind, selTy));
- selTy = qualifyIfaceType ( selTy, ctx0 );
- selTy = tvsToOffsets(line,selTy, ktyvars);
- sels = cons( zpair(conArgNm,selTy), sels);
- }
- }
-
- /* Now ty is the constructor's type, not including context.
- Throw away any parts of the context not mentioned in ty,
- and use it to qualify ty.
- */
- ty = qualifyIfaceType ( ty, ctx0 );
-
- /* stick the tycon's kind on, if not simply STAR */
- if (whatIs(tycon(tc).kind) != STAR)
- ty = pair(POLYTYPE,pair(tycon(tc).kind, ty));
-
- ty = tvsToOffsets(line,ty, ktyvars);
-
- /* Finally, stick the constructor's type onto it. */
- hd(constrs) = z4ble(conid,fields,ty,mkInt(conStrictCompCount));
- }
-
- /* Final result is that
- constrs :: [((ConId,[((Type,Text))],Type,Int))]
- lists the constructors, their types and # strict comps
- sels :: [((VarId,Type))]
- lists the selectors and their types
- */
- tycon(tc).defn = startGHCConstrs(line,constrs0,sels);
- }
-}
-
-
-static List startGHCConstrs ( Int line, List cons, List sels )
-{
- /* cons :: [((ConId,[((Type,Text,Int))],Type,Int))] */
- /* sels :: [((VarId,Type))] */
- /* returns [Name] */
- List cs, ss;
- Int conNo = length(cons)>1 ? 1 : 0;
- for(cs=cons; nonNull(cs); cs=tl(cs), conNo++) {
- Name c = startGHCConstr(line,conNo,hd(cs));
- hd(cs) = c;
- }
- /* cons :: [Name] */
-
- for(ss=sels; nonNull(ss); ss=tl(ss)) {
- hd(ss) = startGHCSel(line,hd(ss));
- }
- /* sels :: [Name] */
- return appendOnto(cons,sels);
-}
-
-
-static Name startGHCSel ( Int line, ZPair sel )
-{
- /* sel :: ((VarId, Type)) */
- Text t = textOf(zfst(sel));
- Type type = zsnd(sel);
-
- Name n = findName(t);
- if (nonNull(n)) {
- ERRMSG(line) "Repeated definition for selector \"%s\"",
- textToStr(t)
- EEND;
- }
-
- n = newName(t,NIL);
- name(n).line = line;
- name(n).number = SELNAME;
- name(n).arity = 1;
- name(n).defn = NIL;
- name(n).type = type;
- return n;
-}
-
-
-static Name startGHCConstr ( Int line, Int conNo, Z4Ble constr )
-{
- /* constr :: ((ConId,[((Type,Text,Int))],Type,Int)) */
- /* (ADR) ToDo: add rank2 annotation and existential annotation
- * these affect how constr can be used.
- */
- Text con = textOf(zsel14(constr));
- Type type = zsel34(constr);
- Int arity = arityFromType(type);
- Int nStrict = intOf(zsel44(constr));
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(conNo);
- name(n).type = type;
- name(n).hasStrict = nStrict > 0;
- return n;
-}
-
-
-static List finishGHCDataDecl ( ConId tyc )
-{
- List nms;
- Tycon tc = findTycon(textOf(tyc));
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin finishGHCDataDecl %s\n",
- textToStr(textOf(tyc)) );
-# endif
- if (isNull(tc)) internal("finishGHCDataDecl");
-
- for (nms=tycon(tc).defn; nonNull(nms); nms=tl(nms)) {
- Name n = hd(nms);
- Int line = name(n).line;
- assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
- name(n).parent = tc; //---????
- }
-
- return tycon(tc).defn;
-}
-
-
-/* --------------------------------------------------------------------------
- * Newtype decls
- * ------------------------------------------------------------------------*/
-
-static Void startGHCNewType ( Int line, List ctx0,
- ConId tycon, List tvs, Cell constr )
-{
- /* ctx0 :: [((QConId,VarId))] */
- /* tycon :: ConId */
- /* tvs :: [((VarId,Kind))] */
- /* constr :: ((ConId,Type)) or NIL if abstract */
- List tmp;
- Type resTy;
- Text t = textOf(tycon);
-# ifdef DEBUG_IFACE
- fprintf(stderr, "begin startGHCNewType %s\n", textToStr(t) );
-# endif
-
- line = intOf(line);
-
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- } else {
- Tycon tc = newTycon(t);
- tycon(tc).line = line;
- tycon(tc).arity = length(tvs);
- tycon(tc).what = NEWTYPE;
- tycon(tc).kind = tvsToKind(tvs);
- /* can't really do this until I've read in all synonyms */
-
- if (isNull(constr)) {
- tycon(tc).defn = NIL;
- } else {
- /* constr :: ((ConId,Type)) */
- Text con = textOf(zfst(constr));
- Type type = zsnd(constr);
- Name n = findName(con); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(con,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Repeated definition for constructor \"%s\"",
- textToStr(con)
- EEND;
- }
- name(n).arity = 1; /* Save constructor fun details */
- name(n).line = line;
- name(n).number = cfunNo(0);
- name(n).defn = nameId;
- tycon(tc).defn = singleton(n);
-
- /* make resTy the result type of the constr, T v1 ... vn */
- resTy = tycon;
- for (tmp=tvs; nonNull(tmp); tmp=tl(tmp))
- resTy = ap(resTy,zfst(hd(tmp)));
- type = fn(type,resTy);
- if (nonNull(ctx0))
- type = ap(QUAL,pair(ctx0,type));
- type = tvsToOffsets(line,type,tvs);
- name(n).type = type;
- }
- }
-}
-
-
-static Void finishGHCNewType ( ConId tyc )
-{
- Tycon tc = findTycon(textOf(tyc));
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin finishGHCNewType %s\n",
- textToStr(textOf(tyc)) );
-# endif
-
- if (isNull(tc)) internal("finishGHCNewType");
-
- if (isNull(tycon(tc).defn)) {
- /* it's an abstract type */
- }
- else if (length(tycon(tc).defn) == 1) {
- /* As we expect, has a single constructor */
- Name n = hd(tycon(tc).defn);
- Int line = name(n).line;
- assert(currentModule == name(n).mod);
- name(n).type = conidcellsToTycons(line,name(n).type);
- } else {
- internal("finishGHCNewType(2)");
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Class declarations
- * ------------------------------------------------------------------------*/
-
-static Void startGHCClass(line,ctxt,tc_name,kinded_tvs,mems0)
-Int line;
-List ctxt; /* [((QConId, VarId))] */
-ConId tc_name; /* ConId */
-List kinded_tvs; /* [((VarId, Kind))] */
-List mems0; { /* [((VarId, Type))] */
-
- List mems; /* [((VarId, Type))] */
- List tvsInT; /* [VarId] and then [((VarId,Kind))] */
- List tvs; /* [((VarId,Kind))] */
- List ns; /* [Name] */
- Int mno;
-
- ZPair kinded_tv = hd(kinded_tvs);
- Text ct = textOf(tc_name);
- Pair newCtx = pair(tc_name, zfst(kinded_tv));
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin startGHCClass %s\n", textToStr(ct) );
-# endif
-
- line = intOf(line);
- if (length(kinded_tvs) != 1) {
- ERRMSG(line) "Cannot presently handle multiparam type classes in ifaces"
- EEND;
- }
-
- if (nonNull(findClass(ct))) {
- ERRMSG(line) "Repeated definition of class \"%s\"",
- textToStr(ct)
- EEND;
- } else if (nonNull(findTycon(ct))) {
- ERRMSG(line) "\"%s\" used as both class and type constructor",
- textToStr(ct)
- EEND;
- } else {
- Class nw = newClass(ct);
- cclass(nw).text = ct;
- cclass(nw).line = line;
- cclass(nw).arity = 1;
- cclass(nw).head = ap(nw,mkOffset(0));
- cclass(nw).kinds = singleton( zsnd(kinded_tv) );
- cclass(nw).instances = NIL;
- cclass(nw).numSupers = length(ctxt);
-
- /* Kludge to map the single tyvar in the context to Offset 0.
- Need to do something better for multiparam type classes.
- */
- cclass(nw).supers = tvsToOffsets(line,ctxt,
- singleton(kinded_tv));
-
-
- for (mems=mems0; nonNull(mems); mems=tl(mems)) {
- ZPair mem = hd(mems);
- Type memT = zsnd(mem);
- Text mnt = textOf(zfst(mem));
- Name mn;
-
- /* Stick the new context on the member type */
- memT = dictapsToQualtype(memT);
- if (whatIs(memT)==POLYTYPE) internal("startGHCClass");
- if (whatIs(memT)==QUAL) {
- memT = pair(QUAL,
- pair(cons(newCtx,fst(snd(memT))),snd(snd(memT))));
- } else {
- memT = pair(QUAL,
- pair(singleton(newCtx),memT));
- }
-
- /* Cook up a kind for the type. */
- tvsInT = ifTyvarsIn(memT);
- /* tvsInT :: [VarId] */
-
- /* ToDo: maximally bogus. We allow the class tyvar to
- have the kind as supplied by the parser, but we just
- assume that all others have kind *. It's a kludge.
- */
- for (tvs=tvsInT; nonNull(tvs); tvs=tl(tvs)) {
- Kind k;
- if (textOf(hd(tvs)) == textOf(zfst(kinded_tv)))
- k = zsnd(kinded_tv); else
- k = STAR;
- hd(tvs) = zpair(hd(tvs),k);
- }
- /* tvsIntT :: [((VarId,Kind))] */
-
- memT = mkPolyType(tvsToKind(tvsInT),memT);
- memT = tvsToOffsets(line,memT,tvsInT);
-
- /* Park the type back on the member */
- mem = zpair(zfst(mem),memT);
-
- /* Bind code to the member */
- mn = findName(mnt);
- if (nonNull(mn)) {
- ERRMSG(line)
- "Repeated definition for class method \"%s\"",
- textToStr(mnt)
- EEND;
- }
- mn = newName(mnt,NIL);
-
- hd(mems) = mem;
- }
-
- cclass(nw).members = mems0;
- cclass(nw).numMembers = length(mems0);
-
- ns = NIL;
- for (mno=0; mno<cclass(nw).numSupers; mno++) {
- ns = cons(newDSel(nw,mno),ns);
- }
- cclass(nw).dsels = rev(ns);
- }
-}
-
-
-static Class finishGHCClass ( Tycon cls_tyc )
-{
- List mems;
- Int line;
- Int ctr;
- Class nw = findClass ( textOf(cls_tyc) );
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin finishGHCClass %s\n", textToStr(cclass(nw).text) );
-# endif
- if (isNull(nw)) internal("finishGHCClass");
-
- line = cclass(nw).line;
- ctr = -2;
- assert (currentModule == cclass(nw).mod);
-
- cclass(nw).level = 0;
- cclass(nw).head = conidcellsToTycons(line,cclass(nw).head);
- cclass(nw).supers = conidcellsToTycons(line,cclass(nw).supers);
- cclass(nw).members = conidcellsToTycons(line,cclass(nw).members);
-
- for (mems=cclass(nw).members; nonNull(mems); mems=tl(mems)) {
- Pair mem = hd(mems); /* (VarId, Type) */
- Text txt = textOf(fst(mem));
- Type ty = snd(mem);
- Name n = findName(txt);
- assert(nonNull(n));
- name(n).text = txt;
- name(n).line = cclass(nw).line;
- name(n).type = ty;
- name(n).number = ctr--;
- name(n).arity = arityInclDictParams(name(n).type);
- name(n).parent = nw;
- hd(mems) = n;
- }
-
- return nw;
-}
-
-
-/* --------------------------------------------------------------------------
- * Instances
- * ------------------------------------------------------------------------*/
-
-static Inst startGHCInstance (line,ktyvars,cls,var)
-Int line;
-List ktyvars; /* [((VarId,Kind))] */
-Type cls; /* Type */
-VarId var; { /* VarId */
- List tmp, tvs, ks, spec;
-
- List xs1, xs2;
- Kind k;
-
- Inst in = newInst();
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin startGHCInstance\n" );
-# endif
-
- line = intOf(line);
-
- tvs = ifTyvarsIn(cls); /* :: [VarId] */
- /* tvs :: [VarId].
- The order of tvs is important for tvsToOffsets.
- tvs should be a permutation of ktyvars. Fish the tyvar kinds
- out of ktyvars and attach them to tvs.
- */
- for (xs1=tvs; nonNull(xs1); xs1=tl(xs1)) {
- k = NIL;
- for (xs2=ktyvars; nonNull(xs2); xs2=tl(xs2))
- if (textOf(hd(xs1)) == textOf(zfst(hd(xs2))))
- k = zsnd(hd(xs2));
- if (isNull(k)) internal("startGHCInstance: finding kinds");
- hd(xs1) = zpair(hd(xs1),k);
- }
-
- cls = tvsToOffsets(line,cls,tvs);
- spec = NIL;
- while (isAp(cls)) {
- spec = cons(fun(cls),spec);
- cls = arg(cls);
- }
- spec = reverse(spec);
-
- inst(in).line = line;
- inst(in).implements = NIL;
- inst(in).kinds = simpleKind(length(tvs)); /* do this right */
- inst(in).specifics = spec;
- inst(in).numSpecifics = length(spec);
- inst(in).head = cls;
-
- /* Figure out the name of the class being instanced, and store it
- at inst(in).c. finishGHCInstance will resolve it to a real Class. */
- {
- Cell cl = inst(in).head;
- assert(whatIs(cl)==DICTAP);
- cl = unap(DICTAP,cl);
- cl = fst(cl);
- assert ( isQCon(cl) );
- inst(in).c = cl;
- }
-
- {
- Name b = newName( /*inventText()*/ textOf(var),NIL);
- name(b).line = line;
- name(b).arity = length(spec); /* unused? */ /* and surely wrong */
- name(b).number = DFUNNAME;
- name(b).parent = in;
- inst(in).builder = b;
- /* bindNameToClosure(b, lookupGHCClosure(inst(in).mod,var)); */
- }
-
- return in;
-}
-
-
-static Void finishGHCInstance ( Inst in )
-{
- Int line;
- Class c;
- Type cls;
-
-# ifdef DEBUG_IFACE
- fprintf ( stderr, "begin finishGHCInstance\n" );
-# endif
-
- assert (nonNull(in));
- line = inst(in).line;
- assert (currentModule==inst(in).mod);
-
- /* inst(in).c is, prior to finishGHCInstance, a ConId or Tuple,
- since startGHCInstance couldn't possibly have resolved it to
- a Class at that point. We convert it to a Class now.
- */
- c = inst(in).c;
- assert(isQCon(c));
- c = findQualClassWithoutConsultingExportList(c);
- assert(nonNull(c));
- inst(in).c = c;
-
- inst(in).head = conidcellsToTycons(line,inst(in).head);
- inst(in).specifics = conidcellsToTycons(line,inst(in).specifics);
- cclass(c).instances = cons(in,cclass(c).instances);
-}
-
-
-/* --------------------------------------------------------------------------
- * Helper fns
- * ------------------------------------------------------------------------*/
-
-/* This is called from the startGHC* functions. It traverses a structure
- and converts varidcells, ie, type variables parsed by the interface
- parser, into Offsets, which is how Hugs wants to see them internally.
- The Offset for a type variable is determined by its place in the list
- passed as the second arg; the associated kinds are irrelevant.
-
- ((t1,t2)) denotes the typed (z-)pair of t1 and t2.
-*/
-
-/* tvsToOffsets :: LineNo -> Type -> [((VarId,Kind))] -> Type */
-static Type tvsToOffsets(line,type,ktyvars)
-Int line;
-Type type;
-List ktyvars; { /* [((VarId,Kind))] */
- switch (whatIs(type)) {
- case NIL:
- case TUPLE:
- case QUALIDENT:
- case CONIDCELL:
- case TYCON:
- return type;
- case ZTUP2: /* convert to the untyped representation */
- return ap( tvsToOffsets(line,zfst(type),ktyvars),
- tvsToOffsets(line,zsnd(type),ktyvars) );
- case AP:
- return ap( tvsToOffsets(line,fun(type),ktyvars),
- tvsToOffsets(line,arg(type),ktyvars) );
- case POLYTYPE:
- return mkPolyType (
- polySigOf(type),
- tvsToOffsets(line,monotypeOf(type),ktyvars)
- );
- break;
- case QUAL:
- return pair(QUAL,pair(tvsToOffsets(line,fst(snd(type)),ktyvars),
- tvsToOffsets(line,snd(snd(type)),ktyvars)));
- case DICTAP: /* bogus ?? */
- return ap(DICTAP, tvsToOffsets(line,snd(type),ktyvars));
- case UNBOXEDTUP: /* bogus?? */
- return ap(UNBOXEDTUP, tvsToOffsets(line,snd(type),ktyvars));
- case BANG: /* bogus?? */
- return ap(BANG, tvsToOffsets(line,snd(type),ktyvars));
- case VARIDCELL: /* Ha! some real work to do! */
- { Int i = 0;
- Text tv = textOf(type);
- for (; nonNull(ktyvars); i++,ktyvars=tl(ktyvars)) {
- Cell varid;
- Text tt;
- assert(isZPair(hd(ktyvars)));
- varid = zfst(hd(ktyvars));
- tt = textOf(varid);
- if (tv == tt) return mkOffset(i);
- }
- ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
- EEND;
- break;
- }
- default:
- fprintf(stderr, "tvsToOffsets: unknown stuff %d\n", whatIs(type));
- print(type,20);
- fprintf(stderr,"\n");
- assert(0);
- }
- assert(0);
- return NIL; /* NOTREACHED */
-}
-
-
-/* This is called from the finishGHC* functions. It traverses a structure
- and converts conidcells, ie, type constructors parsed by the interface
- parser, into Tycons (or Classes), which is how Hugs wants to see them
- internally. Calls to this fn have to be deferred to the second phase
- of interface loading (finishGHC* rather than startGHC*) so that all relevant
- Tycons or Classes have been loaded into the symbol tables and can be
- looked up.
-*/
-static Type conidcellsToTycons ( Int line, Type type )
-{
- switch (whatIs(type)) {
- case NIL:
- case OFFSET:
- case TYCON:
- case CLASS:
- case VARIDCELL:
- case TUPLE:
- case STAR:
- return type;
- case QUALIDENT:
- { Cell t; /* Tycon or Class */
- Text m = qmodOf(type);
- Module mod = findModule(m);
- if (isNull(mod)) {
- ERRMSG(line)
- "Undefined module in qualified name \"%s\"",
- identToStr(type)
- EEND;
- return NIL;
- }
- t = findQualTyconWithoutConsultingExportList(type);
- if (nonNull(t)) return t;
- t = findQualClassWithoutConsultingExportList(type);
- if (nonNull(t)) return t;
- ERRMSG(line)
- "Undefined qualified class or type \"%s\"",
- identToStr(type)
- EEND;
- return NIL;
- }
- case CONIDCELL:
- { Tycon tc;
- Class cl;
- cl = findQualClass(type);
- if (nonNull(cl)) return cl;
- if (textOf(type)==findText("[]"))
- /* a hack; magically qualify [] into PrelBase.[] */
- return conidcellsToTycons(line,
- mkQualId(mkCon(findText("PrelBase")),type));
- tc = findQualTycon(type);
- if (nonNull(tc)) return tc;
- ERRMSG(line)
- "Undefined class or type constructor \"%s\"",
- identToStr(type)
- EEND;
- return NIL;
- }
- case AP:
- return ap( conidcellsToTycons(line,fun(type)),
- conidcellsToTycons(line,arg(type)) );
- case ZTUP2: /* convert to std pair */
- return ap( conidcellsToTycons(line,zfst(type)),
- conidcellsToTycons(line,zsnd(type)) );
-
- case POLYTYPE:
- return mkPolyType (
- polySigOf(type),
- conidcellsToTycons(line,monotypeOf(type))
- );
- break;
- case QUAL:
- return pair(QUAL,pair(conidcellsToTycons(line,fst(snd(type))),
- conidcellsToTycons(line,snd(snd(type)))));
- case DICTAP: /* :: ap(DICTAP, pair(Class,Type))
- Not sure if this is really the right place to
- convert it to the form Hugs wants, but will do so anyway.
- */
- /* return ap(DICTAP, conidcellsToTycons(line, snd(type))); */
- {
- Class cl = fst(unap(DICTAP,type));
- List args = snd(unap(DICTAP,type));
- return
- conidcellsToTycons(line,pair(cl,args));
- }
- case UNBOXEDTUP:
- return ap(UNBOXEDTUP, conidcellsToTycons(line, snd(type)));
- case BANG:
- return ap(BANG, conidcellsToTycons(line, snd(type)));
- default:
- fprintf(stderr, "conidcellsToTycons: unknown stuff %d\n",
- whatIs(type));
- print(type,20);
- fprintf(stderr,"\n");
- assert(0);
- }
- assert(0);
- return NIL; /* NOTREACHED */
-}
-
-
-/* Find out if a type mentions a type constructor not present in
- the supplied list of qualified tycons.
-*/
-static Bool allTypesKnown ( Type type,
- List aktys /* [QualId] */,
- ConId thisMod )
-{
- switch (whatIs(type)) {
- case NIL:
- case OFFSET:
- case VARIDCELL:
- case TUPLE:
- return TRUE;
- case AP:
- return allTypesKnown(fun(type),aktys,thisMod)
- && allTypesKnown(arg(type),aktys,thisMod);
- case ZTUP2:
- return allTypesKnown(zfst(type),aktys,thisMod)
- && allTypesKnown(zsnd(type),aktys,thisMod);
- case DICTAP:
- return allTypesKnown(unap(DICTAP,type),aktys,thisMod);
-
- case CONIDCELL:
- if (textOf(type)==findText("[]"))
- /* a hack; magically qualify [] into PrelBase.[] */
- type = mkQualId(mkCon(findText("PrelBase")),type); else
- type = mkQualId(thisMod,type);
- /* fall through */
- case QUALIDENT:
- if (isNull(qualidIsMember(type,aktys))) goto missing;
- return TRUE;
- case TYCON:
- return TRUE;
-
- default:
- fprintf(stderr, "allTypesKnown: unknown stuff %d\n", whatIs(type));
- print(type,10);printf("\n");
- internal("allTypesKnown");
- return TRUE; /*notreached*/
- }
- missing:
-# ifdef DEBUG_IFACE
- fprintf ( stderr,"allTypesKnown: unknown " ); print(type,10);
- fprintf(stderr,"\n");
-# endif
- return FALSE;
-}
-
-
-/* --------------------------------------------------------------------------
- * Utilities
- *
- * None of these do lookups or require that lookups have been resolved
- * so they can be performed while reading interfaces.
- * ------------------------------------------------------------------------*/
-
-/* tvsToKind :: [((VarId,Kind))] -> Kinds */
-static Kinds tvsToKind(tvs)
-List tvs; { /* [((VarId,Kind))] */
- List rs;
- Kinds r = STAR;
- for (rs=reverse(tvs); nonNull(rs); rs=tl(rs)) {
- if (whatIs(hd(rs)) != ZTUP2) internal("tvsToKind(1)");
- if (whatIs(zfst(hd(rs))) != VARIDCELL) internal("tvsToKind(2)");
- r = ap(zsnd(hd(rs)),r);
- }
- return r;
-}
-
-
-static Int arityInclDictParams ( Type type )
-{
- Int arity = 0;
- if (isPolyType(type)) type = monotypeOf(type);
-
- if (whatIs(type) == QUAL)
- {
- arity += length ( fst(snd(type)) );
- type = snd(snd(type));
- }
- while (isAp(type) && getHead(type)==typeArrow) {
- arity++;
- type = arg(type);
- }
- return arity;
-}
-
-/* arity of a constructor with this type */
-static Int arityFromType(type)
-Type type; {
- Int arity = 0;
- if (isPolyType(type)) {
- type = monotypeOf(type);
- }
- if (whatIs(type) == QUAL) {
- type = snd(snd(type));
- }
- if (whatIs(type) == EXIST) {
- type = snd(snd(type));
- }
- if (whatIs(type)==RANK2) {
- type = snd(snd(type));
- }
- while (isAp(type) && getHead(type)==typeArrow) {
- arity++;
- type = arg(type);
- }
- return arity;
-}
-
-
-/* ifTyvarsIn :: Type -> [VarId]
- The returned list has no duplicates -- is a set.
-*/
-static List ifTyvarsIn(type)
-Type type; {
- List vs = typeVarsIn(type,NIL,NIL,NIL);
- List vs2 = vs;
- for (; nonNull(vs2); vs2=tl(vs2))
- if (whatIs(hd(vs2)) != VARIDCELL)
- internal("ifTyvarsIn");
- return vs;
-}
-
-
-
-/* --------------------------------------------------------------------------
- * General object symbol query stuff
- * ------------------------------------------------------------------------*/
-
-#define EXTERN_SYMS_ALLPLATFORMS \
- SymX(MainRegTable) \
- Sym(stg_gc_enter_1) \
- Sym(stg_gc_noregs) \
- Sym(stg_gc_seq_1) \
- Sym(stg_gc_d1) \
- Sym(stg_gc_f1) \
- Sym(stg_chk_0) \
- Sym(stg_chk_1) \
- Sym(stg_gen_chk) \
- SymX(stg_exit) \
- SymX(stg_update_PAP) \
- SymX(stg_error_entry) \
- SymX(__ap_2_upd_info) \
- SymX(__ap_3_upd_info) \
- SymX(__ap_4_upd_info) \
- SymX(__ap_5_upd_info) \
- SymX(__ap_6_upd_info) \
- SymX(__ap_7_upd_info) \
- SymX(__ap_8_upd_info) \
- SymX(__sel_0_upd_info) \
- SymX(__sel_1_upd_info) \
- SymX(__sel_2_upd_info) \
- SymX(__sel_3_upd_info) \
- SymX(__sel_4_upd_info) \
- SymX(__sel_5_upd_info) \
- SymX(__sel_6_upd_info) \
- SymX(__sel_7_upd_info) \
- SymX(__sel_8_upd_info) \
- SymX(__sel_9_upd_info) \
- SymX(__sel_10_upd_info) \
- SymX(__sel_11_upd_info) \
- SymX(__sel_12_upd_info) \
- SymX(upd_frame_info) \
- SymX(seq_frame_info) \
- SymX(CAF_BLACKHOLE_info) \
- SymX(IND_STATIC_info) \
- SymX(EMPTY_MVAR_info) \
- SymX(MUT_ARR_PTRS_FROZEN_info) \
- SymX(newCAF) \
- SymX(putMVarzh_fast) \
- SymX(newMVarzh_fast) \
- SymX(takeMVarzh_fast) \
- SymX(catchzh_fast) \
- SymX(raisezh_fast) \
- SymX(delayzh_fast) \
- SymX(yieldzh_fast) \
- SymX(killThreadzh_fast) \
- SymX(waitReadzh_fast) \
- SymX(waitWritezh_fast) \
- SymX(CHARLIKE_closure) \
- SymX(INTLIKE_closure) \
- SymX(suspendThread) \
- SymX(resumeThread) \
- SymX(stackOverflow) \
- SymX(int2Integerzh_fast) \
- Sym(stg_gc_unbx_r1) \
- SymX(ErrorHdrHook) \
- SymX(mkForeignObjzh_fast) \
- SymX(__encodeDouble) \
- SymX(decodeDoublezh_fast) \
- SymX(isDoubleNaN) \
- SymX(isDoubleInfinite) \
- SymX(isDoubleDenormalized) \
- SymX(isDoubleNegativeZero) \
- SymX(__encodeFloat) \
- SymX(decodeFloatzh_fast) \
- SymX(isFloatNaN) \
- SymX(isFloatInfinite) \
- SymX(isFloatDenormalized) \
- SymX(isFloatNegativeZero) \
- SymX(__int_encodeFloat) \
- SymX(__int_encodeDouble) \
- SymX(mpz_cmp_si) \
- SymX(mpz_cmp) \
- SymX(__mpn_gcd_1) \
- SymX(gcdIntegerzh_fast) \
- SymX(newArrayzh_fast) \
- SymX(unsafeThawArrayzh_fast) \
- SymX(newDoubleArrayzh_fast) \
- SymX(newFloatArrayzh_fast) \
- SymX(newAddrArrayzh_fast) \
- SymX(newWordArrayzh_fast) \
- SymX(newIntArrayzh_fast) \
- SymX(newCharArrayzh_fast) \
- SymX(newMutVarzh_fast) \
- SymX(quotRemIntegerzh_fast) \
- SymX(quotIntegerzh_fast) \
- SymX(remIntegerzh_fast) \
- SymX(divExactIntegerzh_fast) \
- SymX(divModIntegerzh_fast) \
- SymX(timesIntegerzh_fast) \
- SymX(minusIntegerzh_fast) \
- SymX(plusIntegerzh_fast) \
- SymX(addr2Integerzh_fast) \
- SymX(mkWeakzh_fast) \
- SymX(prog_argv) \
- SymX(prog_argc) \
- Sym(resetNonBlockingFd) \
- SymX(getStablePtr) \
- SymX(stable_ptr_table) \
- Sym(createAdjThunk) \
- SymX(shutdownHaskellAndExit) \
- Sym(stg_enterStackTop) \
- SymX(CAF_UNENTERED_entry) \
- Sym(stg_yield_to_Hugs) \
- Sym(StgReturn) \
- Sym(init_stack) \
- SymX(blockAsyncExceptionszh_fast) \
- SymX(unblockAsyncExceptionszh_fast) \
- \
- /* needed by libHS_cbits */ \
- SymX(malloc) \
- SymX(close) \
- SymX(close) \
- Sym(opendir) \
- Sym(closedir) \
- Sym(readdir) \
- SymX(isatty) \
- SymX(read) \
- SymX(lseek) \
- SymX(write) \
- SymX(realloc) \
- SymX(getcwd) \
- SymX(free) \
- SymX(strcpy) \
- SymX(fprintf) \
- SymX(exit) \
- SymX(unlink) \
- SymX(memcpy) \
- SymX(memchr) \
- SymX(rmdir) \
- SymX(rename) \
- SymX(chdir) \
- SymX(getenv) \
-
-#define EXTERN_SYMS_cygwin32 \
- SymX(GetCurrentProcess) \
- SymX(GetProcessTimes) \
- Sym(__udivdi3) \
- SymX(bzero) \
- Sym(select) \
- SymX(_impure_ptr) \
- Sym(lstat) \
- Sym(setmode) \
- SymX(system) \
- SymX(sleep) \
- SymX(__imp__tzname) \
- SymX(__imp__timezone) \
- SymX(tzset) \
- SymX(log) \
- SymX(exp) \
- Sym(sqrt) \
- Sym(sin) \
- Sym(cos) \
- SymX(pow) \
- SymX(__errno) \
- Sym(stat) \
- Sym(fstat) \
- Sym(gettimeofday) \
- SymX(localtime) \
- SymX(strftime) \
- SymX(mktime) \
- SymX(execl) \
- Sym(mkdir) \
- Sym(open) \
- Sym(tcgetattr) \
- Sym(tcsetattr) \
- Sym(getrusage) \
- Sym(fcntl) \
- Sym(waitpid) \
- SymX(gmtime) \
-
-
-#define EXTERN_SYMS_linux \
- SymX(__errno_location) \
- Sym(__xstat) \
- Sym(__fxstat) \
- Sym(__lxstat) \
- SymX(select) \
- SymX(stderr) \
- SymX(vfork) \
- SymX(_exit) \
- SymX(tzname) \
- SymX(localtime) \
- SymX(strftime) \
- SymX(timezone) \
- SymX(mktime) \
- SymX(gmtime) \
- Sym(setitimer) \
- Sym(chmod) \
- SymX(execl) \
- Sym(mkdir) \
- Sym(open) \
- Sym(tcgetattr) \
- Sym(tcsetattr) \
- Sym(gettimeofday) \
- Sym(getrusage) \
- Sym(waitpid) \
- Sym(fcntl) \
-
-
-#define EXTERN_SYMS_solaris2 \
- SymX(gettimeofday) \
-
-
-#if defined(linux_TARGET_OS)
-#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_linux
-#endif
-
-#if defined(solaris2_TARGET_OS)
-#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_solaris2
-#endif
-
-#if defined(cygwin32_TARGET_OS)
-#define EXTERN_SYMS_THISPLATFORM EXTERN_SYMS_cygwin32
-#endif
-
-#if defined(mingw32_TARGET_OS)
-#define EXTERN_SYMS_THISPLATFORM /* */
-#endif
-
-
-
-/* entirely bogus claims about types of these symbols */
-#define Sym(vvv) extern void (vvv);
-#define SymX(vvv) /**/
-EXTERN_SYMS_ALLPLATFORMS
-EXTERN_SYMS_THISPLATFORM
-#undef Sym
-#undef SymX
-
-
-#define Sym(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
- (void*)(&(vvv)) },
-#define SymX(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
- (void*)(&(vvv)) },
-OSym rtsTab[]
- = {
- EXTERN_SYMS_ALLPLATFORMS
- EXTERN_SYMS_THISPLATFORM
- {0,0}
- };
-#undef Sym
-#undef SymX
-
-
-
-
-/* A kludge to assist Win32 debugging. */
-char* nameFromStaticOPtr ( void* ptr )
-{
- int k;
- for (k = 0; rtsTab[k].nm; k++)
- if (ptr == rtsTab[k].ad)
- return rtsTab[k].nm;
- return NULL;
-}
-
-
-void* lookupObjName ( char* nm )
-{
- int k;
- char* pp;
- void* a;
- Text t;
- Module m;
- char nm2[200];
- int first_real_char;
-
- nm2[199] = 0;
- strncpy(nm2,nm,200);
-
- /* first see if it's an RTS name */
- for (k = 0; rtsTab[k].nm; k++)
- if (0==strcmp(nm2,rtsTab[k].nm))
- return rtsTab[k].ad;
-
- /* perhaps an extra-symbol ? */
- a = lookupOExtraTabName ( nm );
- if (a) return a;
-
-# if LEADING_UNDERSCORE
- first_real_char = 1;
-# else
- first_real_char = 0;
-# endif
-
- /* Maybe it's an __init_Module thing? */
- if (strlen(nm2+first_real_char) > 7
- && strncmp(nm2+first_real_char, "__init_", 7)==0) {
- t = unZcodeThenFindText(nm2+first_real_char+7);
- if (t == findText("PrelGHC")) return (4+(char*)NULL); /* kludge */
- m = findModule(t);
- if (isNull(m)) goto dire_straits;
- a = lookupOTabName ( m, nm );
- if (a) return a;
- goto dire_straits;
- }
-
- /* if not an RTS name, look in the
- relevant module's object symbol table
- */
- pp = strchr(nm2+first_real_char, '_');
- if (!pp || !isupper(nm2[first_real_char])) goto dire_straits;
- *pp = 0;
- t = unZcodeThenFindText(nm2+first_real_char);
- m = findModule(t);
- if (isNull(m)) goto dire_straits;
-
- a = lookupOTabName ( m, nm ); /* RATIONALISE */
- if (a) return a;
-
- dire_straits:
- /* make a desperate, last-ditch attempt to find it */
- a = lookupOTabNameAbsolutelyEverywhere ( nm );
- if (a) return a;
-
- fprintf ( stderr,
- "lookupObjName: can't resolve name `%s'\n",
- nm );
- assert(0);
- return NULL;
-}
-
-
-int is_dynamically_loaded_code_or_rodata_ptr ( char* p )
-{
- OSectionKind sk = lookupSection(p);
- assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
- return (sk == HUGS_SECTIONKIND_CODE_OR_RODATA);
-}
-
-
-int is_dynamically_loaded_rwdata_ptr ( char* p )
-{
- OSectionKind sk = lookupSection(p);
- assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
- return (sk == HUGS_SECTIONKIND_RWDATA);
-}
-
-
-int is_not_dynamically_loaded_ptr ( char* p )
-{
- OSectionKind sk = lookupSection(p);
- assert (sk != HUGS_SECTIONKIND_NOINFOAVAIL);
- return (sk == HUGS_SECTIONKIND_OTHER);
-}
-
-
-/* --------------------------------------------------------------------------
- * Control:
- * ------------------------------------------------------------------------*/
-
-Void interfayce(what)
-Int what; {
- switch (what) {
- case POSTPREL: break;
-
- case PREPREL:
- case RESET:
- ifaces_outstanding = NIL;
- break;
- case MARK:
- mark(ifaces_outstanding);
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-# -------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.12 2000/04/10 02:28:08 andy Exp $
-# -------------------------------------------------------------------------- #
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-PRELUDE = Prelude.hs PrelPrim.hs
-
-STD_LIBS = Array.lhs Char.lhs Complex.lhs CPUTime.lhs \
- Directory.lhs IO.lhs Ix.lhs List.lhs Locale.lhs \
- Maybe.lhs Monad.lhs Numeric.lhs Ratio.lhs \
- Random.lhs System.lhs
-
-# To Fix: Time, Directory
-
-DATA_LIBS = FiniteMap.lhs Set.lhs \
- EdisonPrelude.hs \
- Assoc.hs AssocDefaults.hs AssocList.hs PatriciaLoMap.hs \
- Collection.hs CollectionDefaults.hs CollectionUtils.hs \
- LazyPairingHeap.hs LeftistHeap.hs MinHeap.hs SkewHeap.hs \
- SplayHeap.hs TestOrdBag.hs TestOrdSet.hs UnbalancedSet.hs \
- BankersQueue.hs BinaryRandList.hs BraunSeq.hs JoinList.hs \
- ListSeq.hs MyersStack.hs RandList.hs RevSeq.hs Sequence.hs \
- SequenceDefaults.hs SimpleQueue.hs SizedSeq.hs TestSeq.hs
-
-TEXT_LIBS = Pretty.lhs Html.lhs HtmlBlockTable.lhs \
- Haskell2Xml.hs \
- ParseSTLib.hs \
- Xml2Haskell.hs \
- XmlCombinators.hs \
- XmlHtmlGen.hs \
- XmlHtmlPP.hs \
- XmlHtmlParse.hs \
- XmlLex.hs \
- XmlLib.hs \
- XmlPP.hs \
- XmlParse.hs \
- XmlTypes.hs
-
-LANG_LIBS = Addr.lhs Bits.lhs ByteArray.lhs Dynamic.lhs \
- Exception.lhs Int.lhs IOExts.lhs LazyST.lhs \
- MonadEither.lhs MonadFix.lhs MonadIdentity.lhs \
- MonadReader.lhs MonadRWS.lhs MonadState.lhs \
- MonadTrans.lhs MonadWriter.lhs Monoid.lhs \
- MutableArray.lhs NumExts.lhs PackedString.lhs \
- ShowFunctions.lhs ST.lhs Stable.lhs StablePtr.lhs \
- TimeExts.lhs Weak.lhs Word.lhs
-
-UTIL_LIBS = QuickCheck.hs QuickCheckBatch.hs QuickCheckPoly.hs \
- QuickCheckUtils.hs GetOpt.lhs \
- Regex.lhs RegexString.lhs Memo.lhs Readline.lhs \
- Select.lhs
-
-CONC_LIBS = Channel.lhs ChannelVar.lhs Concurrent.lhs Merge.lhs \
- Parallel.lhs SampleVar.lhs Semaphore.lhs Strategies.lhs
-
-
-LIBS = $(PRELUDE) \
- $(STD_LIBS) \
- $(DATA_LIBS) \
- $(LANG_LIBS) \
- $(TEXT_LIBS) \
- $(CONC_LIBS) \
- $(UTIL_LIBS)
-
-all :: $(LIBS)
-
-
-HUGSCPP = ../../utils/hscpp/hscpp -D__HUGS__ -D__HASKELL98__
-
-%.lhs :: $(GHC_LIB_DIR)/std/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.hs :: $(GHC_LIB_DIR)/hugs/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/concurrent/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/data/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.hs :: $(FPTOOLS_TOP)/hslibs/data/edison/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-%.hs :: $(FPTOOLS_TOP)/hslibs/data/edison/Seq/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-%.hs :: $(FPTOOLS_TOP)/hslibs/data/edison/Coll/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-%.hs :: $(FPTOOLS_TOP)/hslibs/data/edison/Assoc/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/lang/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-%.lhs :: $(FPTOOLS_TOP)/hslibs/lang/monads/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/net/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/posix/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/text/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-%.lhs :: $(FPTOOLS_TOP)/hslibs/text/html/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-%.hs :: $(FPTOOLS_TOP)/hslibs/text/haxml/lib/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-
-
-%.lhs :: $(FPTOOLS_TOP)/hslibs/util/%.lhs
- $(HUGSCPP) -I../../includes $< > $*.lhs
-%.hs :: $(FPTOOLS_TOP)/hslibs/util/check/%.hs
- $(HUGSCPP) -I../../includes $< > $*.hs
-
-CLEAN_FILES += $(LIBS)
-
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-#ifdef HEAD
-module Array (
- module Ix, -- export all of Ix
- Array, array, listArray, (!), bounds, indices, elems, assocs,
- accumArray, (//), accum, ixmap ) where
-
-import Ix
-#if STD_PRELUDE
-import List( (\\) )
-
-infixl 9 !, //
-#else
-import PreludeBuiltin
-#endif
-#endif /* HEAD */
-#ifdef BODY
-
-#if STD_PRELUDE
-data Array a b = MkArray (a,a) (a -> b) deriving ()
-
-array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
-array b ivs =
- if and [inRange b i | (i,_) <- ivs]
- then MkArray b
- (\j -> case [v | (i,v) <- ivs, i == j] of
- [v] -> v
- [] -> error "Array.!: \
- \undefined array element"
- _ -> error "Array.!: \
- \multiply defined array element")
- else error "Array.array: out-of-range array association"
-
-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
-(!) (MkArray _ f) = f
-
-bounds :: (Ix a) => Array a b -> (a,a)
-bounds (MkArray 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
- map fn (MkArray b f) = MkArray b (fn . f)
-
-#else /* STD_PRELUDE */
-
-data Ix ix => Array ix elt = Array (ix,ix) (PrimArray elt)
-data Ix ix => ByteArray ix = ByteArray (ix,ix) PrimByteArray
-data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (PrimMutableArray s elt)
-data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (PrimMutableByteArray s)
-
-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)
-
-
-#endif /* STD_PRELUDE */
-
-#ifdef PROVIDE_ARRAY
-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
-
-----------------------------------------------------------------
--- pointer equality tests:
-----------------------------------------------------------------
-
-instance Eq (Ref s a) where (==) = primSameRef
-instance Eq (PrimMutableArray s a) where (==) = primSameMutableArray
-
-instance Eq (PrimMutableByteArray s) where (==) = primSameMutableByteArray
-
-instance (Ix ix) => Eq (MutableArray s ix elt) where
- MutableArray _ arr1 == MutableArray _ arr2 = arr1 == arr2
-
-instance (Ix ix) => Eq (MutableByteArray s ix) where
- MutableByteArray _ arr1 == MutableByteArray _ arr2 = arr1 == arr2
-
-#endif /* PROVIDE_ARRAYS */
-
-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 ])
-#endif /* BODY */
+++ /dev/null
-#ifdef HEAD
-module Char (
- isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, isLower,
- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
- digitToInt, intToDigit,
- toUpper, toLower,
- ord, chr,
- readLitChar, showLitChar, lexLitChar
- ) where
-
-import Array -- used for character name table.
-
-import UnicodePrims -- source of primitive Unicode functions.
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
--- Character-testing operations
-isAscii, isControl, isPrint, isSpace, isUpper, isLower,
- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum :: Char -> Bool
-
-isAscii c = c < '\x80'
-
-isLatin1 c = c <= '\xff'
-
--- Only ASCII Chars can be controls
-
-isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
-
--- This function does not
-
-isPrint = primUnicodeIsPrint
-
--- Only Latin-1 spaces recognized
-
-isSpace c = c `elem` " \t\n\r\f\v\xA0"
-
-isUpper = primUnicodeIsUpper
-
-isLower = primUnicodeIsLower
-
-isAlpha c = isUpper c || isLower c
-
-isDigit c = c >= '0' && c <= '9'
-
-isOctDigit c = c >= '0' && c <= '7'
-
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
- c >= 'a' && c <= 'f'
-
-isAlphaNum = primUnicodeIsAlphaNum
-
-
--- 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"
-
-
--- Case-changing operations
-toUpper :: Char -> Char
-toUpper = primUnicodeToUpper
-
-toLower :: Char -> Char
-toLower = primUnicodeToLower
-
--- Character code functions
-ord :: Char -> Int
-ord = fromEnum
-
-chr :: Int -> Char
-chr = toEnum
-
--- Text functions
-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 <= '_'
- = [(chr (ord c - ord '@'), s)]
- readEsc s@(d:_) | isDigit d
- = [(chr n, t) | (n,t) <- readDec s]
- readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
- readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
- readEsc s@(c:_) | isUpper c
- = let table = ('\DEL', "DEL") : assocs asciiTab
- in case [(c,s') | (c, mne) <- table,
- ([],s') <- [match mne s]]
- of (pr:_) -> [pr]
- [] -> []
- readEsc _ = []
-readLitChar (c:s) = [(c,s)]
-
-showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = showChar '\\' .
- protectEsc isDigit (shows (ord 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 ('\\' : asciiTab!c)
-
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
-match :: (Eq a) => [a] -> [a] -> ([a],[a])
-match (x:xs) (y:ys) | x == y = match xs ys
-match xs ys = (xs,ys)
-
-asciiTab = listArray ('\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"]
-
-lexLitChar :: ReadS String
-lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
- where
- lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
- lexEsc s@(d:_) | isDigit d = lexDigits s
- lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
- -- Very crude approximation to \XYZ. Let readers work this out.
- lexEsc s@(c:_) | isUpper c = [span isCharName s]
- lexEsc _ = []
- isCharName c = isUpper c || isDigit c
-
-lexLitChar (c:s) = [([c],s)]
-lexLitChar "" = []
-
-#endif /* BODY */
+++ /dev/null
-
-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 (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
-
-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
-
-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
-module Directory (
- createDirectory, removeDirectory, removeFile,
- renameDirectory, renameFile, getDirectoryContents,
- getCurrentDirectory, setCurrentDirectory ) where
-
-createDirectory :: FilePath -> IO ()
-removeDirectory :: FilePath -> IO ()
-removeFile :: FilePath -> IO ()
-renameDirectory :: FilePath -> FilePath -> IO ()
-renameFile :: FilePath -> FilePath -> IO ()
-getDirectoryContents :: FilePath -> IO [FilePath]
-getCurrentDirectory :: IO FilePath
-setCurrentDirectory :: FilePath -> IO ()
-
-
-
-
+++ /dev/null
-module IO (
- Handle, HandlePosn,
- IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
- BufferMode(NoBuffering,LineBuffering,BlockBuffering),
- SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
- stdin, stdout, stderr, openFile, hClose, hFileSize, hIsEOF, isEOF,
- hSetBuffering, hGetBuffering, hFlush, hGetPosn, hSetPosn, hSeek,
- hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hReady,
- hGetChar, hLookAhead, hGetContents, hPutChar, hPutStr, hPrint,
- isAlreadyExistsError, isAlreadyInUseError, isFullError, isEOFError,
- isIllegalOperation, isPermissionError, isUserError,
- ioeGetHandle, ioeGetFileName ) where
-import Ix
-
-data Handle = ...
-instance Eq Handle where ...
-data HandlePosn = ...
-instance Eq HandlePosn where ...
-
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Read, Show)
-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-stdin, stdout, stderr :: Handle
-openFile :: FilePath -> IOMode -> IO Handle
-hClose :: Handle -> IO ()
-hFileSize :: Handle -> IO Integer
-hIsEOF :: Handle -> IO Bool
-isEOF :: IO Bool
-isEOF = hIsEOF stdin
-hSetBuffering :: Handle -> BufferMode -> IO ()
-hGetBuffering :: Handle -> IO BufferMode
-hFlush :: Handle -> IO ()
-hGetPosn :: Handle -> IO HandlePosn
-hSetPosn :: HandlePosn -> IO ()
-hSeek :: Handle -> SeekMode -> Integer -> IO ()
-hIsOpen :: Handle -> IO Bool
-hIsClosed :: Handle -> IO Bool
-hIsReadable :: Handle -> IO Bool
-hIsWritable :: Handle -> IO Bool
-hIsSeekable :: Handle -> IO Bool
-hReady :: Handle -> IO Bool
-
-try :: IO a -> IO (Either IOError a)
-try f = catch (do r <- f
- return (Right r))
- (return . Left)
-
-bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c
-bracket before after m = do
- x <- before
- rs <- try (m x)
- after x
- case rs of
- Right r -> return r
- Left e -> fail e
-
--- variant of the above where middle computation doesn't want x
-bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c
-bracket_ before after m = do
- x <- before
- rs <- try m
- after x
- case rs of
- Right r -> return r
- Left e -> fail e
+++ /dev/null
------------------------------------------------------------------------------
--- Signed Integers
--- Suitable for use with Hugs 1.4 on 32 bit systems.
------------------------------------------------------------------------------
-
-module Int
- ( Int8
- , Int16
- , Int32
- --, Int64
- , int8ToInt -- :: Int8 -> Int
- , intToInt8 -- :: Int -> Int8
- , int16ToInt -- :: Int16 -> Int
- , intToInt16 -- :: Int -> Int16
- , int32ToInt -- :: Int32 -> Int
- , intToInt32 -- :: Int -> Int32
- -- plus Eq, Ord, Num, Bounded, Real, Integral, Ix, Enum, Read,
- -- Show and Bits instances for each of Int8, Int16 and Int32
- ) where
-
-import PreludeBuiltin
-import Bits
-
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-int8ToInt :: Int8 -> Int
-intToInt8 :: Int -> Int8
-int16ToInt :: Int16 -> Int
-intToInt16 :: Int -> Int16
-int32ToInt :: Int32 -> Int
-intToInt32 :: Int -> Int32
-
--- And some non-exported ones
-
-int8ToInt16 :: Int8 -> Int16
-int8ToInt32 :: Int8 -> Int32
-int16ToInt8 :: Int16 -> Int8
-int16ToInt32 :: Int16 -> Int32
-int32ToInt8 :: Int32 -> Int8
-int32ToInt16 :: Int32 -> Int16
-
-int8ToInt16 = I16 . int8ToInt
-int8ToInt32 = I32 . int8ToInt
-int16ToInt8 = I8 . int16ToInt
-int16ToInt32 = I32 . int16ToInt
-int32ToInt8 = I8 . int32ToInt
-int32ToInt16 = I16 . int32ToInt
-
------------------------------------------------------------------------------
--- Int8
------------------------------------------------------------------------------
-
-newtype Int8 = I8 Int
-
-int8ToInt (I8 x) = if x' <= 0x7f then x' else x' - 0x100
- where x' = x `primAndInt` 0xff
-intToInt8 = I8
-
-instance Eq Int8 where (==) = binop (==)
-instance Ord Int8 where compare = binop compare
-
-instance Num Int8 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int8 where
- minBound = 0x80
- maxBound = 0x7f
-
-instance Real Int8 where
- toRational x = toInteger x % 1
-
-instance Integral Int8 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int8 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int8 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int8)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int8)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int8 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int8 where
- showsPrec p = showsPrec p . from
-
-binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
-binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
-
-instance Bits Int8 where
- x .&. y = int32ToInt8 (binop8 (.&.) x y)
- x .|. y = int32ToInt8 (binop8 (.|.) x y)
- x `xor` y = int32ToInt8 (binop8 xor x y)
- complement = int32ToInt8 . complement . int8ToInt32
- x `shift` i = int32ToInt8 (int8ToInt32 x `shift` i)
--- rotate
- bit = int32ToInt8 . bit
- setBit x i = int32ToInt8 (setBit (int8ToInt32 x) i)
- clearBit x i = int32ToInt8 (clearBit (int8ToInt32 x) i)
- complementBit x i = int32ToInt8 (complementBit (int8ToInt32 x) i)
- testBit x i = testBit (int8ToInt32 x) i
- bitSize _ = 8
- isSigned _ = True
-
------------------------------------------------------------------------------
--- Int16
------------------------------------------------------------------------------
-
-newtype Int16 = I16 Int
-
-int16ToInt (I16 x) = if x' <= 0x7fff then x' else x' - 0x10000
- where x' = x `primAndInt` 0xffff
-intToInt16 = I16
-
-instance Eq Int16 where (==) = binop (==)
-instance Ord Int16 where compare = binop compare
-
-instance Num Int16 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int16 where
- minBound = 0x8000
- maxBound = 0x7fff
-
-instance Real Int16 where
- toRational x = toInteger x % 1
-
-instance Integral Int16 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int16 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int16 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int16)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int16)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int16 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int16 where
- showsPrec p = showsPrec p . from
-
-binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
-binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
-
-instance Bits Int16 where
- x .&. y = int32ToInt16 (binop16 (.&.) x y)
- x .|. y = int32ToInt16 (binop16 (.|.) x y)
- x `xor` y = int32ToInt16 (binop16 xor x y)
- complement = int32ToInt16 . complement . int16ToInt32
- x `shift` i = int32ToInt16 (int16ToInt32 x `shift` i)
--- rotate
- bit = int32ToInt16 . bit
- setBit x i = int32ToInt16 (setBit (int16ToInt32 x) i)
- clearBit x i = int32ToInt16 (clearBit (int16ToInt32 x) i)
- complementBit x i = int32ToInt16 (complementBit (int16ToInt32 x) i)
- testBit x i = testBit (int16ToInt32 x) i
- bitSize _ = 16
- isSigned _ = True
-
------------------------------------------------------------------------------
--- Int32
------------------------------------------------------------------------------
-
-newtype Int32 = I32 Int
-
-int32ToInt (I32 x) = x
-intToInt32 = I32
-
-instance Eq Int32 where (==) = binop (==)
-instance Ord Int32 where compare = binop compare
-
-instance Num Int32 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = to
-
-instance Bounded Int32 where
- minBound = to minBound
- maxBound = to maxBound
-
-instance Real Int32 where
- toRational x = toInteger x % 1
-
-instance Integral Int32 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- toInteger = toInteger . from
- toInt = toInt . from
-
-instance Ix Int32 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = from (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int32 where
- toEnum = to
- fromEnum = from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Int32)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Int32)]
- where last = if d < c then minBound else maxBound
-
-instance Read Int32 where
- readsPrec p s = [ (to x,r) | (x,r) <- readsPrec p s ]
-
-instance Show Int32 where
- showsPrec p = showsPrec p . from
-
-instance Bits Int32 where
- (.&.) = lift2 primAndInt
- (.|.) = lift2 primOrInt
- xor = lift2 primXorInt
- complement = lift1 primNotInt
- shift x n
- | n >= 0 = to (primShiftLInt (from x) (primIntToWord n))
- | otherwise = to (primShiftRLInt (from x) (primIntToWord (-n)))
--- rotate
- bit = shift 1
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = x .&. bit i /= 0
- bitSize _ = 32
- isSigned _ = True
-
------------------------------------------------------------------------------
--- End of exported definitions
---
--- The remainder of this file consists of definitions which are only
--- used in the implementation.
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
--- Coercions - used to make the instance declarations more uniform
------------------------------------------------------------------------------
-
-class Coerce a where
- to :: Int -> a
- from :: a -> Int
-
-instance Coerce Int32 where
- from = int32ToInt
- to = intToInt32
-
-instance Coerce Int8 where
- from = int8ToInt
- to = intToInt8
-
-instance Coerce Int16 where
- from = int16ToInt
- to = intToInt16
-
-binop :: Coerce int => (Int -> Int -> a) -> (int -> int -> a)
-binop op x y = from x `op` from y
-
-to2 :: Coerce int => (Int, Int) -> (int, int)
-to2 (x,y) = (to x, to y)
-
-lift1 :: Coerce int => (Int -> Int) -> (int -> int)
-lift1 f x = to (f (from x))
-
-lift2 :: Coerce int => (Int -> Int -> Int) -> (int -> int -> int)
-lift2 f x y = to (f (from x) (from y))
-
------------------------------------------------------------------------------
--- Code copied from the Prelude
------------------------------------------------------------------------------
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
------------------------------------------------------------------------------
--- End
------------------------------------------------------------------------------
+++ /dev/null
-#ifdef HEAD
-module Ix ( Ix(range, index, inRange), rangeSize ) where
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
-class (Show a, Ord a) => Ix a where
- range :: (a,a) -> [a]
- index :: (a,a) -> a -> Int
- inRange :: (a,a) -> a -> Bool
-
-rangeSize :: Ix a => (a,a) -> Int
-rangeSize b@(l,h) | l > h = 0
- | otherwise = index b h + 1
-
-#if STD_PRELUDE
-#else
-instance Ix Bool where
- range (c,c') = [c..c']
- index b@(c,c') ci
- | inRange b ci = fromEnum ci - fromEnum c
- | otherwise = error "Ix.index.Bool: Index out of range."
- inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
- where i = fromEnum ci
-#endif
-
-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.Char: Index out of range."
- inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
- where i = fromEnum ci
-
-instance Ix Int where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = i - m
- | otherwise = error "Ix.index.Int: Index out of range."
- inRange (m,n) i = m <= i && i <= n
-
-#ifdef PROVIDE_INTEGER
-instance Ix Integer where
- range (m,n) = [m..n]
- index b@(m,n) i
-#if STD_PRELUDE
- | inRange b i = fromInteger (i - m)
-#else
- /* fromInteger may not have an Integer arg :-) */
- | inRange b i = toInt (i - m)
-#endif
- | otherwise = error "Ix.index.Integer: Index out of range."
- inRange (m,n) i = m <= i && i <= n
-#endif
-
-#if STD_PRELUDE
-instance (Ix a,Ix b) => Ix (a, b) -- as derived, for all tuples
-instance Ix Bool -- as derived
-instance Ix Ordering -- as derived
-instance Ix () -- as derived
-#else
--- #error "Missing Ix instances"
-#endif
-
-#endif /* BODY */
\ No newline at end of file
+++ /dev/null
-#ifdef HEAD
-module List (
- elemIndex, elemIndices,
- find, findIndex, findIndices,
- nub, nubBy, delete, deleteBy, (\\),
- union, unionBy, intersect, intersectBy,
- intersperse, transpose, partition, group, groupBy,
- inits, tails, isPrefixOf, isSuffixOf,
- mapAccumL, mapAccumR,
- sort, sortBy, insertBy, maximumBy, minimumBy,
- genericLength, genericTake, genericDrop,
- genericSplitAt, genericIndex, genericReplicate,
- zip4, zip5, zip6, zip7,
- zipWith4, zipWith5, zipWith6, zipWith7,
- unzip4, unzip5, unzip6, unzip7
- ) where
-
-#if STD_PRELUDE
-import Maybe( listToMaybe )
-
-infix 5 \\
-#else
-import PreludeBuiltin
-#endif
-#endif /* HEAD */
-#ifdef BODY
-
-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
-
-#if 1
-transpose :: [[a]] -> [[a]]
-transpose = foldr
- (\xs xss -> zipWith (:) xs (xss ++ repeat []))
- []
-#else
--- This variant was posted to the haskell mailing list
--- by Jonas Holmerin <md93-jho@nada.kth.se> on 31 Mar 1998.
--- He claims that it is more symmetric since it can handle
--- transpose (repeat [1..5])
--- as well as finite lists of infinite lists such as
--- transpose (map repeat [1..5])
-transpose :: [[a]] -> [[a]]
-transpose = foldr
- (\xs xss -> zipLazier (:) xs (xss ++ repeat []))
- []
- where
- zipLazier f (x:xs) xss = f x (head xss) : zipLazier f xs (tail xss)
- zipLazier _ _ _ = []
-#endif
-
-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
-
-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 _ [] = []
-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))
- ([],[],[],[],[],[],[])
-
-#endif /* BODY */
\ No newline at end of file
+++ /dev/null
-#ifdef HEAD
-module Maybe(
- isJust, fromJust, fromMaybe, listToMaybe, maybeToList,
- catMaybes, mapMaybe, unfoldr ) where
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
-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:_) = Just a
-
-catMaybes :: [Maybe a] -> [a]
-catMaybes ms = [ m | Just m <- ms ]
-
-mapMaybe :: (a -> Maybe b) -> [a] -> [b]
-mapMaybe f = catMaybes . map f
-
-unfoldr :: ([a] -> Maybe ([a], a)) -> [a] -> ([a],[a])
-unfoldr f x =
- case f x of
- Just (x',y) -> let (ys,x'') = unfoldr f x' in (x'',y:ys)
- Nothing -> (x,[])
-
-#endif /* BODY */
+++ /dev/null
-module Monad (
- join, mapAndUnzipM, zipWithM, zipWithM_, foldM, when, unless, ap,
- liftM, liftM2, liftM3, liftM4, liftM5
- ) where
-
-join :: (Monad m) => m (m a) -> m a
-join x = x >>= id
-
-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
-
-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 ($)
-
-#if STD_PRELUDE
-liftM :: (Monad m) => (a -> b) -> (m a -> m b)
-liftM f = \a -> [f a' | a' <- a]
-
-liftM2 :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c)
-liftM2 f = \a b -> [f a' b' | a' <- a, b' <- b]
-
-liftM3 :: (Monad m) => (a -> b -> c -> d) ->
- (m a -> m b -> m c -> m d)
-liftM3 f = \a b c -> [f a' b' c' | a' <- a, b' <- b, c' <- 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 -> [f a' b' c' d' |
- a' <- a, b' <- b, c' <- c, d' <- 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 -> [f a' b' c' d' e' |
- a' <- a, b' <- b,
- c' <- c, d' <- d, e' <- e]
-#else
-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')
- }
-
-#endif
\ No newline at end of file
+++ /dev/null
-#ifdef HEAD
-module Numeric(fromRat,
- showSigned, showInt,
- readSigned, readInt,
- readDec, readOct, readHex,
- floatToDigits,
- showEFloat, showFFloat, showGFloat, showFloat,
- readFloat, lexDigits) where
-
-import Char
-import Array
-
-import PreludeBuiltin
-#endif
-#ifdef BODY
-
--- This converts a rational to a floating. This should be used in the
--- Fractional instances of Float and Double.
-
-fromRat :: (RealFloat a) => Rational -> a
-fromRat x =
- if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
- else if x < 0 then - fromRat' (-x) -- first.
- else fromRat' x
-
--- Conversion process:
--- Scale the rational number by the RealFloat base until
--- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
--- Then round the rational to an Integer and encode it with the exponent
--- that we got from the scaling.
--- To speed up the scaling process we compute the log2 of the number to get
--- a first guess of the exponent.
-fromRat' :: (RealFloat a) => Rational -> a
-fromRat' x = r
- where b = floatRadix r
- p = floatDigits r
- (minExp0, _) = floatRange r
- minExp = minExp0 - p -- the real minimum exponent
- xMin = toRational (expt b (p-1))
- xMax = toRational (expt b p)
- p0 = (integerLogBase b (numerator x) -
- integerLogBase b (denominator x) - p) `max` minExp
- f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
- (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
- r = encodeFloat (round x') p'
-
--- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
-scaleRat :: Rational -> Int -> Rational -> Rational ->
- Int -> Rational -> (Rational, Int)
-scaleRat b minExp xMin xMax p x
- | p <= minExp = (x, p)
- | x >= xMax = scaleRat b minExp xMin xMax (p+1) (x/b)
- | x < xMin = scaleRat b minExp xMin xMax (p-1) (x*b)
- | otherwise = (x, p)
-
--- Exponentiation with a cache for the most common numbers.
-minExpt = 0::Int
-maxExpt = 1100::Int
-expt :: BIGNUMTYPE -> Int -> BIGNUMTYPE
-expt base n =
- if base == 2 && n >= minExpt && n <= maxExpt then
- expts!n
- else
- base^n
-
-expts :: Array Int BIGNUMTYPE
-expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
-
--- Compute the (floor of the) log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b,
--- but that would be very slow! We are just slightly more clever.
-integerLogBase :: BIGNUMTYPE -> BIGNUMTYPE -> Int
-integerLogBase b i =
- if i < b then
- 0
- else
- -- Try squaring the base first to cut down the number of divisions.
- let l = 2 * integerLogBase (b*b) i
- doDiv :: BIGNUMTYPE -> Int -> Int
- doDiv i l = if i < b then l else doDiv (i `div` b) (l+1)
- in doDiv (i `div` (b^l)) l
-
-
--- Misc utilities to show integers and floats
-
-showSigned :: Real a => (a -> ShowS) -> Int -> a -> ShowS
-showSigned showPos p x | x < 0 = showParen (p > 6)
- (showChar '-' . showPos (-x))
- | otherwise = showPos x
-
--- 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]
-
-
--- 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 ]
-
--- Unsigned readers for various bases
-readDec, readOct, readHex :: (Integral a) => ReadS a
-readDec = readInt 10 isDigit digitToInt
-readOct = readInt 8 isOctDigit digitToInt
-readHex = readInt 16 isHexDigit digitToInt
-
-
-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) => BIGNUMTYPE -> 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 =
-#if 1 /* hack to overcome temporary Hugs bug (fixed size Integers) */
- 0
-#else
- if b==2 && base==10 then
- -- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
- else
- ceiling ((log (fromInteger (f+1)) +
- fromInt e * log (fromInteger b)) /
- log (fromInteger base) `asTypeOf` x)
-#endif
- 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)
-
-
-
--- This floating point reader uses a less restrictive syntax for floating
--- point than the Haskell lexer. The `.' is optional.
-
-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,d) <- lexDigits r,
- (ds',t) <- lexFrac d ]
-
- lexFrac ('.':ds) = lexDigits ds
- 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
-
-lexDigits :: ReadS String
-lexDigits = nonnull isDigit
-
-nonnull :: (Char -> Bool) -> ReadS String
-nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
-
-#endif /* BODY */
+++ /dev/null
--- Standard functions on rational numbers
-
-#ifdef HEAD
-module Ratio (
- Ratio, Rational, (%), numerator, denominator, approxRational ) where
-
-#if STD_PRELUDE
-infixl 7 %
-#endif
-
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
-data (Integral a) => Ratio a = !a :% !a deriving (Eq)
-type Rational = Ratio BIGNUMTYPE
-
-(%) :: (Integral a) => a -> a -> Ratio a
-numerator, denominator :: (Integral a) => Ratio a -> a
-approxRational :: (RealFrac a) => a -> a -> Rational
-
-
--- "reduce" is a subsidiary function used only in this module.
--- It normalises a ratio by dividing both numerator
--- and denominator by their greatest common divisor.
---
--- E.g., 12 `reduce` 8 == 3 :% 2
--- 12 `reduce` (-8) == 3 :% (-2)
-
-reduce _ 0 = error "Ratio.% : zero denominator"
-reduce x y = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-
-x % y = reduce (x * signum y) (abs y)
-
-numerator (x :% _) = x
-
-denominator (_ :% y) = y
-
-
-instance (Integral a) => Ord (Ratio a) where
- (x:%y) <= (x':%y') = x * y' <= x' * y
- (x:%y) < (x':%y') = 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) = (-x) :% y
- abs (x:%y) = abs x :% y
- signum (x:%y) = signum x :% 1
- fromInteger x = fromInteger 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
-
-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
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo = numericEnumFromTo
- enumFromThenTo = numericEnumFromThenTo
- toEnum = fromInteger . toInteger
- fromEnum n = error "Ratio.fromEnum: can't use\
- \ fromEnum with Ratio"
-
-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 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
-
-#endif /* BODY */
+++ /dev/null
-#ifdef HEAD
-module UnicodePrims
- ( primUnicodeIsPrint
- , primUnicodeIsUpper
- , primUnicodeIsLower
- , primUnicodeIsAlphaNum
- ) where
-
-import PreludeBuiltin
-#endif /* HEAD */
-#ifdef BODY
-
--- based on GHC's implementation
-primUnicodeIsPrint c = not (isControl c)
--- The upper case ISO characters have the multiplication sign dumped
--- randomly in the middle of the range. Go figure.
-primUnicodeIsUpper c = c >= 'A' && c <= 'Z' ||
- c >= '\xC0' && c <= '\xD6' ||
- c >= '\xD8' && c <= '\xDE'
--- The lower case ISO characters have the division sign dumped
--- randomly in the middle of the range. Go figure.
-primUnicodeIsLower c = c >= 'a' && c <= 'z' ||
- c >= '\xDF' && c <= '\xF6' ||
- c >= '\xF8' && c <= '\xFF'
-primUnicodeIsAlphaNum c = isAlpha c || isDigit c
-primUnicodeToUpper c
- | isLower c = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
- | otherwise = c
-primUnicodeToLower c
- | isUpper c = toEnum (fromEnum c - fromEnum 'A' + fromEnum 'a')
- | otherwise = c
-
-#endif /* BODY */
+++ /dev/null
------------------------------------------------------------------------------
--- Unsigned Integers
--- Suitable for use with Hugs 1.4 on 32 bit systems.
------------------------------------------------------------------------------
-module Word
- ( Word8
- , Word16
- , Word32
- , Word64
- , word8ToWord32 -- :: Word8 -> Word32
- , word32ToWord8 -- :: Word32 -> Word8
- , word16ToWord32 -- :: Word16 -> Word32
- , word32ToWord16 -- :: Word32 -> Word16
- , word8ToInt -- :: Word8 -> Int
- , intToWord8 -- :: Int -> Word8
- , word16ToInt -- :: Word16 -> Int
- , intToWord16 -- :: Int -> Word16
- , word32ToInt -- :: Word32 -> Int
- , intToWord32 -- :: Int -> Word32
- ) where
-
-import PreludeBuiltin
-import Bits
-
------------------------------------------------------------------------------
--- The "official" coercion functions
------------------------------------------------------------------------------
-
-word8ToWord32 :: Word8 -> Word32
-word32ToWord8 :: Word32 -> Word8
-word16ToWord32 :: Word16 -> Word32
-word32ToWord16 :: Word32 -> Word16
-
-word8ToInt :: Word8 -> Int
-intToWord8 :: Int -> Word8
-word16ToInt :: Word16 -> Int
-intToWord16 :: Int -> Word16
-word32ToInt :: Word32 -> Int
-intToWord32 :: Int -> Word32
-
-word8ToInt = word32ToInt . word8ToWord32
-intToWord8 = word32ToWord8 . intToWord32
-word16ToInt = word32ToInt . word16ToWord32
-intToWord16 = word32ToWord16 . intToWord32
-
-word32ToInt (W32 x) = primWordToInt x
-intToWord32 x = W32 (primIntToWord x)
-
-
------------------------------------------------------------------------------
--- Word8
------------------------------------------------------------------------------
-
-newtype Word8 = W8 Word32
-
-word8ToWord32 (W8 x) = x .&. 0xff
-word32ToWord8 = W8
-
-instance Eq Word8 where (==) = binop (==)
-instance Ord Word8 where compare = binop compare
-
-instance Num Word8 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = intToWord8
-
-instance Bounded Word8 where
- minBound = 0
- maxBound = 0xff
-
-instance Real Word8 where
- toRational x = toInteger x % 1
-
-instance Integral Word8 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- divMod = quotRem
- toInteger = toInteger . from
- toInt = word8ToInt
-
-instance Ix Word8 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (from (i - m))
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word8 where
- toEnum = to . intToWord32
- fromEnum = word32ToInt . from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word8)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word8)]
- where last = if d < c then minBound else maxBound
-
-instance Read Word8 where
- readsPrec p = readDec
-
-instance Show Word8 where
- showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
-
-instance Bits Word8 where
- x .&. y = to (binop (.&.) x y)
- x .|. y = to (binop (.|.) x y)
- x `xor` y = to (binop xor x y)
- complement = to . complement . from
- x `shift` i = to (from x `shift` i)
--- rotate
- bit = to . bit
- setBit x i = to (setBit (from x) i)
- clearBit x i = to (clearBit (from x) i)
- complementBit x i = to (complementBit (from x) i)
- testBit x i = testBit (from x) i
- bitSize _ = 8
- isSigned _ = False
-
------------------------------------------------------------------------------
--- Word16
------------------------------------------------------------------------------
-
-newtype Word16 = W16 Word32
-
-word16ToWord32 (W16 x) = x .&. 0xffff
-word32ToWord16 = W16
-
-instance Eq Word16 where (==) = binop (==)
-instance Ord Word16 where compare = binop compare
-
-instance Num Word16 where
- x + y = to (binop (+) x y)
- x - y = to (binop (-) x y)
- negate = to . negate . from
- x * y = to (binop (*) x y)
- abs = absReal
- signum = signumReal
- fromInteger = to . fromInteger
- fromInt = intToWord16
-
-instance Bounded Word16 where
- minBound = 0
- maxBound = 0xffff
-
-instance Real Word16 where
- toRational x = toInteger x % 1
-
-instance Integral Word16 where
- x `div` y = to (binop div x y)
- x `quot` y = to (binop quot x y)
- x `rem` y = to (binop rem x y)
- x `mod` y = to (binop mod x y)
- x `quotRem` y = to2 (binop quotRem x y)
- divMod = quotRem
- toInteger = toInteger . from
- toInt = word16ToInt
-
-instance Ix Word16 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (from (i - m))
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word16 where
- toEnum = to . intToWord32
- fromEnum = word32ToInt . from
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Word16)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (last::Word16)]
- where last = if d < c then minBound else maxBound
-
-instance Read Word16 where
- readsPrec p = readDec
-
-instance Show Word16 where
- showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
-
-instance Bits Word16 where
- x .&. y = to (binop (.&.) x y)
- x .|. y = to (binop (.|.) x y)
- x `xor` y = to (binop xor x y)
- complement = to . complement . from
- x `shift` i = to (from x `shift` i)
--- rotate
- bit = to . bit
- setBit x i = to (setBit (from x) i)
- clearBit x i = to (clearBit (from x) i)
- complementBit x i = to (complementBit (from x) i)
- testBit x i = testBit (from x) i
- bitSize _ = 16
- isSigned _ = False
-
------------------------------------------------------------------------------
--- Word32
------------------------------------------------------------------------------
-
-newtype Word32 = W32 Word
-
-w32 :: Word32 -> Word
-w32 (W32 x) = x
-
-lift0 :: Word -> Word32
-lift1 :: (Word -> Word) -> (Word32 -> Word32)
-lift2 :: (Word -> Word -> Word) -> (Word32 -> Word32 -> Word32)
-lift2' :: (Word -> Word -> (Word,Word)) -> (Word32 -> Word32 -> (Word32,Word32))
-
-lift0 x = W32 x
-lift1 f (W32 x) = W32 (f x)
-lift2 f (W32 x) (W32 y) = W32 (f x y)
-
-lift2' f (W32 x) (W32 y) = case f x y of (a,b) -> (W32 a, W32 b)
-
-instance Eq Word32 where
- x == y = primEqWord (w32 x) (w32 y)
- x /= y = primNeWord (w32 x) (w32 y)
-
-instance Ord Word32 where
- x < y = primLtWord (w32 x) (w32 y)
- x <= y = primLeWord (w32 x) (w32 y)
- x >= y = primGeWord (w32 x) (w32 y)
- x > y = primGtWord (w32 x) (w32 y)
-
-instance Num Word32 where
- (+) = lift2 primPlusWord
- (-) = lift2 primMinusWord
- negate = lift1 primNegateWord
- (*) = lift2 primTimesWord
- abs = id
- signum x = if x == 0 then 0 else 1
- fromInteger = W32 . primIntegerToWord
- fromInt = W32 . primIntToWord
-
-instance Bounded Word32 where
- minBound = 0
- maxBound = W32 primMaxWord
-
-instance Real Word32 where
- toRational x = toInteger x % 1
-
-instance Integral Word32 where
- quotRem = lift2' primQuotRemWord
- quot = lift2 primQuotWord
- rem = lift2 primRemWord
- divMod = lift2' primQuotRemWord -- no difference for unsigned values!
- div = lift2 primQuotWord
- mod = lift2 primRemWord
- toInteger = primWordToInteger . w32
- toInt = primWordToInt . w32
-
-instance Ix Word32 where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = word32ToInt (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Word32 where
- toEnum = fromInt
- fromEnum = toInt
-
- enumFrom w = [w .. maxBound]
- enumFromTo w1 w2
- | w1 <= w2 = eft32 w1 w2
- | otherwise = []
- enumFromThen w1 w2 = [w1, w2 .. last]
- where
- last
- | w1 < w2 = maxBound::Word32
- | otherwise = minBound
- enumFromThenTo w1 w2 last = eftt32 w1 (w2 - w1) (>last)
-
---------------------------------
--- Begin stolen from GHC (but then modified!)
---------------------------------
-
--- Termination is easy because the step is 1
-eft32 :: Word32 -> Word32 -> [Word32]
-eft32 now last = go now
- where
- go x
- | x == last = [x]
- | otherwise = x : (go `strict` (x+1))
-
--- Termination is hard because the step is not 1
--- Warning: this code is known not to work near maxBound
-eftt32 :: Word32 -> Word32 -> (Word32->Bool) -> [Word32]
-eftt32 now step done = go now
- where
- go now
- | done now = []
- | otherwise = now : (go `strict` (now+step))
-
---------------------------------
--- End stolen from GHC.
---------------------------------
-
-instance Read Word32 where
- readsPrec p = readDec
-
-instance Show Word32 where
- showsPrec p = showInt . toInteger -- a particularily counterintuitive name!
-
-instance Bits Word32 where
- (.&.) = lift2 primAndWord
- (.|.) = lift2 primOrWord
- xor = lift2 primXorWord
- complement = lift1 primNotWord
- shift x n
- | n >= 0 = W32 (primShiftLWord (w32 x) (primIntToWord n))
- | otherwise = W32 (primShiftRLWord (w32 x) (primIntToWord (-n)))
--- rotate
- bit = shift 1
- setBit x i = x .|. bit i
- clearBit x i = x .&. complement (bit i)
- complementBit x i = x `xor` bit i
- testBit x i = x .&. bit i /= 0
- bitSize _ = 32
- isSigned _ = False
-
------------------------------------------------------------------------------
--- Word64
------------------------------------------------------------------------------
-
-data Word64 = W64 {lo,hi::Word32} deriving (Eq, Ord, Bounded)
-
-w64ToInteger W64{lo,hi} = toInteger lo + 0x100000000 * toInteger hi
-integerToW64 x = case x `quotRem` 0x100000000 of
- (h,l) -> W64{lo=fromInteger l, hi=fromInteger h}
-
-instance Show Word64 where
- showsPrec p = showInt . w64ToInteger
-
-instance Read Word64 where
- readsPrec p s = [ (integerToW64 x,r) | (x,r) <- readDec s ]
-
------------------------------------------------------------------------------
--- End of exported definitions
---
--- The remainder of this file consists of definitions which are only
--- used in the implementation.
------------------------------------------------------------------------------
-
------------------------------------------------------------------------------
--- Enumeration code: copied from Prelude
------------------------------------------------------------------------------
-
-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 : strict numericEnumFrom (n+1)
-numericEnumFromThen n m = iterate ((m-n)+) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m = takeWhile (if n' >= n then (<= m) else (>= m))
- (numericEnumFromThen n n')
-
------------------------------------------------------------------------------
--- Coercions - used to make the instance declarations more uniform
------------------------------------------------------------------------------
-
-class Coerce a where
- to :: Word32 -> a
- from :: a -> Word32
-
-instance Coerce Word8 where
- from = word8ToWord32
- to = word32ToWord8
-
-instance Coerce Word16 where
- from = word16ToWord32
- to = word32ToWord16
-
-binop :: Coerce word => (Word32 -> Word32 -> a) -> (word -> word -> a)
-binop op x y = from x `op` from y
-
-to2 :: Coerce word => (Word32, Word32) -> (word, word)
-to2 (x,y) = (to x, to y)
-
------------------------------------------------------------------------------
--- Code copied from the Prelude
------------------------------------------------------------------------------
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
------------------------------------------------------------------------------
--- End
------------------------------------------------------------------------------
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Lambda Lifter
- *
- * This is a very simple lambda lifter - it doesn't try to do Johnsson-style
- * lambda lifting (yet).
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: lift.c,v $
- * $Revision: 1.14 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static List liftedBinds = NIL;
-
-static StgExpr abstractExpr ( List vars, StgExpr e );
-static Bool isTopLevel ( StgVar v );
-static List filterFreeVars ( List vs );
-static List liftLetBinds ( List binds, Bool topLevel );
-static void liftAlt ( StgCaseAlt alt );
-static void liftPrimAlt ( StgPrimAlt alt );
-static void liftExpr ( StgExpr e );
-
-/* --------------------------------------------------------------------------
- * Lambda lifter
- * ------------------------------------------------------------------------*/
-
-/* abstract variables out of an expression */
-static StgExpr abstractExpr( List vars, StgExpr e )
-{
- List args = NIL;
- List sub = NIL; /* association list */
- for(; nonNull(vars); vars=tl(vars)) {
- StgVar var = hd(vars);
- StgVar arg = mkStgVar(NIL,NIL);
- stgVarRep(arg) = stgVarRep(var);
- args = cons(arg,args);
- sub = cons(pair(var,arg),sub);
- }
- return makeStgLambda(rev(args),substExpr(sub,e));
-}
-
-/* ToDo: should be conservative estimate but isn't */
-/* Will a variable be floated out to top level - conservative estimate? */
-static Bool isTopLevel( StgVar v )
-{
- if (isNull(stgVarBody(v))) {
- return FALSE; /* only let bound vars can be floated */
- } else if (stgVarInfo(v) == NONE) {
- return TRUE; /* those at top level are already there */
- } else {
- return FALSE;
- }
-}
-
-static List filterFreeVars( List vs )
-{
- List fvs = NIL;
- if (vs == NONE) {
- return NIL;
- } else {
- for(; nonNull(vs); vs=tl(vs)) {
- StgVar v = hd(vs);
- if (!isTopLevel(v)) {
- fvs = cons(v,fvs);
- }
- }
- return fvs;
- }
-}
-
-static Int nameCounter;
-
-static List liftLetBinds( List binds, Bool topLevel )
-{
- List bs = NIL;
- for(; nonNull(binds); binds=tl(binds)) {
- StgVar bind = hd(binds);
- StgRhs rhs = stgVarBody(bind);
- List fvs = filterFreeVars(stgVarInfo(bind));
-
- switch (whatIs(rhs)) {
- case STGCON:
- case STGAPP:
- case STGVAR:
- case NAME:
- bs = cons(bind,bs);
- break;
- default:
- liftExpr(rhs);
- if (nonNull(fvs)) {
- StgVar v = mkStgVar(abstractExpr(fvs,rhs),NONE);
- {
- Name n;
- char s[16];
- sprintf(s,"(lift%d)",nameCounter++);
- n = newName(findText(s),NIL);
- name(n).closure = v;
- stgVarBody(bind) = makeStgApp(n, fvs);
- liftedBinds = cons(n,liftedBinds);
- }
- }
- bs = cons(bind,bs);
- break;
- }
- }
- return bs;
-}
-
-static void liftAlt( StgCaseAlt alt )
-{
- if (isDefaultAlt(alt))
- liftExpr(stgDefaultBody(alt)); else
- liftExpr(stgCaseAltBody(alt));
-}
-
-static void liftPrimAlt( StgPrimAlt alt )
-{
- liftExpr(stgPrimAltBody(alt));
-}
-
-static void liftExpr( StgExpr e )
-{
- switch (whatIs(e)) {
- case LETREC:
- stgLetBinds(e) = liftLetBinds(stgLetBinds(e),FALSE);
- liftExpr(stgLetBody(e));
- break;
- case LAMBDA:
- liftExpr(stgLambdaBody(e));
- break;
- case CASE:
- liftExpr(stgCaseScrut(e));
- mapProc(liftAlt,stgCaseAlts(e));
- break;
- case PRIMCASE:
- liftExpr(stgPrimCaseScrut(e));
- mapProc(liftPrimAlt,stgPrimCaseAlts(e));
- break;
- case STGPRIM:
- break;
- case STGAPP:
- break;
- case STGVAR:
- case NAME:
- case TUPLE:
- break;
- default:
- internal("liftExpr");
- }
-}
-
-/* Lift the list of top-level binds for a module. */
-void liftModule ( Module mod )
-{
- List binds = NIL;
- List cl;
-
- nameCounter = 0;
- for (cl = module(mod).codeList; nonNull(cl); cl = tl(cl)) {
- StgVar bind = getNameOrTupleClosure(hd(cl));
- if (isCPtr(bind)) continue;
- assert(nonNull(bind));
- if (debugSC) {
- if (currentModule != modulePrelude) {
- fprintf(stderr, "\n");
- ppStg(bind);
- fprintf(stderr, "\n");
- }
- }
- freeVarsBind(NIL,bind);
- stgVarInfo(bind) = NONE; /* mark as top level */
- binds = cons(bind,binds);
- }
-
- liftedBinds = NIL;
- binds = liftLetBinds(binds,TRUE);
- module(mod).codeList = revOnto(liftedBinds, module(mod).codeList);
- liftedBinds = NIL;
-}
-
-/* --------------------------------------------------------------------------
- * Compiler control:
- * ------------------------------------------------------------------------*/
-
-Void liftControl(what)
-Int what; {
- switch (what) {
- case POSTPREL: break;
-
- case PREPREL:
- case RESET:
- liftedBinds = NIL;
- break;
- case MARK:
- mark(liftedBinds);
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Load symbols required from the Prelude
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: link.c,v $
- * $Revision: 1.60 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "Rts.h" /* to make Prelude.h palatable */
-#include "Assembler.h" /* for asmPrimOps and AsmReps */
-#include "Prelude.h" /* for fixupRTStoPreludeRefs */
-
-
-Type typeArrow; /* Function spaces */
-
-Type typeChar;
-Type typeInt;
-Type typeInteger;
-Type typeWord;
-Type typeAddr;
-Type typePrimArray;
-Type typePrimByteArray;
-Type typeRef;
-Type typePrimMutableArray;
-Type typePrimMutableByteArray;
-Type typeFloat;
-Type typeDouble;
-Type typeStable;
-Type typeThreadId;
-Type typeMVar;
-#ifdef PROVIDE_WEAK
-Type typeWeak;
-#endif
-#ifdef PROVIDE_FOREIGN
-Type typeForeign;
-#endif
-
-Type typeList;
-Type typeUnit;
-Type typeString;
-Type typeBool;
-Type typeST;
-Type typeIO;
-Type typeException;
-
-Class classEq; /* `standard' classes */
-Class classOrd;
-Class classShow;
-Class classRead;
-Class classIx;
-Class classEnum;
-Class classBounded;
-
-Class classReal; /* `numeric' classes */
-Class classIntegral;
-Class classRealFrac;
-Class classRealFloat;
-Class classFractional;
-Class classFloating;
-Class classNum;
-Class classMonad; /* Monads and monads with a zero */
-
-List stdDefaults; /* standard default values */
-
-Name nameTrue;
-Name nameFalse; /* primitive boolean constructors */
-Name nameNil;
-Name nameCons; /* primitive list constructors */
-Name nameUnit; /* primitive Unit type constructor */
-
-Name nameEq;
-Name nameFromInt;
-Name nameFromDouble; /* coercion of numerics */
-Name nameFromInteger;
-Name nameReturn;
-Name nameBind; /* for translating monad comps */
-Name nameZero; /* for monads with a zero */
-
-Name nameId;
-Name nameShow;
-Name namePutStr;
-Name nameRunIO_toplevel;
-Name namePrint;
-
-Name nameOtherwise;
-Name nameUndefined; /* generic undefined value */
-Name namePmSub;
-Name namePMFail;
-Name nameEqChar;
-Name namePmInt;
-Name namePmInteger;
-Name namePmDouble;
-Name namePmLe;
-Name namePmSubtract;
-Name namePmFromInteger;
-Name nameMkIO;
-Name nameUnpackString;
-Name nameError;
-Name nameInd;
-Name nameCreateAdjThunk;
-
-Name nameAnd;
-Name nameCompAux;
-Name nameRangeSize;
-Name nameComp;
-Name nameShowField;
-Name nameApp;
-Name nameShowParen;
-Name nameReadParen;
-Name nameLex;
-Name nameReadField;
-Name nameFlip;
-
-Name namePrimSeq;
-Name namePrimCatch;
-Name namePrimRaise;
-Name namePrimTakeMVar;
-
-Name nameFromTo;
-Name nameFromThen;
-Name nameFrom;
-Name nameFromThenTo;
-Name nameNegate;
-
-Name nameAssert;
-Name nameAssertError;
-Name nameTangleMessage;
-Name nameIrrefutPatError;
-Name nameNoMethodBindingError;
-Name nameNonExhaustiveGuardsError;
-Name namePatError;
-Name nameRecSelError;
-Name nameRecConError;
-Name nameRecUpdError;
-
-/* these names are required before we've had a chance to do the right thing */
-Name nameSel;
-Name nameUnsafeUnpackCString;
-
-/* constructors used during translation and codegen */
-Name nameMkC; /* Char# -> Char */
-Name nameMkI; /* Int# -> Int */
-Name nameMkInteger; /* Integer# -> Integer */
-Name nameMkW; /* Word# -> Word */
-Name nameMkA; /* Addr# -> Addr */
-Name nameMkF; /* Float# -> Float */
-Name nameMkD; /* Double# -> Double */
-Name nameMkPrimArray;
-Name nameMkPrimByteArray;
-Name nameMkRef;
-Name nameMkPrimMutableArray;
-Name nameMkPrimMutableByteArray;
-Name nameMkStable; /* StablePtr# a -> StablePtr a */
-Name nameMkThreadId; /* ThreadId# -> ThreadId */
-Name nameMkPrimMVar; /* MVar# a -> MVar a */
-#ifdef PROVIDE_WEAK
-Name nameMkWeak; /* Weak# a -> Weak a */
-#endif
-#ifdef PROVIDE_FOREIGN
-Name nameMkForeign; /* ForeignObj# -> ForeignObj */
-#endif
-
-
-
-Name nameMinBnd;
-Name nameMaxBnd;
-Name nameCompare;
-Name nameShowsPrec;
-Name nameIndex;
-Name nameReadsPrec;
-Name nameRange;
-Name nameEQ;
-Name nameInRange;
-Name nameGt;
-Name nameLe;
-Name namePlus;
-Name nameMult;
-Name nameMFail;
-Type typeOrdering;
-Module modulePrelPrim;
-Module modulePrelude;
-Name nameMap;
-Name nameMinus;
-
-/* --------------------------------------------------------------------------
- * Frequently used type skeletons:
- * ------------------------------------------------------------------------*/
-
-Type arrow; /* mkOffset(0) -> mkOffset(1) */
-Type boundPair; /* (mkOffset(0),mkOffset(0)) */
-Type listof; /* [ mkOffset(0) ] */
-Type typeVarToVar; /* mkOffset(0) -> mkOffset(0) */
-
-Cell predNum; /* Num (mkOffset(0)) */
-Cell predFractional; /* Fractional (mkOffset(0)) */
-Cell predIntegral; /* Integral (mkOffset(0)) */
-Kind starToStar; /* Type -> Type */
-Cell predMonad; /* Monad (mkOffset(0)) */
-Type typeProgIO; /* IO a */
-
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-static Tycon linkTycon ( String s );
-static Tycon linkClass ( String s );
-static Name linkName ( String s );
-static Name predefinePrim ( String s );
-
-
-static Tycon linkTycon( String s )
-{
- Tycon tc = findTycon(findText(s));
- if (nonNull(tc)) return tc;
- if (combined) {
- tc = findTyconInAnyModule(findText(s));
- if (nonNull(tc)) return tc;
- }
-FPrintf(stderr, "frambozenvla! unknown tycon %s\n", s );
-return NIL;
- ERRMSG(0) "Prelude does not define standard type \"%s\"", s
- EEND;
-}
-
-static Class linkClass( String s )
-{
- Class cc = findClass(findText(s));
- if (nonNull(cc)) return cc;
- if (combined) {
- cc = findClassInAnyModule(findText(s));
- if (nonNull(cc)) return cc;
- }
-FPrintf(stderr, "frambozenvla! unknown class %s\n", s );
-return NIL;
- ERRMSG(0) "Prelude does not define standard class \"%s\"", s
- EEND;
-}
-
-static Name linkName( String s )
-{
- Name n = findName(findText(s));
- if (nonNull(n)) return n;
- if (combined) {
- n = findNameInAnyModule(findText(s));
- if (nonNull(n)) return n;
- }
-FPrintf(stderr, "frambozenvla! unknown name %s\n", s );
-return NIL;
- ERRMSG(0) "Prelude does not define standard name \"%s\"", s
- EEND;
-}
-
-static Name predefinePrim ( String s )
-{
- 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;
-}
-
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-/* In standalone mode, linkPreludeTC, linkPreludeCM and linkPrimNames
- are called, in that order, during static analysis of Prelude.hs.
- In combined mode such an analysis does not happen. Instead these
- calls will be made as a result of a call link(POSTPREL).
-
- linkPreludeTC, linkPreludeCM and linkPreludeNames are needed in both
- standalone and combined modes.
-*/
-
-
-Void linkPreludeTC(void) { /* Hook to tycons and classes in */
- static Bool initialised = FALSE; /* prelude when first loaded */
- if (!initialised) {
- Int i;
- initialised = TRUE;
- if (combined) {
- setCurrModule(modulePrelude);
- } else {
- setCurrModule(modulePrelPrim);
- }
-
- typeChar = linkTycon("Char");
- typeInt = linkTycon("Int");
- typeInteger = linkTycon("Integer");
- typeWord = linkTycon("Word");
- typeAddr = linkTycon("Addr");
- typePrimArray = linkTycon("PrimArray");
- typePrimByteArray = linkTycon("PrimByteArray");
- typeRef = linkTycon("STRef");
- typePrimMutableArray = linkTycon("PrimMutableArray");
- typePrimMutableByteArray = linkTycon("PrimMutableByteArray");
- typeFloat = linkTycon("Float");
- typeDouble = linkTycon("Double");
- typeStable = linkTycon("StablePtr");
-# ifdef PROVIDE_WEAK
- typeWeak = linkTycon("Weak");
-# endif
-# ifdef PROVIDE_FOREIGN
- typeForeign = linkTycon("ForeignObj");
-# endif
- typeThreadId = linkTycon("ThreadId");
- typeMVar = linkTycon("MVar");
- typeBool = linkTycon("Bool");
- typeST = linkTycon("ST");
- typeIO = linkTycon("IO");
- typeException = linkTycon("Exception");
- typeString = linkTycon("String");
- typeOrdering = linkTycon("Ordering");
-
- classEq = linkClass("Eq");
- classOrd = linkClass("Ord");
- classIx = linkClass("Ix");
- classEnum = linkClass("Enum");
- classShow = linkClass("Show");
- classRead = linkClass("Read");
- classBounded = linkClass("Bounded");
- classReal = linkClass("Real");
- classIntegral = linkClass("Integral");
- classRealFrac = linkClass("RealFrac");
- classRealFloat = linkClass("RealFloat");
- classFractional = linkClass("Fractional");
- classFloating = linkClass("Floating");
- classNum = linkClass("Num");
- classMonad = linkClass("Monad");
-
- stdDefaults = NIL;
- stdDefaults = cons(typeDouble,stdDefaults);
- stdDefaults = cons(typeInteger,stdDefaults);
-
- predNum = ap(classNum,aVar);
- predFractional = ap(classFractional,aVar);
- predIntegral = ap(classIntegral,aVar);
- predMonad = ap(classMonad,aVar);
- typeProgIO = ap(typeIO,aVar);
-
- nameMkC = addPrimCfunREP(findText("C#"),1,0,CHAR_REP);
- nameMkI = addPrimCfunREP(findText("I#"),1,0,INT_REP);
- nameMkW = addPrimCfunREP(findText("W#"),1,0,WORD_REP);
- nameMkA = addPrimCfunREP(findText("A#"),1,0,ADDR_REP);
- nameMkF = addPrimCfunREP(findText("F#"),1,0,FLOAT_REP);
- nameMkD = addPrimCfunREP(findText("D#"),1,0,DOUBLE_REP);
- nameMkStable = addPrimCfunREP(findText("Stable#"),1,0,STABLE_REP);
- nameMkThreadId = addPrimCfunREP(findText("ThreadId#"),1,0,THREADID_REP);
-
-# ifdef PROVIDE_FOREIGN
- nameMkForeign = addPrimCfunREP(findText("Foreign#"),1,0,0);
-# endif
-# ifdef PROVIDE_WEAK
- nameMkWeak = addPrimCfunREP(findText("Weak#"),1,0,0);
-# endif
- nameMkPrimArray = addPrimCfunREP(findText("PrimArray#"),1,0,0);
- nameMkPrimByteArray = addPrimCfunREP(findText("PrimByteArray#"),1,0,0);
- nameMkRef = addPrimCfunREP(findText("STRef#"),1,0,0);
- nameMkPrimMutableArray = addPrimCfunREP(findText("PrimMutableArray#"),1,0,0);
- nameMkPrimMutableByteArray = addPrimCfunREP(findText("PrimMutableByteArray#"),1,0,0);
- nameMkPrimMVar = addPrimCfunREP(findText("MVar#"),1,0,0);
- nameMkInteger = addPrimCfunREP(findText("Integer#"),1,0,0);
-
- if (!combined) {
- name(namePrimSeq).type = primType(MONAD_Id, "ab", "b");
- name(namePrimCatch).type = primType(MONAD_Id, "aH", "a");
- name(namePrimRaise).type = primType(MONAD_Id, "E", "a");
-
- /* This is a lie. For a more accurate type of primTakeMVar
- see ghc/interpreter/lib/Prelude.hs.
- */
- name(namePrimTakeMVar).type = primType(MONAD_Id, "rbc", "d");
- }
-
- if (!combined) {
- for (i=2; i<=NUM_DTUPLES; i++) {/* Add derived instances of tuples */
- addTupInst(classEq,i);
- addTupInst(classOrd,i);
- addTupInst(classIx,i);
- addTupInst(classShow,i);
- addTupInst(classRead,i);
- addTupInst(classBounded,i);
- }
- }
- }
-}
-
-Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */
- static Bool initialised = FALSE; /* prelude when first loaded */
- if (!initialised) {
- Int i;
- initialised = TRUE;
-
- if (combined) {
- setCurrModule(modulePrelude);
- } else {
- setCurrModule(modulePrelPrim);
- }
-
- /* constructors */
- nameFalse = linkName("False");
- nameTrue = linkName("True");
-
- /* members */
- nameEq = linkName("==");
- nameFromInt = linkName("fromInt");
- nameFromInteger = linkName("fromInteger");
- nameReturn = linkName("return");
- nameBind = linkName(">>=");
- nameMFail = linkName("fail");
- nameLe = linkName("<=");
- nameGt = linkName(">");
- nameShowsPrec = linkName("showsPrec");
- nameReadsPrec = linkName("readsPrec");
- nameEQ = linkName("EQ");
- nameCompare = linkName("compare");
- nameMinBnd = linkName("minBound");
- nameMaxBnd = linkName("maxBound");
- nameRange = linkName("range");
- nameIndex = linkName("index");
- namePlus = linkName("+");
- nameMult = linkName("*");
- nameRangeSize = linkName("rangeSize");
- nameInRange = linkName("inRange");
- nameMinus = linkName("-");
- /* These come before calls to implementPrim */
- if (!combined) {
- for(i=0; i<NUM_TUPLES; ++i) {
- if (i != 1) implementTuple(i);
- }
- }
- }
-}
-
-Void linkPrimNames ( void ) { /* Hook to names defined in Prelude */
- static Bool initialised = FALSE;
-
- if (!initialised) {
- initialised = TRUE;
-
- if (combined) {
- setCurrModule(modulePrelude);
- } else {
- setCurrModule(modulePrelPrim);
- }
-
- /* primops */
- nameMkIO = linkName("hugsprimMkIO");
-
- if (!combined) {
- Int i;
- for (i=0; asmPrimOps[i].name; ++i) {
- Text t = findText(asmPrimOps[i].name);
- Name n = findName(t);
- if (isNull(n)) {
- n = newName(t,NIL);
- name(n).line = 0;
- name(n).defn = NIL;
- name(n).type = primType(asmPrimOps[i].monad,
- asmPrimOps[i].args,
- asmPrimOps[i].results);
- name(n).arity = strlen(asmPrimOps[i].args);
- name(n).primop = &(asmPrimOps[i]);
- implementPrim(n);
- } else {
- ERRMSG(0) "Link Error in Prelude, surplus definition of \"%s\"",
- asmPrimOps[i].name
- EEND;
- // Name already defined!
- }
- }
- }
-
- /* static(tidyInfix) */
- nameNegate = linkName("negate");
- /* user interface */
- nameRunIO_toplevel = linkName("hugsprimRunIO_toplevel");
- nameShow = linkName("show");
- namePutStr = linkName("putStr");
- namePrint = linkName("print");
- /* desugar */
- nameOtherwise = linkName("otherwise");
- nameUndefined = linkName("undefined");
- /* pmc */
- namePmSub = linkName("hugsprimPmSub");
- /* translator */
- nameEqChar = linkName("hugsprimEqChar");
- nameCreateAdjThunk = linkName("hugsprimCreateAdjThunk");
- namePmInt = linkName("hugsprimPmInt");
- namePmInteger = linkName("hugsprimPmInteger");
- namePmDouble = linkName("hugsprimPmDouble");
-
- nameFromDouble = linkName("fromDouble");
- namePmFromInteger = linkName("hugsprimPmFromInteger");
-
- namePmSubtract = linkName("hugsprimPmSubtract");
- namePmLe = linkName("hugsprimPmLe");
-
- if (!combined) {
- implementCfun ( nameCons, NIL );
- implementCfun ( nameNil, NIL );
- implementCfun ( nameUnit, NIL );
- }
- }
-}
-
-
-/* --------------------------------------------------------------------------
- *
- * ------------------------------------------------------------------------*/
-
-/* ToDo: fix pFun (or eliminate its use) */
-#define pFun(n,s) n = predefinePrim(s)
-
-Void linkControl(what)
-Int what; {
- Int i;
- switch (what) {
- //case EXIT : fooble();break;
- case RESET :
- case MARK :
- break;
-
- case POSTPREL: {
- Name nm;
- Module modulePrelBase = findModule(findText("PrelBase"));
- assert(nonNull(modulePrelBase));
- /* fprintf(stderr, "linkControl(POSTPREL)\n"); */
- setCurrModule(modulePrelude);
- linkPreludeTC();
- linkPreludeCM();
- linkPrimNames();
- fixupRTStoPreludeRefs ( lookupObjName );
-
- nameUnpackString = linkName("hugsprimUnpackString");
- namePMFail = linkName("hugsprimPmFail");
-assert(nonNull(namePMFail));
-#define xyzzy(aaa,bbb) aaa = linkName(bbb)
-
-
- /* pmc */
- pFun(nameSel, "_SEL");
-
- /* strict constructors */
- xyzzy(nameFlip, "flip" );
-
- /* parser */
- xyzzy(nameFromTo, "enumFromTo");
- xyzzy(nameFromThenTo, "enumFromThenTo");
- xyzzy(nameFrom, "enumFrom");
- xyzzy(nameFromThen, "enumFromThen");
-
- /* deriving */
- xyzzy(nameApp, "++");
- xyzzy(nameReadField, "hugsprimReadField");
- xyzzy(nameReadParen, "readParen");
- xyzzy(nameShowField, "hugsprimShowField");
- xyzzy(nameShowParen, "showParen");
- xyzzy(nameLex, "lex");
- xyzzy(nameComp, ".");
- xyzzy(nameAnd, "&&");
- xyzzy(nameCompAux, "hugsprimCompAux");
- xyzzy(nameMap, "map");
-
- /* implementTagToCon */
- xyzzy(nameError, "hugsprimError");
-
-
- typeStable = linkTycon("Stable");
- typeRef = linkTycon("IORef");
- // {Prim,PrimByte,PrimMutable,PrimMutableByte}Array ?
-
- ifLinkConstrItbl ( nameFalse );
- ifLinkConstrItbl ( nameTrue );
- ifLinkConstrItbl ( nameNil );
- ifLinkConstrItbl ( nameCons );
-
- /* PrelErr.hi doesn't give a type for error, alas.
- So error never appears in any symbol table.
- So we fake it by copying the table entry for
- hugsprimError -- which is just a call to error.
- Although we put it on the Prelude export list, we
- have to claim internally that it lives in PrelErr,
- so that the correct symbol (PrelErr_error_closure)
- is referred to.
- Big Big Sigh.
- */
- nm = newName ( findText("error"), NIL );
- name(nm) = name(nameError);
- name(nm).mod = findModule(findText("PrelErr"));
- name(nm).text = findText("error");
- setCurrModule(modulePrelude);
- module(modulePrelude).exports
- = cons ( nm, module(modulePrelude).exports );
-
- /* The GHC prelude doesn't seem to export Addr. Add it to the
- export list for the sake of compatibility with standalone mode.
- */
- module(modulePrelude).exports
- = cons ( pair(typeAddr,DOTDOT),
- module(modulePrelude).exports );
- addTycon(typeAddr);
-
- /* Make nameListMonad be the builder fn for instance Monad [].
- Standalone hugs does this with a disgusting hack in
- checkInstDefn() in static.c. We have a slightly different
- disgusting hack for the combined case.
- */
- {
- Class cm; /* :: Class */
- List is; /* :: [Inst] */
- cm = findClassInAnyModule(findText("Monad"));
- assert(nonNull(cm));
- is = cclass(cm).instances;
- assert(nonNull(is));
- while (nonNull(is) && snd(inst(hd(is)).head) != typeList)
- is = tl(is);
- assert(nonNull(is));
- nameListMonad = inst(hd(is)).builder;
- assert(nonNull(nameListMonad));
- }
-
- break;
- }
- case PREPREL :
-
- if (combined) {
- Module modulePrelBase;
-
- modulePrelude = findFakeModule(textPrelude);
-
- nameMkC = addWiredInBoxingTycon("PrelBase", "Char", "C#",
- CHAR_REP, STAR );
- nameMkI = addWiredInBoxingTycon("PrelBase", "Int", "I#",
- INT_REP, STAR );
- nameMkW = addWiredInBoxingTycon("PrelAddr", "Word", "W#",
- WORD_REP, STAR );
- nameMkA = addWiredInBoxingTycon("PrelAddr", "Addr", "A#",
- ADDR_REP, STAR );
- nameMkF = addWiredInBoxingTycon("PrelFloat","Float", "F#",
- FLOAT_REP, STAR );
- nameMkD = addWiredInBoxingTycon("PrelFloat","Double","D#",
- DOUBLE_REP, STAR );
- nameMkInteger
- = addWiredInBoxingTycon("PrelNum","Integer","Integer#",
- 0 ,STAR );
- nameMkPrimByteArray
- = addWiredInBoxingTycon("PrelGHC","ByteArray",
- "PrimByteArray#",0 ,STAR );
-
- for (i=0; i<NUM_TUPLES; ++i) {
- if (i != 1) addTupleTycon(i);
- }
- addWiredInEnumTycon("PrelBase","Bool",
- doubleton(findText("False"),
- findText("True")));
-
- //nameMkThreadId
- // = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
- // ,1,0,THREADID_REP);
-
- setCurrModule(modulePrelude);
-
- typeArrow = addPrimTycon(findText("(->)"),
- pair(STAR,pair(STAR,STAR)),
- 2,DATATYPE,NIL);
-
- /* desugaring */
- pFun(nameInd, "_indirect");
- name(nameInd).number = DFUNNAME;
-
- /* newtype and USE_NEWTYPE_FOR_DICTS */
- /* make a name entry for PrelBase.id _before_ loading Prelude
- since ifSetClassDefaultsAndDCon() may need to refer to
- nameId.
- */
- modulePrelBase = findModule(findText("PrelBase"));
- module(modulePrelBase).objectExtraNames
- = singleton(findText("libHSstd_cbits"));
-
- setCurrModule(modulePrelBase);
- pFun(nameId, "id");
- setCurrModule(modulePrelude);
-
- } else {
- fixupRTStoPreludeRefs(NULL);
-
- modulePrelPrim = findFakeModule(textPrelPrim);
- modulePrelude = findFakeModule(textPrelude);
- setCurrModule(modulePrelPrim);
-
- for (i=0; i<NUM_TUPLES; ++i) {
- if (i != 1) addTupleTycon(i);
- }
- setCurrModule(modulePrelPrim);
-
- typeArrow = addPrimTycon(findText("(->)"),
- pair(STAR,pair(STAR,STAR)),
- 2,DATATYPE,NIL);
-
- /* newtype and USE_NEWTYPE_FOR_DICTS */
- pFun(nameId, "id");
-
- /* desugaring */
- pFun(nameInd, "_indirect");
- name(nameInd).number = DFUNNAME;
-
- /* pmc */
- pFun(nameSel, "_SEL");
-
- /* strict constructors */
- pFun(nameFlip, "flip" );
-
- /* parser */
- pFun(nameFromTo, "enumFromTo");
- pFun(nameFromThenTo, "enumFromThenTo");
- pFun(nameFrom, "enumFrom");
- pFun(nameFromThen, "enumFromThen");
-
- /* deriving */
- pFun(nameApp, "++");
- pFun(nameReadField, "hugsprimReadField");
- pFun(nameReadParen, "readParen");
- pFun(nameShowField, "hugsprimShowField");
- pFun(nameShowParen, "showParen");
- pFun(nameLex, "lex");
- pFun(nameComp, ".");
- pFun(nameAnd, "&&");
- pFun(nameCompAux, "hugsprimCompAux");
- pFun(nameMap, "map");
-
- /* implementTagToCon */
- pFun(namePMFail, "hugsprimPmFail");
- pFun(nameError, "error");
- pFun(nameUnpackString, "hugsprimUnpackString");
-
- /* assertion and exception issues */
- pFun(nameAssert, "assert");
- pFun(nameAssertError, "assertError");
- pFun(nameTangleMessage, "tangleMessager");
- pFun(nameIrrefutPatError,
- "irrefutPatError");
- pFun(nameNoMethodBindingError,
- "noMethodBindingError");
- pFun(nameNonExhaustiveGuardsError,
- "nonExhaustiveGuardsError");
- pFun(namePatError, "patError");
- pFun(nameRecSelError, "recSelError");
- pFun(nameRecConError, "recConError");
- pFun(nameRecUpdError, "recUpdError");
-
- /* hooks for handwritten bytecode */
- pFun(namePrimSeq, "primSeq");
- pFun(namePrimCatch, "primCatch");
- pFun(namePrimRaise, "primRaise");
- pFun(namePrimTakeMVar, "primTakeMVar");
- {
- Name n = namePrimSeq;
- name(n).line = 0;
- name(n).arity = 1;
- name(n).type = NIL;
- name(n).closure = mkCPtr ( asm_BCO_seq() );
- addToCodeList ( modulePrelPrim, n );
- }
- {
- Name n = namePrimCatch;
- name(n).line = 0;
- name(n).arity = 2;
- name(n).type = NIL;
- name(n).closure = mkCPtr ( asm_BCO_catch() );
- addToCodeList ( modulePrelPrim, n );
- }
- {
- Name n = namePrimRaise;
- name(n).line = 0;
- name(n).arity = 1;
- name(n).type = NIL;
- name(n).closure = mkCPtr ( asm_BCO_raise() );
- addToCodeList ( modulePrelPrim, n );
- }
- {
- Name n = namePrimTakeMVar;
- name(n).line = 0;
- name(n).arity = 2;
- name(n).type = NIL;
- name(n).closure = mkCPtr ( asm_BCO_takeMVar() );
- addToCodeList ( modulePrelPrim, n );
- }
- }
- break;
- }
-}
-#undef pFun
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Machine dependent code
- * RISCOS specific code provided by Bryan Scatergood, JBS
- * Macintosh specific code provided by Hans Aberg (haberg@matematik.su.se)
- * HaskellScript code and recursive directory search provided by
- * Daan Leijen (leijen@fwi.uva.nl)
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: machdep.c,v $
- * $Revision: 1.32 $
- * $Date: 2000/05/26 10:14:33 $
- * ------------------------------------------------------------------------*/
-
-#ifdef HAVE_SIGNAL_H
-# include <signal.h>
-#endif
-#ifdef HAVE_SYS_TYPES_H
-# include <sys/types.h>
-#else
-# ifdef HAVE_TYPES_H
-# include <types.h>
-# endif
-#endif
-
-#if 0
-#if HAVE_SYS_PARAM_H
-# include <sys/param.h>
-#endif
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-# include <sys/stat.h>
-#else
-# ifdef HAVE_STAT_H
-# include <stat.h>
-# endif
-#endif
-#ifdef HAVE_TIME_H
-# include <time.h>
-#endif
-
-/* Windows/DOS include files */
-#ifdef HAVE_DOS_H
-# include <dos.h>
-#endif
-#if defined HAVE_CONIO_H
-# include <conio.h>
-#endif
-#ifdef HAVE_IO_H
-# include <io.h>
-#endif
-#ifdef HAVE_STD_H
-# include <std.h>
-#endif
-#ifdef HAVE_WINDOWS_H
-# include <windows.h>
-#endif
-
-#if DOS
-#include <mem.h>
-extern unsigned _stklen = 8000; /* Allocate an 8k stack segment */
-#endif
-
-#if RISCOS
-#include "swis.h"
-#include "os.h"
-#endif
-
-/* Macintosh include files */
-#ifdef HAVE_CONSOLE_H
-# include <console.h>
-#endif
-#ifdef HAVE_PASCAL_H
-# include <pascal.h>
-#endif
-#ifdef HAVE_FILES_H
-# include <Files.h>
-#endif
-#ifdef HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-#ifdef HAVE_ERRNO_H
-# include <errno.h>
-#endif
-#ifdef HAVE_STDLIB_H
-# include <stdlib.h>
-#endif
-#ifdef HAVE_UNIX_H
-#include <unix.h>
-#endif
-#if SYMANTEC_C
-int allow_break_count = 0;
-#endif
-
-/* --------------------------------------------------------------------------
- * Find information about a file:
- * ------------------------------------------------------------------------*/
-
-#include "machdep_time.h"
-
-static Bool local readable ( String );
-static Void local getFileInfo ( String, Time *, Long * );
-
-static Void local getFileInfo(f,tm,sz) /* find time stamp and size of file*/
-String f;
-Time *tm;
-Long *sz; {
-#if defined HAVE_SYS_STAT_H || defined HAVE_STAT_H || defined HAVE_UNIX_H
- struct stat scbuf;
- if (!stat(f,&scbuf)) {
- if (tm) *tm = scbuf.st_mtime;
- *sz = (Long)(scbuf.st_size);
- } else {
- if (tm) *tm = 0;
- *sz = 0;
- }
-#else /* normally just use stat() */
- os_regset r; /* RISCOS PRM p.850 and p.837 */
- r.r[0] = 17; /* Read catalogue, no path */
- r.r[1] = (int)s;
- os_swi(OS_File, &r);
- if(r.r[0] == 1 && (r.r[2] & 0xFFF00000) == 0xFFF00000) {
- if (tm) tm->hi = r.r[2] & 0xFF; /* Load address (high byte) */
- if (tm) tm->lo = r.r[3]; /* Execution address (low 4 bytes) */
- } else { /* Not found, or not time-stamped */
- if (tm) tm->hi = tm->lo = 0;
- }
- *sz = (Long)(r.r[0] == 1 ? r.r[4] : 0);
-#endif
-}
-
-Void getFileSize ( String f, Long* sz )
-{
- getFileInfo ( f, NULL, sz );
-}
-
-#if defined HAVE_GETFINFO /* Mac971031 */
-/* --------------------------------------------------------------------------
- * Define a MacOS version of access():
- * If the file is not accessible, -1 is returned and errno is set to
- * the reason for the failure.
- * If the file is accessible and the dummy is 0 (existence), 2 (write),
- * or 4 (read), the return is 0.
- * If the file is accessible, and the dummy is 1 (executable), then if
- * the file is a program (of type 'APPL'), the return is 0, otherwise -1.
- * Warnings: Use with caution. UNIX access do no translate to Macs.
- * Check of write access is not implemented (same as read).
- * ------------------------------------------------------------------------*/
-
-int access(char *fileName, int dummy) {
- FInfo fi;
- short rc;
-
- errno = getfinfo(fileName, 0, &fi);
- if (errno != 0) return -1; /* Check file accessible. */
-
- /* Cases dummy = existence, read, write. */
- if (dummy == 0 || dummy & 0x6) return 0;
-
- /* Case dummy = executable. */
- if (dummy == 1) {
- if (fi.fdType == 'APPL') return 0;
- errno = fi.fdType;
- return -1;
- }
-
- return 0;
-}
-#endif
-
-static Bool local readable(f) /* is f a regular, readable file */
-String f; {
-#if DJGPP2 || defined HAVE_GETFINFO /* stat returns bogus mode bits on djgpp2 */
- return (0 == access(f,4));
-#elif defined HAVE_SYS_STAT_H || defined HAVE_STAT_H
- struct stat scbuf;
- /* fprintf(stderr, "readable: %s\n", f ); */
- return ( !stat(f,&scbuf)
- && (scbuf.st_mode & S_IREAD) /* readable */
- && (scbuf.st_mode & S_IFREG) /* regular file */
- );
-#elif defined HAVE_OS_SWI /* RISCOS specific */
- os_regset r; /* RISCOS PRM p.850 -- JBS */
- assert(dummy == 0);
- r.r[0] = 17; /* Read catalogue, no path */
- r.r[1] = (int)f;
- os_swi(OS_File, &r);
- return r.r[0] != 1; /* Does this check it's a regular file? ADR */
-#endif
-}
-
-
-/* --------------------------------------------------------------------------
- * Search for script files on the HUGS path:
- * ------------------------------------------------------------------------*/
-
-static String local hugsdir ( Void );
-#if HSCRIPT
-static String local hscriptDir ( Void );
-#endif
-static int local pathCmp ( String, String );
-static String local normPath ( String );
-static Void local searchChr ( Int );
-static Void local searchStr ( String );
-static Bool local tryEndings ( String );
-
-#if (DOS_FILENAMES || __CYGWIN32__)
-# define SLASH '/'
-# define SLASH_STR "/"
-# define isSLASH(c) ((c)=='\\' || (c)=='/')
-# define PATHSEP ';'
-# define PATHSEP_STR ";"
-# define DLL_ENDING ".u_o"
-#elif MAC_FILENAMES
-# define SLASH ':'
-# define isSLASH(c) ((c)==SLASH)
-# define PATHSEP ';'
-# define PATHSEP_STR ";"
-/* Mac PEF (Preferred Executable Format) file */
-# define DLL_ENDING ".pef"
-#else
-# define SLASH '/'
-# define SLASH_STR "/"
-# define isSLASH(c) ((c)==SLASH)
-# define PATHSEP ':'
-# define PATHSEP_STR ":"
-# define DLL_ENDING ".u_o"
-#endif
-
-static String local hugsdir() { /* directory containing lib/Prelude.hs */
-#if HSCRIPT
- /* In HaskellScript (Win32 only), we lookup InstallDir in the registry. */
- static char dir[FILENAME_MAX+1] = "";
- if (dir[0] == '\0') { /* not initialised yet */
- String s = readRegString(HKEY_LOCAL_MACHINE,HugsRoot,"InstallDir",
- HUGSDIR);
- if (s) {
- strcpy(dir,s);
- }
- }
- return dir;
-#elif HAVE_GETMODULEFILENAME && !DOS && !__CYGWIN32__
- /* On Windows, we can find the binary we're running and it's
- * conventional to put the libraries in the same place.
- */
- static char dir[FILENAME_MAX+1] = "";
- if (dir[0] == '\0') { /* not initialised yet */
- String slash = 0;
- GetModuleFileName((HMODULE)0,dir,FILENAME_MAX+1);
- if (dir[0] == '\0') { /* GetModuleFileName must have failed */
- return HUGSDIR;
- }
- slash = strrchr(dir,SLASH);
- if (slash) { /* truncate after directory name */
- *slash = '\0';
- }
- }
- return dir;
-#else
- /* On Unix systems, we can't find the binary we're running and
- * the libraries may not be installed near the binary anyway.
- * This forces us to use a hardwired path which is set at
- * configuration time (--datadir=...).
- */
- return HUGSDIR;
-#endif
-}
-
-#if HSCRIPT
-static String local hscriptDir() { /* Directory containing hscript.dll */
- static char dir[FILENAME_MAX+1] = "";
- if (dir[0] == '\0') { /* not initialised yet */
- String s = readRegString(HKEY_LOCAL_MACHINE,HScriptRoot,"InstallDir","");
- if (s) {
- strcpy(dir,s);
- }
- }
- return dir;
-}
-#endif
-
-
-static String local normPath(s) /* Try, as much as possible, to normalize */
-String s; { /* a pathname in some appropriate manner. */
-#if PATH_CANONICALIZATION
- String path = RealPath(s);
-#if CASE_INSENSITIVE_FILENAMES
- strlwr(path); /* and convert to lowercase */
-#endif
- return path;
-#else /* ! PATH_CANONICALIZATION */
- return s;
-#endif /* ! PATH_CANONICALIZATION */
-}
-
-#if HSCRIPT
-static String endings[] = { "", ".u_hi", ".hs", ".lhs", ".hsx", ".hash", 0 };
-#else
-static String endings[] = { "", ".u_hi", ".hs", ".lhs", 0 };
-#endif
-static char searchBuf[FILENAME_MAX+1];
-static Int searchPos;
-
-#define searchReset(n) searchBuf[searchPos=(n)]='\0'
-
-static Void local searchChr(c) /* Add single character to search buffer */
-Int c; {
- if (searchPos<FILENAME_MAX) {
- searchBuf[searchPos++] = (char)c;
- searchBuf[searchPos] = '\0';
- }
-}
-
-static Void local searchStr(s) /* Add string to search buffer */
-String s; {
- while (*s && searchPos<FILENAME_MAX)
- searchBuf[searchPos++] = *s++;
- searchBuf[searchPos] = '\0';
-}
-
-static Bool local tryEndings(s) /* Try each of the listed endings */
-String s; {
- Int i = 0;
- searchStr(s);
- for (; endings[i]; ++i) {
- Int save = searchPos;
- searchStr(endings[i]);
- if (readable(searchBuf))
- return TRUE;
- searchReset(save);
- }
- return FALSE;
-}
-
-
-
-#if SEARCH_DIR
-
-/* scandir, June 98 Daan Leijen
- searches the base directory and its direct subdirectories for a file
-
- input: searchbuf contains SLASH terminated base directory
- argument s contains the (base) filename
- output: TRUE: searchBuf contains the full filename
- FALSE: searchBuf is garbage, file not found
-*/
-
-
-#ifdef HAVE_WINDOWS_H
-
-static Bool scanSubDirs(s)
-String s;
-{
- struct _finddata_t findInfo;
- long handle;
- int save;
-
- save = searchPos;
- /* is it in the current directory ? */
- if (tryEndings(s)) return TRUE;
-
- searchReset(save);
- searchStr("*");
-
- /* initiate the search */
- handle = _findfirst( searchBuf, &findInfo );
- if (handle==-1) { errno = 0; return FALSE; }
-
- /* search all subdirectories */
- do {
- /* if we have a valid sub directory */
- if (((findInfo.attrib & _A_SUBDIR) == _A_SUBDIR) &&
- (findInfo.name[0] != '.')) {
- searchReset(save);
- searchStr(findInfo.name);
- searchChr(SLASH);
- if (tryEndings(s)) {
- return TRUE;
- }
- }
- } while (_findnext( handle, &findInfo ) == 0);
-
- _findclose( handle );
- return FALSE;
-}
-
-#elif defined(HAVE_FTW_H)
-
-#include <ftw.h>
-
-static char baseFile[FILENAME_MAX+1];
-static char basePath[FILENAME_MAX+1];
-static int basePathLen;
-
-static int scanitem( const char* path,
- const struct stat* statinfo,
- int info )
-{
- if (info == FTW_D) { /* is it a directory */
- searchReset(0);
- searchStr(path);
- searchChr(SLASH);
- if (tryEndings(baseFile)) {
- return 1;
- }
- }
- return 0;
-}
-
-static Bool scanSubDirs(s)
-String s;
-{
- int r;
- strcpy(baseFile,s);
- strcpy(basePath,searchBuf);
- basePathLen = strlen(basePath);
-
- /* is it in the current directory ? */
- if (tryEndings(s)) return TRUE;
-
- /* otherwise scan the subdirectories */
- r = ftw( basePath, scanitem, 2 );
- errno = 0;
- return (r > 0);
-}
-
-#endif /* HAVE_WINDOWS_H || HAVE_FTW_H */
-#endif /* SEARCH_DIR */
-
-String findPathname(along,nm) /* Look for a file along specified path */
-String along; /* Return NULL if file does not exist */
-String nm; {
- /* AC, 1/21/99: modified to search hugsPath first, then projectPath */
- String s = findMPathname(along,nm,hugsPath);
- return s ? s : normPath(searchBuf);
-}
-
-/* AC, 1/21/99: modified to pass in path to search explicitly */
-String findMPathname(along,nm,path)/* Look for a file along specified path */
-String along; /* If nonzero, a path prefix from along is */
-String nm; /* used as the first prefix in the search. */
-String path; {
- String pathpt = path;
-
- searchReset(0);
- if (along) { /* Was a path for an existing file given? */
- Int last = (-1);
- Int i = 0;
- for (; along[i]; i++) {
- searchChr(along[i]);
- if (isSLASH(along[i]))
- last = i;
- }
- searchReset(last+1);
- }
- if (tryEndings(nm))
- return normPath(searchBuf);
-
- if (pathpt && *pathpt) { /* Otherwise, we look along the HUGSPATH */
- Bool more = TRUE;
- do {
- Bool recurse = FALSE; /* DL: shall we recurse ? */
- searchReset(0);
- if (*pathpt) {
- if (*pathpt!=PATHSEP) {
- /* Pre-define one MPW-style "shell-variable" */
- if (strncmp(pathpt,"{Hugs}",6)==0) {
- searchStr(hugsdir());
- pathpt += 6;
- }
-#if HSCRIPT
- /* And another - we ought to generalise this stuff */
- else if (strncmp(pathpt,"{HScript}",9)==0) {
- searchStr(hscriptDir());
- pathpt += 9;
- }
-#endif
- do {
- searchChr(*pathpt++);
- } while (*pathpt && *pathpt!=PATHSEP);
- recurse = (pathpt[-1] == SLASH);
- if (!recurse) {
- searchChr(SLASH);
- }
- }
- if (*pathpt==PATHSEP)
- pathpt++;
- else
- more = FALSE;
- } else {
- more = FALSE;
- }
-#if SEARCH_DIR
- if (recurse ? scanSubDirs(nm) : tryEndings(nm)) {
- return normPath(searchBuf);
- }
-#else
- if (tryEndings(nm)) {
- return normPath(searchBuf);
- }
-#endif
- } while (more);
- }
-
- searchReset(0); /* As a last resort, look for file in the current dir */
- return (tryEndings(nm) ? normPath(searchBuf) : 0);
-}
-
-/* --------------------------------------------------------------------------
- * New path handling stuff for the Combined System (tm)
- * ------------------------------------------------------------------------*/
-
-char installDir[N_INSTALLDIR];
-
-/* Sets installDir to $STGHUGSDIR, and ensures there is a trailing
- slash at the end.
-*/
-void setInstallDir ( String argv_0 )
-{
- int i;
- char* r = getenv("STGHUGSDIR");
- if (!r) {
- fprintf(stderr,
- "%s: installation error: environment variable STGHUGSDIR is not set.\n",
- argv_0 );
- fprintf(stderr,
- "%s: pls set it to be the directory where STGHugs98 is installed.\n\n",
- argv_0 );
- exit(2);
-
- }
-
- if (strlen(r) > N_INSTALLDIR-30 ) {
- fprintf(stderr,
- "%s: environment variable STGHUGSDIR is suspiciously long; pls remedy\n\n",
- argv_0 );
- exit(2);
- }
-
- strcpy ( installDir, r );
- i = strlen(installDir);
- if (installDir[i-1] != SLASH) installDir[i++] = SLASH;
- installDir[i] = 0;
-}
-
-
-Bool findFilesForModule (
- String modName,
- String* path,
- String* sExt,
- Bool* sAvail, Time* sTime, Long* sSize,
- Bool* oiAvail, Time* oiTime, Long* oSize, Long* iSize
- )
-{
- /* Let the module name given be M.
- For each path entry P,
- a s(rc) file will be P/M.hs or P/M.lhs
- an i(nterface) file will be P/M.hi
- an o(bject) file will be P/M.o
- If there is a s file or (both i and o files)
- use P to fill in the path names.
- Otherwise, move on to the next path entry.
- If all path entries are exhausted, return False.
-
- If in standalone, only look for (and succeed for) source modules.
- Caller free()s path. sExt is statically allocated.
- srcExt is only set if a valid source file is found.
- */
- Int nPath;
- Bool literate;
- String peStart, peEnd;
- String augdPath; /* .:hugsPath:installDir/../lib/std:installDir/lib */
- Time oTime, iTime;
- Bool oAvail, iAvail;
-
- *path = *sExt = NULL;
- *sAvail = *oiAvail = oAvail = iAvail = FALSE;
- *sSize = *oSize = *iSize = 0;
-
- augdPath = malloc( 2*(10+3+strlen(installDir))
- +strlen(hugsPath) +50/*paranoia*/);
- if (!augdPath)
- internal("moduleNameToFileNames: malloc failed(2)");
-
- augdPath[0] = 0;
-
- if (combined) {
- strcat(augdPath, installDir);
- strcat(augdPath, "..");
- strcat(augdPath, SLASH_STR);
- strcat(augdPath, "lib");
- strcat(augdPath, SLASH_STR);
- strcat(augdPath, "std");
- strcat(augdPath, PATHSEP_STR);
- }
-
- strcat(augdPath, installDir);
- strcat(augdPath, "lib");
- strcat(augdPath, PATHSEP_STR);
-
- /* these two were previously before the above `if' */
- strcat(augdPath, ".");
- strcat(augdPath, PATHSEP_STR);
-
- strcat(augdPath, hugsPath);
- strcat(augdPath, PATHSEP_STR);
-
- /* fprintf ( stderr, "augdpath = `%s'\n", augdPath ); */
-
- peEnd = augdPath-1;
- while (1) {
- /* Advance peStart and peEnd very paranoically, giving up at
- the first sign of mutancy in the path string.
- */
- if (peEnd >= augdPath && !(*peEnd)) { free(augdPath); return FALSE; }
- peStart = peEnd+1;
- peEnd = peStart;
- while (*peEnd && *peEnd != PATHSEP) peEnd++;
-
- /* Now peStart .. peEnd-1 bracket the next path element. */
- nPath = peEnd-peStart;
- if (nPath + strlen(modName) + 10 /*slush*/ > FILENAME_MAX) {
- ERRMSG(0) "Hugs path \"%s\" contains excessively long component",
- hugsPath
- EEND;
- free(augdPath);
- return FALSE;
- }
-
- strncpy(searchBuf, peStart, nPath);
- searchBuf[nPath] = 0;
- if (nPath > 0 && !isSLASH(searchBuf[nPath-1]))
- searchBuf[nPath++] = SLASH;
-
- strcpy(searchBuf+nPath, modName);
- nPath += strlen(modName);
-
- /* searchBuf now holds 'P/M'. Try out the various endings. */
- *path = *sExt = NULL;
- *sAvail = *oiAvail = oAvail = iAvail = FALSE;
- *sSize = *oSize = *iSize = 0;
-
- if (combined) {
- strcpy(searchBuf+nPath, DLL_ENDING);
- if (readable(searchBuf)) {
- oAvail = TRUE;
- getFileInfo(searchBuf, &oTime, oSize);
- }
- strcpy(searchBuf+nPath, HI_ENDING);
- if (readable(searchBuf)) {
- iAvail = TRUE;
- getFileInfo(searchBuf, &iTime, iSize);
- }
- if (oAvail && iAvail) {
- *oiAvail = TRUE;
- *oiTime = whicheverIsLater ( oTime, iTime );
- }
- }
-
- strcpy(searchBuf+nPath, ".hs");
- if (readable(searchBuf)) {
- *sAvail = TRUE;
- literate = FALSE;
- getFileInfo(searchBuf, sTime, sSize);
- *sExt = ".hs";
- } else {
- strcpy(searchBuf+nPath, ".lhs");
- if (readable(searchBuf)) {
- *sAvail = TRUE;
- literate = TRUE;
- getFileInfo(searchBuf, sTime, sSize);
- *sExt = ".lhs";
- }
- }
-
- /* Success? */
- if (*sAvail || *oiAvail) {
- nPath -= strlen(modName);
- *path = malloc(nPath+1);
- if (!(*path))
- internal("moduleNameToFileNames: malloc failed(1)");
- strncpy(*path, searchBuf, nPath);
- (*path)[nPath] = 0;
- free(augdPath);
- return TRUE;
- }
-
- }
-
-}
-
-
-/* If the primaryObjectName is (eg)
- /foo/bar/PrelSwamp.o
- and the extraFileName is (eg)
- swampy_cbits
- and DLL_ENDING is set to .o
- return
- /foo/bar/swampy_cbits.o
- and set *extraFileSize to its size, or -1 if not avail
-*/
-String getExtraObjectInfo ( String primaryObjectName,
- String extraFileName,
- Int* extraFileSize )
-{
- Time xTime;
- Long xSize;
- String xtra;
-
- Int i = strlen(primaryObjectName)-1;
- while (i >= 0 && primaryObjectName[i] != SLASH) i--;
- if (i == -1) return extraFileName;
- i++;
- xtra = malloc ( i+3+strlen(extraFileName)+strlen(DLL_ENDING) );
- if (!xtra) internal("deriveExtraObjectName: malloc failed");
- strncpy ( xtra, primaryObjectName, i );
- xtra[i] = 0;
- strcat ( xtra, extraFileName );
- strcat ( xtra, DLL_ENDING );
-
- *extraFileSize = -1;
- if (readable(xtra)) {
- getFileInfo ( xtra, &xTime, &xSize );
- *extraFileSize = xSize;
- }
- return xtra;
-}
-
-
-/* --------------------------------------------------------------------------
- * Substitute old value of path into empty entries in new path
- * eg substPath("a:b:c::d:e","x:y:z") = "a:b:c:x:y:z:d:e"
- * ------------------------------------------------------------------------*/
-
-static String local substPath ( String,String );
-
-static String local substPath(new,sub) /* substitute sub path into new path*/
-String new;
-String sub; {
- Bool substituted = FALSE; /* only allow one replacement */
- Int maxlen = strlen(sub) + strlen(new); /* safe upper bound */
- String r = (String) malloc(maxlen+1); /* result string */
- String t = r; /* pointer into r */
- String next = new; /* next uncopied char in new */
- String start = next; /* start of last path component */
- if (r == 0) {
- ERRMSG(0) "String storage space exhausted"
- EEND;
- }
- do {
- if (*next == PATHSEP || *next == '\0') {
- if (!substituted && next == start) {
- String s = sub;
- for(; *s != '\0'; ++s) {
- *t++ = *s;
- }
- substituted = TRUE;
- }
- start = next+1;
- }
- } while ((*t++ = *next++) != '\0');
- return r;
-}
-
-
-/* --------------------------------------------------------------------------
- * Garbage collection notification:
- * ------------------------------------------------------------------------*/
-
-Bool gcMessages = FALSE; /* TRUE => print GC messages */
-
-Void gcStarted() { /* Notify garbage collector start */
- if (gcMessages) {
- Printf("{{Gc");
- FlushStdout();
- }
-}
-
-Void gcScanning() { /* Notify garbage collector scans */
- if (gcMessages) {
- Putchar(':');
- FlushStdout();
- }
-}
-
-Void gcRecovered(recovered) /* Notify garbage collection done */
-Int recovered; {
- if (gcMessages) {
- Printf("%d}}",recovered);
- FlushStdout();
- }
-}
-
-Cell *CStackBase; /* Retain start of C control stack */
-
-#if RISCOS /* Stack traversal for RISCOS */
-
-/* Warning: The following code is specific to the Acorn ARM under RISCOS
- (and C4). We must explicitly walk back through the stack frames, since
- the stack is extended from the heap. (see PRM pp. 1757). gcCStack must
- not be modified, since the offset '5' assumes that only v1 is used inside
- this function. Hence we do all the real work in gcARM.
-*/
-
-#define spreg 13 /* C3 has SP=R13 */
-
-#define previousFrame(fp) ((int *)((fp)[-3]))
-#define programCounter(fp) ((int *)((*(fp)-12) & ~0xFC000003))
-#define isSubSPSP(w) (((w)&dontCare) == doCare)
-#define doCare (0xE24DD000) /* SUB r13,r13,#0 */
-#define dontCare (~0x00100FFF) /* S and # bits */
-#define immediateArg(x) ( ((x)&0xFF) << (((x)&0xF00)>>7) )
-
-static void gcARM(int *fp) {
- int si = *programCounter(fp); /* Save instruction indicates how */
- /* many registers in this frame */
- int *regs = fp - 4;
- if (si & (1<<0)) markWithoutMove(*regs--);
- if (si & (1<<1)) markWithoutMove(*regs--);
- if (si & (1<<2)) markWithoutMove(*regs--);
- if (si & (1<<3)) markWithoutMove(*regs--);
- if (si & (1<<4)) markWithoutMove(*regs--);
- if (si & (1<<5)) markWithoutMove(*regs--);
- if (si & (1<<6)) markWithoutMove(*regs--);
- if (si & (1<<7)) markWithoutMove(*regs--);
- if (si & (1<<8)) markWithoutMove(*regs--);
- if (si & (1<<9)) markWithoutMove(*regs--);
- if (previousFrame(fp)) {
- /* The non-register stack space is for the previous frame is above
- this fp, and not below the previous fp, because of the way stack
- extension works. It seems the only way of discovering its size is
- finding the SUB sp, sp, #? instruction by walking through the code
- following the entry point.
- */
- int *oldpc = programCounter(previousFrame(fp));
- int fsize = 0, i;
- for(i = 1; i < 6; ++i)
- if(isSubSPSP(oldpc[i])) fsize += immediateArg(oldpc[i]) / 4;
- for(i=1; i<=fsize; ++i)
- markWithoutMove(fp[i]);
- }
-}
-
-void gcCStack() {
- int dummy;
- int *fp = 5 + &dummy;
- while (fp) {
- gcARM(fp);
- fp = previousFrame(fp);
- }
-}
-
-#else /* Garbage collection for standard stack machines */
-
-Void gcCStack() { /* Garbage collect elements off */
- Cell stackTop = NIL; /* C stack */
- Cell *ptr = &stackTop;
-#if SIZEOF_VOID_P == 2
- if (((long)(ptr) - (long)(CStackBase))&1)
- fatal("gcCStack");
-#elif STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
- if (((long)(ptr) - (long)(CStackBase))&1)
- fatal("gcCStack");
-#else
- if (((long)(ptr) - (long)(CStackBase))&3)
- fatal("gcCStack");
-#endif
-
-#define Blargh mark(*ptr);
-#if 0
- markWithoutMove((*ptr)/sizeof(Cell)); \
- markWithoutMove(( (void*)(*ptr)-(void*)heapTopFst)/sizeof(Cell)); \
- markWithoutMove(( (void*)(*ptr)-(void*)heapTopSnd)/sizeof(Cell))
-#endif
-
-#define StackGrowsDown { while (ptr<=CStackBase) { Blargh; ptr++; }; }
-#define StackGrowsUp { while (ptr>=CStackBase) { Blargh; ptr--; }; }
-#define GuessDirection if (ptr>CStackBase) StackGrowsUp else StackGrowsDown
-
-#if STACK_DIRECTION > 0
- StackGrowsUp;
-#elif STACK_DIRECTION < 0
- StackGrowsDown;
-#else
- GuessDirection;
-#endif
-
-#if SIZEOF_VOID_P==4 && STACK_ALIGNMENT == 2 /* eg Macintosh 68000 */
- ptr = (Cell *)((long)(&stackTop) + 2);
- StackGrowsDown;
-#endif
-
-#undef StackGrowsDown
-#undef StackGrowsUp
-#undef GuessDirection
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * Interrupt handling:
- * ------------------------------------------------------------------------*/
-
-static Void installHandlers ( void ) { /* Install handlers for all fatal */
- /* signals except SIGINT and SIGBREAK*/
-#if IS_WIN32
- /* SetConsoleCtrlHandler(consoleHandler,TRUE); */
-#endif
-#if !DONT_PANIC && !DOS
-# ifdef SIGABRT
- signal(SIGABRT,panic);
-# endif
-# ifdef SIGBUS
- signal(SIGBUS,panic);
-# endif
-# ifdef SIGFPE
- signal(SIGFPE,panic);
-# endif
-# ifdef SIGHUP
- signal(SIGHUP,panic);
-# endif
-# ifdef SIGILL
- signal(SIGILL,panic);
-# endif
-# ifdef SIGQUIT
- signal(SIGQUIT,panic);
-# endif
-# ifdef SIGSEGV
- signal(SIGSEGV,panic);
-# endif
-# ifdef SIGTERM
- signal(SIGTERM,panic);
-# endif
-#endif /* !DONT_PANIC && !DOS */
-}
-
-/* --------------------------------------------------------------------------
- * Shell escapes:
- * ------------------------------------------------------------------------*/
-
-static Bool local startEdit(line,nm) /* Start editor on file name at */
-Int line; /* given line. Both name and line */
-String nm; { /* or just line may be zero */
- static char editorCmd[FILENAME_MAX+1];
-
-#if !SYMANTEC_C
- if (hugsEdit && *hugsEdit) { /* Check that editor configured */
-#else
- /* On a Mac, files have creator information, telling which program
- to launch to, so an editor named to the empty string "" is often
- desirable. */
- if (hugsEdit) { /* Check that editor configured */
-#endif
- Int n = FILENAME_MAX;
- String he = hugsEdit;
- String ec = editorCmd;
- String rd = NULL; /* Set to nonnull to redo ... */
-
- for (; n>0 && *he && *he!=' ' && *he!='%'; n--)
- *ec++ = *he++; /* Copy editor name to buffer */
- /* assuming filename ends at space */
-
- if (nm && line && n>1 && *he){ /* Name, line, and enough space */
- rd = ec; /* save, in case we don't find name*/
- while (n>0 && *he) {
- if (*he=='%') {
- if (*++he=='d' && n>10) {
- sprintf(ec,"%d",line);
- he++;
- }
- else if (*he=='s' && (size_t)n>strlen(nm)) {
- strcpy(ec,nm);
- rd = NULL;
- he++;
- }
- else if (*he=='%' && n>1) {
- strcpy(ec,"%");
- he++;
- }
- else /* Ignore % char if not followed */
- *ec = '\0'; /* by one of d, s, or %, */
- for (; *ec && n>0; n--)
- ec++;
- } /* ignore % followed by anything other than d, s, or % */
- else { /* Copy other characters across */
- *ec++ = *he++;
- n--;
- }
- }
- }
- else
- line = 0;
-
- if (rd) { /* If file name was not included */
- ec = rd;
- line = 0;
- }
-
- if (nm && line==0 && n>1) { /* Name, but no line ... */
- *ec++ = ' ';
- for (; n>0 && *nm; n--) /* ... just copy file name */
- *ec++ = *nm++;
- }
-
- *ec = '\0'; /* Add terminating null byte */
- }
- else {
- ERRMSG(0) "Hugs is not configured to use an editor"
- EEND;
- }
-
-#if HAVE_WINEXEC
- WinExec(editorCmd, SW_SHOW);
- return FALSE;
-#else
- if (shellEsc(editorCmd))
- Printf("Warning: Editor terminated abnormally\n");
- return TRUE;
-#endif
-}
-
-Int shellEsc(s) /* run a shell command (or shell) */
-String s; {
-#if HAVE_MACSYSTEM
- return macsystem(s);
-#else
-#if HAVE_BIN_SH
- if (s[0]=='\0') {
- s = fromEnv("SHELL","/bin/sh");
- }
-#endif
- return system(s);
-#endif
-}
-
-#if RISCOS /* RISCOS also needs a chdir() */
-int chdir(char *s) { /* RISCOS PRM p. 885 -- JBS */
- return os_swi2(OS_FSControl + XOS_Bit, 0, (int)s) != NULL;
-}
-#elif defined HAVE_PBHSETVOLSYNC /* Macintosh */
-int chdir(const char *s) {
- char* str;
- WDPBRec wd;
- wd.ioCompletion = 0;
- str = (char*)malloc(strlen(s) + 1);
- if (str == 0) return -1;
- strcpy(str, s);
- wd.ioNamePtr = C2PStr(str);
- wd.ioVRefNum = 0;
- wd.ioWDDirID = 0;
- errno = PBHSetVolSync(&wd);
- free(str);
- if (errno == 0) {
- return 0;
- } else {
- return -1;
- }
-}
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Things to do with the argv/argc and the env
- * ------------------------------------------------------------------------*/
-
-int nh_argc ( void )
-{
- return prog_argc;
-}
-
-int nh_argvb ( int argno, int offset )
-{
- return (int)(prog_argv[argno][offset]);
-}
-
-/* --------------------------------------------------------------------------
- * Machine dependent control:
- * ------------------------------------------------------------------------*/
-
-Void machdep(what) /* Handle machine specific */
-Int what; { /* initialisation etc.. */
- switch (what) {
- case MARK : break;
- case POSTPREL: break;
- case PREPREL : installHandlers();
- break;
- case RESET :
- case BREAK :
- case EXIT :
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-#ifndef MACHDEP_TIME_INCLUDED
-#define MACHDEP_TIME_INCLUDED
-
-#ifdef HAVE_TIME_H
-# include <time.h>
-#endif
-
-#if RISCOS
-typedef struct { unsigned hi, lo; } Time;
-#define timeChanged(now,thn) (now.hi!=thn.hi || now.lo!=thn.lo)
-#define timeSet(var,tm) var.hi = tm.hi; var.lo = tm.lo
-#error firstTimeIsLater, whicheverIsLater needs implementing
-#else
-typedef time_t Time;
-#define timeChanged(now,thn) (now!=thn)
-#define timeSet(var,tm) var = tm
-#define firstTimeIsLater(t1,t2) ((t1)>(t2))
-#define whicheverIsLater(t1,t2) (((t1)>(t2)) ? (t1) : (t2))
-#endif
-
-#endif
+++ /dev/null
-
-/* This is a hack. I totally deny writing it. If this code breaks,
- * you get to keep all the pieces. JRS, 23 feb 99.
- */
-
-#include <stdio.h>
-#include <errno.h>
-#include <assert.h>
-#include <malloc.h>
-#include <stdlib.h>
-#include <ctype.h>
-#ifndef _WIN32
-#include <sys/times.h>
-#include <sys/resource.h>
-#include <sys/stat.h>
-#include <time.h>
-#endif
-#include <unistd.h>
-
-#ifndef _WIN32
-double nh_getCPUtime ( void )
-{
- double usertime;
- struct rusage usage;
- getrusage ( RUSAGE_SELF, &usage );
- usertime = (double)usage.ru_utime.tv_sec +
- (double)usage.ru_utime.tv_usec / 1000000.0;
- return usertime;
-}
-
-double nh_getCPUprec ( void )
-{
- /* or perhaps CLOCKS_PER_SEC ? */
- return 1.0 / (double)(CLK_TCK);
-}
-#else
-double nh_getCPUtime ( void )
-{
- return 1;
-}
-
-double nh_getCPUprec ( void )
-{
- return 1;
-}
-#endif
-
-int nh_getPID ( void )
-{
-#ifndef _WIN32
- return (int) getpid();
-#else
- return (int) 0;
-#endif
-}
-
-void nh_exitwith ( int code )
-{
- exit(code);
-}
-
-int nh_system ( char* cmd )
-{
- return system ( cmd );
-}
-
-int nh_iseof ( FILE* f )
-{
- int c;
- errno = 0;
- c = fgetc ( f );
- if (c == EOF) return 1;
- ungetc ( c, f );
- return 0;
-}
-
-int nh_filesize ( FILE* f )
-{
-#ifndef _WIN32
- struct stat buf;
- errno = 0;
- fstat ( fileno(f), &buf );
- return buf.st_size;
-#else
- errno = EPERM;
- return 0;
-#endif
-}
-
-int nh_stdin ( void )
-{
- errno = 0;
- return (int)stdin;
-}
-
-int nh_stdout ( void )
-{
- errno = 0;
- return (int)stdout;
-}
-
-int nh_stderr ( void )
-{
- errno = 0;
- return (int)stderr;
-}
-
-int nh_open ( char* fname, int wr )
-{
- FILE* f;
- errno = 0;
- f = fopen ( fname, (wr==0) ? "r": ((wr==1) ? "w" : "a") );
- return (int)f;
-}
-
-void nh_close ( FILE* f )
-{
- errno = 0;
- fflush ( f );
- fclose ( f );
-}
-
-void nh_flush ( FILE* f )
-{
- errno = 0;
- fflush ( f );
-}
-
-void nh_write ( FILE* f, int c )
-{
- errno = 0;
- fputc(c,f);
- if (f==stderr) { fflush(f); }
- if (f==stdout) { fflush(f); }
-}
-
-int nh_read ( FILE* f )
-{
- errno = 0;
- return fgetc(f);
-}
-
-int nh_errno ( void )
-{
- int t = errno;
- errno = 0;
- return t;
-}
-
-int nh_malloc ( int n )
-{
- char* p = malloc(n);
- return (int)p;
-}
-
-void nh_free ( int n )
-{
- free ( (char*)n );
-}
-
-void nh_store ( int p, int ch )
-{
- *(char*)p = (char)ch;
-}
-
-int nh_load ( int p )
-{
- return (int)(*(char*)p);
-}
-
-int nh_getenv ( int p )
-{
- return (int)getenv ( (const char *)p );
-}
-
+++ /dev/null
-EXPORTS
-nh_getCPUtime
-nh_getCPUprec
-nh_getPID
-nh_exitwith
-nh_system
-nh_iseof
-nh_filesize
-nh_stdin
-nh_stdout
-nh_stderr
-nh_open
-nh_close
-nh_flush
-nh_write
-nh_read
-nh_errno
-nh_malloc
-nh_free
-nh_store
-nh_load
-nh_getenv
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Machinery for dynamic loading and linking of object code. Should be
- * completely independent from the rest of Hugs so we can use it in
- * other applications if desired.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * ------------------------------------------------------------------------*/
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <ctype.h>
-#include <assert.h>
-#include "config.h" /* for linux_TARGET_OS etc */
-#include "object.h"
-
-
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
-static int ocVerifyImage_ELF ( ObjectCode* oc, int verb );
-static int ocGetNames_ELF ( ObjectCode* oc, int verb );
-static int ocResolve_ELF ( ObjectCode* oc, int verb );
-#elif defined(cygwin32_TARGET_OS)
-static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb );
-static int ocGetNames_PEi386 ( ObjectCode* oc, int verb );
-static int ocResolve_PEi386 ( ObjectCode* oc, int verb );
-#endif
-
-static char* hackyAppend ( char* s1, char* s2 );
-static int sortSymbols ( ObjectCode* oc );
-
-
-/* --------------------------------------------------------------------------
- * Arch-independent interface to the runtime linker
- * ------------------------------------------------------------------------*/
-
-ObjectCode* ocNew ( void (*errMsg)(char*),
- void* (*clientLookup)(char*),
- int (*clientWantsSymbol)(char*),
- char* objFileName,
- int objFileSize )
-{
- ObjectCode* oc = malloc(sizeof(ObjectCode));
- if (!oc) {
- errMsg("ocNew: can't allocate memory for object code record");
- return NULL;
- }
-
-# if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- oc->formatName = "ELF";
-# elif defined(cygwin32_TARGET_OS)
- oc->formatName = "PEi386";
-# else
- free(oc);
- errMsg("ocNew: not implemented on this platform");
- return NULL;
-# endif
-
- oc->status = OBJECT_NOTINUSE;
- oc->objFileName = objFileName;
- oc->objFileSize = objFileSize;
- oc->errMsg = errMsg;
- oc->clientLookup = clientLookup;
- oc->clientWantsSymbol = clientWantsSymbol;
-
- oc->oImage = malloc ( objFileSize );
- if (!oc->oImage) {
- free(oc);
- errMsg("ocNew: can't allocate memory for object code");
- return NULL;
- }
- oc->oTab = NULL;
- oc->sizeoTab = 0;
- oc->usedoTab = 0;
- oc->sectionTab = NULL;
- oc->sizesectionTab = 0;
- oc->usedsectionTab = 0;
- oc->next = NULL;
- return oc;
-}
-
-
-int ocLoadImage ( ObjectCode* oc, int verb )
-{
- int n;
- FILE* f;
- assert (oc && oc->status==OBJECT_NOTINUSE);
- if (verb) fprintf(stderr, "ocLoadImage %s\n", oc->objFileName );
- f = fopen(oc->objFileName, "rb");
- if (!f) {
- (oc->errMsg(hackyAppend("ocLoadImage: can't read: ",
- oc->objFileName)));
- return 0;
- }
- n = fread ( oc->oImage, 1, oc->objFileSize, f );
- if (n != oc->objFileSize) {
- fclose(f);
- oc->errMsg(hackyAppend("ocLoadImage: I/O error whilst reading: ",
- oc->objFileName));
- return 0;
- }
- oc->status = OBJECT_OIMAGE;
- if (verb) fprintf(stderr, "ocLoadImage %s: read %d bytes\n",
- oc->objFileName, oc->objFileSize );
- return 1;
-}
-
-
-/* returns 1 if ok, 0 if error */
-int ocVerifyImage ( ObjectCode* oc, int verb )
-{
- int ret;
- assert (oc && oc->status==OBJECT_OIMAGE);
- if (verb) fprintf(stderr, "ocVerifyImage: begin\n");
-# if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- ret = ocVerifyImage_ELF ( oc, verb );
-# elif defined(cygwin32_TARGET_OS)
- ret = ocVerifyImage_PEi386 ( oc, verb );
-# else
- oc->errMsg("ocVerifyImage: not implemented on this platform");
- return 0;
-# endif
- if (verb) fprintf(stderr, "ocVerifyImage: done, status = %d", ret);
-
- if (ret) oc->status = OBJECT_VERIFIED;
- return ret;
-}
-
-
-/* returns 1 if ok, 0 if error */
-int ocGetNames ( ObjectCode* oc, int verb )
-{
- int ret;
- assert (oc && oc->status==OBJECT_VERIFIED);
- if (verb) fprintf(stderr, "ocGetNames: begin\n");
-# if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- ret = ocGetNames_ELF ( oc, verb );
-# elif defined(cygwin32_TARGET_OS)
- ret = ocGetNames_PEi386 ( oc, verb );
-# else
- oc->errMsg("ocGetNames: not implemented on this platform");
- return 0;
-# endif
- if (verb) fprintf(stderr, "ocGetNames: done, status = %d\n", ret);
- if (ret) ret = sortSymbols(oc);
- if (ret) oc->status = OBJECT_HAVENAMES;
- return ret;
-}
-
-
-/* returns 1 if ok, 0 if error */
-int ocResolve ( ObjectCode* oc, int verb )
-{
- int ret;
- assert (oc && oc->status==OBJECT_HAVENAMES);
- if (verb) fprintf(stderr, "ocResolve: begin\n");
-# if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
- ret = ocResolve_ELF ( oc, verb );
-# elif defined(cygwin32_TARGET_OS)
- ret = ocResolve_PEi386 ( oc, verb );
-# else
- oc->errMsg("ocResolve: not implemented on this platform");
- return 0;
-# endif
- if (verb) fprintf(stderr, "ocResolve: done, status = %d\n", ret);
- if (ret) oc->status = OBJECT_RESOLVED;
- return ret;
-}
-
-
-void ocFree ( ObjectCode* oc )
-{
- if (oc) {
- if (oc->oImage) free(oc->oImage);
- if (oc->oTab) free(oc->oTab);
- if (oc->sectionTab) free(oc->sectionTab);
- free(oc);
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Simple, dynamically expandable association tables
- * ------------------------------------------------------------------------*/
-
-/* A bit tricky. Assumes that if tab==NULL, then
- currUsed and *currSize must be zero.
- Returns NULL if expansion failed.
-*/
-static void* genericExpand ( void* tab,
- int* currSize, int currUsed,
- int initSize, int elemSize )
-{
- int size2;
- void* tab2;
- if (currUsed < *currSize) return tab;
- size2 = (*currSize == 0) ? initSize : (2 * *currSize);
- tab2 = malloc ( size2 * elemSize );
- if (!tab2) return NULL;
- if (*currSize > 0)
- memcpy ( tab2, tab, elemSize * *currSize );
- *currSize = size2;
- if (tab) free ( tab );
- return tab2;
-}
-
-
-/* returns 1 if success, 0 if error */
-static int addSymbol ( ObjectCode* oc, char* nm, void* ad )
-{
- OSym* newTab;
-
- if (oc->clientWantsSymbol && !oc->clientWantsSymbol(nm))
- return 1;
-
- newTab
- = genericExpand ( oc->oTab,
- &(oc->sizeoTab),
- oc->usedoTab,
- 8, sizeof(OSym) );
-
- if (!newTab) {
- oc->errMsg("addSymbol: malloc failed whilst expanding table");
- return 0;
- }
- oc->oTab = newTab;
- oc->oTab[ oc->usedoTab ].nm = nm;
- oc->oTab[ oc->usedoTab ].ad = ad;
- oc->usedoTab++;
- return 1;
-}
-
-
-/* Reorder symbol table so that symbols are in alphabetical order.
- Detects an error if, after sorting, any two symbols are the same,
- since this would imply that the same symbol has been inserted more
- than once. Returns 1 if success, 0 if error.
-*/
-static int sortSymbols ( ObjectCode* oc )
-{
- static int incs[14]
- = { 1, 4, 13, 40, 121, 364, 1093, 3280,
- 9841, 29524, 88573, 265720, 797161, 2391484 };
-
- int lo = 0;
- int hi = oc->usedoTab-1;
- int i, j, h, bigN, hp;
- OSym v;
-
- bigN = hi - lo + 1; if (bigN < 2) return 1;
- hp = 0; while (incs[hp] < bigN) hp++; hp--;
-
- for (; hp >= 0; hp--) {
- h = incs[hp];
- i = lo + h;
- while (1) {
- if (i > hi) break;
- v = oc->oTab[i];
- j = i;
- while (strcmp(oc->oTab[j-h].nm, v.nm) > 0) {
- oc->oTab[j] = oc->oTab[j-h];
- j = j - h;
- if (j <= (lo + h - 1)) break;
- }
- oc->oTab[j] = v;
- i++;
- }
- }
-
- for (i = 1; i < oc->usedoTab; i++) {
- j = strcmp(oc->oTab[i-1].nm, oc->oTab[i].nm);
- if (j > 0) {
- oc->errMsg("sortSymbols: sorting failed");
- return 0;
- }
- if (j == 0) {
- oc->errMsg("sortSymbols: duplicate symbols in object file:");
- oc->errMsg(oc->oTab[i].nm);
- return 0;
- }
- }
-
- return 1;
-}
-
-
-/* returns 1 if success, 0 if error */
-static int addSection ( ObjectCode* oc, void* start, void* end, OSectionKind sect )
-{
- OSection* newTab
- = genericExpand ( oc->sectionTab,
- &(oc->sizesectionTab),
- oc->usedsectionTab,
- 4, sizeof(OSection) );
- if (!newTab) {
- oc->errMsg("addSection: malloc failed whilst expanding table");
- return 0;
- }
- oc->sectionTab = newTab;
- oc->sectionTab[ oc->usedsectionTab ].start = start;
- oc->sectionTab[ oc->usedsectionTab ].end = end;
- oc->sectionTab[ oc->usedsectionTab ].kind = sect;
- oc->usedsectionTab++;
- return 1;
-}
-
-
-void* ocLookupSym ( ObjectCode* oc, char* sym )
-{
- int lo, hi, mid, cmp;
-
- assert(oc);
- if (oc->status != OBJECT_HAVENAMES
- && oc->status != OBJECT_RESOLVED) {
- oc->errMsg("ocLookupSym: no symbols available");
- return NULL;
- }
-
- /* Originally used a sequential search; should still work
- for (i = 0; i < oc->usedoTab; i++) {
- if (0)
- fprintf ( stderr,
- "ocLookupSym: request %s, table has %s\n",
- sym, oc->oTab[i].nm );
- if (0==strcmp(sym,oc->oTab[i].nm))
- return oc->oTab[i].ad;
- }
- */
-
- lo = 0;
- hi = oc->usedoTab-1;
- while (1) {
- /* Invariant: the unsearched area is oc->oTab[lo .. hi] inclusive. */
- if (hi < lo) return NULL;
- mid = (hi + lo) / 2;
- cmp = strcmp(sym, oc->oTab[mid].nm);
- if (cmp == 0) return oc->oTab[mid].ad;
- if (cmp < 0) hi = mid-1;
- if (cmp > 0) lo = mid+1;
- }
-}
-
-
-char* ocLookupAddr ( ObjectCode* oc, void* addr )
-{
- int i;
-
- assert(oc);
- if (oc->status != OBJECT_HAVENAMES
- && oc->status != OBJECT_RESOLVED) {
- oc->errMsg("ocLookupAddr: no symbols available");
- return NULL;
- }
-
- for (i = 0; i < oc->usedoTab; i++) {
- if (addr == oc->oTab[i].ad)
- return oc->oTab[i].nm;
- }
- return NULL;
-}
-
-
-OSectionKind ocLookupSection ( ObjectCode* oc, void* addr )
-{
- int i;
-
- assert(oc);
- if (oc->status != OBJECT_HAVENAMES
- && oc->status != OBJECT_RESOLVED) {
- oc->errMsg("ocLookupSection: no symbols available");
- return HUGS_SECTIONKIND_NOINFOAVAIL;
- }
-
-
- for (i = 0; i < oc->usedsectionTab; i++) {
- if (oc->sectionTab[i].start <= addr
- && addr <= oc->sectionTab[i].end)
- return oc->sectionTab[i].kind;
- }
-
- return HUGS_SECTIONKIND_NOINFOAVAIL;
-}
-
-
-/* Ghastly append which leaks space. But we only use it for
- error messages -- that's my excuse.
-*/
-static char* hackyAppend ( char* s1, char* s2 )
-{
- char* res = malloc ( 4 + strlen(s1) + strlen(s2) );
- if (!res) {
- fprintf ( stderr, "hugs: fatal: hackyAppend\n\t%s\n\t%s\n", s1, s2 );
- assert(res);
- }
- strcpy(res,s1);
- strcat(res,s2);
- return res;
-}
-
-/* --------------------------------------------------------------------------
- * PEi386 specifics (cygwin32)
- * ------------------------------------------------------------------------*/
-
-/* The information for this linker comes from
- Microsoft Portable Executable
- and Common Object File Format Specification
- revision 5.1 January 1998
- which SimonM says comes from the MS Developer Network CDs.
-*/
-
-
-#if defined(cygwin32_TARGET_OS)
-
-#define FALSE 0
-#define TRUE 1
-
-
-typedef unsigned char UChar;
-typedef unsigned short UInt16;
-typedef unsigned int UInt32;
-typedef int Int32;
-
-
-typedef
- struct {
- UInt16 Machine;
- UInt16 NumberOfSections;
- UInt32 TimeDateStamp;
- UInt32 PointerToSymbolTable;
- UInt32 NumberOfSymbols;
- UInt16 SizeOfOptionalHeader;
- UInt16 Characteristics;
- }
- COFF_header;
-
-#define sizeof_COFF_header 20
-
-
-typedef
- struct {
- UChar Name[8];
- UInt32 VirtualSize;
- UInt32 VirtualAddress;
- UInt32 SizeOfRawData;
- UInt32 PointerToRawData;
- UInt32 PointerToRelocations;
- UInt32 PointerToLinenumbers;
- UInt16 NumberOfRelocations;
- UInt16 NumberOfLineNumbers;
- UInt32 Characteristics;
- }
- COFF_section;
-
-#define sizeof_COFF_section 40
-
-
-typedef
- struct {
- UChar Name[8];
- UInt32 Value;
- UInt16 SectionNumber;
- UInt16 Type;
- UChar StorageClass;
- UChar NumberOfAuxSymbols;
- }
- COFF_symbol;
-
-#define sizeof_COFF_symbol 18
-
-
-typedef
- struct {
- UInt32 VirtualAddress;
- UInt32 SymbolTableIndex;
- UInt16 Type;
- }
- COFF_reloc;
-
-#define sizeof_COFF_reloc 10
-
-
-/* From PE spec doc, section 3.3.2 */
-#define IMAGE_FILE_RELOCS_STRIPPED 0x0001
-#define IMAGE_FILE_EXECUTABLE_IMAGE 0x0002
-#define IMAGE_FILE_DLL 0x2000
-#define IMAGE_FILE_SYSTEM 0x1000
-#define IMAGE_FILE_BYTES_REVERSED_HI 0x8000
-#define IMAGE_FILE_BYTES_REVERSED_LO 0x0080
-#define IMAGE_FILE_32BIT_MACHINE 0x0100
-
-/* From PE spec doc, section 5.4.2 and 5.4.4 */
-#define IMAGE_SYM_CLASS_EXTERNAL 2
-#define IMAGE_SYM_CLASS_STATIC 3
-#define IMAGE_SYM_UNDEFINED 0
-
-/* From PE spec doc, section 4.1 */
-#define IMAGE_SCN_CNT_CODE 0x00000020
-#define IMAGE_SCN_CNT_INITIALIZED_DATA 0x00000040
-
-/* From PE spec doc, section 5.2.1 */
-#define IMAGE_REL_I386_DIR32 0x0006
-#define IMAGE_REL_I386_REL32 0x0014
-
-
-/* We use myindex to calculate array addresses, rather than
- simply doing the normal subscript thing. That's because
- some of the above structs have sizes which are not
- a whole number of words. GCC rounds their sizes up to a
- whole number of words, which means that the address calcs
- arising from using normal C indexing or pointer arithmetic
- are just plain wrong. Sigh.
-*/
-static UChar* myindex ( int scale, int index, void* base )
-{
- return
- ((UChar*)base) + scale * index;
-}
-
-
-static void printName ( UChar* name, UChar* strtab )
-{
- if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
- UInt32 strtab_offset = * (UInt32*)(name+4);
- fprintf ( stderr, "%s", strtab + strtab_offset );
- } else {
- int i;
- for (i = 0; i < 8; i++) {
- if (name[i] == 0) break;
- fprintf ( stderr, "%c", name[i] );
- }
- }
-}
-
-
-static void copyName ( UChar* name, UChar* strtab,
- UChar* dst, int dstSize )
-{
- if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
- UInt32 strtab_offset = * (UInt32*)(name+4);
- strncpy ( dst, strtab+strtab_offset, dstSize );
- dst[dstSize-1] = 0;
- } else {
- int i = 0;
- while (1) {
- if (i >= 8) break;
- if (name[i] == 0) break;
- dst[i] = name[i];
- i++;
- }
- dst[i] = 0;
- }
-}
-
-
-static UChar* cstring_from_COFF_symbol_name ( UChar* name,
- UChar* strtab )
-{
- UChar* newstr;
- /* If the string is longer than 8 bytes, look in the
- string table for it -- this will be correctly zero terminated.
- */
- if (name[0]==0 && name[1]==0 && name[2]==0 && name[3]==0) {
- UInt32 strtab_offset = * (UInt32*)(name+4);
- return ((UChar*)strtab) + strtab_offset;
- }
- /* Otherwise, if shorter than 8 bytes, return the original,
- which by defn is correctly terminated.
- */
- if (name[7]==0) return name;
- /* The annoying case: 8 bytes. Copy into a temporary
- (which is never freed ...)
- */
- newstr = malloc(9);
- if (newstr) {
- strncpy(newstr,name,8);
- newstr[8] = 0;
- }
- return newstr;
-}
-
-
-/* Just compares the short names (first 8 chars) */
-static COFF_section* findPEi386SectionCalled ( ObjectCode* oc,
- char* name )
-{
- int i;
- COFF_header* hdr
- = (COFF_header*)(oc->oImage);
- COFF_section* sectab
- = (COFF_section*) (
- ((UChar*)(oc->oImage))
- + sizeof_COFF_header + hdr->SizeOfOptionalHeader
- );
- for (i = 0; i < hdr->NumberOfSections; i++) {
- UChar* n1;
- UChar* n2;
- COFF_section* section_i
- = (COFF_section*)
- myindex ( sizeof_COFF_section, i, sectab );
- n1 = (UChar*) &(section_i->Name);
- n2 = name;
- if (n1[0]==n2[0] && n1[1]==n2[1] && n1[2]==n2[2] &&
- n1[3]==n2[3] && n1[4]==n2[4] && n1[5]==n2[5] &&
- n1[6]==n2[6] && n1[7]==n2[7])
- return section_i;
- }
-
- return NULL;
-}
-
-
-static void zapTrailingAtSign ( UChar* sym )
-{
- int i, j;
- if (sym[0] == 0) return;
- i = 0;
- while (sym[i] != 0) i++;
- i--;
- j = i;
- while (j > 0 && isdigit(sym[j])) j--;
- if (j > 0 && sym[j] == '@' && j != i) sym[j] = 0;
-}
-
-
-static int ocVerifyImage_PEi386 ( ObjectCode* oc, int verb )
-{
- int i, j;
- COFF_header* hdr;
- COFF_section* sectab;
- COFF_symbol* symtab;
- UChar* strtab;
-
- hdr = (COFF_header*)(oc->oImage);
- sectab = (COFF_section*) (
- ((UChar*)(oc->oImage))
- + sizeof_COFF_header + hdr->SizeOfOptionalHeader
- );
- symtab = (COFF_symbol*) (
- ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- );
- strtab = ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- + hdr->NumberOfSymbols * sizeof_COFF_symbol;
-
- if (hdr->Machine != 0x14c) {
- oc->errMsg("Not x86 PEi386");
- return FALSE;
- }
- if (hdr->SizeOfOptionalHeader != 0) {
- oc->errMsg("PEi386 with nonempty optional header");
- return FALSE;
- }
- if ( /* (hdr->Characteristics & IMAGE_FILE_RELOCS_STRIPPED) || */
- (hdr->Characteristics & IMAGE_FILE_EXECUTABLE_IMAGE) ||
- (hdr->Characteristics & IMAGE_FILE_DLL) ||
- (hdr->Characteristics & IMAGE_FILE_SYSTEM) ) {
- oc->errMsg("Not a PEi386 object file");
- return FALSE;
- }
- if ( (hdr->Characteristics & IMAGE_FILE_BYTES_REVERSED_HI) ||
- !(hdr->Characteristics & IMAGE_FILE_32BIT_MACHINE) ) {
- oc->errMsg("Invalid PEi386 word size or endiannness");
- return FALSE;
- }
-
- if (!verb) return TRUE;
- /* No further verification after this point; only debug printing. */
-
- fprintf ( stderr,
- "sectab offset = %d\n", ((UChar*)sectab) - ((UChar*)hdr) );
- fprintf ( stderr,
- "symtab offset = %d\n", ((UChar*)symtab) - ((UChar*)hdr) );
- fprintf ( stderr,
- "strtab offset = %d\n", ((UChar*)strtab) - ((UChar*)hdr) );
-
- fprintf ( stderr, "\n" );
- fprintf ( stderr,
- "Machine: 0x%x\n", (UInt32)(hdr->Machine) );
- fprintf ( stderr,
- "# sections: %d\n", (UInt32)(hdr->NumberOfSections) );
- fprintf ( stderr,
- "time/date: 0x%x\n", (UInt32)(hdr->TimeDateStamp) );
- fprintf ( stderr,
- "symtab offset: %d\n", (UInt32)(hdr->PointerToSymbolTable) );
- fprintf ( stderr,
- "# symbols: %d\n", (UInt32)(hdr->NumberOfSymbols) );
- fprintf ( stderr,
- "sz of opt hdr: %d\n", (UInt32)(hdr->SizeOfOptionalHeader) );
- fprintf ( stderr,
- "characteristics: 0x%x\n", (UInt32)(hdr->Characteristics) );
-
- fprintf ( stderr, "\n" );
- fprintf ( stderr, "string table has size 0x%x\n", * (UInt32*)strtab );
- fprintf ( stderr, "---START of string table---\n");
- for (i = 4; i < *(UInt32*)strtab; i++) {
- if (strtab[i] == 0)
- fprintf ( stderr, "\n"); else
- fprintf( stderr, "%c", strtab[i] );
- }
- fprintf ( stderr, "--- END of string table---\n");
-
- fprintf ( stderr, "\n" );
- for (i = 0; i < hdr->NumberOfSections; i++) {
- COFF_reloc* reltab;
- COFF_section* sectab_i
- = (COFF_section*)
- myindex ( sizeof_COFF_section, i, sectab );
- fprintf ( stderr,
- "\n"
- "section %d\n"
- " name `",
- i
- );
- printName ( sectab_i->Name, strtab );
- fprintf ( stderr,
- "'\n"
- " vsize %d\n"
- " vaddr %d\n"
- " data sz %d\n"
- " data off %d\n"
- " num rel %d\n"
- " off rel %d\n",
- sectab_i->VirtualSize,
- sectab_i->VirtualAddress,
- sectab_i->SizeOfRawData,
- sectab_i->PointerToRawData,
- sectab_i->NumberOfRelocations,
- sectab_i->PointerToRelocations
- );
- reltab = (COFF_reloc*) (
- ((UChar*)(oc->oImage)) + sectab_i->PointerToRelocations
- );
- for (j = 0; j < sectab_i->NumberOfRelocations; j++) {
- COFF_symbol* sym;
- COFF_reloc* rel = (COFF_reloc*)
- myindex ( sizeof_COFF_reloc, j, reltab );
- fprintf ( stderr,
- " type 0x%-4x vaddr 0x%-8x name `",
- (UInt32)rel->Type,
- rel->VirtualAddress );
- sym = (COFF_symbol*)
- myindex ( sizeof_COFF_symbol, rel->SymbolTableIndex, symtab );
- printName ( sym->Name, strtab );
- fprintf ( stderr, "'\n" );
- }
- fprintf ( stderr, "\n" );
- }
-
-
- fprintf ( stderr, "\n" );
- i = 0;
- while (1) {
- COFF_symbol* symtab_i;
- if (i >= hdr->NumberOfSymbols) break;
- symtab_i = (COFF_symbol*)
- myindex ( sizeof_COFF_symbol, i, symtab );
- fprintf ( stderr,
- "symbol %d\n"
- " name `",
- i
- );
- printName ( symtab_i->Name, strtab );
- fprintf ( stderr,
- "'\n"
- " value 0x%x\n"
- " sec# %d\n"
- " type 0x%x\n"
- " sclass 0x%x\n"
- " nAux %d\n",
- symtab_i->Value,
- (Int32)(symtab_i->SectionNumber) - 1,
- (UInt32)symtab_i->Type,
- (UInt32)symtab_i->StorageClass,
- (UInt32)symtab_i->NumberOfAuxSymbols
- );
- i += symtab_i->NumberOfAuxSymbols;
- i++;
- }
-
- fprintf ( stderr, "\n" );
-
- return TRUE;
-}
-
-
-static int ocGetNames_PEi386 ( ObjectCode* oc, int verb )
-{
- COFF_header* hdr;
- COFF_section* sectab;
- COFF_symbol* symtab;
- UChar* strtab;
-
- UChar* sname;
- void* addr;
- int i;
-
- hdr = (COFF_header*)(oc->oImage);
- sectab = (COFF_section*) (
- ((UChar*)(oc->oImage))
- + sizeof_COFF_header + hdr->SizeOfOptionalHeader
- );
- symtab = (COFF_symbol*) (
- ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- );
- strtab = ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- + hdr->NumberOfSymbols * sizeof_COFF_symbol;
-
- /* Copy exported symbols into the ObjectCode. */
- i = 0;
- while (1) {
- COFF_symbol* symtab_i;
- if (i >= hdr->NumberOfSymbols) break;
- symtab_i = (COFF_symbol*)
- myindex ( sizeof_COFF_symbol, i, symtab );
-
- if (symtab_i->StorageClass == IMAGE_SYM_CLASS_EXTERNAL &&
- symtab_i->SectionNumber != IMAGE_SYM_UNDEFINED) {
-
- /* This symbol is global and defined, viz, exported */
- COFF_section* sectabent;
-
- sname = cstring_from_COFF_symbol_name (
- symtab_i->Name, strtab
- );
- if (!sname) {
- oc->errMsg("Out of memory when copying PEi386 symbol");
- return FALSE;
- }
-
- /* for IMAGE_SYMCLASS_EXTERNAL
- && !IMAGE_SYM_UNDEFINED,
- the address of the symbol is:
- address of relevant section + offset in section
- */
- sectabent = (COFF_section*)
- myindex ( sizeof_COFF_section,
- symtab_i->SectionNumber-1,
- sectab );
- addr = ((UChar*)(oc->oImage))
- + (sectabent->PointerToRawData
- + symtab_i->Value);
- /* fprintf ( stderr, "addSymbol %p `%s'\n", addr,sname); */
- if (!addSymbol(oc,sname,addr)) return FALSE;
- }
- i += symtab_i->NumberOfAuxSymbols;
- i++;
- }
-
- /* Copy section information into the ObjectCode. */
- for (i = 0; i < hdr->NumberOfSections; i++) {
- UChar* start;
- UChar* end;
-
- OSectionKind kind
- = HUGS_SECTIONKIND_OTHER;
- COFF_section* sectab_i
- = (COFF_section*)
- myindex ( sizeof_COFF_section, i, sectab );
- /* fprintf ( stderr, "section name = %s\n", sectab_i->Name ); */
-
-#if 0
- /* I'm sure this is the Right Way to do it. However, the
- alternative of testing the sectab_i->Name field seems to
- work ok with Cygwin.
- */
- if (sectab_i->Characteristics & IMAGE_SCN_CNT_CODE ||
- sectab_i->Characteristics & IMAGE_SCN_CNT_INITIALIZED_DATA)
- kind = HUGS_SECTIONKIND_CODE_OR_RODATA;
-#endif
-
- if (0==strcmp(".text",sectab_i->Name))
- kind = HUGS_SECTIONKIND_CODE_OR_RODATA;
- if (0==strcmp(".data",sectab_i->Name) ||
- 0==strcmp(".bss",sectab_i->Name))
- kind = HUGS_SECTIONKIND_RWDATA;
-
- start = ((UChar*)(oc->oImage))
- + sectab_i->PointerToRawData;
- end = start
- + sectab_i->SizeOfRawData - 1;
-
- if (kind != HUGS_SECTIONKIND_OTHER) {
- addSection ( oc, start, end, kind );
- } else {
- fprintf ( stderr, "unknown section name = `%s'\n",
- sectab_i->Name);
- oc->errMsg("Unknown PEi386 section name");
- return FALSE;
- }
- }
-
- return TRUE;
-}
-
-
-static int ocResolve_PEi386 ( ObjectCode* oc, int verb )
-{
- COFF_header* hdr;
- COFF_section* sectab;
- COFF_symbol* symtab;
- UChar* strtab;
-
- UInt32 A;
- UInt32 S;
- UInt32* pP;
-
- int i, j;
- char symbol[1000]; // ToDo
-
- hdr = (COFF_header*)(oc->oImage);
- sectab = (COFF_section*) (
- ((UChar*)(oc->oImage))
- + sizeof_COFF_header + hdr->SizeOfOptionalHeader
- );
- symtab = (COFF_symbol*) (
- ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- );
- strtab = ((UChar*)(oc->oImage))
- + hdr->PointerToSymbolTable
- + hdr->NumberOfSymbols * sizeof_COFF_symbol;
-
- for (i = 0; i < hdr->NumberOfSections; i++) {
- COFF_section* sectab_i
- = (COFF_section*)
- myindex ( sizeof_COFF_section, i, sectab );
- COFF_reloc* reltab
- = (COFF_reloc*) (
- ((UChar*)(oc->oImage)) + sectab_i->PointerToRelocations
- );
- for (j = 0; j < sectab_i->NumberOfRelocations; j++) {
- COFF_symbol* sym;
- COFF_reloc* reltab_j
- = (COFF_reloc*)
- myindex ( sizeof_COFF_reloc, j, reltab );
-
- /* the location to patch */
- pP = (UInt32*)(
- ((UChar*)(oc->oImage))
- + (sectab_i->PointerToRawData
- + reltab_j->VirtualAddress)
- );
- /* the existing contents of pP */
- A = *pP;
- /* the symbol to connect to */
- sym = (COFF_symbol*)
- myindex ( sizeof_COFF_symbol,
- reltab_j->SymbolTableIndex, symtab );
- if (verb) {
- fprintf ( stderr,
- "reloc sec %2d num %3d: type 0x%-4x "
- "vaddr 0x%-8x name `",
- i, j,
- (UInt32)reltab_j->Type,
- reltab_j->VirtualAddress );
- printName ( sym->Name, strtab );
- fprintf ( stderr, "'\n" );
- }
-
- if (sym->StorageClass == IMAGE_SYM_CLASS_STATIC) {
- COFF_section* section_sym
- = findPEi386SectionCalled ( oc, sym->Name );
- if (!section_sym) {
- fprintf ( stderr, "bad section = `%s'\n", sym->Name );
- oc->errMsg("Can't find abovementioned PEi386 section");
- return FALSE;
- }
- S = ((UInt32)(oc->oImage))
- + (section_sym->PointerToRawData
- + sym->Value);
- } else {
- copyName ( sym->Name, strtab, symbol, 1000 );
- zapTrailingAtSign ( symbol );
- S = (UInt32) ocLookupSym ( oc, symbol );
- if (S == 0)
- S = (UInt32)(oc->clientLookup ( symbol ));
- if (S == 0) {
- char errtxt[2000];
- strcpy(errtxt,oc->objFileName);
- strcat(errtxt,": unresolvable reference to: ");
- strcat(errtxt,symbol);
- oc->errMsg(errtxt);
- return FALSE;
- }
- }
-
- switch (reltab_j->Type) {
- case IMAGE_REL_I386_DIR32:
- *pP = A + S;
- break;
- case IMAGE_REL_I386_REL32:
- /* Tricky. We have to insert a displacement at
- pP which, when added to the PC for the _next_
- insn, gives the address of the target (S).
- Problem is to know the address of the next insn
- when we only know pP. We assume that this
- literal field is always the last in the insn,
- so that the address of the next insn is pP+4
- -- hence the constant 4.
- Also I don't know if A should be added, but so
- far it has always been zero.
- */
- assert(A==0);
- *pP = S - ((UInt32)pP) - 4;
- break;
- default:
- fprintf(stderr,
- "unhandled PEi386 relocation type %d\n",
- reltab_j->Type);
- oc->errMsg("unhandled PEi386 relocation type");
- return FALSE;
- }
-
- }
- }
-
- return TRUE;
-}
-
-#endif /* defined(cygwin32_TARGET_OS) */
-
-
-/* --------------------------------------------------------------------------
- * ELF specifics (Linux, Solaris)
- * ------------------------------------------------------------------------*/
-
-#if defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS)
-
-#define FALSE 0
-#define TRUE 1
-
-#include <elf.h>
-
-static char* findElfSection ( void* objImage, Elf32_Word sh_type )
-{
- int i;
- char* ehdrC = (char*)objImage;
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* ptr = NULL;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == sh_type &&
- i != ehdr->e_shstrndx) {
- ptr = ehdrC + shdr[i].sh_offset;
- break;
- }
- }
- return ptr;
-}
-
-
-static int ocVerifyImage_ELF ( ObjectCode* oc, int verb )
-{
- Elf32_Shdr* shdr;
- Elf32_Sym* stab;
- int i, j, nent, nstrtab, nsymtabs;
- char* sh_strtab;
- char* strtab;
-
- char* ehdrC = (char*)(oc->oImage);
- Elf32_Ehdr* ehdr = ( Elf32_Ehdr*)ehdrC;
-
- if (ehdr->e_ident[EI_MAG0] != ELFMAG0 ||
- ehdr->e_ident[EI_MAG1] != ELFMAG1 ||
- ehdr->e_ident[EI_MAG2] != ELFMAG2 ||
- ehdr->e_ident[EI_MAG3] != ELFMAG3) {
- oc->errMsg("Not an ELF header");
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is an ELF header\n" );
-
- if (ehdr->e_ident[EI_CLASS] != ELFCLASS32) {
- oc->errMsg("Not 32 bit ELF" );
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is 32 bit ELF\n" );
-
- if (ehdr->e_ident[EI_DATA] == ELFDATA2LSB) {
- if (verb) fprintf ( stderr, "Is little-endian\n" );
- } else
- if (ehdr->e_ident[EI_DATA] == ELFDATA2MSB) {
- if (verb) fprintf ( stderr, "Is big-endian\n" );
- } else {
- oc->errMsg("Unknown endiannness");
- return FALSE;
- }
-
- if (ehdr->e_type != ET_REL) {
- oc->errMsg("Not a relocatable object (.o) file");
- return FALSE;
- }
- if (verb) fprintf ( stderr, "Is a relocatable object (.o) file\n" );
-
- if (verb) fprintf ( stderr, "Architecture is " );
- switch (ehdr->e_machine) {
- case EM_386: if (verb) fprintf ( stderr, "x86\n" ); break;
- case EM_SPARC: if (verb) fprintf ( stderr, "sparc\n" ); break;
- default: if (verb) fprintf ( stderr, "unknown\n" );
- oc->errMsg("Unknown architecture");
- return FALSE;
- }
-
- if (verb)
- fprintf ( stderr,
- "\nSection header table: start %d, n_entries %d, ent_size %d\n",
- ehdr->e_shoff, ehdr->e_shnum, ehdr->e_shentsize );
-
- assert (ehdr->e_shentsize == sizeof(Elf32_Shdr));
-
- shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
-
- if (ehdr->e_shstrndx == SHN_UNDEF) {
- oc->errMsg("No section header string table");
- return FALSE;
- } else {
- if (verb) fprintf ( stderr,"Section header string table is section %d\n",
- ehdr->e_shstrndx);
- sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
- }
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (verb) fprintf ( stderr, "%2d: ", i );
- if (verb) fprintf ( stderr, "type=%2d ", shdr[i].sh_type );
- if (verb) fprintf ( stderr, "size=%4d ", shdr[i].sh_size );
- if (verb) fprintf ( stderr, "offs=%4d ", shdr[i].sh_offset );
- if (verb) fprintf ( stderr, " (%p .. %p) ",
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1);
-
- if (shdr[i].sh_type == SHT_REL && verb) fprintf ( stderr, "Rel " ); else
- if (shdr[i].sh_type == SHT_RELA && verb) fprintf ( stderr, "RelA " ); else
- if (verb) fprintf ( stderr, " " );
- if (sh_strtab && verb)
- fprintf ( stderr, "sname=%s", sh_strtab + shdr[i].sh_name );
- if (verb) fprintf ( stderr, "\n" );
- }
-
- if (verb) fprintf ( stderr, "\n\nString tables\n" );
- strtab = NULL;
- nstrtab = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_STRTAB &&
- i != ehdr->e_shstrndx) {
- if (verb)
- fprintf ( stderr, " section %d is a normal string table\n", i );
- strtab = ehdrC + shdr[i].sh_offset;
- nstrtab++;
- }
- }
- if (nstrtab != 1) {
- oc->errMsg("WARNING: no string tables, or too many");
- return FALSE;
- }
-
- nsymtabs = 0;
- if (verb) fprintf ( stderr, "\n\nSymbol tables\n" );
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
- if (verb) fprintf ( stderr, "section %d is a symbol table\n", i );
- nsymtabs++;
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- if (verb) fprintf ( stderr, " number of entries is apparently %d (%d rem)\n",
- nent,
- shdr[i].sh_size % sizeof(Elf32_Sym)
- );
- if (0 != shdr[i].sh_size % sizeof(Elf32_Sym)) {
- oc->errMsg("non-integral number of symbol table entries");
- return FALSE;
- }
- for (j = 0; j < nent; j++) {
- if (verb) fprintf ( stderr, " %2d ", j );
- if (verb) fprintf ( stderr, " sec=%-5d size=%-3d val=%-5p ",
- (int)stab[j].st_shndx,
- (int)stab[j].st_size,
- (char*)stab[j].st_value );
-
- if (verb) fprintf ( stderr, "type=" );
- switch (ELF32_ST_TYPE(stab[j].st_info)) {
- case STT_NOTYPE: if (verb) fprintf ( stderr, "notype " ); break;
- case STT_OBJECT: if (verb) fprintf ( stderr, "object " ); break;
- case STT_FUNC : if (verb) fprintf ( stderr, "func " ); break;
- case STT_SECTION: if (verb) fprintf ( stderr, "section" ); break;
- case STT_FILE: if (verb) fprintf ( stderr, "file " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "bind=" );
- switch (ELF32_ST_BIND(stab[j].st_info)) {
- case STB_LOCAL : if (verb) fprintf ( stderr, "local " ); break;
- case STB_GLOBAL: if (verb) fprintf ( stderr, "global" ); break;
- case STB_WEAK : if (verb) fprintf ( stderr, "weak " ); break;
- default: if (verb) fprintf ( stderr, "? " ); break;
- }
- if (verb) fprintf ( stderr, " " );
-
- if (verb) fprintf ( stderr, "name=%s\n", strtab + stab[j].st_name );
- }
- }
-
- if (nsymtabs == 0) {
- oc->errMsg("Didn't find any symbol tables");
- return FALSE;
- }
-
- return TRUE;
-}
-
-
-static int ocGetNames_ELF ( ObjectCode* oc, int verb )
-{
- int i, j, k, nent;
- Elf32_Sym* stab;
-
- char* ehdrC = (char*)(oc->oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*)ehdrC;
- char* strtab = findElfSection ( ehdrC, SHT_STRTAB );
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset;
-
- if (!strtab) {
- oc->errMsg("ELF: no strtab!");
- return FALSE;
- }
-
- k = 0;
- for (i = 0; i < ehdr->e_shnum; i++) {
-
- /* make a HugsDLSection entry for relevant sections */
- OSectionKind kind = HUGS_SECTIONKIND_OTHER;
- if (0==strcmp(".data",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".data1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_SECTIONKIND_RWDATA;
- if (0==strcmp(".text",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata",sh_strtab+shdr[i].sh_name) ||
- 0==strcmp(".rodata1",sh_strtab+shdr[i].sh_name))
- kind = HUGS_SECTIONKIND_CODE_OR_RODATA;
- if (kind != HUGS_SECTIONKIND_OTHER)
- addSection (
- oc,
- ehdrC + shdr[i].sh_offset,
- ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1,
- kind
- );
-
- if (shdr[i].sh_type != SHT_SYMTAB) continue;
-
- /* copy stuff into this module's object symbol table */
- stab = (Elf32_Sym*) (ehdrC + shdr[i].sh_offset);
- nent = shdr[i].sh_size / sizeof(Elf32_Sym);
- for (j = 0; j < nent; j++) {
- if ( ( ELF32_ST_BIND(stab[j].st_info)==STB_GLOBAL ||
- ELF32_ST_BIND(stab[j].st_info)==STB_LOCAL
- )
- &&
- ( ELF32_ST_TYPE(stab[j].st_info)==STT_FUNC ||
- ELF32_ST_TYPE(stab[j].st_info)==STT_OBJECT)
- /* || ELF32_ST_TYPE(stab[j].st_info)==STT_NOTYPE */
- ) {
- char* nm = strtab + stab[j].st_name;
- char* ad = ehdrC
- + shdr[ stab[j].st_shndx ].sh_offset
- + stab[j].st_value;
- assert(nm);
- assert(ad);
- if (verb)
- fprintf(stderr, "addOTabName: %10p %s %s\n",
- ad, oc->objFileName, nm );
- if (!addSymbol ( oc, nm, ad )) return FALSE;
- }
- else
- if (verb)
- fprintf(stderr, "skipping `%s'\n", strtab + stab[j].st_name );
- }
- }
-
- return TRUE;
-}
-
-
-static int ocResolve_ELF ( ObjectCode* oc, int verb )
-{
- char symbol[1000]; // ToDo
- char* strtab;
- int i, j;
- Elf32_Sym* stab = NULL;
- char* ehdrC = (char*)(oc->oImage);
- Elf32_Ehdr* ehdr = (Elf32_Ehdr*) ehdrC;
- Elf32_Shdr* shdr = (Elf32_Shdr*) (ehdrC + ehdr->e_shoff);
- Elf32_Word* targ;
-
- /* first find "the" symbol table */
- stab = (Elf32_Sym*) findElfSection ( ehdrC, SHT_SYMTAB );
-
- /* also go find the string table */
- strtab = findElfSection ( ehdrC, SHT_STRTAB );
-
- if (!stab || !strtab) {
- oc->errMsg("can't find string or symbol table");
- return FALSE;
- }
-
- for (i = 0; i < ehdr->e_shnum; i++) {
- if (shdr[i].sh_type == SHT_REL ) {
- Elf32_Rel* rtab = (Elf32_Rel*) (ehdrC + shdr[i].sh_offset);
- int nent = shdr[i].sh_size / sizeof(Elf32_Rel);
- int target_shndx = shdr[i].sh_info;
- int symtab_shndx = shdr[i].sh_link;
- stab = (Elf32_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset);
- targ = (Elf32_Word*)(ehdrC + shdr[ target_shndx ].sh_offset);
- if (verb)
- fprintf ( stderr,
- "relocations for section %d using symtab %d\n",
- target_shndx, symtab_shndx );
- for (j = 0; j < nent; j++) {
- Elf32_Addr offset = rtab[j].r_offset;
- Elf32_Word info = rtab[j].r_info;
-
- Elf32_Addr P = ((Elf32_Addr)targ) + offset;
- Elf32_Word* pP = (Elf32_Word*)P;
- Elf32_Addr A = *pP;
- Elf32_Addr S;
-
- if (verb) fprintf ( stderr, "Rel entry %3d is raw(%6p %6p) ",
- j, (void*)offset, (void*)info );
- if (!info) {
- if (verb) fprintf ( stderr, " ZERO\n" );
- S = 0;
- } else {
- /* First see if it is a nameless local symbol. */
- if (stab[ ELF32_R_SYM(info)].st_name == 0) {
- if (verb) fprintf ( stderr, "(noname) ");
- S = (Elf32_Addr)(ehdrC
- + shdr[stab[ELF32_R_SYM(info)].st_shndx ].sh_offset
- + stab[ELF32_R_SYM(info)].st_value
- );
- strcpy ( symbol, "(noname)");
- } else {
- /* No? Perhaps it's a named symbol in this file. */
- strcpy ( symbol, strtab+stab[ ELF32_R_SYM(info)].st_name );
- if (verb) fprintf ( stderr, "`%s' ", symbol );
- S = (Elf32_Addr)ocLookupSym ( oc, symbol );
- if (!S) {
- /* No? Ok, too hard. Hand the problem to the client.
- And if that fails, we're outta options.
- */
- S = (Elf32_Addr)(oc->clientLookup ( symbol ) );
- }
- }
- if (verb) fprintf ( stderr, "resolves to %p\n", (void*)S );
- if (!S) {
- char errtxt[2000];
- strcpy(errtxt,oc->objFileName);
- strcat(errtxt,": unresolvable reference to: ");
- strcat(errtxt,symbol);
- oc->errMsg(errtxt);
- return FALSE;
- }
- }
- /* fprintf ( stderr, "Reloc: P = %p S = %p A = %p\n\n",
- (void*)P, (void*)S, (void*)A );
- */
- switch (ELF32_R_TYPE(info)) {
-# if defined(linux_TARGET_OS)
- case R_386_32: *pP = S + A; break;
- case R_386_PC32: *pP = S + A - P; break;
-# endif
- default: fprintf(stderr,
- "unhandled ELF relocation type %d\n",
- ELF32_R_TYPE(info));
- oc->errMsg("unhandled ELF relocation type");
- return FALSE;
- }
-
- }
- }
- else
- if (shdr[i].sh_type == SHT_RELA) {
- oc->errMsg("RelA style reloc table -- not yet done");
- return FALSE;
- }
- }
-
- return TRUE;
-}
-
-
-#endif /* defined(linux_TARGET_OS) || defined(solaris2_TARGET_OS) */
-
-
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Machinery for dynamic loading and linking of object code. Should be
- * completely independent from the rest of Hugs so we can use it in
- * other applications if desired.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * ------------------------------------------------------------------------*/
-
-#ifndef __HUGS_OBJECT_H
-#define __HUGS_OBJECT_H
-
-/* An entry in a very crude object symbol table */
-typedef struct { char* nm; void* ad; }
- OSym;
-
-
-/* Indication of section kinds for loaded objects. Needed by
- the GC for deciding whether or not a pointer on the stack
- is a code pointer.
-*/
-typedef enum { HUGS_SECTIONKIND_CODE_OR_RODATA,
- HUGS_SECTIONKIND_RWDATA,
- HUGS_SECTIONKIND_OTHER,
- HUGS_SECTIONKIND_NOINFOAVAIL }
- OSectionKind;
-
-typedef struct { void* start; void* end; OSectionKind kind; }
- OSection;
-
-
-/* Indication of the status of an ObjectCode structure.
- NOTINUSE -- currently unused.
- OIMAGE -- object image is in memory, but that's all.
- VERIFIED -- OIMAGE + the loaded image has been verified as
- a valid object file.
- HAVENAMES -- VERIFIED + names *defined* in this image have been
- extracted from the image and placed in the oTab,
- and also section info placed in sectionTab.
- RESOLVED -- HAVENAMES + all names *used* in this image have
- successfully been resolved.
-
-*/
-typedef enum { OBJECT_NOTINUSE,
- OBJECT_OIMAGE,
- OBJECT_VERIFIED,
- OBJECT_HAVENAMES,
- OBJECT_RESOLVED }
- OStatus;
-
-
-/* Top-level structure for an object module. One of these is allocated
- for each object file in use. This should really be an abstract type
- to clients.
-*/
-typedef
- struct __ObjectCode {
- OStatus status;
- char* objFileName;
- int objFileSize;
- char* formatName; /* eg "ELF32", "DLL", "COFF", etc. */
-
- /* proc to call to deliver an error message to the client. */
- void (*errMsg)(char*);
-
- /* proc to call to resolve symbols not defined in this module,
- when asked to resolve symbols in this module (in ocResolve) */
- void* (*clientLookup)(char*);
-
- /* proc used during ocGetNames to ask client if it wants to
- acquire a given symbol from the obj file. */
- int (*clientWantsSymbol)(char*);
-
- /* ptr to malloc'd lump of memory holding the obj file */
- void* oImage;
-
- /* ptr to object symbol table; lives in mallocville.
- Dynamically expands. */
- OSym* oTab;
- int sizeoTab;
- int usedoTab;
-
- /* The section-kind entries for this object module.
- Dynamically expands. */
- OSection* sectionTab;
- int sizesectionTab;
- int usedsectionTab;
-
- /* Allow a chain of these things */
- struct __ObjectCode * next;
- }
- ObjectCode;
-
-
-/* The API */
-extern ObjectCode* ocNew ( void (*errMsg)(char*),
- void* (*clientLookup)(char*),
- int (*clientWantsSymbol)(char*),
- char* objFileName,
- int objFileSize );
-
-extern int /*Bool*/ ocLoadImage ( ObjectCode* oc, int verb );
-extern int /*Bool*/ ocVerifyImage ( ObjectCode* oc, int verb );
-extern int /*Bool*/ ocGetNames ( ObjectCode* oc, int verb );
-extern int /*Bool*/ ocResolve ( ObjectCode* oc, int verb );
-extern void ocFree ( ObjectCode* oc );
-
-extern void* ocLookupSym ( ObjectCode* oc, char* sym );
-extern char* ocLookupAddr ( ObjectCode* oc, void* addr );
-extern OSectionKind ocLookupSection ( ObjectCode* oc, void* addr );
-
-#endif
-
-/*-------------------------------------------------------------------------*/
-
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Unparse expressions and types - for use in error messages, type checker
- * and for debugging.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: output.c,v $
- * $Revision: 1.18 $
- * $Date: 2000/04/25 17:43:50 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include <ctype.h>
-
-#define DEPTH_LIMIT 15
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local put ( Int,Cell );
-static Void local putFlds ( Cell,List );
-static Void local putComp ( Cell,List );
-static Void local putQual ( Cell );
-static Bool local isDictVal ( Cell );
-static Cell local maySkipDict ( Cell );
-static Void local putAp ( Int,Cell );
-static Void local putOverInfix ( Int,Text,Syntax,Cell );
-static Void local putInfix ( Int,Text,Syntax,Cell,Cell );
-static Void local putSimpleAp ( Cell,Int );
-static Void local putTuple ( Int,Cell );
-static Int local unusedTups ( Int,Cell );
-static Void local unlexOp ( Text );
-
-static Void local putSigType ( Cell );
-static Void local putContext ( List,List,Int );
-static Void local putPred ( Cell,Int );
-static Void local putType ( Cell,Int,Int );
-static Void local putTyVar ( Int );
-static Bool local putTupleType ( Cell,Int );
-static Void local putApType ( Type,Int,Int );
-
-static Void local putKind ( Kind );
-static Void local putKinds ( Kinds );
-
-
-/* --------------------------------------------------------------------------
- * Basic output routines:
- * ------------------------------------------------------------------------*/
-
-FILE *outputStream; /* current output stream */
-Int outColumn = 0; /* current output column number */
-
-#define OPEN(b) if (b) putChr('(');
-#define CLOSE(b) if (b) putChr(')');
-
-Void putChr(c) /* print single character */
-Int c; {
- Putc(c,outputStream);
- outColumn++;
-}
-
-Void putStr(s) /* print string */
-String s; {
- for (; *s; s++) {
- Putc(*s,outputStream);
- outColumn++;
- }
-}
-
-Void putInt(n) /* print integer */
-Int n; {
- static char intBuf[16];
- sprintf(intBuf,"%d",n);
- putStr(intBuf);
-}
-
-Void putPtr(p) /* print pointer */
-Ptr p; {
- static char intBuf[16];
- sprintf(intBuf,"%p",p);
- putStr(intBuf);
-}
-
-/* --------------------------------------------------------------------------
- * Precedence values (See Haskell 1.3 report, p.12):
- * ------------------------------------------------------------------------*/
-
-#define ALWAYS FUN_PREC /* Always use parens (unless atomic)*/
- /* User defined operators have prec */
- /* in the range MIN_PREC..MAX_PREC */
-#define ARROW_PREC MAX_PREC /* for printing -> in type exprs */
-#define COCO_PREC (MIN_PREC-1) /* :: is left assoc, low precedence */
-#define COND_PREC (MIN_PREC-2) /* conditional expressions */
-#define WHERE_PREC (MIN_PREC-3) /* where expressions */
-#define LAM_PREC (MIN_PREC-4) /* lambda abstraction */
-#define NEVER LAM_PREC /* Never use parentheses */
-
-
-/* --------------------------------------------------------------------------
- * Print an expression (used to display context of type errors):
- * ------------------------------------------------------------------------*/
-
-static Int putDepth = 0; /* limits depth of printing DBG */
-
-static Void local put(d,e) /* print expression e in context of */
-Int d; /* operator of precedence d */
-Cell e; {
- List xs;
-
- if (putDepth>DEPTH_LIMIT) {
- putStr("...");
- return;
- }
- else
- putDepth++;
-
- switch (whatIs(e)) {
- case FINLIST : putChr('[');
- xs = snd(e);
- if (nonNull(xs)) {
- put(NEVER,hd(xs));
- while (nonNull(xs=tl(xs))) {
- putChr(',');
- put(NEVER,hd(xs));
- }
- }
- putChr(']');
- break;
-
- case AP : putAp(d,e);
- break;
-
- case NAME : unlexVar(name(e).text);
- break;
-
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR :
- case CONIDCELL :
- case CONOPCELL : unlexVar(textOf(e));
- break;
-
-#if IPARAM
- case IPVAR : putChr('?');
- unlexVar(textOf(e));
- break;
-
- case WITHEXP : OPEN(d>WHERE_PREC);
- putStr("dlet {...} in ");
- put(WHERE_PREC+1,fst(snd(e)));
- CLOSE(d>WHERE_PREC);
- break;
-#endif
-
-#if TREX
- case RECSEL : putChr('#');
- unlexVar(extText(snd(e)));
- break;
-#endif
-
- case FREECELL : putStr("{free!}");
- break;
-
- case TUPLE : putTuple(tupleOf(e),e);
- break;
-
- case WILDCARD : putChr('_');
- break;
-
- case ASPAT : put(NEVER,fst(snd(e)));
- putChr('@');
- put(ALWAYS,snd(snd(e)));
- break;
-
- case LAZYPAT : putChr('~');
- put(ALWAYS,snd(e));
- break;
-
- case DOCOMP : putStr("do {...}");
- break;
-
- case MDOCOMP : putStr("do {...}");
- break;
-
- case COMP : putComp(fst(snd(e)),snd(snd(e)));
- break;
-
- case MONADCOMP : putComp(fst(snd(snd(e))),snd(snd(snd(e))));
- break;
-
- case CHARCELL : unlexCharConst(charOf(e));
- break;
-
- case INTCELL : { Int i = intOf(e);
- if (i<0 && d>=UMINUS_PREC) putChr('(');
- putInt(i);
- if (i<0 && d>=UMINUS_PREC) putChr(')');
- }
- break;
-
- case FLOATCELL : { Float f = floatOf(e);
- if (f<0 && d>=UMINUS_PREC) putChr('(');
- putStr(floatToString(e));
- if (f<0 && d>=UMINUS_PREC) putChr(')');
- }
- break;
-
- case STRCELL : unlexStrConst(textOf(e));
- break;
-
- case LETREC : OPEN(d>WHERE_PREC);
-#if 0
- putStr("let {");
- put(NEVER,fst(snd(e)));
- putStr("} in ");
-#else
- putStr("let {...} in ");
-#endif
- put(WHERE_PREC+1,snd(snd(e)));
- CLOSE(d>WHERE_PREC);
- break;
-
- case COND : OPEN(d>COND_PREC);
- putStr("if ");
- put(COND_PREC+1,fst3(snd(e)));
- putStr(" then ");
- put(COND_PREC+1,snd3(snd(e)));
- putStr(" else ");
- put(COND_PREC+1,thd3(snd(e)));
- CLOSE(d>COND_PREC);
- break;
-
- case LAMBDA : xs = fst(snd(e));
- if (whatIs(xs)==BIGLAM)
- xs = snd(snd(xs));
- while (nonNull(xs) && isDictVal(hd(xs)))
- xs = tl(xs);
- if (isNull(xs)) {
- put(d,snd(snd(snd(e))));
- break;
- }
- OPEN(d>LAM_PREC);
- putChr('\\');
- if (nonNull(xs)) {
- put(ALWAYS,hd(xs));
- while (nonNull(xs=tl(xs))) {
- putChr(' ');
- put(ALWAYS,hd(xs));
- }
- }
- putStr(" -> ");
- put(LAM_PREC,snd(snd(snd(e))));
- CLOSE(d>LAM_PREC);
- break;
-
- case ESIGN : OPEN(d>COCO_PREC);
- put(COCO_PREC,fst(snd(e)));
- putStr(" :: ");
- putSigType(snd(snd(e)));
- CLOSE(d>COCO_PREC);
- break;
-
- case BIGLAM : put(d,snd(snd(e)));
- break;
-
- case CASE : putStr("case ");
- put(NEVER,fst(snd(e)));
-#if 0
- putStr(" of {");
- put(NEVER,snd(snd(e)));
- putChr('}');
-#else
- putStr(" of {...}");
-#endif
- break;
-
- case CONFLDS : putFlds(fst(snd(e)),snd(snd(e)));
- break;
-
- case UPDFLDS : putFlds(fst3(snd(e)),thd3(snd(e)));
- break;
-
- default : /*internal("put");*/
- putChr('$');
- putInt(e);
- break;
- }
- putDepth--;
-}
-
-static Void local putFlds(exp,fs) /* Output exp using labelled fields*/
-Cell exp;
-List fs; {
- put(ALWAYS,exp);
- putChr('{');
- for (; nonNull(fs); fs=tl(fs)) {
- Cell v = hd(fs);
- if (isVar(v))
- put(NEVER,v);
- else {
- Cell f = fst(v);
- Cell e = snd(v);
- Text t = isName(f) ? name(f).text :
- isVar(f) ? textOf(f) : inventText();
- Text s = isName(e) ? name(e).text :
- isVar(e) ? textOf(e) : inventText();
-
- put(NEVER,f);
- if (haskell98 || s!=t) {
- putStr(" = ");
- put(NEVER,e);
- }
- }
- if (nonNull(tl(fs)))
- putStr(", ");
- }
- putChr('}');
-}
-
-static Void local putComp(e,qs) /* print comprehension */
-Cell e;
-List qs; {
- putStr("[ ");
- put(NEVER,e);
- if (nonNull(qs)) {
- putStr(" | ");
- putQual(hd(qs));
- while (nonNull(qs=tl(qs))) {
- putStr(", ");
- putQual(hd(qs));
- }
- }
- putStr(" ]");
-}
-
-static Void local putQual(q) /* print list comp qualifier */
-Cell q; {
- switch (whatIs(q)) {
- case BOOLQUAL : put(NEVER,snd(q));
- return;
-
- case QWHERE : putStr("let {...}");
- return;
-
- case FROMQUAL : put(ALWAYS,fst(snd(q)));
- putStr("<-");
- put(NEVER,snd(snd(q)));
- return;
- }
-}
-
-static Bool local isDictVal(e) /* Look for dictionary value */
-Cell e; {
-#if 0 /* was !DEBUG_CODE -- is it necessary? */
- Cell h = getHead(e);
- switch (whatIs(h)) {
- case DICTVAR : return TRUE;
- case NAME : return isDfun(h);
- }
-#endif
- return FALSE;
-}
-
-static Cell local maySkipDict(e) /* descend function application, */
-Cell e; { /* ignoring dict aps */
- while (isAp(e) && isDictVal(arg(e)))
- e = fun(e);
- return e;
-}
-
-static Void local putAp(d,e) /* print application (args>=1) */
-Int d;
-Cell e; {
- Cell h;
- Text t = 0; /* bogus init to keep gcc -O happy */
- Syntax sy;
- Int args = 0;
-
- for (h=e; isAp(h); h=fun(h)) /* find head of expression, looking*/
- if (!isDictVal(arg(h))) /* for dictionary arguments */
- args++;
-
- if (args==0) { /* Special case when *all* args */
- put(d,h); /* are dictionary values */
- return;
- }
-
- switch (whatIs(h)) {
- case ADDPAT : if (args==1)
- putInfix(d,textPlus,syntaxOf(namePlus),
- arg(e),mkInt(intValOf(fun(e))));
- else
- putStr("ADDPAT");
- return;
-
- case TUPLE : OPEN(args>tupleOf(h) && d>=FUN_PREC);
- putTuple(tupleOf(h),e);
- CLOSE(args>tupleOf(h) && d>=FUN_PREC);
- return;
-
- case NAME : if (args==1 &&
- ((h==nameFromInt && isInt(arg(e))) ||
- (h==nameFromDouble && isFloat(arg(e))))) {
- put(d,arg(e));
- return;
- }
- t = name(h).text;
- sy = syntaxOf(h);
- break;
-
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR :
- case CONIDCELL :
- case CONOPCELL : sy = defaultSyntax(t = textOf(h));
- break;
-
-#if TREX
- case EXT : if (args==2) {
- String punc = "(";
- do {
- putStr(punc);
- punc = ", ";
- putStr(textToStr(extText(h)));
- putStr("=");
- put(NEVER,extField(e));
- args = 0;
- e = extRow(e);
- for (h=e; isAp(h); h=fun(h))
- if (!isDictVal(arg(h)))
- args++;
- } while (isExt(h) && args==2);
- if (e!=nameNoRec) {
- putStr(" | ");
- put(NEVER,e);
- }
- putChr(')');
- return;
- }
- else if (args<2)
- internal("putExt");
- else
- args-=2;
- break;
-#endif
-
- default : sy = APPLIC;
- break;
- }
-
- e = maySkipDict(e);
-
- if (sy==APPLIC) { /* print simple application */
- OPEN(d>=FUN_PREC);
- putSimpleAp(e,args);
- CLOSE(d>=FUN_PREC);
- return;
- }
- else if (args==1) { /* print section of the form (e+) */
- putChr('(');
- put(FUN_PREC-1,arg(e));
- putChr(' ');
- unlexOp(t);
- putChr(')');
- }
- else if (args==2) /* infix expr of the form e1 + e2 */
- putInfix(d,t,sy,arg(maySkipDict(fun(e))),arg(e));
- else { /* o/w (e1 + e2) e3 ... en (n>=3) */
- OPEN(d>=FUN_PREC);
- putOverInfix(args,t,sy,e);
- CLOSE(d>=FUN_PREC);
- }
-}
-
-static Void local putOverInfix(args,t,sy,e)
-Int args; /* infix applied to >= 3 arguments */
-Text t;
-Syntax sy;
-Cell e; {
- if (args>2) {
- putOverInfix(args-1,t,sy,maySkipDict(fun(e)));
- putChr(' ');
- put(FUN_PREC,arg(e));
- }
- else
- putInfix(ALWAYS,t,sy,arg(maySkipDict(fun(e))),arg(e));
-}
-
-static Void local putInfix(d,t,sy,e,f) /* print infix expression */
-Int d;
-Text t; /* Infix operator symbol */
-Syntax sy; /* with name t, syntax s */
-Cell e, f; { /* Left and right operands */
- Syntax a = assocOf(sy);
- Int p = precOf(sy);
-
- OPEN(d>p);
- put((a==LEFT_ASS ? p : 1+p), e);
- putChr(' ');
- unlexOp(t);
- putChr(' ');
- put((a==RIGHT_ASS ? p : 1+p), f);
- CLOSE(d>p);
-}
-
-static Void local putSimpleAp(e,n) /* print application e0 e1 ... en */
-Cell e;
-Int n; {
- if (n>0) {
- putSimpleAp(maySkipDict(fun(e)),n-1);
- putChr(' ');
- put(FUN_PREC,arg(e));
- }
- else
- put(FUN_PREC,e);
-}
-
-static Void local putTuple(ts,e) /* Print tuple expression, allowing*/
-Int ts; /* for possibility of either too */
-Cell e; { /* few or too many args to constr */
- Int i;
- putChr('(');
- if ((i=unusedTups(ts,e))>0) {
- while (--i>0)
- putChr(',');
- putChr(')');
- }
-}
-
-static Int local unusedTups(ts,e) /* print first part of tuple expr */
-Int ts; /* returning number of constructor */
-Cell e; { /* args not yet printed ... */
- if (isAp(e)) {
- if ((ts=unusedTups(ts,fun(e))-1)>=0) {
- put(NEVER,arg(e));
- putChr(ts>0?',':')');
- }
- else {
- putChr(' ');
- put(FUN_PREC,arg(e));
- }
- }
- return ts;
-}
-
-Void unlexVarStr(s)
-String s; {
- if ((isascii((int)(s[0])) && isalpha((int)(s[0])))
- || s[0]=='_' || s[0]=='[' || s[0]=='('
- || s[0]=='$'
- || (s[0]==':' && s[1]=='D')
- )
- putStr(s);
- else {
- putChr('(');
- putStr(s);
- putChr(')');
- }
-}
-
-Void unlexVar(t) /* print text as a variable name */
-Text t; { /* operator symbols must be enclosed*/
- unlexVarStr(textToStr(t)); /* in parentheses... except [] ... */
-}
-
-static Void local unlexOp(t) /* print text as operator name */
-Text t; { /* alpha numeric symbols must be */
- String s = textToStr(t); /* enclosed by backquotes */
-
- if (isascii((int)(s[0])) && isalpha((int)(s[0]))) {
- putChr('`');
- putStr(s);
- putChr('`');
- }
- else
- putStr(s);
-}
-
-Void unlexCharConst(c)
-Cell c; {
- putChr('\'');
- putStr(unlexChar(c,'\''));
- putChr('\'');
-}
-
-Void unlexStrConst(t)
-Text t; {
- String s = textToStr(t);
- static Char SO = 14; /* ASCII code for '\SO' */
- Bool lastWasSO = FALSE;
- Bool lastWasDigit = FALSE;
- Bool lastWasEsc = FALSE;
-
- putChr('\"');
- for (; *s; s++) {
- String ch = unlexChar(*s,'\"');
- Char c = ' ';
-
- if ((lastWasSO && *ch=='H') ||
- (lastWasEsc && lastWasDigit
- && isascii((int)(*ch)) && isdigit((int)(*ch))))
- putStr("\\&");
-
- lastWasEsc = (*ch=='\\');
- lastWasSO = (*s==SO);
- for (; *ch; c = *ch++)
- putChr(*ch);
- lastWasDigit = (isascii(c) && isdigit(c));
- }
- putChr('\"');
-}
-
-/* --------------------------------------------------------------------------
- * Print type expression:
- * ------------------------------------------------------------------------*/
-
-static Void local putSigType(t) /* print (possibly) generic type */
-Cell t; {
- Int fr = 0;
- if (isPolyType(t)) {
- Kinds ks = polySigOf(t);
- for (; isAp(ks); ks=tl(ks))
- fr++;
- t = monotypeOf(t);
- }
-
- putType(t,NEVER,fr); /* Finally, print rest of type ... */
-}
-
-static Void local putContext(ps,qs,fr) /* print context list */
-List ps;
-List qs;
-Int fr; {
- Int len = length(ps) + length(qs);
- Int c = len;
-#if IPARAM
- Bool useParens = len!=1 || isIP(fun(hd(ps)));
-#else
- Bool useParens = len!=1;
-#endif
- if (useParens)
- putChr('(');
- for (; nonNull(ps); ps=tl(ps)) {
- putPred(hd(ps),fr);
- if (--c > 0) {
- putStr(", ");
- }
- }
- for (; nonNull(qs); qs=tl(qs)) {
- putPred(hd(qs),fr);
- if (--c > 0) {
- putStr(", ");
- }
- }
- if (useParens)
- putChr(')');
-}
-
-static Void local putPred(pi,fr) /* Output predicate */
-Cell pi;
-Int fr; {
- if (isAp(pi)) {
-#if TREX
- if (isExt(fun(pi))) {
- putType(arg(pi),ALWAYS,fr);
- putChr('\\');
- putStr(textToStr(extText(fun(pi))));
- return;
- }
-#endif
-#if IPARAM
- if (whatIs(fun(pi)) == IPCELL) {
- putChr('?');
- putPred(fun(pi),fr);
- putStr(" :: ");
- putType(arg(pi),NEVER,fr);
- return;
- }
-#endif
- putPred(fun(pi),fr);
- putChr(' ');
- putType(arg(pi),ALWAYS,fr);
- }
- else if (isClass(pi))
- putStr(textToStr(cclass(pi).text));
- else if (isCon(pi))
- putStr(textToStr(textOf(pi)));
-#if IPARAM
- else if (whatIs(pi) == IPCELL)
- unlexVar(textOf(pi));
-#endif
- else
- putStr("<unknownPredicate>");
-}
-
-static Void local putType(t,prec,fr) /* print nongeneric type expression*/
-Cell t;
-Int prec;
-Int fr; {
- switch(whatIs(t)) {
- case TYCON : putStr(textToStr(tycon(t).text));
- break;
-
- case TUPLE : { Int n = tupleOf(t);
- putChr('(');
- while (--n > 0)
- putChr(',');
- putChr(')');
- }
- break;
-
- case POLYTYPE : { Kinds ks = polySigOf(t);
- OPEN(prec>=ARROW_PREC);
- putStr("forall ");
- for (; isAp(ks); ks=tl(ks)) {
- putTyVar(fr++);
- if (isAp(tl(ks)))
- putChr(' ');
- }
- putStr(". ");
- putType(monotypeOf(t),NEVER,fr);
- CLOSE(prec>=ARROW_PREC);
- }
- break;
-
- case CDICTS :
- case QUAL : OPEN(prec>=ARROW_PREC);
- if (whatIs(snd(snd(t)))==CDICTS) {
- putContext(fst(snd(t)),fst(snd(snd(snd(t)))),fr);
- putStr(" => ");
- putType(snd(snd(snd(snd(t)))),NEVER,fr);
- } else {
- putContext(fst(snd(t)),NIL,fr);
- putStr(" => ");
- putType(snd(snd(t)),NEVER,fr);
- }
- CLOSE(prec>=ARROW_PREC);
- break;
-
- case EXIST :
- case RANK2 : putType(snd(snd(t)),prec,fr);
- break;
-
- case OFFSET : putTyVar(offsetOf(t));
- break;
-
- case VARIDCELL :
- case VAROPCELL : putChr('_');
- unlexVar(textOf(t));
- break;
-
- case INTCELL : putChr('_');
- putInt(intOf(t));
- break;
-
- case AP : { Cell typeHead = getHead(t);
- Bool brackets = (argCount!=0 && prec>=ALWAYS);
- Int args = argCount;
-
- if (typeHead==typeList) {
- if (argCount==1) {
- putChr('[');
- putType(arg(t),NEVER,fr);
- putChr(']');
- return;
- }
- }
- else if (typeHead==typeArrow) {
- if (argCount==2) {
- OPEN(prec>=ARROW_PREC);
- putType(arg(fun(t)),ARROW_PREC,fr);
- putStr(" -> ");
- putType(arg(t),NEVER,fr);
- CLOSE(prec>=ARROW_PREC);
- return;
- }
-#if 0
- else if (argCount==1) {
- putChr('(');
- putType(arg(t),ARROW_PREC,fr);
- putStr("->)");
- return;
- }
-#endif
- }
- else if (isTuple(typeHead)) {
- if (argCount==tupleOf(typeHead)) {
- putChr('(');
- putTupleType(t,fr);
- putChr(')');
- return;
- }
- }
-#if TREX
- else if (isExt(typeHead)) {
- if (args==2) {
- String punc = "(";
- do {
- putStr(punc);
- punc = ", ";
- putStr(textToStr(extText(typeHead)));
- putStr(" :: ");
- putType(extField(t),NEVER,fr);
- t = extRow(t);
- typeHead = getHead(t);
- } while (isExt(typeHead) && argCount==2);
- if (t!=typeNoRow) {
- putStr(" | ");
- putType(t,NEVER,fr);
- }
- putChr(')');
- return;
- }
- else if (args<2)
- internal("putExt");
- else
- args-=2;
- }
-#endif
- OPEN(brackets);
- putApType(t,args,fr);
- CLOSE(brackets);
- }
- break;
-
- default : putStr("(bad type)");
- }
-}
-
-static Void local putTyVar(n) /* print type variable */
-Int n; {
- static String alphabet /* for the benefit of EBCDIC :-) */
- ="abcdefghijklmnopqrstuvwxyz";
- putChr(alphabet[n%26]);
- if (n /= 26) /* just in case there are > 26 vars*/
- putInt(n);
-}
-
-static Bool local putTupleType(e,fr) /* print tuple of types, returning */
-Cell e; /* TRUE if something was printed, */
-Int fr; { /* FALSE otherwise; used to control*/
- if (isAp(e)) { /* printing of intermed. commas */
- if (putTupleType(fun(e),fr))
- putChr(',');
- putType(arg(e),NEVER,fr);
- return TRUE;
- }
- return FALSE;
-}
-
-static Void local putApType(t,n,fr) /* print type application */
-Cell t;
-Int n;
-Int fr; {
- if (n>0) {
- putApType(fun(t),n-1,fr);
- putChr(' ');
- putType(arg(t),ALWAYS,fr);
- }
- else
- putType(t,ALWAYS,fr);
-}
-
-/* --------------------------------------------------------------------------
- * Print kind expression:
- * ------------------------------------------------------------------------*/
-
-static Void local putKind(k) /* print kind expression */
-Kind k; {
- switch (whatIs(k)) {
- case AP : if (isAp(fst(k))) {
- putChr('(');
- putKind(fst(k));
- putChr(')');
- }
- else
- putKind(fst(k));
- putStr(" -> ");
- putKind(snd(k));
- break;
-
-#if TREX
- case ROW : putStr("row");
- break;
-#endif
-
- case STAR : putChr('*');
- break;
-
- case OFFSET : putTyVar(offsetOf(k));
- break;
-
- case INTCELL : putChr('_');
- putInt(intOf(k));
- break;
-
- default : putStr("(bad kind)");
- }
-}
-
-static Void local putKinds(ks) /* Print list of kinds */
-Kinds ks; {
- if (isNull(ks))
- putStr("()");
- else if (nonNull(tl(ks))) {
- putChr('(');
- putKind(hd(ks));
- while (nonNull(ks=tl(ks))) {
- putChr(',');
- putKind(hd(ks));
- }
- putChr(')');
- }
- else
- putKind(hd(ks));
-}
-
-/* --------------------------------------------------------------------------
- * Main drivers:
- * ------------------------------------------------------------------------*/
-
-FILE *mystdout ( Void ) {
- /* We use this from the gdb command line when debugging */
- return stdout;
-}
-
-Void printExp(fp,e) /* print expr on specified stream */
-FILE *fp;
-Cell e; {
- outputStream = fp;
- putDepth = 0;
- put(NEVER,e);
-}
-
-Void printType(fp,t) /* print type on specified stream */
-FILE *fp;
-Cell t; {
- outputStream = fp;
- putSigType(t);
-}
-
-Void printContext(fp,qs) /* print context on spec. stream */
-FILE *fp;
-List qs; {
- outputStream = fp;
- putContext(qs,NIL,0);
-}
-
-Void printPred(fp,pi) /* print predicate pi on stream */
-FILE *fp;
-Cell pi; {
- outputStream = fp;
- putPred(pi,0);
-}
-
-Void printKind(fp,k) /* print kind k on stream */
-FILE *fp;
-Kind k; {
- outputStream = fp;
- putKind(k);
-}
-
-Void printKinds(fp,ks) /* print list of kinds on stream */
-FILE *fp;
-Kinds ks; {
- outputStream = fp;
- putKinds(ks);
-}
-
-Void printFD(fp,fd) /* print functional dependency */
-FILE* fp;
-Pair fd; {
- List us;
- outputStream = fp;
- for (us=fst(fd); nonNull(us); us=tl(us)) {
- putTyVar(offsetOf(hd(us)));
- if (nonNull(tl(us))) {
- putChr(' ');
- }
- }
- putStr(" -> ");
- for (us=snd(fd); nonNull(us); us=tl(us)) {
- putTyVar(offsetOf(hd(us)));
- if (nonNull(tl(us))) {
- putChr(' ');
- }
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Hugs parser (included as part of input.c)
- *
- * Expect 6 shift/reduce conflicts when passing this grammar through yacc,
- * but don't worry; they should all be resolved in an appropriate manner.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: parser.y,v $
- * $Revision: 1.30 $
- * $Date: 2000/04/25 17:43:50 $
- * ------------------------------------------------------------------------*/
-
-%{
-#ifndef lint
-#define lint
-#endif
-#define sigdecl(l,vs,t) ap(SIGDECL,triple(l,vs,t))
-#define fixdecl(l,ops,a,p) ap(FIXDECL,\
- triple(l,ops,mkInt(mkSyntax(a,intOf(p)))))
-#define grded(gs) ap(GUARDED,gs)
-#define only(t) ap(ONLY,t)
-#define letrec(bs,e) (nonNull(bs) ? ap(LETREC,pair(bs,e)) : e)
-#define qualify(ps,t) (nonNull(ps) ? ap(QUAL,pair(ps,t)) : t)
-#define yyerror(s) /* errors handled elsewhere */
-#define YYSTYPE Cell
-
-static Cell local gcShadow ( Int,Cell );
-static Void local syntaxError ( String );
-static String local unexpected ( Void );
-static Cell local checkPrec ( Cell );
-static Void local fixDefn ( Syntax,Cell,Cell,List );
-static Cell local buildTuple ( List );
-static List local checkCtxt ( List );
-static Cell local checkPred ( Cell );
-static Pair local checkDo ( List );
-static Cell local checkTyLhs ( Cell );
-#if !TREX
-static Void local noTREX ( String );
-#endif
-#if !IPARAM
-static Void local noIP ( String );
-#endif
-
-/* For the purposes of reasonably portable garbage collection, it is
- * necessary to simulate the YACC stack on the Hugs stack to keep
- * track of all intermediate constructs. The lexical analyser
- * pushes a token onto the stack for each token that is found, with
- * these elements being removed as reduce actions are performed,
- * taking account of look-ahead tokens as described by gcShadow()
- * below.
- *
- * Of the non-terminals used below, only start, topDecl & begin
- * do not leave any values on the Hugs stack. The same is true for the
- * terminals EXPR and SCRIPT. At the end of a successful parse, there
- * should only be one element left on the stack, containing the result
- * of the parse.
- */
-
-#define gc0(e) gcShadow(0,e)
-#define gc1(e) gcShadow(1,e)
-#define gc2(e) gcShadow(2,e)
-#define gc3(e) gcShadow(3,e)
-#define gc4(e) gcShadow(4,e)
-#define gc5(e) gcShadow(5,e)
-#define gc6(e) gcShadow(6,e)
-#define gc7(e) gcShadow(7,e)
-#define gc8(e) gcShadow(8,e)
-#define gc9(e) gcShadow(9,e)
-
-%}
-
-%token EXPR CONTEXT SCRIPT
-%token CASEXP OF DATA TYPE IF
-%token THEN ELSE WHERE LET IN
-%token INFIXN INFIXL INFIXR FOREIGN TNEWTYPE
-%token DEFAULT DERIVING DO TCLASS TINSTANCE
-%token MDO
-/*#if IPARAM*/
-%token WITH DLET
-/*#endif*/
-%token REPEAT ALL NUMLIT CHARLIT STRINGLIT
-%token VAROP VARID CONOP CONID
-%token QVAROP QVARID QCONOP QCONID
-/*#if TREX*/
-%token RECSELID IPVARID
-/*#endif*/
-%token COCO '=' UPTO '@' '\\'
-%token '|' '-' FROM ARROW '~'
-%token '!' IMPLIES '(' ',' ')'
-%token '[' ';' ']' '`' '.'
-%token TMODULE IMPORT HIDING QUALIFIED ASMOD
-%token EXPORT UUEXPORT INTERFACE REQUIRES UNSAFE
-%token INSTIMPORT DYNAMIC CCALL STDKALL
-%token UTL UTR UUUSAGE
-
-%%
-/*- Top level script/module structure -------------------------------------*/
-
-start : EXPR exp wherePart {inputExpr = letrec($3,$2); sp-=2;}
- | CONTEXT context {inputContext = $2; sp-=1;}
- | SCRIPT topModule {drop(); push($2);}
- | INTERFACE iface {sp-=1;}
- | error {syntaxError("input");}
- ;
-
-
-/*- GHC interface file parsing: -------------------------------------------*/
-
-/* Reading in an interface file is surprisingly like reading
- * a normal Haskell module: we read in a bunch of declarations,
- * construct symbol table entries, etc. The "only" differences
- * are that there's no syntactic sugar to deal with and we don't
- * have to read in expressions.
- */
-
-/*- Top-level interface files -----------------------------*/
-iface : INTERFACE STRINGLIT ifCon NUMLIT ifOrphans ifCheckVersion WHERE ifTopDecls
- {$$ = gc8(ap(I_INTERFACE,
- zpair($3,$8))); }
- | INTERFACE error {syntaxError("interface file");}
- ;
-
-ifTopDecls: {$$=gc0(NIL);}
- | ifTopDecl ';' ifTopDecls {$$=gc3(cons($1,$3));}
- ;
-
-ifTopDecl
- : IMPORT CONID NUMLIT ifOrphans ifIsBoot ifOptCOCO ifVersionList
- {$$=gc7(ap(I_IMPORT,zpair($2,$7))); }
-
- | INSTIMPORT CONID {$$=gc2(ap(I_INSTIMPORT,NIL));}
-
- | UUEXPORT CONID ifEntities {$$=gc3(ap(I_EXPORT,zpair($2,$3)));}
-
- | NUMLIT INFIXL optDigit ifVarCon
- {$$=gc4(ap(I_FIXDECL,
- ztriple($3,mkInt(LEFT_ASS),$4)));}
- | NUMLIT INFIXR optDigit ifVarCon
- {$$=gc4(ap(I_FIXDECL,
- ztriple($3,mkInt(RIGHT_ASS),$4)));}
- | NUMLIT INFIXN optDigit ifVarCon
- {$$=gc4(ap(I_FIXDECL,
- ztriple($3,mkInt(NON_ASS),$4)));}
-
- | TINSTANCE ifCtxInst ifInstHdL '=' ifVar
- {$$=gc5(ap(I_INSTANCE,
- z5ble($1,$2,$3,$5,NIL)));}
-
- | NUMLIT TYPE ifCon ifKindedTyvarL '=' ifType
- {$$=gc6(ap(I_TYPE,
- z4ble($2,$3,$4,$6)));}
-
- | NUMLIT DATA ifCtxDecl ifConData ifKindedTyvarL ifConstrs
- {$$=gc6(ap(I_DATA,
- z5ble($2,$3,$4,$5,$6)));}
-
- | NUMLIT TNEWTYPE ifCtxDecl ifConData ifKindedTyvarL ifNewTypeConstr
- {$$=gc6(ap(I_NEWTYPE,
- z5ble($2,$3,$4,$5,$6)));}
-
- | NUMLIT TCLASS ifCtxDecl ifCon ifKindedTyvar ifCmeths
- {$$=gc6(ap(I_CLASS,
- z5ble($2,$3,$4,
- singleton($5),$6)));}
-
- | NUMLIT ifVar COCO ifType
- {$$=gc4(ap(I_VALUE,
- ztriple($3,$2,$4)));}
-
- | error { syntaxError(
- "interface declaration"); }
- ;
-
-
-/*- Top-level misc interface stuff ------------------------*/
-ifOrphans : '!' {$$=gc1(NIL);}
- | {$$=gc0(NIL);}
-ifIsBoot : '@' {$$=gc1(NIL);}
- | {$$=gc0(NIL);}
- ;
-ifOptCOCO : COCO {$$=gc1(NIL);}
- | {$$=gc0(NIL);}
- ;
-ifCheckVersion
- : NUMLIT {$$ = gc1(NIL); }
- ;
-
-
-
-/*- Interface variable and constructor ids ----------------*/
-ifTyvar : VARID {$$ = $1;}
- ;
-ifVar : VARID {$$ = gc1($1);}
- ;
-ifCon : CONID {$$ = gc1($1);}
- ;
-
-ifVarCon : VARID {$$ = gc1($1);}
- | CONID {$$ = gc1($1);}
- ;
-
-ifQCon : CONID {$$ = gc1($1);}
- | QCONID {$$ = gc1($1);}
- ;
-ifConData : ifCon {$$ = gc1($1);}
- | '(' ')' {$$ = gc2(typeUnit);}
- | '[' ']' {$$ = gc2(typeList);}
- | '(' ARROW ')' {$$ = gc3(typeArrow);}
- ;
-ifTCName : CONID { $$ = gc1($1); }
- | CONOP { $$ = gc1($1); }
- | '(' ARROW ')' { $$ = gc3(typeArrow); }
- | '[' ']' { $$ = gc1(typeList); }
- ;
-ifQTCName : ifTCName { $$ = gc1($1); }
- | QCONID { $$ = gc1($1); }
- | QCONOP { $$ = gc1($1); }
- ;
-
-
-/*- Interface contexts ------------------------------------*/
-ifCtxInst /* __forall [a b] => :: [((VarId,Kind))] */
- : ALL ifForall IMPLIES {$$=gc3($2);}
- | {$$=gc0(NIL);}
- ;
-ifInstHd /* { Class aType } :: ((ConId, Type)) */
- : '{' ifQCon ifAType '}' {$$=gc4(ap(DICTAP,
- zpair($2,$3)));}
- ;
-
-ifInstHdL /* { C a1 } -> { C2 a2 } -> ... -> { Cn an } :: Type */
- : ifInstHd ARROW ifInstHdL {$$=gc3(ap($1,$3));}
- | ifInstHd {$$=gc1($1);}
- ;
-
-ifCtxDecl /* {M.C1 a, C2 b} => :: [(QConId, VarId)] */
- : ifCtxDeclT IMPLIES { $$ = gc2($1); }
- | { $$ = gc0(NIL); }
- ;
-ifCtxDeclT /* {M.C1 a, C2 b} :: [(QConId, VarId)] */
- : { $$ = gc0(NIL); }
- | '{' ifCtxDeclL '}' { $$ = gc3($2); }
- ;
-
-ifCtxDeclL /* M.C1 a, C2 b :: [(QConId, VarId)] */
- : ifCtxDeclLE ',' ifCtxDeclL {$$=gc3(cons($1,$3));}
- | ifCtxDeclLE {$$=gc1(cons($1,NIL));}
- | {$$=gc0(NIL);}
- ;
-ifCtxDeclLE /* M.C1 a :: (QConId,VarId) */
- : ifQCon ifTyvar {$$=gc2(zpair($1,$2));}
- ;
-
-
-/*- Interface data declarations - constructor lists -------*/
-/* The (Type,VarId,Int) are (field type, name (or NIL), strictness).
- Strictness is a number: mkInt(0) indicates lazy, mkInt(1)
- indicates a strict field (!type) as in standard H98, and
- mkInt(2) indicates unpacked -- a GHC extension.
-*/
-
-ifConstrs /* = Con1 | ... | ConN :: [((ConId,[((Type,VarId,Int))]))] */
- : {$$ = gc0(NIL);}
- | '=' ifConstrL {$$ = gc2($2);}
- ;
-ifConstrL /* [((ConId,[((Type,VarId,Int))]))] */
- : ifConstr {$$ = gc1(singleton($1));}
- | ifConstr '|' ifConstrL {$$ = gc3(cons($1,$3));}
- ;
-ifConstr /* ((ConId,[((Type,VarId,Int))])) */
- : ifConData ifDataAnonFieldL {$$ = gc2(zpair($1,$2));}
- | ifConData '{' ifDataNamedFieldL '}'
- {$$ = gc4(zpair($1,$3));}
- ;
-ifDataAnonFieldL /* [((Type,VarId,Int))] */
- : {$$=gc0(NIL);}
- | ifDataAnonField ifDataAnonFieldL
- {$$=gc2(cons($1,$2));}
- ;
-ifDataNamedFieldL /* [((Type,VarId,Int))] */
- : {$$=gc0(NIL);}
- | ifDataNamedField {$$=gc1(cons($1,NIL));}
- | ifDataNamedField ',' ifDataNamedFieldL
- {$$=gc3(cons($1,$3));}
- ;
-ifDataAnonField /* ((Type,VarId,Int)) */
- : ifAType {$$=gc1(ztriple($1,NIL,mkInt(0)));}
- | '!' ifAType {$$=gc2(ztriple($2,NIL,mkInt(1)));}
- | '!' '!' ifAType {$$=gc3(ztriple($3,NIL,mkInt(2)));}
- ;
-ifDataNamedField /* ((Type,VarId,Int)) */
- : ifVar COCO ifAType {$$=gc3(ztriple($3,$1,mkInt(0)));}
- | ifVar COCO '!' ifAType {$$=gc4(ztriple($4,$1,mkInt(1)));}
- | ifVar COCO '!' '!' ifAType {$$=gc5(ztriple($5,$1,mkInt(2)));}
- ;
-
-
-/*- Interface class declarations - methods ----------------*/
-ifCmeths /* [((VarId,Type))] */
- : { $$ = gc0(NIL); }
- | WHERE '{' ifCmethL '}' { $$ = gc4($3); }
- ;
-ifCmethL /* [((VarId,Type))] */
- : ifCmeth { $$ = gc1(singleton($1)); }
- | ifCmeth ';' ifCmethL { $$ = gc3(cons($1,$3)); }
- ;
-ifCmeth /* ((VarId,Type)) */
- : ifVar COCO ifType { $$ = gc3(zpair($1,$3)); }
- | ifVar '=' COCO ifType { $$ = gc4(zpair($1,$4)); }
- /* has default method */
- ;
-
-
-/*- Interface newtype declararions ------------------------*/
-ifNewTypeConstr /* ((ConId,Type)) */
- : '=' ifCon ifAType { $$ = gc3(zpair($2,$3)); }
- ;
-
-
-/*- Interface type expressions ----------------------------*/
-ifType : ALL ifForall ifCtxDeclT IMPLIES ifType
- { if ($3 == NIL)
- $$=gc5($5); else
- $$=gc5(pair(QUAL,pair($3,$5)));
- }
- | ifBType ARROW ifType { $$ = gc3(fn($1,$3)); }
- | ifBType { $$ = gc1($1); }
- ;
-ifForall /* [((VarId,Kind))] */
- : '[' ifKindedTyvarL ']' { $$ = gc3($2); }
- ;
-
-ifTypeL2 /* [Type], 2 or more */
- : ifType ',' ifType { $$ = gc3(doubleton($1,$3)); }
- | ifType ',' ifTypeL2 { $$ = gc3(cons($1,$3)); }
- ;
-
-ifTypeL /* [Type], 0 or more */
- : ifType ',' ifTypeL { $$ = gc3(cons($1,$3)); }
- | ifType { $$ = gc1(singleton($1)); }
- | { $$ = gc0(NIL); }
- ;
-
-ifBType : ifAType { $$ = gc1($1); }
- | ifBType ifAType { $$ = gc2(ap($1,$2)); }
- | UUUSAGE ifUsage ifAType { $$ = gc3($3); }
- ;
-
-ifAType : ifQTCName { $$ = gc1($1); }
- | ifTyvar { $$ = gc1($1); }
- | '(' ')' { $$ = gc2(typeUnit); }
- | '(' ifTypeL2 ')' { $$ = gc3(buildTuple(reverse($2))); }
- | '[' ifType ']' { $$ = gc3(ap(mkCon(tycon(typeList).text),
- $2));}
- | '{' ifQTCName ifAType '}' { $$ = gc4(ap(DICTAP,
- pair($2,$3))); }
- | '(' ifType ')' { $$ = gc3($2); }
- | UTL ifTypeL UTR { $$ = gc3(ap(UNBOXEDTUP,$2)); }
- ;
-
-
-/*- KW's usage stuff --------------------------------------*/
-ifUsage : '-' { $$ = gc1(NIL); }
- | '!' { $$ = gc1(NIL); }
- | ifVar { $$ = gc1(NIL); }
- ;
-
-
-/*- Interface kinds ---------------------------------------*/
-ifKindedTyvarL /* [((VarId,Kind))] */
- : { $$ = gc0(NIL); }
- | ifKindedTyvar ifKindedTyvarL { $$ = gc2(cons($1,$2)); }
- ;
-ifKindedTyvar /* ((VarId,Kind)) */
- : ifTyvar { $$ = gc1(zpair($1,STAR)); }
- | ifTyvar COCO ifAKind { $$ = gc3(zpair($1,$3)); }
- ;
-ifKind : ifAKind { $$ = gc1($1); }
- | ifAKind ARROW ifKind { $$ = gc3(ap($1,$3)); }
- ;
-ifAKind : VAROP { $$ = gc1(STAR); }
- /* should be '*' */
- | '(' ifKind ')' { $$ = gc3($2); }
- ;
-
-
-/*- Interface version/export/import stuff -----------------*/
-ifEntities
- : { $$ = gc0(NIL); }
- | ifEntity ifEntities { $$ = gc2(cons($1,$2)); }
- ;
-ifEntity
- : ifEntityOcc {$$=gc1($1);}
- | ifEntityOcc ifStuffInside {$$=gc2(zpair($1,$2));}
- ;
-ifEntityOcc
- : ifVar { $$ = gc1($1); }
- | ifCon { $$ = gc1($1); }
- | ARROW { $$ = gc1(typeArrow); }
- | '(' ARROW ')' { $$ = gc3(typeArrow); }
- /* why allow both? */
- ;
-ifStuffInside
- : '{' ifValOccs '}' { $$ = gc3($2); }
- ;
-ifValOccs
- : { $$ = gc0(NIL); }
- | ifVar ifValOccs { $$ = gc2(cons($1,$2)); }
- | ifCon ifValOccs { $$ = gc2(cons($1,$2)); }
- ;
-
-ifVersionList
- : {$$=gc0(NIL);}
- | VARID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
- | CONID NUMLIT ifVersionList {$$=gc3(cons($1,$3));}
- ;
-
-
-/*- Haskell module header/import parsing: -----------------------------------
- * Module chasing is now totally different from Classic Hugs98. We parse
- * the entire syntax tree. Subsequent passes over the tree collect and
- * chase imports; we no longer attempt to do so whilst parsing.
- *-------------------------------------------------------------------------*/
-
-/* In Haskell 1.2, the default module header was "module Main where"
- * In 1.3, this changed to "module Main(main) where".
- * We use the 1.2 header because it breaks much less pre-module code.
- * STG Hugs, 15 March 00: disallow default headers (pro tem).
- */
-topModule : TMODULE modname expspec WHERE '{' modBody end
- {$$=gc7(ap(M_MODULE,
- ztriple($2,$3,$6)));}
- | TMODULE modname WHERE '{' modBody end
- {$$=gc6(ap(M_MODULE,
- ztriple(
- $2,
- singleton(ap(MODULEENT,$2)),
- $5)));}
-
- | begin modBody end {ConId fakeNm = mkCon(module(
- moduleBeingParsed).text);
- $$ = gc2(ap(M_MODULE,
- ztriple(fakeNm,
- singleton(ap(MODULEENT,fakeNm)),
- $2)));}
-
- | TMODULE error {syntaxError("module definition");}
- ;
-
-modname : CONID {$$ = gc1($1);}
- ;
-modid : CONID {$$ = gc1($1);}
- ;
-modBody : topDecls {$$ = gc1($1);}
- | impDecls {$$ = gc1($1);}
- | impDecls ';' topDecls {$$ = gc3(appendOnto($1,$3));}
- ;
-
-/*- Exports: --------------------------------------------------------------*/
-
-expspec : '(' ')' {$$ = gc2(NIL);}
- | '(' exports ')' {$$ = gc3($2);}
- | '(' exports ',' ')' {$$ = gc4($2);}
- ;
-exports : exports ',' export {$$ = gc3(cons($3,$1));}
- | export {$$ = gc1(singleton($1));}
- ;
-/* The qcon should be qconid.
- * Relaxing the rule lets us explicitly export (:) from the Prelude.
- */
-export : qvar {$$ = $1;}
- | qcon {$$ = $1;}
- | qconid '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
- | qconid '(' qnames ')' {$$ = gc4(pair($1,$3));}
- | TMODULE modid {$$ = gc2(ap(MODULEENT,$2));}
- ;
-qnames : /* empty */ {$$ = gc0(NIL);}
- | ',' {$$ = gc1(NIL);}
- | qnames1 {$$ = $1;}
- | qnames1 ',' {$$ = gc2($1);}
- ;
-qnames1 : qnames1 ',' qname {$$ = gc3(cons($3,$1));}
- | qname {$$ = gc1(singleton($1));}
- ;
-qname : qvar {$$ = $1;}
- | qcon {$$ = $1;}
- ;
-
-/*- Import declarations: --------------------------------------------------*/
-
-impDecls : impDecls ';' impDecl {$$ = gc3(appendOnto($3,$1));}
- | impDecl {$$ = gc1($1);}
- ;
-
-/* Note that qualified import ignores the import list. */
-impDecl : IMPORT modid impspec {$$=gc3(doubleton(
- ap(M_IMPORT_Q,zpair($2,$2)),
- ap(M_IMPORT_UNQ,zpair($2,$3))
- ));}
- | IMPORT modid ASMOD modid impspec
- {$$=gc5(doubleton(
- ap(M_IMPORT_Q,zpair($2,$4)),
- ap(M_IMPORT_UNQ,zpair($2,$5))
- ));}
- | IMPORT QUALIFIED modid ASMOD modid impspec
- {$$=gc6(singleton(
- ap(M_IMPORT_Q,zpair($3,$5))
- ));}
- | IMPORT QUALIFIED modid impspec
- {$$=gc4(singleton(
- ap(M_IMPORT_Q,zpair($3,$3))
- ));}
- | IMPORT error {syntaxError("import declaration");}
- ;
-impspec : /* empty */ {$$ = gc0(DOTDOT);}
- | HIDING '(' imports ')' {$$ = gc4(ap(HIDDEN,$3));}
- | '(' imports ')' {$$ = gc3($2);}
- ;
-imports : /* empty */ {$$ = gc0(NIL);}
- | ',' {$$ = gc1(NIL);}
- | imports1 {$$ = $1;}
- | imports1 ',' {$$ = gc2($1);}
- ;
-imports1 : imports1 ',' import {$$ = gc3(cons($3,$1));}
- | import {$$ = gc1(singleton($1));}
- ;
-import : var {$$ = $1;}
- | CONID {$$ = $1;}
- | CONID '(' UPTO ')' {$$ = gc4(pair($1,DOTDOT));}
- | CONID '(' names ')' {$$ = gc4(pair($1,$3));}
- ;
-names : /* empty */ {$$ = gc0(NIL);}
- | ',' {$$ = gc1(NIL);}
- | names1 {$$ = $1;}
- | names1 ',' {$$ = gc2($1);}
- ;
-names1 : names1 ',' name {$$ = gc3(cons($3,$1));}
- | name {$$ = gc1(singleton($1));}
- ;
-name : var {$$ = $1;}
- | con {$$ = $1;}
- ;
-
-/*- Top-level declarations: -----------------------------------------------*/
-
-topDecls : /* empty */ {$$=gc0(NIL);}
- | topDecl ';' topDecls {$$=gc3(cons($1,$3));}
- | decl ';' topDecls {$$=gc3(cons(ap(M_VALUE,$1),$3));}
- | topDecl {$$=gc1(cons($1,NIL));}
- | decl {$$=gc1(cons(ap(M_VALUE,$1),NIL));}
- ;
-
-/*- Type declarations: ----------------------------------------------------*/
-
-topDecl : TYPE tyLhs '=' type {$$=gc4(ap(M_TYCON,
- z4ble($3,$2,$4,
- SYNONYM)));}
- | TYPE tyLhs '=' type IN invars
- {$$=gc6(ap(M_TYCON,
- z4ble($3,$2,ap($4,$6),
- RESTRICTSYN)));}
- | TYPE error {syntaxError("type definition");}
- | DATA btype2 '=' constrs deriving
- {$$=gc5(ap(M_TYCON,
- z4ble($3,checkTyLhs($2),
- ap(rev($4),$5),
- DATATYPE)));}
- | DATA context IMPLIES tyLhs '=' constrs deriving
- {$$=gc7(ap(M_TYCON,
- z4ble($5,$4,
- ap(qualify($2,rev($6)),$7),
- DATATYPE)));}
- | DATA btype2 {$$=gc2(ap(M_TYCON,
- z4ble($1,checkTyLhs($2),
- ap(NIL,NIL),DATATYPE)));}
- | DATA context IMPLIES tyLhs {$$=gc4(ap(M_TYCON,
- z4ble($1,$4,
- ap(qualify($2,NIL),NIL),
- DATATYPE)));}
- | DATA error {syntaxError("data definition");}
- | TNEWTYPE btype2 '=' nconstr deriving
- {$$=gc5(ap(M_TYCON,
- z4ble($3,checkTyLhs($2),
- ap($4,$5),NEWTYPE)));}
- | TNEWTYPE context IMPLIES tyLhs '=' nconstr deriving
- {$$=gc7(ap(M_TYCON,
- z4ble($5,$4,
- ap(qualify($2,$6),$7),
- NEWTYPE)));}
- | TNEWTYPE error {syntaxError("newtype definition");}
- ;
-tyLhs : tyLhs varid {$$ = gc2(ap($1,$2));}
- | CONID {$$ = $1;}
- | error {syntaxError("type defn lhs");}
- ;
-invars : invars ',' invar {$$ = gc3(cons($3,$1));}
- | invar {$$ = gc1(cons($1,NIL));}
- ;
-invar : var COCO topType {$$ = gc3(sigdecl($2,singleton($1),
- $3));}
- | var {$$ = $1;}
- ;
-constrs : constrs '|' pconstr {$$ = gc3(cons($3,$1));}
- | pconstr {$$ = gc1(cons($1,NIL));}
- ;
-pconstr : ALL varids '.' qconstr {$$ = gc4(ap(POLYTYPE,
- pair(rev($2),$4)));}
- | qconstr {$$ = $1;}
- ;
-qconstr : context IMPLIES constr {$$ = gc3(qualify($1,$3));}
- | constr {$$ = $1;}
- ;
-constr : '!' btype conop bbtype {$$ = gc4(ap(ap($3,bang($2)),$4));}
- | btype1 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
- | btype2 conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
- | bpolyType conop bbtype {$$ = gc3(ap(ap($2,$1),$3));}
- | btype2 {$$ = $1;}
- | btype3 {$$ = $1;}
- | btype4 {$$ = $1;}
- | con '{' fieldspecs '}' {$$ = gc4(ap(LABC,pair($1,rev($3))));}
- | con '{' '}' {$$ = gc3(ap(LABC,pair($1,NIL)));}
- | error {syntaxError("data type definition");}
- ;
-btype3 : btype2 '!' atype {$$ = gc3(ap($1,bang($3)));}
- | btype3 '!' atype {$$ = gc3(ap($1,bang($3)));}
- | btype3 atype {$$ = gc2(ap($1,$2));}
- ;
-btype4 : btype2 bpolyType {$$ = gc2(ap($1,$2));}
- | btype3 bpolyType {$$ = gc2(ap($1,$2));}
- | btype4 bpolyType {$$ = gc2(ap($1,$2));}
- | btype4 atype {$$ = gc2(ap($1,$2));}
- | btype4 '!' atype {$$ = gc3(ap($1,bang($3)));}
- ;
-bbtype : '!' btype {$$ = gc2(bang($2));}
- | btype {$$ = $1;}
- | bpolyType {$$ = $1;}
- ;
-nconstr : pconstr {$$ = gc1(singleton($1));}
- ;
-fieldspecs: fieldspecs ',' fieldspec {$$ = gc3(cons($3,$1));}
- | fieldspec {$$ = gc1(cons($1,NIL));}
- ;
-fieldspec : vars COCO polyType {$$ = gc3(pair(rev($1),$3));}
- | vars COCO type {$$ = gc3(pair(rev($1),$3));}
- | vars COCO '!' type {$$ = gc4(pair(rev($1),bang($4)));}
- ;
-deriving : /* empty */ {$$ = gc0(NIL);}
- | DERIVING qconid {$$ = gc2(singleton($2));}
- | DERIVING '(' derivs0 ')' {$$ = gc4($3);}
- ;
-derivs0 : /* empty */ {$$ = gc0(NIL);}
- | derivs {$$ = gc1(rev($1));}
- ;
-derivs : derivs ',' qconid {$$ = gc3(cons($3,$1));}
- | qconid {$$ = gc1(singleton($1));}
- ;
-
-/*- Processing definitions of primitives ----------------------------------*/
-
-topDecl : FOREIGN IMPORT callconv DYNAMIC unsafe_flag var COCO type
- {$$=gc8(ap(M_FOREIGN_IM,z5ble($1,$3,NIL,$6,$8)));}
- | FOREIGN IMPORT callconv ext_loc ext_name unsafe_flag var COCO type
- {$$=gc9(ap(M_FOREIGN_IM,z5ble($1,$3,pair($4,$5),$7,$9)));}
- | FOREIGN EXPORT callconv DYNAMIC qvarid COCO type
- {$$=gc7(ap(M_FOREIGN_EX,z5ble($1,$3,$4,$5,$7)));}
- ;
-
-callconv : CCALL {$$ = gc1(textCcall);}
- | STDKALL {$$ = gc1(textStdcall);}
- | /* empty */ {$$ = gc0(NIL);}
- ;
-ext_loc : STRINGLIT {$$ = $1;}
- ;
-ext_name : STRINGLIT {$$ = $1;}
- ;
-unsafe_flag: /* empty */ {$$ = gc0(NIL);}
- | UNSAFE {$$ = gc1(NIL); /* ignored */ }
- ;
-
-
-/*- Class declarations: ---------------------------------------------------*/
-
-topDecl : TCLASS crule fds wherePart {$$=gc4(ap(M_CLASS,z4ble($1,$2,$4,$3)));}
- | TINSTANCE irule wherePart {$$=gc3(ap(M_INST,ztriple($1,$2,$3)));}
- | DEFAULT '(' dtypes ')' {$$=gc4(ap(M_DEFAULT,zpair($1,$3)));}
- | TCLASS error {syntaxError("class declaration");}
- | TINSTANCE error {syntaxError("instance declaration");}
- | DEFAULT error {syntaxError("default declaration");}
- ;
-crule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
- | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
- ;
-irule : context IMPLIES btype2 {$$ = gc3(pair($1,checkPred($3)));}
- | btype2 {$$ = gc1(pair(NIL,checkPred($1)));}
- ;
-dtypes : /* empty */ {$$ = gc0(NIL);}
- | dtypes1 {$$ = gc1(rev($1));}
- ;
-dtypes1 : dtypes1 ',' type {$$ = gc3(cons($3,$1));}
- | type {$$ = gc1(cons($1,NIL));}
- ;
-
-fds : /* empty */ {$$ = gc0(NIL);}
- | '|' fds1 {h98DoesntSupport(row,"dependent parameters");
- $$ = gc2(rev($2));}
- ;
-fds1 : fds1 ',' fd {$$ = gc3(cons($3,$1));}
- | fd {$$ = gc1(cons($1,NIL));}
- |
- ;
-fd : varids0 ARROW varids0 {$$ = gc3(pair(rev($1),rev($3)));}
- ;
-varids0 : /* empty */ {$$ = gc0(NIL);}
- | varids0 varid {$$ = gc2(cons($2,$1));}
- ;
-
- /*- Type expressions: -----------------------------------------------------*/
-
-topType : ALL varids '.' topType0 {$$ = gc4(ap(POLYTYPE,
- pair(rev($2),$4)));}
- | topType0 {$$ = $1;}
- ;
-topType0 : context IMPLIES topType1 {$$ = gc3(qualify($1,$3));}
- | topType1 {$$ = $1;}
- ;
-topType1 : bpolyType ARROW topType1 {$$ = gc3(fn($1,$3));}
- | btype1 ARROW topType1 {$$ = gc3(fn($1,$3));}
- | btype2 ARROW topType1 {$$ = gc3(fn($1,$3));}
- | btype {$$ = $1;}
- ;
-polyType : ALL varids '.' sigType {$$ = gc4(ap(POLYTYPE,
- pair(rev($2),$4)));}
- | context IMPLIES type {$$ = gc3(qualify($1,$3));}
- | bpolyType {$$ = $1;}
- ;
-bpolyType : '(' polyType ')' {$$ = gc3($2);}
- ;
-varids : varids varid {$$ = gc2(cons($2,$1));}
- | varid {$$ = gc1(singleton($1));}
- ;
-sigType : context IMPLIES type {$$ = gc3(qualify($1,$3));}
- | type {$$ = $1;}
- ;
-context : '(' ')' {$$ = gc2(NIL);}
- | btype2 {$$ = gc1(singleton(checkPred($1)));}
- | '(' btype2 ')' {$$ = gc3(singleton(checkPred($2)));}
- | '(' btypes2 ')' {$$ = gc3(checkCtxt(rev($2)));}
-/*#if TREX*/
- | lacks {$$ = gc1(singleton($1));}
- | '(' lacks1 ')' {$$ = gc3(checkCtxt(rev($2)));}
- ;
-lacks : varid '\\' varid {
-#if TREX
- $$ = gc3(ap(mkExt(textOf($3)),$1));
-#else
- noTREX("a type context");
-#endif
- }
- | IPVARID COCO type {
-#if IPARAM
- $$ = gc3(pair(mkIParam($1),$3));
-#else
- noIP("a type context");
-#endif
- }
- ;
-lacks1 : btypes2 ',' lacks {$$ = gc3(cons($3,$1));}
- | lacks1 ',' btype2 {$$ = gc3(cons($3,$1));}
- | lacks1 ',' lacks {$$ = gc3(cons($3,$1));}
- | btype2 ',' lacks {$$ = gc3(cons($3,cons($1,NIL)));}
- | lacks {$$ = gc1(singleton($1));}
- ;
-/*#endif*/
-
-type : type1 {$$ = $1;}
- | btype2 {$$ = $1;}
- ;
-type1 : btype1 {$$ = $1;}
- | btype1 ARROW type {$$ = gc3(fn($1,$3));}
- | btype2 ARROW type {$$ = gc3(fn($1,$3));}
- | error {syntaxError("type expression");}
- ;
-btype : btype1 {$$ = $1;}
- | btype2 {$$ = $1;}
- ;
-btype1 : btype1 atype {$$ = gc2(ap($1,$2));}
- | atype1 {$$ = $1;}
- ;
-btype2 : btype2 atype {$$ = gc2(ap($1,$2));}
- | qconid {$$ = $1;}
- ;
-atype : atype1 {$$ = $1;}
- | qconid {$$ = $1;}
- ;
-atype1 : varid {$$ = $1;}
- | '(' ')' {$$ = gc2(typeUnit);}
- | '(' ARROW ')' {$$ = gc3(typeArrow);}
- | '(' type1 ')' {$$ = gc3($2);}
- | '(' btype2 ')' {$$ = gc3($2);}
- | '(' tupCommas ')' {$$ = gc3($2);}
- | '(' btypes2 ')' {$$ = gc3(buildTuple($2));}
- | '(' typeTuple ')' {$$ = gc3(buildTuple($2));}
- | '(' tfields ')' {
-#if TREX
- $$ = gc3(revOnto($2,typeNoRow));
-#else
- noTREX("a type");
-#endif
- }
- | '(' tfields '|' type ')' {
-#if TREX
- $$ = gc5(revOnto($2,$4));
-#else
- noTREX("a type");
-#endif
- }
- | '[' type ']' {$$ = gc3(ap(typeList,$2));}
- | '[' ']' {$$ = gc2(typeList);}
- | '_' {h98DoesntSupport(row,"anonymous type variables");
- $$ = gc1(inventVar());}
- ;
-btypes2 : btypes2 ',' btype2 {$$ = gc3(cons($3,$1));}
- | btype2 ',' btype2 {$$ = gc3(cons($3,cons($1,NIL)));}
- ;
-typeTuple : type1 ',' type {$$ = gc3(cons($3,cons($1,NIL)));}
- | btype2 ',' type1 {$$ = gc3(cons($3,cons($1,NIL)));}
- | btypes2 ',' type1 {$$ = gc3(cons($3,$1));}
- | typeTuple ',' type {$$ = gc3(cons($3,$1));}
- ;
-/*#if TREX*/
-tfields : tfields ',' tfield {$$ = gc3(cons($3,$1));}
- | tfield {$$ = gc1(singleton($1));}
- ;
-tfield : varid COCO type {h98DoesntSupport(row,"extensible records");
- $$ = gc3(ap(mkExt(textOf($1)),$3));}
- ;
-/*#endif*/
-
-/*- Value declarations: ---------------------------------------------------*/
-
-gendecl : INFIXN optDigit ops {$$ = gc3(fixdecl($1,$3,NON_ASS,$2));}
- | INFIXN error {syntaxError("fixity decl");}
- | INFIXL optDigit ops {$$ = gc3(fixdecl($1,$3,LEFT_ASS,$2));}
- | INFIXL error {syntaxError("fixity decl");}
- | INFIXR optDigit ops {$$ = gc3(fixdecl($1,$3,RIGHT_ASS,$2));}
- | INFIXR error {syntaxError("fixity decl");}
- | vars COCO topType {$$ = gc3(sigdecl($2,$1,$3));}
- | vars COCO error {syntaxError("type signature");}
- ;
-optDigit : NUMLIT {$$ = gc1(checkPrec($1));}
- | /* empty */ {$$ = gc0(mkInt(DEF_PREC));}
- ;
-ops : ops ',' op {$$ = gc3(cons($3,$1));}
- | op {$$ = gc1(singleton($1));}
- ;
-vars : vars ',' var {$$ = gc3(cons($3,$1));}
- | var {$$ = gc1(singleton($1));}
- ;
-decls : '{' decls0 end {$$ = gc3($2);}
- | '{' decls1 end {$$ = gc3($2);}
- ;
-decls0 : /* empty */ {$$ = gc0(NIL);}
- | decls0 ';' {$$ = gc2($1);}
- | decls1 ';' {$$ = gc2($1);}
- ;
-decls1 : decls0 decl {$$ = gc2(cons($2,$1));}
- ;
-decl : gendecl {$$ = $1;}
- | funlhs rhs {$$ = gc2(ap(FUNBIND,pair($1,$2)));}
- | funlhs COCO type rhs {$$ = gc4(ap(FUNBIND,
- pair($1,ap(RSIGN,
- ap($4,$3)))));}
- | pat0 rhs {$$ = gc2(ap(PATBIND,pair($1,$2)));}
- ;
-funlhs : funlhs0 {$$ = $1;}
- | funlhs1 {$$ = $1;}
- | npk {$$ = $1;}
- ;
-funlhs0 : pat10_vI varop pat0 {$$ = gc3(ap2($2,$1,$3));}
- | infixPat varop pat0 {$$ = gc3(ap2($2,$1,$3));}
- | NUMLIT varop pat0 {$$ = gc3(ap2($2,$1,$3));}
- | var varop_pl pat0 {$$ = gc3(ap2($2,$1,$3));}
- | var '+' pat0_INT {$$ = gc3(ap2(varPlus,$1,$3));}
- ;
-funlhs1 : '(' funlhs0 ')' apat {$$ = gc4(ap($2,$4));}
- | '(' funlhs1 ')' apat {$$ = gc4(ap($2,$4));}
- | '(' npk ')' apat {$$ = gc4(ap($2,$4));}
- | var apat {$$ = gc2(ap($1,$2));}
- | funlhs1 apat {$$ = gc2(ap($1,$2));}
- ;
-rhs : rhs1 wherePart {$$ = gc2(letrec($2,$1));}
- | error {syntaxError("declaration");}
- ;
-rhs1 : '=' exp {$$ = gc2(pair($1,$2));}
- | gdrhs {$$ = gc1(grded(rev($1)));}
- ;
-gdrhs : gdrhs gddef {$$ = gc2(cons($2,$1));}
- | gddef {$$ = gc1(singleton($1));}
- ;
-gddef : '|' exp0 '=' exp {$$ = gc4(pair($3,pair($2,$4)));}
- ;
-wherePart : /* empty */ {$$ = gc0(NIL);}
- | WHERE decls {$$ = gc2($2);}
- ;
-
-/*- Patterns: -------------------------------------------------------------*/
-
-pat : npk {$$ = $1;}
- | pat_npk {$$ = $1;}
- ;
-pat_npk : pat0 COCO type {$$ = gc3(ap(ESIGN,pair($1,$3)));}
- | pat0 {$$ = $1;}
- ;
-npk : var '+' NUMLIT {$$ = gc3(ap2(varPlus,$1,$3));}
- ;
-pat0 : var {$$ = $1;}
- | NUMLIT {$$ = $1;}
- | pat0_vI {$$ = $1;}
- ;
-pat0_INT : var {$$ = $1;}
- | pat0_vI {$$ = $1;}
- ;
-pat0_vI : pat10_vI {$$ = $1;}
- | infixPat {$$ = gc1(ap(INFIX,$1));}
- ;
-infixPat : '-' pat10 {$$ = gc2(ap(NEG,only($2)));}
- | '-' error {syntaxError("pattern");}
- | var qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
- | var qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
- | NUMLIT qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
- | NUMLIT qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
- | pat10_vI qconop pat10 {$$ = gc3(ap(ap($2,only($1)),$3));}
- | pat10_vI qconop '-' pat10 {$$ = gc4(ap(NEG,ap2($2,only($1),$4)));}
- | infixPat qconop pat10 {$$ = gc3(ap(ap($2,$1),$3));}
- | infixPat qconop '-' pat10 {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
- ;
-pat10 : fpat {$$ = $1;}
- | apat {$$ = $1;}
- ;
-pat10_vI : fpat {$$ = $1;}
- | apat_vI {$$ = $1;}
- ;
-fpat : fpat apat {$$ = gc2(ap($1,$2));}
- | gcon apat {$$ = gc2(ap($1,$2));}
- ;
-apat : NUMLIT {$$ = $1;}
- | var {$$ = $1;}
- | apat_vI {$$ = $1;}
- ;
-apat_vI : var '@' apat {$$ = gc3(ap(ASPAT,pair($1,$3)));}
- | gcon {$$ = $1;}
- | qcon '{' patbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
- | CHARLIT {$$ = $1;}
- | STRINGLIT {$$ = $1;}
- | '_' {$$ = gc1(WILDCARD);}
- | '(' pat_npk ')' {$$ = gc3($2);}
- | '(' npk ')' {$$ = gc3($2);}
- | '(' pats2 ')' {$$ = gc3(buildTuple($2));}
- | '[' pats1 ']' {$$ = gc3(ap(FINLIST,rev($2)));}
- | '~' apat {$$ = gc2(ap(LAZYPAT,$2));}
-/*#if TREX*/
- | '(' patfields ')' {
-#if TREX
- $$ = gc3(revOnto($2,nameNoRec));
-#else
- $$ = gc3(NIL);
-#endif
- }
- | '(' patfields '|' pat ')' {$$ = gc5(revOnto($2,$4));}
-/*#endif TREX*/
- ;
-pats2 : pats2 ',' pat {$$ = gc3(cons($3,$1));}
- | pat ',' pat {$$ = gc3(cons($3,singleton($1)));}
- ;
-pats1 : pats1 ',' pat {$$ = gc3(cons($3,$1));}
- | pat {$$ = gc1(singleton($1));}
- ;
-patbinds : /* empty */ {$$ = gc0(NIL);}
- | patbinds1 {$$ = gc1(rev($1));}
- ;
-patbinds1 : patbinds1 ',' patbind {$$ = gc3(cons($3,$1));}
- | patbind {$$ = gc1(singleton($1));}
- ;
-patbind : qvar '=' pat {$$ = gc3(pair($1,$3));}
- | var {$$ = $1;}
- ;
-/*#if TREX*/
-patfields : patfields ',' patfield {$$ = gc3(cons($3,$1));}
- | patfield {$$ = gc1(singleton($1));}
- ;
-patfield : varid '=' pat {
-#if TREX
- $$ = gc3(ap(mkExt(textOf($1)),$3));
-#else
- noTREX("a pattern");
-#endif
- }
- ;
-/*#endif TREX*/
-
-/*- Expressions: ----------------------------------------------------------*/
-
-exp : exp_err {$$ = $1;}
- | error {syntaxError("expression");}
- ;
-exp_err : exp0a COCO sigType {$$ = gc3(ap(ESIGN,pair($1,$3)));}
- | exp0a WITH dbinds {
-#if IPARAM
- $$ = gc3(ap(WITHEXP,pair($1,$3)));
-#else
- noIP("an expression");
-#endif
- }
- | exp0 {$$ = $1;}
- ;
-exp0 : exp0a {$$ = $1;}
- | exp0b {$$ = $1;}
- ;
-exp0a : infixExpa {$$ = gc1(ap(INFIX,$1));}
- | exp10a {$$ = $1;}
- ;
-exp0b : infixExpb {$$ = gc1(ap(INFIX,$1));}
- | exp10b {$$ = $1;}
- ;
-infixExpa : infixExpa qop '-' exp10a {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
- | infixExpa qop exp10a {$$ = gc3(ap(ap($2,$1),$3));}
- | '-' exp10a {$$ = gc2(ap(NEG,only($2)));}
- | exp10a qop '-' exp10a {$$ = gc4(ap(NEG,
- ap(ap($2,only($1)),$4)));}
- | exp10a qop exp10a {$$ = gc3(ap(ap($2,only($1)),$3));}
- ;
-infixExpb : infixExpa qop '-' exp10b {$$ = gc4(ap(NEG,ap(ap($2,$1),$4)));}
- | infixExpa qop exp10b {$$ = gc3(ap(ap($2,$1),$3));}
- | '-' exp10b {$$ = gc2(ap(NEG,only($2)));}
- | exp10a qop '-' exp10b {$$ = gc4(ap(NEG,
- ap(ap($2,only($1)),$4)));}
- | exp10a qop exp10b {$$ = gc3(ap(ap($2,only($1)),$3));}
- ;
-exp10a : CASEXP exp OF '{' alts end {$$ = gc6(ap(CASE,pair($2,rev($5))));}
- | DO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
- | MDO '{' stmts end {$$ = gc4(ap(DOCOMP,checkDo($3)));}
- | appExp {$$ = $1;}
- ;
-exp10b : '\\' pats ARROW exp {$$ = gc4(ap(LAMBDA,
- pair(rev($2),
- pair($3,$4))));}
- | LET decls IN exp {$$ = gc4(letrec($2,$4));}
- | IF exp THEN exp ELSE exp {$$ = gc6(ap(COND,triple($2,$4,$6)));}
- | DLET dbinds IN exp {
-#if IPARAM
- $$ = gc4(ap(WITHEXP,pair($4,$2)));
-#else
- noIP("an expression");
-#endif
- }
- ;
-pats : pats apat {$$ = gc2(cons($2,$1));}
- | apat {$$ = gc1(cons($1,NIL));}
- ;
-appExp : appExp aexp {$$ = gc2(ap($1,$2));}
- | aexp {$$ = $1;}
- ;
-aexp : qvar {$$ = $1;}
- | qvar '@' aexp {$$ = gc3(ap(ASPAT,pair($1,$3)));}
- | '~' aexp {$$ = gc2(ap(LAZYPAT,$2));}
- | IPVARID {$$ = $1;}
- | '_' {$$ = gc1(WILDCARD);}
- | gcon {$$ = $1;}
- | qcon '{' fbinds '}' {$$ = gc4(ap(CONFLDS,pair($1,$3)));}
- | aexp '{' fbinds '}' {$$ = gc4(ap(UPDFLDS,
- triple($1,NIL,$3)));}
- | NUMLIT {$$ = $1;}
- | CHARLIT {$$ = $1;}
- | STRINGLIT {$$ = $1;}
- | REPEAT {$$ = $1;}
- | '(' exp ')' {$$ = gc3($2);}
- | '(' exps2 ')' {$$ = gc3(buildTuple($2));}
-/*#if TREX*/
- | '(' vfields ')' {
-#if TREX
- $$ = gc3(revOnto($2,nameNoRec));
-#else
- $$ = gc3(NIL);
-#endif
- }
- | '(' vfields '|' exp ')' {$$ = gc5(revOnto($2,$4));}
- | RECSELID {$$ = $1;}
-/*#endif*/
- | '[' list ']' {$$ = gc3($2);}
- | '(' exp10a qop ')' {$$ = gc4(ap($3,$2));}
- | '(' qvarop_mi exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
- | '(' qconop exp0 ')' {$$ = gc4(ap(ap(nameFlip,$2),$3));}
- ;
-exps2 : exps2 ',' exp {$$ = gc3(cons($3,$1));}
- | exp ',' exp {$$ = gc3(cons($3,cons($1,NIL)));}
- ;
-/*#if TREX*/
-vfields : vfields ',' vfield {$$ = gc3(cons($3,$1));}
- | vfield {$$ = gc1(singleton($1));}
- ;
-vfield : varid '=' exp {
-#if TREX
- $$ = gc3(ap(mkExt(textOf($1)),$3));
-#else
- noTREX("an expression");
-#endif
- }
- ;
-/*#endif*/
-alts : alts1 {$$ = $1;}
- | alts1 ';' {$$ = gc2($1);}
- ;
-alts1 : alts1 ';' alt {$$ = gc3(cons($3,$1));}
- | alt {$$ = gc1(cons($1,NIL));}
- ;
-alt : pat altRhs wherePart {$$ = gc3(pair($1,letrec($3,$2)));}
- ;
-altRhs : guardAlts {$$ = gc1(grded(rev($1)));}
- | ARROW exp {$$ = gc2(pair($1,$2));}
- | error {syntaxError("case expression");}
- ;
-guardAlts : guardAlts guardAlt {$$ = gc2(cons($2,$1));}
- | guardAlt {$$ = gc1(cons($1,NIL));}
- ;
-guardAlt : '|' exp0 ARROW exp {$$ = gc4(pair($3,pair($2,$4)));}
- ;
-stmts : stmts1 ';' {$$ = gc2($1);}
- | stmts1 {$$ = $1;}
- ;
-stmts1 : stmts1 ';' stmt {$$ = gc3(cons($3,$1));}
- | stmt {$$ = gc1(cons($1,NIL));}
- ;
-stmt : exp_err FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
- | LET decls {$$ = gc2(ap(QWHERE,$2));}
-/* | IF exp {$$ = gc2(ap(BOOLQUAL,$2));}*/
- | exp_err {$$ = gc1(ap(DOQUAL,$1));}
- ;
-fbinds : /* empty */ {$$ = gc0(NIL);}
- | fbinds1 {$$ = gc1(rev($1));}
- ;
-fbinds1 : fbinds1 ',' fbind {$$ = gc3(cons($3,$1));}
- | fbind {$$ = gc1(singleton($1));}
- ;
-fbind : var {$$ = $1;}
- | qvar '=' exp {$$ = gc3(pair($1,$3));}
- ;
-
-dbinds : '{' dbs0 end {$$ = gc3($2);}
- | '{' dbs1 end {$$ = gc3($2);}
- ;
-dbs0 : /* empty */ {$$ = gc0(NIL);}
- | dbs0 ';' {$$ = gc2($1);}
- | dbs1 ';' {$$ = gc2($1);}
- ;
-dbs1 : dbs0 dbind {$$ = gc2(cons($2,$1));}
- ;
-dbind : IPVARID '=' exp {$$ = gc3(pair($1,$3));}
- ;
-
-/*- List Expressions: -------------------------------------------------------*/
-
-list : exp {$$ = gc1(ap(FINLIST,cons($1,NIL)));}
- | exps2 {$$ = gc1(ap(FINLIST,rev($1)));}
- | exp '|' quals {$$ = gc3(ap(COMP,pair($1,rev($3))));}
- | exp UPTO exp {$$ = gc3(ap(ap(nameFromTo,$1),$3));}
- | exp ',' exp UPTO {$$ = gc4(ap(ap(nameFromThen,$1),$3));}
- | exp UPTO {$$ = gc2(ap(nameFrom,$1));}
- | exp ',' exp UPTO exp {$$ = gc5(ap(ap(ap(nameFromThenTo,
- $1),$3),$5));}
- ;
-quals : quals ',' qual {$$ = gc3(cons($3,$1));}
- | qual {$$ = gc1(cons($1,NIL));}
- ;
-qual : exp FROM exp {$$ = gc3(ap(FROMQUAL,pair($1,$3)));}
- | exp {$$ = gc1(ap(BOOLQUAL,$1));}
- | LET decls {$$ = gc2(ap(QWHERE,$2));}
- ;
-
-/*- Identifiers and symbols: ----------------------------------------------*/
-
-gcon : qcon {$$ = $1;}
- | '(' ')' {$$ = gc2(nameUnit);}
- | '[' ']' {$$ = gc2(nameNil);}
- | '(' tupCommas ')' {$$ = gc3($2);}
- ;
-tupCommas : tupCommas ',' {$$ = gc2(mkTuple(tupleOf($1)+1));}
- | ',' {$$ = gc1(mkTuple(2));}
- ;
-varid : VARID {$$ = $1;}
- | HIDING {$$ = gc1(varHiding);}
- | QUALIFIED {$$ = gc1(varQualified);}
- | ASMOD {$$ = gc1(varAsMod);}
- ;
-qconid : QCONID {$$ = $1;}
- | CONID {$$ = $1;}
- ;
-var : varid {$$ = $1;}
- | '(' VAROP ')' {$$ = gc3($2);}
- | '(' '+' ')' {$$ = gc3(varPlus);}
- | '(' '-' ')' {$$ = gc3(varMinus);}
- | '(' '!' ')' {$$ = gc3(varBang);}
- | '(' '.' ')' {$$ = gc3(varDot);}
- ;
-qvar : QVARID {$$ = $1;}
- | '(' QVAROP ')' {$$ = gc3($2);}
- | var {$$ = $1;}
- ;
-con : CONID {$$ = $1;}
- | '(' CONOP ')' {$$ = gc3($2);}
- ;
-qcon : QCONID {$$ = $1;}
- | '(' QCONOP ')' {$$ = gc3($2);}
- | con {$$ = $1;}
- ;
-varop : '+' {$$ = gc1(varPlus);}
- | '-' {$$ = gc1(varMinus);}
- | varop_mipl {$$ = $1;}
- ;
-varop_mi : '+' {$$ = gc1(varPlus);}
- | varop_mipl {$$ = $1;}
- ;
-varop_pl : '-' {$$ = gc1(varMinus);}
- | varop_mipl {$$ = $1;}
- ;
-varop_mipl: VAROP {$$ = $1;}
- | '`' varid '`' {$$ = gc3($2);}
- | '!' {$$ = gc1(varBang);}
- | '.' {$$ = gc1(varDot);}
- ;
-qvarop : '-' {$$ = gc1(varMinus);}
- | qvarop_mi {$$ = $1;}
- ;
-qvarop_mi : QVAROP {$$ = $1;}
- | '`' QVARID '`' {$$ = gc3($2);}
- | varop_mi {$$ = $1;}
- ;
-
-conop : CONOP {$$ = $1;}
- | '`' CONID '`' {$$ = gc3($2);}
- ;
-qconop : QCONOP {$$ = $1;}
- | '`' QCONID '`' {$$ = gc3($2);}
- | conop {$$ = $1;}
- ;
-op : varop {$$ = $1;}
- | conop {$$ = $1;}
- ;
-qop : qvarop {$$ = $1;}
- | qconop {$$ = $1;}
- ;
-
-/*- Stuff from STG hugs ---------------------------------------------------*/
-
-qvarid : varid1 {$$ = gc1($1);}
- | QVARID {$$ = gc1($1);}
-
-varid1 : VARID {$$ = gc1($1);}
- | HIDING {$$ = gc1(varHiding);}
- | QUALIFIED {$$ = gc1(varQualified);}
- | ASMOD {$$ = gc1(varAsMod);}
- ;
-
-/*- Tricks to force insertion of leading and closing braces ---------------*/
-
-begin : error {yyerrok;
- if (offsideON) goOffside(startColumn);}
- ;
-
-end : '}' {$$ = $1;}
- | error {yyerrok;
- if (offsideON && canUnOffside()) {
- unOffside();
- /* insert extra token on stack*/
- push(NIL);
- pushed(0) = pushed(1);
- pushed(1) = mkInt(column);
- }
- else
- syntaxError("definition");
- }
- ;
-
-/*-------------------------------------------------------------------------*/
-
-%%
-
-static Cell local gcShadow(n,e) /* keep parsed fragments on stack */
-Int n;
-Cell e; {
- /* If a look ahead token is held then the required stack transformation
- * is:
- * pushed: n 1 0 1 0
- * x1 | ... | xn | la ===> e | la
- * top() top()
- *
- * Otherwise, the transformation is:
- * pushed: n-1 0 0
- * x1 | ... | xn ===> e
- * top() top()
- */
- if (yychar>=0) {
- pushed(n-1) = top();
- pushed(n) = e;
- }
- else
- pushed(n-1) = e;
- sp -= (n-1);
- return e;
-}
-
-static Void local syntaxError(s) /* report on syntax error */
-String s; {
- ERRMSG(row) "Syntax error in %s (unexpected %s)", s, unexpected()
- EEND;
-}
-
-static String local unexpected() { /* find name for unexpected token */
- static char buffer[100];
- static char *fmt = "%s \"%s\"";
- static char *kwd = "keyword";
-
- switch (yychar) {
- case 0 : return "end of input";
-
-#define keyword(kw) sprintf(buffer,fmt,kwd,kw); return buffer;
- case INFIXL : keyword("infixl");
- case INFIXR : keyword("infixr");
- case INFIXN : keyword("infix");
- case FOREIGN : keyword("foreign");
- case UNSAFE : keyword("unsafe");
- case TINSTANCE : keyword("instance");
- case TCLASS : keyword("class");
- case CASEXP : keyword("case");
- case OF : keyword("of");
- case IF : keyword("if");
- case THEN : keyword("then");
- case ELSE : keyword("else");
- case WHERE : keyword("where");
- case TYPE : keyword("type");
- case DATA : keyword("data");
- case TNEWTYPE : keyword("newtype");
- case LET : keyword("let");
- case IN : keyword("in");
- case DERIVING : keyword("deriving");
- case DEFAULT : keyword("default");
- case IMPORT : keyword("import");
- case TMODULE : keyword("module");
- /* AJG: Hugs98/Classic use the keyword forall
- rather than __forall.
- Agree on one or the other
- */
- case ALL : keyword("__forall");
-#if IPARAM
- case DLET : keyword("dlet");
- case WITH : keyword("with");
-#endif
-#undef keyword
-
- case ARROW : return "`->'";
- case '=' : return "`='";
- case COCO : return "`::'";
- case '-' : return "`-'";
- case '!' : return "`!'";
- case ',' : return "comma";
- case '@' : return "`@'";
- case '(' : return "`('";
- case ')' : return "`)'";
- case '{' : return "`{', possibly due to bad layout";
- case '}' : return "`}', possibly due to bad layout";
- case '_' : return "`_'";
- case '|' : return "`|'";
- case '.' : return "`.'";
- case ';' : return "`;', possibly due to bad layout";
- case UPTO : return "`..'";
- case '[' : return "`['";
- case ']' : return "`]'";
- case FROM : return "`<-'";
- case '\\' : return "backslash (lambda)";
- case '~' : return "tilde";
- case '`' : return "backquote";
-#if TREX
- case RECSELID : sprintf(buffer,"selector \"#%s\"",
- textToStr(extText(snd(yylval))));
- return buffer;
-#endif
-#if IPARAM
- case IPVARID : sprintf(buffer,"implicit parameter \"?%s\"",
- textToStr(textOf(yylval)));
- return buffer;
-#endif
- case VAROP :
- case VARID :
- case CONOP :
- case CONID : sprintf(buffer,"symbol \"%s\"",
- textToStr(textOf(yylval)));
- return buffer;
- case QVAROP :
- case QVARID :
- case QCONOP :
- case QCONID : sprintf(buffer,"symbol \"%s\"",
- identToStr(yylval));
- return buffer;
- case HIDING : return "symbol \"hiding\"";
- case QUALIFIED : return "symbol \"qualified\"";
- case ASMOD : return "symbol \"as\"";
- case NUMLIT : return "numeric literal";
- case CHARLIT : return "character literal";
- case STRINGLIT : return "string literal";
- case IMPLIES : return "`=>'";
- default : return "token";
- }
-}
-
-static Cell local checkPrec(p) /* Check for valid precedence value*/
-Cell p; {
- if (!isInt(p) || intOf(p)<MIN_PREC || intOf(p)>MAX_PREC) {
- ERRMSG(row) "Precedence value must be an integer in the range [%d..%d]",
- MIN_PREC, MAX_PREC
- EEND;
- }
- return p;
-}
-
-static Cell local buildTuple(tup) /* build tuple (x1,...,xn) from */
-List tup; { /* list [xn,...,x1] */
- Int n = 0;
- Cell t = tup;
- Cell x;
-
- do { /* . . */
- x = fst(t); /* / \ / \ */
- fst(t) = snd(t); /* xn . . xn */
- snd(t) = x; /* . ===> . */
- x = t; /* . . */
- t = fun(x); /* . . */
- n++; /* / \ / \ */
- } while (nonNull(t)); /* x1 NIL (n) x1 */
- fst(x) = mkTuple(n);
- return tup;
-}
-
-static List local checkCtxt(con) /* validate context */
-Type con; {
- mapOver(checkPred, con);
- return con;
-}
-
-static Cell local checkPred(c) /* check that type expr is a valid */
-Cell c; { /* constraint */
- Cell cn = getHead(c);
-#if TREX
- if (isExt(cn) && argCount==1)
- return c;
-#endif
-#if IPARAM
- if (isIP(cn))
- return c;
-#endif
- if (!isQCon(cn) /*|| argCount==0*/)
- syntaxError("class expression");
- return c;
-}
-
-static Pair local checkDo(dqs) /* convert reversed list of dquals */
-List dqs; { /* to an (expr,quals) pair */
- if (isNull(dqs) || whatIs(hd(dqs))!=DOQUAL) {
- ERRMSG(row) "Last generator in do {...} must be an expression"
- EEND;
- }
- fst(dqs) = snd(fst(dqs)); /* put expression in fst of pair */
- snd(dqs) = rev(snd(dqs)); /* & reversed list of quals in snd */
- return dqs;
-}
-
-static Cell local checkTyLhs(c) /* check that lhs is of the form */
-Cell c; { /* T a1 ... a */
- Cell tlhs = c;
- while (isAp(tlhs) && whatIs(arg(tlhs))==VARIDCELL) {
- tlhs = fun(tlhs);
- }
- if (whatIs(tlhs)!=CONIDCELL) {
- ERRMSG(row) "Illegal left hand side in datatype definition"
- EEND;
- }
- return c;
-}
-
-
-#if !TREX
-static Void local noTREX(where)
-String where; {
- ERRMSG(row) "Attempt to use TREX records while parsing %s.\n", where ETHEN
- ERRTEXT "(TREX is disabled in this build of Hugs)"
- EEND;
-}
-#endif
-#if !IPARAM
-static Void local noIP(where)
-String where; {
- ERRMSG(row) "Attempt to use Implicit Parameters while parsing %s.\n", where ETHEN
- ERRTEXT "(Implicit Parameters are disabled in this build of Hugs)"
- EEND;
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Part of the type checker dealing with predicates and entailment
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: preds.c,v $
- * $Revision: 1.11 $
- * $Date: 2000/03/13 11:37:16 $
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Cell local assumeEvid ( Cell,Int );
-#if IPARAM
-static Cell local findIPEvid ( Text );
-static Void local removeIPEvid ( Text );
-#endif
-static List local makePredAss ( List,Int );
-static List local copyPreds ( List );
-static Void local qualify ( List,Cell );
-static Void local qualifyBinding ( List,Cell );
-static Cell local qualifyExpr ( Int,List,Cell );
-static Void local overEvid ( Cell,Cell );
-
-static Void local cutoffExceeded ( Cell,Int,List );
-static Cell local scFind ( Cell,Cell,Int,Cell,Int,Int );
-static Cell local scEntail ( List,Cell,Int,Int );
-static Cell local entail ( List,Cell,Int,Int );
-static Cell local inEntail ( List,Cell,Int,Int );
-#if MULTI_INST
-static Cell local inEntails ( List,Cell,Int,Int );
-static Bool local instCompare ( Inst, Inst );
-#endif
-#if TREX
-static Cell local lacksNorm ( Type,Int,Cell );
-#endif
-
-static List local scSimplify ( List );
-static Void local elimTauts ( Void );
-static Bool local anyGenerics ( Type,Int );
-static List local elimOuterPreds ( List );
-static List local elimPredsUsing ( List,List );
-static Void local reducePreds ( Void );
-static Void local normPreds ( Int );
-
-static Bool local resolveDefs ( List );
-static Bool local resolveVar ( Int );
-static Class local classConstraining ( Int,Cell,Int );
-static Bool local instComp_ ( Inst,Inst );
-
-/* --------------------------------------------------------------------------
- * Predicate assignments:
- *
- * A predicate assignment is represented by a list of triples (pi,o,ev)
- * where o is the offset for types in pi, with evidence required at the
- * node pointed to by ev (which is taken as a dictionary parameter if
- * no other evidence is available). Note that the ev node will be
- * overwritten at a later stage if evidence for that predicate is found
- * subsequently.
- * ------------------------------------------------------------------------*/
-
-static List preds; /* Current predicate assignment */
-
-static Cell local assumeEvid(pi,o) /* Add predicate pi (offset o) to */
-Cell pi; /* preds with new dict var nd */
-Int o; {
- Cell nd = inventDictVar();
- preds = cons(triple(pi,mkInt(o),nd),preds);
- return nd;
-}
-
-#if IPARAM
-static Cell local findIPEvid(t)
-Text t; {
- List ps = preds;
- for (; nonNull(ps); ps=tl(ps)) {
- Cell p = hd(ps);
- if (ipMatch(fst3(p), t))
- return p;
- }
- return NIL;
-}
-
-static Void local removeIPEvid(t)
-Text t; {
- List ps = preds;
- List *prev = &preds;
- for (; nonNull(ps); ps = tl(ps))
- if (ipMatch(fst3(hd(ps)), t)) {
- *prev = tl(ps);
- return;
- } else {
- prev = &tl(ps);
- }
-}
-#endif
-
-
-static List local makePredAss(qs,o) /* Make list of predicate assumps. */
-List qs; /* from qs (offset o), w/ new dict */
-Int o; { /* vars for each predicate */
- List result = NIL;
- for (; nonNull(qs); qs=tl(qs))
- result = cons(triple(hd(qs),mkInt(o),inventDictVar()),result);
- return rev(result);
-}
-
-static List local copyPreds(qs) /* Copy list of predicates */
-List qs; {
- List result = NIL;
- for (; nonNull(qs); qs=tl(qs)) {
- Cell pi = hd(qs);
- result = cons(copyPred(fst3(pi),intOf(snd3(pi))),result);
- }
- return rev(result);
-}
-
-static Void local qualify(qs,alt) /* Add extra dictionary args to */
-List qs; /* qualify alt by predicates in qs */
-Cell alt; { /* :: ([Pat],Rhs) */
- List ds;
- for (ds=NIL; nonNull(qs); qs=tl(qs))
- ds = cons(thd3(hd(qs)),ds);
- fst(alt) = revOnto(ds,fst(alt));
-}
-
-static Void local qualifyBinding(qs,b) /* Add extra dict args to each */
-List qs; /* alternative in function binding */
-Cell b ; {
- if (!isVar(fst(b))) /* check for function binding */
- internal("qualifyBinding");
- map1Proc(qualify,qs,snd(snd(b)));
-}
-
-static Cell local qualifyExpr(l,ps,e) /* Add dictionary params to expr */
-Int l;
-List ps;
-Cell e; {
- if (nonNull(ps)) { /* Qualify input expression with */
- if (whatIs(e)!=LAMBDA) /* additional dictionary params */
- e = ap(LAMBDA,pair(NIL,pair(mkInt(l),e)));
- qualify(ps,snd(e));
- }
- return e;
-}
-
-static Void local overEvid(dv,ev) /* Overwrite dict var dv with */
-Cell dv; /* evidence ev */
-Cell ev; {
- fst(dv) = nameInd;
- snd(dv) = ev;
-}
-
-/* --------------------------------------------------------------------------
- * Predicate entailment:
- *
- * Entailment plays a prominent role in the theory of qualified types, and
- * so, unsurprisingly, in the implementation too. For practical reasons,
- * we break down entailment into two pieces. The first, scEntail, uses
- * only the information provided by class declarations, while the second,
- * entail, also uses the information in instance declarations.
- *
- * scEntail uses the following auxiliary function to do its work:
- *
- * scFind (e : pi') pi : Find evidence for predicate pi using only
- * equality of predicates, superclass entailment,
- * and the evidence e for pi'.
- *
- * scFind (e : pi') pi =
- *
- * if pi = pi' then
- * return e
- *
- * if (pi.class.level < pi'.class.level)
- * get superclass entailment pi' ||- P
- * for each (sc, pi0) in P
- * if (ev := scFind (sc e : pi0) pi) /= NIL
- * return ev
- *
- * return NIL
- *
- * This code assumes that the class hierarchy is acyclic, and that
- * each class has been assigned a `level', which is its height in
- * the hierachy. The first of the assumptions guarantees that the
- * algorithm will terminate. The comparison of levels is an
- * optimization that cuts down the search space: given that superclass
- * entailments can only be used to descend the hierarchy, there is no
- * way we can reach a higher level than the one that we start with,
- * and hence there is no point in looking if we reach such a position.
- *
- * scEntail extends scFind to work on whole predicate assignments:
- *
- * scEntail P pi : Find evidence for predicate pi using the evidence
- * provided by the predicate assignment P, and using
- * only superclass entailments.
- *
- * scEntail P pi =
- *
- * for each (v:pi') in P
- * if (ev := scFind (v:pi') pi) /= NIL
- * return ev;
- * return NIL
- *
- * ------------------------------------------------------------------------*/
-
-Int cutoff = 64; /* Used to limit depth of recursion*/
-
-static Void local cutoffExceeded(pi,o,ps)
-Cell pi; /* Display error msg when cutoff */
-Int o;
-List ps; {
- clearMarks();
- ERRMSG(0)
- "\n*** The type checker has reached the cutoff limit while trying to\n"
- ETHEN ERRTEXT
- "*** determine whether:\n*** " ETHEN ERRPRED(copyPred(pi,o));
- ps = copyPreds(ps);
- ERRTEXT
- "\n*** can be deduced from:\n*** " ETHEN ERRCONTEXT(ps);
- ERRTEXT
- "\n*** This may indicate that the problem is undecidable. However,\n"
- ETHEN ERRTEXT
- "*** you may still try to increase the cutoff limit using the -c\n"
- ETHEN ERRTEXT
- "*** option and then try again. (The current setting is -c%d)\n",
- cutoff
- EEND;
-}
-
-static Cell local scFind(e,pi1,o1,pi,o,d)/* Use superclass entailment to */
-Cell e; /* find evidence for (pi,o) using */
-Cell pi1; /* the evidence e for (pi1,o1). */
-Int o1;
-Cell pi;
-Int o;
-Int d; {
- Class h1 = getHead(pi1);
- Class h = getHead(pi);
- Cell ev = NIL;
-
- /* the h==h1 test is just an optimization, and I'm not
- sure it will work with IPs, so I'm being conservative
- and commenting it out */
- if (/* h==h1 && */ samePred(pi1,o1,pi,o))
- return e;
-
- if (isClass(h1) && (!isClass(h) || cclass(h).level<cclass(h1).level)) {
- Int beta = newKindedVars(cclass(h1).kinds);
- List scs = cclass(h1).supers;
- List dsels = cclass(h1).dsels;
- List ps = NIL;
- if (!matchPred(pi1,o1,cclass(h1).head,beta))
- internal("scFind");
-
- for (; nonNull(scs); scs=tl(scs), dsels=tl(dsels))
- ps = cons(triple(hd(scs),mkInt(beta),ap(hd(dsels),e)),ps);
- ps = rev(ps);
-
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- int i;
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("scEntail(scFind): ", stdout);
- printContext(stdout,copyPreds(ps));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(pi, o));
- fputc('\n', stdout);
- }
-#endif
- improve1(0,ps,pi,o);
- ev = scEntail(ps,pi,o,d);
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes && nonNull(ev)) {
- int i;
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("scSat.\n", stdout);
- }
-#endif
- return ev;
- }
- return NIL;
-}
-
-static Cell local scEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
-List ps; /* Using superclasses and equality.*/
-Cell pi;
-Int o;
-Int d; {
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,ps);
-
- for (; nonNull(ps); ps=tl(ps)) {
- Cell pi1 = hd(ps);
- Cell ev = scFind(thd3(pi1),fst3(pi1),intOf(snd3(pi1)),pi,o,d);
- if (nonNull(ev))
- return ev;
- }
- return NIL;
-}
-
-
-/* --------------------------------------------------------------------------
- * Now we reach the main entailment routine:
- *
- * entail P pi : Find evidence for predicate pi using the evidence
- * provided by the predicate assignment P.
- *
- * entail P pi =
- *
- * if (ev := scEntail P pi) /= NIL
- * return ev;
- *
- * if there is an instance entailment i : Q ||- pi
- * for each pi' in Q
- * if (ev := entail P pi') /= NIL
- * i := ap(i,ev)
- * else
- * return NIL
- * return i
- *
- * return NIL;
- *
- * The form of evidence expressions produced by scEntail can be described
- * by the grammar:
- *
- * e = v | sc e (v = evidence var, sc = superclass sel)
- *
- * while entail extends this to include dictionary expressions given by:
- *
- * d = e | mki d1 ... dn (mki = dictionary constructor)
- *
- * A full grammar for evidence expressions is:
- *
- * d = v | sc d | mki d1 ... dn
- *
- * and this includes evidence expressions of the form sc (mki d1 ... dn)
- * that can never be produced by either of the entail functions described
- * above. This is good, from a practical perspective, because t means
- * that we won't waste effort building a dictionary (mki d1 ... dn) only
- * to extract just one superclass component and throw the rest away.
- * Moreover, conditions on instance decls already guarantee that any
- * expression of this form can be rewritten in the form mki' d1' ... dn'.
- * (Minor point: they don't guarantee that such rewritings will lead to
- * smaller terms, and hence to termination. However, we have already
- * accepted the benefits of an undecidable entailment relation over
- * guarantees of termination, and this additional quirk is unlikely
- * to cause any further concern, except in pathological cases.)
- * ------------------------------------------------------------------------*/
-
-static Cell local entail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
-List ps; /* Uses superclasses, equality, */
-Cell pi; /* tautology, and construction */
-Int o;
-Int d; {
- Cell ev = NIL;
-
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- int i;
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("entail: ", stdout);
- printContext(stdout,copyPreds(ps));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(pi, o));
- fputc('\n', stdout);
- }
-#endif
-
- ev = scEntail(ps,pi,o,d);
- if (nonNull(ev)) {
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- int i;
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("scSat.\n", stdout);
- }
-#endif
- } else {
- ev =
-#if MULTI_INST
- multiInstRes ? inEntails(ps,pi,o,d) :
- inEntail(ps,pi,o,d);
-#else
- inEntail(ps,pi,o,d);
-#endif
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (nonNull(ev) && showInstRes) {
- int i;
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("inSat.\n", stdout);
- }
-#endif
- }
- return ev;
-}
-
-static Cell local inEntail(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
-List ps; /* using a top-level instance */
-Cell pi; /* entailment */
-Int o;
-Int d; {
- int i;
- Inst in;
-
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,ps);
-
-#if TREX
- if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
- Cell e = fun(pi);
- Cell l;
- l = lacksNorm(arg(pi),o,e);
- if (isNull(l) || isInt(l))
- return l;
- else {
- List qs = ps;
- for (; nonNull(qs); qs=tl(qs)) {
- Cell qi = fst3(hd(qs));
- if (isAp(qi) && fun(qi)==e) {
- Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
- if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
- Int f = intOf(snd(l)) - intOf(snd(lq));
- return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
- mkInt(f),
- thd3(hd(qs)));
- }
- }
- }
- return NIL;
- }
- }
- else {
-#endif
-
- in = findInstFor(pi,o); /* Class predicates */
- if (nonNull(in)) {
- Int beta = typeOff;
- Cell e = inst(in).builder;
- List es = inst(in).specifics;
- List fs = NIL;
- for (; nonNull(es); es=tl(es))
- fs = cons(triple(hd(es),mkInt(beta),NIL),fs);
- fs = rev(fs);
- improve(0,ps,fs);
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("try ", stdout);
- printContext(stdout, copyPreds(fs));
- fputs(" => ", stdout);
- printPred(stdout, copyPred(inst(in).head,beta));
- fputc('\n', stdout);
- }
-#endif
- for (es=inst(in).specifics; nonNull(es); es=tl(es)) {
- Cell ev;
- ev = entail(ps,hd(es),beta,d);
- if (nonNull(ev))
- e = ap(e,ev);
- else
- return NIL;
- }
- return e;
- }
-#if EXPLAIN_INSTANCE_RESOLUTION
- else {
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("No instance found for ", stdout);
- printPred(stdout, copyPred(pi, o));
- fputc('\n', stdout);
- }
- }
-#endif
- return NIL;
-#if TREX
- }
-#endif
-}
-
-#if MULTI_INST
-static Cell local inEntails(ps,pi,o,d) /* Calc evidence for (pi,o) from ps*/
-List ps; /* using a top-level instance */
-Cell pi; /* entailment */
-Int o;
-Int d; {
- int i;
- int k = 0;
- Cell ins; /* Class predicates */
- Inst in, in_;
- Cell e_;
-
- if (d++ >= cutoff)
- cutoffExceeded(pi,o,ps);
-
-#if TREX
- if (isAp(pi) && isExt(fun(pi))) { /* Lacks predicates */
- Cell e = fun(pi);
- Cell l;
- l = lacksNorm(arg(pi),o,e);
- if (isNull(l) || isInt(l))
- return l;
- else {
- List qs = ps;
- for (; nonNull(qs); qs=tl(qs)) {
- Cell qi = fst3(hd(qs));
- if (isAp(qi) && fun(qi)==e) {
- Cell lq = lacksNorm(arg(qi),intOf(snd3(hd(qs))),e);
- if (isAp(lq) && intOf(fst(l))==intOf(fst(lq))) {
- Int f = intOf(snd(l)) - intOf(snd(lq));
- return (f==0) ? thd3(hd(qs)) : ap2(nameAddEv,
- mkInt(f),
- thd3(hd(qs)));
- }
- }
- }
- return NIL;
- }
- }
- else {
-#endif
-
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("inEntails: ", stdout);
- printContext(stdout,copyPreds(ps));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(pi, o));
- fputc('\n', stdout);
- }
-#endif
-
- ins = findInstsFor(pi,o);
- for (; nonNull(ins); ins=tl(ins)) {
- in = snd(hd(ins));
- if (nonNull(in)) {
- Int beta = fst(hd(ins));
- Cell e = inst(in).builder;
- Cell es = inst(in).specifics;
-
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fputs("try ", stdout);
- printContext(stdout, es);
- fputs(" => ", stdout);
- printPred(stdout, inst(in).head);
- fputc('\n', stdout);
- }
-#endif
-
- for (; nonNull(es); es=tl(es)) {
- Cell ev = entail(ps,hd(es),beta,d);
- if (nonNull(ev))
- e = ap(e,ev);
- else {
- e = NIL;
- break;
- }
- }
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
-#endif
- if (nonNull(e)) {
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- fprintf(stdout, "Sat\n");
-#endif
- if (k > 0) {
- if (instCompare (in_, in)) {
- ERRMSG(0) "Multiple satisfiable instances for "
- ETHEN
- ERRPRED(copyPred(pi, o));
- ERRTEXT "\nin_ " ETHEN ERRPRED(inst(in_).head);
- ERRTEXT "\nin " ETHEN ERRPRED(inst(in).head);
- ERRTEXT "\n"
- EEND;
- }
- }
- if (k++ == 0) {
- e_ = e;
- in_ = in;
- }
- continue;
- } else {
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes)
- fprintf(stdout, "not Sat\n");
-#endif
- continue;
- }
- }
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fprintf(stdout, "not Sat.\n");
- }
-#endif
- }
- if (k > 0)
- return e_;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- for (i = 0; i < d; i++)
- fputc(' ', stdout);
- fprintf(stdout, "all not Sat.\n");
- }
-#endif
- return NIL;
-#if TREX
- }
-#endif
-}
-
-static Bool local instComp_(ia,ib) /* See if ia is an instance of ib */
-Inst ia, ib;{
- Int alpha = newKindedVars(inst(ia).kinds);
- Int beta = newKindedVars(inst(ib).kinds);
- return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
-}
-
-static Bool local instCompare (ia, ib)
-Inst ia, ib;
-{
- return instComp_(ia, ib) && instComp_(ib, ia);
-}
-#endif
-
-Cell provePred(ks,ps,pi) /* Find evidence for predicate pi */
-Kinds ks; /* assuming ps. If ps is null, */
-List ps; /* then we get to decide whether */
-Cell pi; { /* is tautological, and we can use */
- Int beta; /* the evidence as a dictionary. */
- Cell ev;
- emptySubstitution();
- beta = newKindedVars(ks); /* (ks provides kinds for any */
- ps = makePredAss(ps,beta); /* vars that appear in pi.) */
- ev = entail(ps,pi,beta,0);
- emptySubstitution();
- return ev;
-}
-
-#if TREX
-static Cell local lacksNorm(t,o,e) /* Normalize lacks pred (t,o)\l */
-Type t; /* returning NIL (unsatisfiable), */
-Int o; /* Int (tautological) or pair (v,a)*/
-Cell e; { /* such that, if e is evid for v\l,*/
- Text l = extText(e); /* then (e+a) is evid for (t,o)\l. */
- Int a = 0;
- for (;;) {
- Tyvar *tyv;
- deRef(tyv,t,o);
- if (tyv)
- return pair(mkInt(tyvNum(tyv)),mkInt(a));
- else {
- Cell h = getDerefHead(t,o);
- if (h==typeNoRow && argCount==0)
- return mkInt(a);
- else if (isExt(h) && argCount==2) {
- Text l1 = extText(h);
- if (l1==l)
- return NIL;
- else if (strcmp(textToStr(l1),textToStr(l))<0)
- a++;
- t = arg(t);
- }
- else
- return NIL;
- }
- }
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * Predicate set Simplification:
- *
- * Calculate a minimal equivalent subset of a given set of predicates.
- * ------------------------------------------------------------------------*/
-
-static List local scSimplify(qs) /* Simplify predicates in qs, */
-List qs; { /* returning equiv minimal subset */
- Int n = length(qs);
-
- while (0<n--) {
- Cell pi = hd(qs);
- Cell ev = NIL;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- fputs("scSimplify: ", stdout);
- printContext(stdout,copyPreds(tl(qs)));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
- fputc('\n', stdout);
- }
-#endif
- ev = scEntail(tl(qs),fst3(pi),intOf(snd3(pi)),0);
- if (nonNull(ev)) {
- overEvid(thd3(pi),ev); /* Overwrite dict var with evidence*/
- qs = tl(qs); /* ... and discard predicate */
- }
- else { /* Otherwise, retain predicate */
- Cell tmp = tl(qs);
- tl(qs) = NIL;
- qs = appendOnto(tmp,qs);
- }
- }
- return qs;
-}
-
-List simpleContext(ps,o) /* Simplify context of skeletons */
-List ps; /* skeletons, offset o, using */
-Int o; { /* superclass hierarchy */
- return copyPreds(scSimplify(makePredAss(ps,o)));
-}
-
-/* --------------------------------------------------------------------------
- * Context splitting --- tautological and locally tautological predicates:
- * ------------------------------------------------------------------------*/
-
-static Void local elimTauts() { /* Remove tautological constraints */
- if (haskell98) { /* from preds */
- reducePreds(); /* (or context reduce for Hask98) */
- } else {
- List ps = preds;
- preds = NIL;
- while (nonNull(ps)) {
- Cell pi = hd(ps);
- Cell ev = entail(NIL,fst3(pi),intOf(snd3(pi)),0);
- if (nonNull(ev)) {
- overEvid(thd3(pi),ev);
- ps = tl(ps);
- }
- else {
- List tmp = tl(ps);
- tl(ps) = preds;
- preds = ps;
- ps = tmp;
- }
- }
- }
-}
-
-static Int numFixedVars = 0; /* Number of fixed vars found */
-
-static Bool local anyGenerics(t,o) /* Test for generic vars, and count*/
-Type t; /* fixed variables */
-Int o; {
- Type h = getDerefHead(t,o); /* This code is careful to expand */
- Int a = argCount; /* synonyms; mark* & copy* do not. */
- if (isSynonym(h) && a>=tycon(h).arity) {
- expandSyn(h,a,&t,&o);
- return anyGenerics(t,o);
- }
- else {
- Tyvar* tyv;
- for (; 0<a--; t=fun(t)) { /* cycle through any arguments */
- deRef(tyv,t,o);
- if (anyGenerics(arg(t),o))
- return TRUE;
- }
- deRef(tyv,t,o);
- if (tyv) {
- if (tyv->offs == FIXED_TYVAR) {
- numFixedVars++;
- return FALSE;
- }
- else
- return TRUE;
- }
- else
- return FALSE;
- }
-}
-
-static List local elimOuterPreds(sps) /* Simplify and defer any remaining*/
-List sps; { /* preds that contain no generics. */
- List qs = NIL;
- elimTauts();
- for (preds=scSimplify(preds); nonNull(preds); ) {
- Cell pi = hd(preds);
- Cell nx = tl(preds);
- if (anyGenerics(fst3(pi),intOf(snd3(pi)))
- || !isAp(fst3(pi))
- || isIP(fun(fst3(pi)))) {
- tl(preds) = qs; /* Retain predicate*/
- qs = preds;
- }
- else { /* Defer predicate */
- tl(preds) = sps;
- sps = preds;
- }
- preds = nx;
- }
- preds = qs;
- return sps;
-}
-
-static List local elimPredsUsing(ps,sps)/* Try to discharge or defer preds,*/
-List ps; /* splitting if necessary to match */
-List sps; { /* context ps. sps = savePreds. */
- List rems = NIL;
- while (nonNull(preds)) { /* Pick a predicate from preds */
- Cell p = preds;
- Cell pi = fst3(hd(p));
- Int o = intOf(snd3(hd(p)));
- Cell ev = entail(ps,pi,o,0);
- preds = tl(preds);
-
- if (nonNull(ev)) { /* Discharge if ps ||- (pi,o) */
- overEvid(thd3(hd(p)),ev);
- } else if (isIP(fun(pi))) {
- tl(p) = rems;
- rems = p;
- } else if (!isAp(pi) || !anyGenerics(pi,o)) {
- tl(p) = sps; /* Defer if no generics */
- sps = p;
- }
- else { /* Try to split generics and fixed */
- Inst in;
- if (numFixedVars>0 && nonNull(in=findInstFor(pi,o))) {
- List qs = inst(in).specifics;
- for (ev=inst(in).builder; nonNull(qs); qs=tl(qs))
- ev = ap(ev,assumeEvid(hd(qs),typeOff));
- overEvid(thd3(hd(p)),ev);
- }
- else { /* No worthwhile progress possible */
- tl(p) = rems;
- rems = p;
- }
- }
- }
- preds = rems; /* Return any remaining predicates */
- return sps;
-}
-
-static Void local reducePreds() { /* Context reduce predicates: uggh!*/
- List rems = NIL; /* (A last resort for defaulting) */
- while (nonNull(preds)) { /* Pick a predicate from preds */
- Cell p = preds;
- Cell pi = fst3(hd(p));
- Int o = intOf(snd3(hd(p)));
- Inst in = NIL;
-#if MULTI_INST
- List ins = NIL;
- if (multiInstRes) {
- ins = findInstsFor(pi,o);
- in = nonNull(ins) && isNull(tl(ins)) ? snd(hd(ins)) : NIL;
- } else
-#endif
- in = findInstFor(pi,o);
- preds = tl(preds);
- if (nonNull(in)) {
- List qs = inst(in).specifics;
- Cell ev = inst(in).builder;
- for (; nonNull(qs); qs=tl(qs))
- ev = ap(ev,assumeEvid(hd(qs),typeOff));
- overEvid(thd3(hd(p)),ev);
- }
- else { /* No worthwhile progress possible */
- tl(p) = rems;
- rems = p;
- }
- }
- preds = scSimplify(rems); /* Return any remaining predicates */
-}
-
-static Void local normPreds(line) /* Normalize each element of preds */
-Int line; { /* in some appropriate manner */
-#if TREX
- List ps = preds;
- List pr = NIL;
- while (nonNull(ps)) {
- Cell pi = fst3(hd(ps));
- Cell ev = thd3(hd(ps));
- if (isAp(pi) && isExt(fun(pi))) {
- Cell r = lacksNorm(arg(pi),intOf(snd3(hd(ps))),fun(pi));
- if (isNull(r)) {
- ERRMSG(line) "Cannot satisfy constraint " ETHEN
- ERRPRED(copyPred(pi,intOf(snd3(hd(ps)))));
- ERRTEXT "\n"
- EEND;
- }
- else if (isInt(r)) {
- overEvid(ev,r);
- ps = tl(ps);
- if (isNull(pr))
- preds = ps;
- else
- tl(pr) = ps;
- }
- else if (intOf(snd(r))!=0) {
- Cell nd = inventDictVar();
- Cell ev1 = ap2(nameAddEv,snd(r),nd);
- pi = ap(fun(pi),aVar);
- hd(ps) = triple(pi,fst(r),nd);
- overEvid(ev,ev1);
- pr = ps;
- ps = tl(ps);
- }
- else {
- fst3(hd(ps)) = ap(fun(pi),fst(r));
- pr = ps;
- ps = tl(ps);
- }
- }
- else {
- pr = ps;
- ps = tl(ps);
- }
- }
-#endif
-}
-
-/* --------------------------------------------------------------------------
- * Mechanisms for dealing with defaults:
- * ------------------------------------------------------------------------*/
-
-static Bool local resolveDefs(vs) /* Attempt to resolve defaults */
-List vs; { /* for variables vs subject to */
- List pvs = NIL; /* constraints in preds */
- List qs = preds;
- Bool defaulted = FALSE;
-
-#ifdef DEBUG_DEFAULTS
- Printf("Attempt to resolve variables ");
- printExp(stdout,vs);
- Printf(" with context ");
- printContext(stdout,copyPreds(preds));
- Printf("\n");
-#endif
-
- resetGenerics(); /* find type variables in ps */
- for (; nonNull(qs); qs=tl(qs)) {
- Cell pi = fst3(hd(qs));
- Int o = intOf(snd3(hd(qs)));
- for (; isAp(pi); pi=fun(pi))
- pvs = genvarType(arg(pi),o,pvs);
- }
-
- for (; nonNull(pvs); pvs=tl(pvs)) { /* now try defaults */
- Int vn = intOf(hd(pvs));
-
-#ifdef DEBUG_DEFAULTS
- Printf("is var %d included in ",vn);
- printExp(stdout,vs);
- Printf("?\n");
-#endif
-
- if (!intIsMember(vn,vs))
- defaulted |= resolveVar(vn);
-#ifdef DEBUG_DEFAULTS
- else
- Printf("Yes, so no ambiguity!\n");
-#endif
- }
-
- return defaulted;
-}
-
-static Bool local resolveVar(vn) /* Determine whether an ambig. */
-Int vn; { /* variable vn can be resolved */
- List ps = preds; /* by default in the context of */
- List cs = NIL; /* the predicates in ps */
- Bool aNumClass = FALSE;
-
- if (tyvar(vn)->bound == SKOLEM)
- return FALSE;
-
- /* According to the Haskell definition, we can only default an ambiguous
- * variable if the set of classes that constrain it:
- * (a) includes at least one numeric class.
- * (b) includes only numeric or standard classes.
- * In addition, we will not allow a variable to be defaulted unless it
- * appears only in predicates of the form (Class var).
- */
-
-#ifdef DEBUG_DEFAULTS
- Printf("Trying to default variable %d\n",vn);
-#endif
-
- for (; nonNull(ps); ps=tl(ps)) {
- Cell pi = hd(ps);
- Class c = classConstraining(vn,fst3(pi),intOf(snd3(pi)));
- if (nonNull(c)) {
- if (c==classRealFrac || c==classRealFloat ||
- c==classFractional || c==classFloating ||
- c==classReal || c==classIntegral || c==classNum)
- aNumClass = TRUE;
- else if (c!=classEq && c!=classOrd && c!=classShow &&
- c!=classRead && c!=classIx && c!=classEnum &&
- c!=classBounded)
- return FALSE;
-
- { Type t = arg(fst3(pi));/* Check for single var as arg */
- Int o = intOf(snd3(pi));
- Tyvar *tyv;
- deRef(tyv,t,o);
- if (!tyv || tyvNum(tyv)!=vn)
- return FALSE;
- }
- if (!cellIsMember(c,cs))
- cs = cons(c,cs);
- }
- }
-
- /* Now find the first class (if any) in the list of defaults that
- * is an instance of all of the required classes.
- *
- * If we get this far, then cs only mentions classes from the list
- * above, all of which have only a single parameter of kind *.
- */
-
- if (aNumClass) {
- List ds = defaultDefns; /* N.B. guaranteed to be monotypes */
-#ifdef DEBUG_DEFAULTS
- Printf("Default conditions met, looking for type\n");
-#endif
- for (; nonNull(ds); ds=tl(ds)) {
- List cs1 = cs;
- while (nonNull(cs1) && nonNull(entail(NIL,ap(hd(cs1),hd(ds)),0,0)))
- cs1 = tl(cs1);
- if (isNull(cs1)) {
- bindTv(vn,hd(ds),0);
-#ifdef DEBUG_DEFAULTS
- Printf("Default type for variable %d is ",vn);
- printType(stdout,hd(ds));
- Printf("\n");
-#endif
- return TRUE;
- }
- }
- }
-
-#ifdef DEBUG_DEFAULTS
- Printf("No default permitted/found\n");
-#endif
- return FALSE;
-}
-
-static Class local classConstraining(vn,pi,o)
-Int vn; /* Return class constraining var*/
-Cell pi; /* vn in predicate pi, or NIL if*/
-Int o; { /* vn is not involved */
- for (; isAp(pi); pi=fun(pi))
- if (!doesntOccurIn(tyvar(vn),arg(pi),o))
- return getHead(pi);
- return NIL;
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-#!/bin/bash
-if ! [ -d nofibtmp ]
-then
-echo "runallnofib: Can't cd to nofibtmp"
-exit
-fi
-
-TROOT=/home/v-julsew/Feb24
-NROOT=$TROOT/fpt/nofib
-
-cd nofibtmp
-
-
-##------ imaginary ------##
-
-../runnofib imaginary exp3_8
-../runnofib imaginary gen_regexps
-../runnofib imaginary paraffins
-../runnofib imaginary primes
-../runnofib imaginary rfib
-../runnofib imaginary tak
-../runnofib imaginary wheel-sieve1
-../runnofib imaginary wheel-sieve2
-
-
-##------ spectral ------##
-
-../runnofib spectral ansi
-../runnofib spectral awards
-../runnofib spectral boyer
-../runnofib spectral boyer2
-../runnofib spectral calendar 1993
-../runnofib spectral cichelli
-../runnofib spectral circsim "+RTS -H150m -RTS 8 1000"
-../runnofib spectral clausify
-../runnofib spectral cse
-../runnofib spectral eliza
-
-cp $NROOT/spectral/expert/animals .
-../runnofib spectral expert
-rm animals
-
-##../runnofib spectral fibheaps -- requires -fglasgow-exts
-
-../runnofib spectral fish
-../runnofib spectral fft2
-../runnofib spectral life
-../runnofib spectral knights 8 3
-../runnofib spectral mandel
-../runnofib spectral mandel2
-../runnofib spectral minimax
-../runnofib spectral multiplier
-../runnofib spectral pretty
-../runnofib spectral primetest
-../runnofib spectral rewrite
-../runnofib spectral scc
-../runnofib spectral simple
-../runnofib spectral sorting
-
-cp $NROOT/spectral/treejoin/27000.1 .
-cp $NROOT/spectral/treejoin/27000.2 .
-../runnofib spectral treejoin "+RTS -H200m -G4 -A1m -RTS 27000.1 27000.2"
-rm 27000.1 27000.2
-
-../runnofib spectral/hartel nucleic2
-
-##------ real ------##
-
-export ANNADIR=`pwd`
-cp $NROOT/real/anna/anna_table .
-../runnofib real anna
-rm anna_table
-
-../runnofib real bspt
-../runnofib real compress
-##../runnofib real compress2 -- requires -fglasgow-exts
-
-cp $NROOT/real/ebnf2ps/Times-Roman.afm .
-cp $NROOT/real/ebnf2ps/ebnf2ps.stdin .
-../runnofib real ebnf2ps "ebnf2ps.stdin apat"
-rm Times-Roman.afm ebnf2ps.stdin
-
-../runnofib real fem
-
-cp $NROOT/real/fluid/chan8.dat .
-../runnofib real fluid
-rm chan8.dat
-
-../runnofib real fulsom 7
-../runnofib real gamteb
-../runnofib real gg
-../runnofib real grep
-
-cp $NROOT/real/hidden/objects/four.plate .
-../runnofib real hidden four.plate
-rm four.plate
-
-##../runnofib real HMMS -- a mess. requires some effort to make it work
-../runnofib real hpg "-nt 8 -dt 6 -nv 15 -dv 8 -de 8"
-../runnofib real infer
-../runnofib real lift
-
-cp $NROOT/real/maillist/addresses .
-../runnofib real maillist
-rm addresses addresses.tex
-
-../runnofib real mkhprog "-a Int -b Float -c Foo -d Bar -e Double -f String -g String -h Int -j Double -k Bool -n Basil -p Knob -q Wizzle -r Wissle -s Wibble -t Widdle -A Int -B Float -C Foo -D Bar -E Double -F String -G String -H Int -I Float -J Double -K Bool -L Bool -M Buzzle -N Basil -P Knob -Q Wizzle -R Wissle -S Wibble -T Widdle"
-
-../runnofib real parser
-../runnofib real pic
-
-cp $NROOT/real/prolog/stdlib .
-../runnofib real prolog
-rm stdlib
-
-../runnofib real reptile
-../runnofib real rsa
-../runnofib real symalg
-../runnofib real veritas
+++ /dev/null
-#!/bin/bash
-
-TROOT=/home/v-julsew/Feb24
-CMODE=-c
-STGHUGSFLAGS=-P$TROOT/fpt/ghc/interpreter/lib
-NROOT=$TROOT/fpt/nofib
-HUGZ=$TROOT/fpt/ghc/interpreter
-LD_LIBRARY_PATH=$HUGZ:$LD_LIBRARY_PATH
-HSCPP=$TROOT/fpt/ghc/utils/hscpp
-
-echo
-echo "==================== $1/$2 ===================="
-
-TMPFILE=`mktemp /tmp/nofibXXXXXX`
-if [ $? -ne 0 ]; then
- echo "$0: Can't create temp file"
- exit 1
-fi
-
-if [ -f $NROOT/$1/$2/$2.stdin ]
-then
-echo "$HUGZ/hugs -Q $CMODE -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
-echo " < $NROOT/$1/$2/$2.stdin 2> /dev/null"
-echo " > $TMPFILE"
-else
-echo "$HUGZ/hugs -Q $CMODE -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9"
-echo " < /dev/null 2> /dev/null"
-echo " > $TMPFILE"
-fi
-
-if [ -f $NROOT/$1/$2/$2.stdin ]
-then
-$HUGZ/hugs -Q $CMODE -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < $NROOT/$1/$2/$2.stdin 2> /dev/null > $TMPFILE
-else
-$HUGZ/hugs -Q $CMODE -P$NROOT/$1/$2 Main -- $3 $4 $5 $6 $7 $8 $9 < /dev/null 2> /dev/null > $TMPFILE
-fi
-
-if [ $? -ne 0 ]; then
- echo "=== FAIL (no execution)"
- rm -f $TMPFILE
- exit 0
-fi
-
-cmp -s $TMPFILE $NROOT/$1/$2/$2.stdout
-if [ $? -ne 0 ]; then
- echo "=== FAIL (wrong results)"
-else
- echo "=== Correct"
-fi
-
-rm -f $TMPFILE
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Yet another implementation of Integer
- *
- * Copyright (c) Glasgow University, 1999.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * ------------------------------------------------------------------------*/
-
-#include <stdlib.h>
-#include <stdio.h>
-#include <assert.h>
-#include <ctype.h>
-
-#include "sainteger.h"
-
-
-/* --------------------------------------------------------------------------
- * Local fns
- * ------------------------------------------------------------------------*/
-
-typedef unsigned char uchar;
-typedef unsigned short ush;
-
-
-static int maxused_add ( B*, B* );
-static int maxused_sub ( B*, B* );
-static int maxused_mul ( B*, B* );
-static int maxused_qrm ( B*, B* );
-static int maxused_neg ( B* );
-
-static int ucmp ( B*, B* );
-static void uadd ( B*, B*, B* );
-static void usub ( B*, B*, B* );
-static void umul ( B*, B*, B* );
-static void uqrm ( B*, B*, B*, B* );
-
-/*#define DEBUG_SAINTEGER*/
-/*#define DEBUG_SAINTEGER_UQRM*/
-
-
-#ifdef DEBUG_SAINTEGER
-#define myassert(zzzz) assert(zzzz)
-#else
-#define myassert(zzzz) /* */
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Basics
- * ------------------------------------------------------------------------*/
-
-void pp ( B* x )
-{
- int i;
- printf ( "sign=%2d used=%d size=%d ", x->sign, x->used, x->size );
- for (i = x->used-1; i >= 0; i--)
- printf ( "%2x ", (int)(x->stuff[i]) );
- printf ( "\n" );
-}
-
-
-static int sane ( B* x )
-{
- int i;
-
- if (x->sign == 0 && x->used != 0) return 0;
- if (x->sign != -1 && x->sign != 0 && x->sign != 1) return 0;
-
- if (x->used < 0) return 0;
- if (x->size < 0) return 0;
- if (x->used > x->size) return 0;
- if (x->used == 0) return 1;
- if (x->stuff[x->used-1] == 0) return 0;
- for (i = 0; i < x->used; i++)
- if (x->stuff[i] >= B_BASE) return 0;
- return 1;
-}
-
-
-int is_sane ( B* x )
-{
- return sane(x);
-}
-
-
-static void u_renormalise ( B* b )
-{
- while (b->used > 0 && b->stuff[b->used-1] == 0) b->used--;
- if (b->used == 0) b->sign = 0; else b->sign = 1;
-}
-
-
-void do_renormalise ( B* b )
-{
- while (b->used > 0 && b->stuff[b->used-1] == 0) b->used--;
- if (b->used == 0) b->sign = 0;
-}
-
-/* --------------------------------------------------------------------------
- * Size of things
- * ------------------------------------------------------------------------*/
-
-static int maxused_add ( B* x, B* y )
-{
- myassert(sane(x));
- myassert(sane(y));
- return 1 + (x->used > y->used ? x->used : y->used);
-}
-
-static int maxused_sub ( B* x, B* y )
-{
- myassert(sane(x));
- myassert(sane(y));
- return 1 + (x->used > y->used ? x->used : y->used);
-}
-
-static int maxused_mul ( B* x, B* y )
-{
- myassert(sane(x));
- myassert(sane(y));
- return x->used + y->used;
-}
-
-static int maxused_qrm ( B* x, B* y )
-{
- myassert(sane(x));
- myassert(sane(y));
- return (x->used > y->used ? x->used : y->used);
-}
-
-static int maxused_neg ( B* x )
-{
- myassert(sane(x));
- return x->used;
-}
-
-
-/* quick, safe approx */
-static int maxused_fromInt ( int sizeof_int )
-{
- if (B_BASE == 256) return sizeof_int;
- if (B_BASE >= 16) return 2 * sizeof_int;
- if (B_BASE >= 4) return 4 * sizeof_int;
- /* (B_BASE >= 2) */ return 8 * sizeof_int;
-}
-
-/* ditto */
-static int maxused_fromStr ( char* str )
-{
- int nd = 0;
- if (*str == '-') str++;
- while (isdigit((int)(*str))) { str++; nd++; };
-
- if (B_BASE >= 100) return ((nd+1) / 2);
- if (B_BASE >= 10) return nd;
- /* (B_BASE >= 2)*/ return 4 * nd;
-}
-
-
-int size_add ( B* x, B* y )
-{
- return sizeof(B) + maxused_add(x,y);
-}
-
-int size_sub ( B* x, B* y )
-{
- return sizeof(B) + maxused_sub(x,y);
-}
-
-int size_mul ( B* x, B* y )
-{
- return sizeof(B) + maxused_mul(x,y);
-}
-
-int size_qrm ( B* x, B* y )
-{
- return sizeof(B) + maxused_qrm(x,y);
-}
-
-int size_neg ( B* x )
-{
- return sizeof(B) + maxused_neg(x);
-}
-
-int size_fromInt ( void )
-{
- int sizeof_int = sizeof(int);
- return sizeof(B) + maxused_fromInt ( sizeof_int );
-}
-
-int size_fromWord ( void )
-{
- int sizeof_word = sizeof(unsigned int);
- return sizeof(B) + maxused_fromInt ( sizeof_word );
-}
-
-int size_fromStr ( char* str )
-{
- return sizeof(B) + maxused_fromStr ( str );
-}
-
-int size_fltmantissa ( void )
-{
- return sizeof(B) + sizeof(float);
-}
-
-int size_dblmantissa ( void )
-{
- return sizeof(B) + sizeof(double);
-}
-
-
-/* --------------------------------------------------------------------------
- * Conversions
- * ------------------------------------------------------------------------*/
-
-void do_fromInt ( int n, int sizeRes, B* res )
-{
-
- res->size = sizeRes - sizeof(B);
- res->sign = res->used = 0;
- if (n == 0) { myassert(sane(res)); return; };
- if (n < 0) res->sign = -1; else res->sign = 1;
- if (n < 0) n = -n;
-
- while (n != 0) {
- res->stuff[res->used] = (uchar)(n % B_BASE);
- n /= B_BASE;
- res->used++;
- }
- myassert(sane(res));
-}
-
-void do_fromWord ( unsigned int n, int sizeRes, B* res )
-{
-
- res->size = sizeRes - sizeof(B);
- res->sign = res->used = 0;
- if (n == 0) { myassert(sane(res)); return; };
- res->sign = 1;
-
- while (n != 0) {
- res->stuff[res->used] = (uchar)(n % B_BASE);
- n /= B_BASE;
- res->used++;
- }
- myassert(sane(res));
-}
-
-/* NOTE: This only works currectly if B_BASE >= 10 */
-void do_fromStr ( char* str, int sizeRes, B* res )
-{
- int sign, d, t, j, carry;
-
- res->size = sizeRes - sizeof(B);
- res->sign = res->used = 0;
- sign = 1;
- if (*str == '-') { str++; sign = -1; };
-
- while (isdigit((int)(*str))) {
-
- /* multiply res by 10 */
- carry = 0;
- for (j = 0; j < res->used; j++) {
- t = 10 * res->stuff[j] + carry;
- res->stuff[j] = t % B_BASE;
- carry = t / B_BASE;
- }
- myassert(carry < B_BASE);
- if (carry > 0)
- res->stuff[res->used++] = carry;
-
- /* add a digit on */
- d = *str - '0';
- str++;
-
- carry = d;
- for (j = 0; j < res->used; j++) {
- carry += res->stuff[j];
- res->stuff[j] = carry % B_BASE;
- carry /= B_BASE;
- if (carry == 0) break;
- }
- if (carry > 0)
- res->stuff[res->used++] = carry;
- }
-
- res->sign = sign;
- myassert(sane(res));
-}
-
-int do_toInt ( B* x )
-{
- int i, d, res;
- if (x->sign == 0) return 0;
- res = 0;
- for (i = x->used-1; i >= 0; i--) {
- d = x->stuff[i];
- res = res * B_BASE + d;
- }
- if (x->sign < 0) res = -res;
- return res;
-}
-
-unsigned int do_toWord ( B* x )
-{
- int i, d;
- unsigned int res;
- if (x->sign == 0) return 0;
- res = 0;
- for (i = x->used-1; i >= 0; i--) {
- d = x->stuff[i];
- res = res * B_BASE + d;
- }
- return res;
-}
-
-float do_toFloat ( B* x )
-{
- int i, d;
- float res;
- if (x->sign == 0) return 0.0;
- res = 0.0;
- for (i = x->used-1; i >= 0; i--) {
- d = x->stuff[i];
- res = res * B_BASE_FLT + d;
- }
- if (x->sign < 0) res = -res;
- return res;
-}
-
-double do_toDouble ( B* x )
-{
- int i, d;
- double res;
- if (x->sign == 0) return 0.0;
- res = 0.0;
- for (i = x->used-1; i >= 0; i--) {
- d = x->stuff[i];
- res = res * B_BASE_FLT + d;
- }
- if (x->sign < 0) res = -res;
- return res;
-}
-
-
-/* --------------------------------------------------------------------------
- * Signed ops
- * ------------------------------------------------------------------------*/
-
-/* A helper for signed + and -. sdiff(x,y) ignores the signs of x and y
- sets p to the signed value abs(x)-abs(y).
-*/
-static void sdiff ( B* x, B* y, B* res )
-{
- int t;
- myassert(sane(x));
- myassert(sane(y));
- myassert(res->size == maxused_sub(x,y));
- t = ucmp(x,y);
- if (t == 0) { res->sign = res->used = 0; return; }
- if (t == -1) {
- /* x < y */
- usub(y,x,res);
- res->sign = -1;
- } else {
- /* x > y */
- usub(x,y,res);
- res->sign = 1;
- }
- myassert(sane(res));
-}
-
-int do_getsign ( B* x )
-{
- myassert(sane(x));
- return x->sign;
-}
-
-void do_neg ( B* x, int sizeRes, B* res )
-{
- int i;
- myassert(sane(x));
- res->size = sizeRes - sizeof(B);
- res->used = x->used;
- for (i = 0; i < x->used; i++)
- res->stuff[i] = x->stuff[i];
- res->sign = - (x->sign);
-}
-
-void do_add ( B* x, B* y, int sizeRes, B* res )
-{
- myassert(sane(x));
- myassert(sane(y));
- res->size = sizeRes - sizeof(B);
- res->used = res->sign = 0;
-
- if ( (x->sign >= 0 && y->sign >= 0) ||
- (x->sign < 0 && y->sign < 0)) {
- /* same sign; add magnitude and clone sign */
- uadd(x,y,res);
- if (x->sign < 0 && res->sign != 0) res->sign = -1;
- }
- else
- /* signs differ; employ sdiff */
- if (x->sign >= 0 && y->sign < 0) {
- sdiff(x,y,res);
- } else {
- myassert(x->sign < 0 && y->sign >= 0);
- sdiff(y,x,res);
- }
- myassert(sane(res));
-}
-
-void do_sub ( B* x, B* y, int sizeRes, B* res )
-{
- myassert(sane(x));
- myassert(sane(y));
- res->size = sizeRes - sizeof(B);
- res->used = res->sign = 0;
-
- if ( (x->sign >= 0 && y->sign < 0) ||
- (x->sign < 0 && y->sign >= 0)) {
- /* opposite signs; add magnitudes and clone sign of x */
- uadd(x,y,res);
- myassert(res->sign != 0);
- if (x->sign < 0) res->sign = -1;
- }
- else
- /* signs are the same; employ sdiff */
- if (x->sign >= 0 && y->sign >= 0) {
- sdiff(x,y,res);
- } else {
- myassert(x->sign < 0 && y->sign < 0);
- sdiff(y,x,res);
- }
- myassert(sane(res));
-}
-
-
-void do_mul ( B* x, B* y, int sizeRes, B* res )
-{
- myassert(sane(x));
- myassert(sane(y));
- res->size = sizeRes - sizeof(B);
- res->used = res->sign = 0;
-
- if (x->sign == 0 || y->sign == 0) {
- res->sign = res->used = 0;
- myassert(sane(res));
- return;
- }
- umul(x,y,res);
- if (x->sign != y->sign) res->sign = -1;
- myassert(sane(res));
-}
-
-
-void do_qrm ( B* x, B* y, int sizeRes, B* q, B* r )
-{
- myassert(sane(x));
- myassert(sane(y));
-
- q->size = r->size = sizeRes - sizeof(B);
- q->used = r->used = q->sign = r->sign = 0;
-
- if (y->sign == 0) {
- fprintf(stderr, "do_qrm: division by zero -- exiting now!\n");
- exit(1);
- return;
- }
-
- if (x->sign == 0) {
- q->used = r->used = q->sign = r->sign = 0;
- myassert(sane(q)); myassert(sane(r));
- return;
- }
-
- uqrm ( x, y, q, r );
- if (x->sign != y->sign && q->sign != 0) q->sign = -1;
- if (x->sign == -1 && r->sign != 0) r->sign = -1;
-
- myassert(sane(q)); myassert(sane(r));
-}
-
-int do_cmp ( B* x, B* y )
-{
- if (!sane(x))
- pp(x);
- myassert(sane(x));
- myassert(sane(y));
- if (x->sign < y->sign) return -1;
- if (x->sign > y->sign) return 1;
- myassert(x->sign == y->sign);
- if (x->sign == 0) return 0;
- if (x->sign == 1) return ucmp(x,y); else return ucmp(y,x);
-}
-
-
-/* --------------------------------------------------------------------------
- * Unsigned ops
- * ------------------------------------------------------------------------*/
-
-static int ucmp ( B* x, B* y )
-{
- int i;
- myassert(sane(x));
- myassert(sane(y));
- if (x->used < y->used) return -1;
- if (x->used > y->used) return 1;
- for (i = x->used-1; i >= 0; i--) {
- if (x->stuff[i] < y->stuff[i]) return -1;
- if (x->stuff[i] > y->stuff[i]) return 1;
- }
- return 0;
-}
-
-
-
-static void uadd ( B* x, B* y, B* res )
-{
- int c, i, t, n;
- B* longer;
-
- myassert(sane(x));
- myassert(sane(y));
- myassert (res->size == maxused_add(x,y));
- res->used = res->size;
- res->stuff[res->used-1] = 0;
-
- if (x->used > y->used) {
- n = y->used;
- longer = x;
- } else {
- n = x->used;
- longer = y;
- }
-
- c = 0;
- for (i = 0; i < n; i++) {
- t = x->stuff[i] + y->stuff[i] + c;
- if (t >= B_BASE) {
- res->stuff[i] = t-B_BASE;
- c = 1;
- } else {
- res->stuff[i] = t;
- c = 0;
- }
- }
-
- for (i = n; i < longer->used; i++) {
- t = longer->stuff[i] + c;
- if (t >= B_BASE) {
- res->stuff[i] = t-B_BASE;
- } else {
- res->stuff[i] = t;
- c = 0;
- }
- }
- if (c > 0) {
- myassert(res->used == longer->used+1);
- res->stuff[longer->used] = c;
- }
-
- u_renormalise(res);
- myassert(sane(res));
-}
-
-
-static void usub ( B* x, B* y, B* res )
-{
- int b, i, t;
- myassert(sane(x));
- myassert(sane(y));
- myassert (x->used >= y->used);
- myassert (res->size == maxused_sub(x,y));
-
- b = 0;
- for (i = 0; i < y->used; i++) {
- t = x->stuff[i] - y->stuff[i] - b;
- if (t < 0) {
- res->stuff[i] = t + B_BASE;
- b = 1;
- } else {
- res->stuff[i] = t;
- b = 0;
- }
- }
-
- for (i = y->used; i < x->used; i++) {
- t = x->stuff[i] - b;
- if (t < 0) {
- res->stuff[i] = t + B_BASE;
- } else {
- res->stuff[i] = t;
- b = 0;
- }
- }
- myassert (b == 0);
-
- res->used = x->used;
- u_renormalise(res);
- myassert(sane(res));
-}
-
-
-void umul ( B* x, B* y, B* res )
-{
- int i, j, carry;
-
- myassert(sane(x));
- myassert(sane(y));
- myassert(res->size == maxused_mul(x,y));
-
- for (j = 0; j < y->used; j++) res->stuff[j] = 0;
-
- for (i = 0; i < x->used; i++) {
- carry = 0;
- for (j = 0; j < y->used; j++) {
- carry += res->stuff[i+j] + x->stuff[i]*y->stuff[j];
- res->stuff[i+j] = carry % B_BASE;
- carry /= B_BASE;
- myassert (carry < B_BASE);
- }
- res->stuff[i+y->used] = carry;
- }
-
- res->used = x->used+y->used;
- u_renormalise(res);
- myassert(sane(res));
-}
-
-
-static void uqrm ( B* dend, B* isor, B* dres, B* mres )
-{
- int i, j, t, vh, toolarge, delta, carry, scaleup;
- uchar *dend_stuff, *isor_stuff, *tmp;
-
- myassert(sane(isor));
- myassert(sane(dend));
- myassert(isor->used > 0); // against division by zero
-
- myassert(dres->size == maxused_qrm(isor,dend));
- myassert(mres->size == maxused_qrm(isor,dend));
-
- if (dend->used < isor->used) {
- // Result of division must be zero, since dividend has
- // fewer digits than the divisor. Remainder is the
- // original dividend.
- dres->used = 0;
- mres->used = dend->used;
- for (j = 0; j < mres->used; j++) mres->stuff[j] = dend->stuff[j];
- u_renormalise(dres); u_renormalise(mres);
- myassert(sane(dres));
- myassert(sane(mres));
- return;
- }
-
- if (isor->used == 1) {
-
- // Simple case; divisor is a single digit
- carry = 0;
- for (j = dend->used-1; j >= 0; j--) {
- carry += dend->stuff[j];
- dres->stuff[j] = carry/isor->stuff[0];
- carry = B_BASE*(carry%isor->stuff[0]);
- }
- carry /= B_BASE;
- dres->used = dend->used;
- u_renormalise(dres);
-
- // Remainder is the final carry value
- mres->used = 0;
- if (carry > 0) {
- mres->used = 1;
- mres->stuff[0] = carry;
- }
- u_renormalise(dres); u_renormalise(mres);
- myassert(sane(dres));
- myassert(sane(mres));
- return;
-
- } else {
-
- // Complex case: both dividend and divisor have two or more digits.
- myassert(isor->used >= 2);
- myassert(dend->used >= 2);
-
- // Allocate space for a copy of both dividend and divisor, since we
- // need to mess with them. Also allocate tmp as a place to hold
- // values of the form quotient_digit * divisor.
- dend_stuff = malloc ( sizeof(uchar)*(dend->used+1) );
- isor_stuff = malloc ( sizeof(uchar)*isor->used );
- tmp = malloc ( sizeof(uchar)*(isor->used+1) );
- myassert (dend_stuff && isor_stuff && tmp);
-
- // Calculate a scaling-up factor, and multiply both divisor and
- // dividend by it. Doing this reduces the number of corrections
- // needed to the quotient-digit-estimates made in the loop below,
- // and thus speeds up division, but is not actually needed to
- // get the correct results. The scaleup factor should not increase
- // the number of digits needed to represent either the divisor
- // (since the factor is derived from it) or the dividend (since
- // we already gave it a new leading zero).
- scaleup = B_BASE / (1 + isor->stuff[isor->used-1]);
- myassert (1 <= scaleup && scaleup <= B_BASE/2);
-
- if (scaleup == 1) {
- // Don't bother to multiply; just copy.
- for (j = 0; j < dend->used; j++) dend_stuff[j] = dend->stuff[j];
- for (j = 0; j < isor->used; j++) isor_stuff[j] = isor->stuff[j];
-
- // Extend dividend with leading zero.
- dend_stuff[dend->used] = tmp[isor->used] = 0;
-
- } else {
- carry = 0;
- for (j = 0; j < isor->used; j++) {
- t = scaleup * isor->stuff[j] + carry;
- isor_stuff[j] = t % B_BASE;
- carry = t / B_BASE;
- }
- myassert (carry == 0);
-
- carry = 0;
- for (j = 0; j < dend->used; j++) {
- t = scaleup * dend->stuff[j] + carry;
- dend_stuff[j] = t % B_BASE;
- carry = t / B_BASE;
- }
- dend_stuff[dend->used] = carry;
- tmp[isor->used] = 0;
- }
-
- // For each quotient digit ...
- for (i = dend->used; i >= isor->used; i--) {
- myassert (i-2 >= 0);
- myassert (i <= dend->used);
- myassert (isor->used >= 2);
-
-#if DEBUG_SAINTEGER_UQRM
- printf("\n---------\nqdigit %d\n", i );
- printf("dend_stuff is ");
- for (j = dend->used; j>= 0; j--) printf("%d ",dend_stuff[j]);
- printf("\n");
-#endif
- // Make a guess vh of the quotient digit
- vh = (B_BASE*B_BASE*dend_stuff[i] + B_BASE*dend_stuff[i-1] + dend_stuff[i-2])
- /
- (B_BASE*isor_stuff[isor->used-1] + isor_stuff[isor->used-2]);
- if (vh > B_BASE-1) vh = B_BASE-1;
-#if DEBUG_SAINTEGER_UQRM
- printf("guess formed from %d %d %d %d %d\n",
- dend_stuff[i], dend_stuff[i-1] , dend_stuff[i-2],
- isor_stuff[isor->used-1], isor_stuff[isor->used-2]);
- printf("guess is %d\n", vh );
-#endif
- // Check if vh is too large (by 1). Calculate vh * isor into tmp
- // and see if it exceeds the same length prefix of dend. If so,
- // vh needs to be decremented.
- carry = 0;
- for (j = 0; j < isor->used; j++) {
- t = vh * isor_stuff[j] + carry;
- tmp[j] = t % B_BASE;
- carry = t / B_BASE;
- }
- tmp[isor->used] = carry;
- delta = i - isor->used;
-#if DEBUG_SAINTEGER_UQRM
- printf("final carry is %d\n", carry);
- printf("vh * isor is " );
- for (j = isor->used; j >=0; j--) printf("%d ",tmp[j]);printf("\n");
- printf("delta = %d\n", delta );
-#endif
- toolarge = 0;
- for (j = isor->used; j >= 0; j--) {
-#if DEBUG_SAINTEGER_UQRM
- printf ( "(%d,%d) ", (int)(tmp[j]), (int)(dend_stuff[j+delta]) );
-#endif
- if (tmp[j] > dend_stuff[j+delta]) {toolarge=1; break;};
- if (tmp[j] < dend_stuff[j+delta]) break;
- }
-
- // If we did guess too large, decrement vh and subtract a copy of
- // isor from tmp. This had better not go negative!
- if (toolarge) {
-#if DEBUG_SAINTEGER_UQRM
- printf ( "guess too large\n" );
-#endif
- vh--;
- carry = 0;
- for (j = 0; j < isor->used; j++) {
- if (carry + isor_stuff[j] > tmp[j]) {
- tmp[j] = (B_BASE + tmp[j]) - isor_stuff[j] - carry;
- carry = 1;
- } else {
- tmp[j] = tmp[j] - isor_stuff[j] - carry;
- carry = 0;
- }
- }
- //if (carry > 0) {pp(isor);pp(dend);};
- //myassert(carry == 0);
- if (carry > 0) {
- myassert(tmp[isor->used] > 0);
- tmp[isor->used]--;
- }
-#if DEBUG_SAINTEGER_UQRM
- printf("after adjustment of tmp ");
- for (j = isor->used; j >=0; j--) printf("%d ",tmp[j]);
- printf("\n");
-#endif
- }
-
- // Now vh really is the i'th quotient digit.
- // Subtract (tmp << delta) from
- // the dividend.
- carry = 0;
- for (j = 0; j <= isor->used; j++) {
- if (carry + tmp[j] > dend_stuff[j+delta]) {
- dend_stuff[j+delta] = (B_BASE+dend_stuff[j+delta]) - tmp[j] - carry;
- carry = 1;
- } else {
- dend_stuff[j+delta] = dend_stuff[j+delta] - tmp[j] - carry;
- carry = 0;
- }
- }
- myassert(carry==0);
-
-#if DEBUG_SAINTEGER_UQRM
- printf("after final sub ");
- for(j=dend->used; j>=0; j--) printf("%d ", dend_stuff[j]);
- printf("\n");
-#endif
-
- // park vh in the result array
-#if DEBUG_SAINTEGER_UDIV
- printf("[%d] <- %d\n", i-isor->used, vh );
-#endif
- dres->stuff[i-isor->used] = vh;
- }
- }
-
- // Now we've got all the quotient digits. Zap leading zeroes.
- dres->used = dend->used - isor->used + 1;
- u_renormalise(dres);
- myassert(sane(dres));
-
- // The remainder is in dend_stuff. Copy, divide by the original scaling
- // factor, and zap leading zeroes.
- mres->used = dend->used;
- for (j = 0; j < dend->used; j++) mres->stuff[j] = dend_stuff[j];
- u_renormalise(mres);
- myassert(sane(mres));
-
- if (scaleup > 1) {
- carry = 0;
- for (j = mres->used-1; j >= 0; j--) {
- carry += mres->stuff[j];
- mres->stuff[j] = carry/scaleup;
- carry = B_BASE*(carry%scaleup);
- }
- myassert (carry == 0);
- u_renormalise(mres);
- myassert(sane(mres));
- }
-
- free(tmp);
- free(isor_stuff);
- free(dend_stuff);
-}
-
-
-/* --------------------------------------------------------------------------
- * Test framework
- * ------------------------------------------------------------------------*/
-
-#if 0
-int main ( int argc, char** argv )
-{
- int i, j, t, k, m;
- B *bi, *bj, *bk, *bm;
-
- for (i = -10007; i <= 10007; i++) {
- printf ( "i = %d\n", i );
-
- t = size_fromInt(); bi = malloc(t); myassert(bi);
- do_fromInt(i, t, bi);
-
- t = do_toInt(bi); myassert(i == t);
-
- for (j = -10007; j <= 10007; j++) {
-
- t = size_fromInt(); bj = malloc(t); myassert(bj);
- do_fromInt(j, t, bj);
-
- t = do_toInt(bj); myassert(j == t);
-
- if (1) {
- t = size_add(bi,bj); bk = malloc(t); myassert(bk);
- do_add(bi,bj,t,bk);
- k = do_toInt(bk);
- if (i+j != k) {
- pp(bi); pp(bj); pp(bk);
- myassert(i+j == k);
- }
- free(bk);
- }
-
- if (1) {
- t = size_sub(bi,bj); bk = malloc(t); myassert(bk);
- do_sub(bi,bj,t,bk);
- k = do_toInt(bk);
- if (i-j != k) {
- pp(bi); pp(bj); pp(bk);
- myassert(i-j == k);
- }
- free(bk);
- }
-
- if (1) {
- t = size_mul(bi,bj); bk = malloc(t); myassert(bk);
- do_mul(bi,bj,t,bk);
- k = do_toInt(bk);
- if (i*j != k) {
- pp(bi); pp(bj); pp(bk);
- myassert(i*j == k);
- }
- free(bk);
- }
-
- if (j != 0) {
- t = size_qrm(bi,bj);
- bk = malloc(t); myassert(bk);
- bm = malloc(t); myassert(bm);
- do_qrm(bi,bj,t,bk,bm);
- k = do_toInt(bk);
- m = do_toInt(bm);
- myassert(k == i/j);
- myassert(m == i%j);
- free(bk); free(bm);
- }
-
- free(bj);
- }
- free(bi);
-
- }
- printf("done\n");
- return 0;
-}
-#endif
-
-#if 0
-int main ( int argc, char** argv )
-{
- B *a, *b, *c, *d, *e;
- a = fromInt(1); b=fromInt(9); pp(a); pp(b);
- c = mkB( maxused_uqrm(a,b) );
- d = mkB( maxused_uqrm(a,b) );
- e = mkB( maxused_uadd(a,b) );
- uadd(a,b,e); pp(e);
- //uqrm(a,b,c,d); pp(c); pp(d);
-
- return 0;
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Strongly connected components algorithm for static.c.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: scc.c,v $
- * $Revision: 1.7 $
- * $Date: 2000/03/22 18:14:23 $
- * ------------------------------------------------------------------------*/
-
-#ifndef SCC_C
-#define SCC_C
-#define visited(d) (isInt(DEPENDS(d))) /* binding already visited?*/
-
-static Cell daSccs = NIL;
-static Int daCount;
-
-static Int local sccMin ( Int x, Int y) /* calculate minimum of x,y */
-{ /* (unless y is zero) */
- return (x<=y || y==0) ? x : y;
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * A couple of parts of this program require an algorithm for sorting a list
- * of values (with some added dependency information) into a list of strongly
- * connected components in which each value appears before its dependents.
- *
- * The algorithm used here is based on those described in:
- * 1) Robert Tarjan, Depth-first search and Linear Graph Algorithms,
- * SIAM J COMPUT, vol 1, no 2, June 1972, pp.146-160.
- * 2) Aho, Hopcroft and Ullman, Design and Analysis of Algorithms,
- * Addison Wesley, 1972. pp.189-195.
- * The version used here probably owes most to the latter presentation but
- * has been modified to simplify the algorithm and improve the use of space.
- *
- * This would probably have been a good application for C++ templates ...
- * ------------------------------------------------------------------------*/
-
-static Int local LOWLINK( Cell v ) /* calculate `lowlink' of v */
-{
- Int low = daCount;
- Int dfn = daCount; /* depth first search no. of v */
- List ws = DEPENDS(v); /* adjacency list for v */
-
- SETDEPENDS(v,mkInt(daCount++)); /* push v onto stack */
- push(v);
-
- while (nonNull(ws)) { /* scan adjacency list for v */
- Cell w = hd(ws);
- ws = tl(ws);
- low = sccMin(low, (visited(w) ? intOf(DEPENDS(w)) : LOWLINK(w)));
- }
-
- if (low == dfn) { /* start a new scc? */
- List temp=NIL;
- do { /* take elements from stack */
- SETDEPENDS(top(),mkInt(0));
- temp = cons(top(),temp);
- } while (pop()!=v);
- daSccs = cons(temp,daSccs); /* make new strongly connected comp*/
- }
-
- return low;
-}
-
-#ifdef SCC
-static List local SCC ( List bs ) /* sort list with added dependency */
-{ /* info into SCCs */
- List tmp = NIL;
- clearStack();
- daSccs = NIL; /* clear current list of SCCs */
-
- for (daCount=1; nonNull(bs); bs=tl(bs)) /* visit each binding */
- if (!visited(hd(bs)))
- LOWLINK(hd(bs));
- tmp = rev(daSccs);
- daSccs = NIL;
- return tmp; /* reverse to obtain correct order */
-}
-#endif
-
-#ifdef SCC2 /* Two argument version */
-static List local SCC2 ( List bs,
- List cs ) /* sort lists with added dependency*/
-{ /* info into SCCs */
- List tmp = NIL;
- clearStack();
- daSccs = NIL; /* clear current list of SCCs */
-
- for (daCount=1; nonNull(bs); bs=tl(bs)) /* visit each binding */
- if (!visited(hd(bs)))
- LOWLINK(hd(bs));
- for (; nonNull(cs); cs=tl(cs))
- if (!visited(hd(cs)))
- LOWLINK(hd(cs));
- tmp = rev(daSccs);
- daSccs = NIL;
- return tmp; /* reverse to obtain correct order */
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Static Analysis for Hugs
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: static.c,v $
- * $Revision: 1.42 $
- * $Date: 2000/06/02 16:19:47 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local kindError ( Int,Constr,Constr,String,Kind,Int );
-static Void local checkQualImport ( Pair );
-static Void local checkUnqualImport ( Triple );
-
-static Name local lookupName ( Text,List );
-static List local checkSubentities ( List,List,List,String,Text );
-static List local checkExportTycon ( List,Text,Cell,Tycon );
-static List local checkExportClass ( List,Text,Cell,Class );
-static List local checkExport ( List,Text,Cell );
-static List local checkImportEntity ( List,Module,Cell );
-static List local resolveImportList ( Module,Cell );
-static Void local checkImportList ( Pair );
-
-static Void local importEntity ( Module,Cell );
-static Void local importName ( Module,Name );
-static Void local importTycon ( Module,Tycon );
-static Void local importClass ( Module,Class );
-static List local checkExports ( List, Module );
-
-static Void local checkTyconDefn ( Tycon );
-static Void local depConstrs ( Tycon,List,Cell );
-static List local addSels ( Int,Name,List,List );
-static List local selectCtxt ( List,List );
-static Void local checkSynonyms ( List );
-static List local visitSyn ( List,Tycon,List );
-static Type local instantiateSyn ( Type,Type );
-
-static Void local checkClassDefn ( Class );
-static Cell local depPredExp ( Int,List,Cell );
-static Void local checkMems ( Class,List,Cell );
-static Void local checkMems2 ( Class,Cell );
-static Void local addMembers ( Class );
-static Name local newMember ( Int,Int,Cell,Type,Class );
-static Text local generateText ( String,Class );
-
-static List local classBindings ( String,Class,List );
-static Name local memberName ( Class,Text );
-static List local numInsert ( Int,Cell,List );
-
-static List local maybeAppendVar ( Cell,List );
-
-static Type local checkSigType ( Int,String,Cell,Type );
-static Void local checkOptQuantVars ( Int,List,List );
-static Type local depTopType ( Int,List,Type );
-static Type local depCompType ( Int,List,Type );
-static Type local depTypeExp ( Int,List,Type );
-static Type local depTypeVar ( Int,List,Text );
-static List local checkQuantVars ( Int,List,List,Cell );
-static List local otvars ( Cell,List );
-static Bool local osubset ( List,List );
-static Void local kindConstr ( Int,Int,Int,Constr );
-static Kind local kindAtom ( Int,Constr );
-static Void local kindPred ( Int,Int,Int,Cell );
-static Void local kindType ( Int,String,Type );
-static Void local fixKinds ( Void );
-
-static Void local kindTCGroup ( List );
-static Void local initTCKind ( Cell );
-static Void local kindTC ( Cell );
-static Void local genTC ( Cell );
-
-static Void local checkInstDefn ( Inst );
-static Void local insertInst ( Inst );
-static Bool local instCompare ( Inst,Inst );
-static Name local newInstImp ( Inst );
-static Void local kindInst ( Inst,Int );
-static Void local checkDerive ( Tycon,List,List,Cell );
-static Void local addDerInst ( Int,Class,List,List,Type,Int );
-static Void local deriveContexts ( List );
-static Void local initDerInst ( Inst );
-static Void local calcInstPreds ( Inst );
-static Void local maybeAddPred ( Cell,Int,Int,List );
-static List local calcFunDeps ( List );
-static Cell local copyAdj ( Cell,Int,Int );
-static Void local tidyDerInst ( Inst );
-static List local otvarsZonk ( Cell,List,Int );
-
-static Void local addDerivImp ( Inst );
-
-static Void local checkDefaultDefns ( Void );
-
-static Void local checkForeignImport ( Name );
-static Void local checkForeignExport ( Name );
-
-static Cell local tidyInfix ( Int,Cell );
-static Pair local attachFixity ( Int,Cell );
-static Syntax local lookupSyntax ( Text );
-
-static Cell local checkPat ( Int,Cell );
-static Cell local checkMaybeCnkPat ( Int,Cell );
-static Cell local checkApPat ( Int,Int,Cell );
-static Void local addToPatVars ( Int,Cell );
-static Name local conDefined ( Int,Cell );
-static Void local checkIsCfun ( Int,Name );
-static Void local checkCfunArgs ( Int,Cell,Int );
-static Cell local checkPatType ( Int,String,Cell,Type );
-static Cell local applyBtyvs ( Cell );
-static Cell local bindPat ( Int,Cell );
-static Void local bindPats ( Int,List );
-
-static List local extractSigdecls ( List );
-static List local extractFixdecls ( List );
-static List local extractBindings ( List );
-static List local getPatVars ( Int,Cell,List );
-static List local addPatVar ( Int,Cell,List );
-static List local eqnsToBindings ( List,List,List,List );
-static Void local notDefined ( Int,List,Cell );
-static Cell local findBinding ( Text,List );
-static Cell local getAttr ( List,Cell );
-static Void local addSigdecl ( List,Cell );
-static Void local addFixdecl ( List,List,List,List,Triple );
-static Void local dupFixity ( Int,Text );
-static Void local missFixity ( Int,Text );
-
-static List local dependencyAnal ( List );
-static List local topDependAnal ( List );
-static Void local addDepField ( Cell );
-static Void local remDepField ( List );
-static Void local remDepField1 ( Cell );
-static Void local clearScope ( Void );
-static Void local withinScope ( List );
-static Void local leaveScope ( Void );
-static Void local saveSyntax ( Cell,Cell );
-
-static Void local depBinding ( Cell );
-static Void local depDefaults ( Class );
-static Void local depInsts ( Inst );
-static Void local depClassBindings ( List );
-static Void local depAlt ( Cell );
-static Void local depRhs ( Cell );
-static Void local depGuard ( Cell );
-static Cell local depExpr ( Int,Cell );
-static Void local depPair ( Int,Cell );
-static Void local depTriple ( Int,Cell );
-static Void local depComp ( Int,Cell,List );
-static Void local depCaseAlt ( Int,Cell );
-static Cell local depVar ( Int,Cell );
-static Cell local depQVar ( Int,Cell );
-static Void local depConFlds ( Int,Cell,Bool );
-static Void local depUpdFlds ( Int,Cell );
-static List local depFields ( Int,Cell,List,Bool );
-#if IPARAM
-static Void local depWith ( Int,Cell );
-static List local depDwFlds ( Int,Cell,List );
-#endif
-#if TREX
-static Cell local depRecord ( Int,Cell );
-#endif
-
-static List local tcscc ( List,List );
-static List local bscc ( List );
-
-static Void local addRSsigdecls ( Pair );
-static Void local allNoPrevDef ( Cell );
-static Void local noPrevDef ( Int,Cell );
-static Bool local odiff ( List,List );
-
-static Void local duplicateErrorAux ( Int,Module,Text,String );
-#define duplicateError(l,m,t,k) duplicateErrorAux(l,m,t,k)
-static Void local checkTypeIn ( Pair );
-
-/* --------------------------------------------------------------------------
- * The code in this file is arranged in roughly the following order:
- * - Kind inference preliminaries
- * - Module declarations
- * - Type declarations (data, type, newtype, type in)
- * - Class declarations
- * - Type signatures
- * - Instance declarations
- * - Default declarations
- * - Primitive definitions
- * - Patterns
- * - Infix expressions
- * - Value definitions
- * - Top-level static analysis and control
- * - Haskell 98 compatibility tests
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Kind checking preliminaries:
- * ------------------------------------------------------------------------*/
-
-Bool kindExpert = FALSE; /* TRUE => display kind errors in */
- /* full detail */
-
-static Void local kindError(l,c,in,wh,k,o)
-Int l; /* line number near constuctor exp */
-Constr c; /* constructor */
-Constr in; /* context (if any) */
-String wh; /* place in which error occurs */
-Kind k; /* expected kind (k,o) */
-Int o; { /* inferred kind (typeIs,typeOff) */
- clearMarks();
-
- if (!kindExpert) { /* for those with a fear of kinds */
- ERRMSG(l) "Illegal type" ETHEN
- if (nonNull(in)) {
- ERRTEXT " \"" ETHEN ERRTYPE(in);
- ERRTEXT "\"" ETHEN
- }
- ERRTEXT " in %s\n", wh
- EEND;
- }
-
- ERRMSG(l) "Kind error in %s", wh ETHEN
- if (nonNull(in)) {
- ERRTEXT "\n*** expression : " ETHEN ERRTYPE(in);
- }
- ERRTEXT "\n*** constructor : " ETHEN ERRTYPE(c);
- ERRTEXT "\n*** kind : " ETHEN ERRKIND(copyType(typeIs,typeOff));
- ERRTEXT "\n*** does not match : " ETHEN ERRKIND(copyType(k,o));
- if (unifyFails) {
- ERRTEXT "\n*** because : %s", unifyFails ETHEN
- }
- ERRTEXT "\n"
- EEND;
-}
-
-#define shouldKind(l,c,in,wh,k,o) if (!kunify(typeIs,typeOff,k,o)) \
- kindError(l,c,in,wh,k,o)
-#define checkKind(l,a,m,c,in,wh,k,o) kindConstr(l,a,m,c); \
- shouldKind(l,c,in,wh,k,o)
-#define inferKind(k,o) typeIs=k; typeOff=o
-
-static List unkindTypes; /* types in need of kind annotation*/
-#if TREX
-Kind extKind; /* Kind of extension, *->row->row */
-#endif
-
-/* --------------------------------------------------------------------------
- * Static analysis of modules:
- * ------------------------------------------------------------------------*/
-
-Void startModule ( Module m ) /* switch to a new module */
-{
- if (isNull(m)) internal("startModule");
- setCurrModule(m);
-}
-
-Void setExportList(exps) /* Add export list to current module */
-List exps; {
- module(currentModule).exports = exps;
-}
-
-Void addQualImport(orig,new) /* Add to qualified import list */
-Cell orig; /* Original name of module */
-Cell new; { /* Name module is called within this module (or NIL) */
- module(currentModule).qualImports =
- cons(pair(isNull(new)?orig:new,orig),module(currentModule).qualImports);
-}
-
-Void addUnqualImport(mod,entities) /* Add to unqualified import list */
-Cell mod; /* Name of module */
-List entities; { /* List of entity names */
- unqualImports = cons(pair(mod,entities),unqualImports);
-}
-
-static Void local checkQualImport(i) /* Process qualified import */
-Pair i; {
- Module m = findModid(snd(i));
- if (isNull(m)) {
- ERRMSG(0) "Module \"%s\" not previously loaded",
- textToStr(textOf(snd(i)))
- EEND;
- }
- snd(i)=m;
-}
-
-static Void local checkUnqualImport(i) /* Process unqualified import */
-Pair i; {
- Module m = findModid(fst(i));
- if (isNull(m)) {
- ERRMSG(0) "Module \"%s\" not previously loaded",
- textToStr(textOf(fst(i)))
- EEND;
- }
- fst(i)=m;
-}
-
-static Name local lookupName(t,nms) /* find text t in list of Names */
-Text t;
-List nms; { /* :: [Name] */
- for(; nonNull(nms); nms=tl(nms)) {
- if (t == name(hd(nms)).text)
- return hd(nms);
- }
- return NIL;
-}
-
-static List local checkSubentities(imports,named,wanted,description,textParent)
-List imports;
-List named; /* :: [ Q?(Var|Con)(Id|Op) ] */
-List wanted; /* :: [Name] */
-String description; /* "<constructor>|<member> of <type>|<class>" */
-Text textParent; {
- for(; nonNull(named); named=tl(named)) {
- Pair x = hd(named);
- /* ToDo: ignores qualifier; doesn't check that entity is in scope */
- Text t = isPair(snd(x)) ? qtextOf(x) : textOf(x);
- Name n = lookupName(t,wanted);
- if (isNull(n)) {
- ERRMSG(0) "Entity \"%s\" is not a %s \"%s\"",
- textToStr(t),
- description,
- textToStr(textParent)
- EEND;
- }
- imports = cons(n,imports);
- }
- return imports;
-}
-
-static List local checkImportEntity(imports,exporter,entity)
-List imports; /* Accumulated list of things to import */
-Module exporter;
-Cell entity; { /* Entry from import list */
- List oldImports = imports;
- Text t = isIdent(entity) ? textOf(entity) : textOf(fst(entity));
- List es = NIL;
- es = module(exporter).exports;
-
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es); /* :: Entity
- | (Entity, NIL|DOTDOT)
- | tycon
- | class
- */
- if (isPair(e)) {
- Cell f = fst(e);
- if (isTycon(f)) {
- if (tycon(f).text == t) {
- imports = cons(f,imports);
- if (!isIdent(entity)) {
- switch (tycon(f).what) {
- case NEWTYPE:
- case DATATYPE:
- if (DOTDOT == snd(entity)) {
- imports = dupOnto(tycon(f).defn,imports);
- } else {
- imports = checkSubentities(
- imports,snd(entity),tycon(f).defn,
- "constructor of type",t);
- }
- break;
- default:;
- /* deliberate fall thru */
- }
- }
- }
- } else if (isClass(f)) {
- if (cclass(f).text == t) {
- imports = cons(f,imports);
- if (!isIdent(entity)) {
- if (DOTDOT == snd(entity)) {
- return dupOnto(cclass(f).members,imports);
- } else {
- return checkSubentities(
- imports,snd(entity),cclass(f).members,
- "member of class",t);
- }
- }
- }
- } else {
- internal("checkImportEntity2");
- }
- } else if (isName(e)) {
- if (isIdent(entity) && name(e).text == t) {
- imports = cons(e,imports);
- }
- } else {
- internal("checkImportEntity3");
- }
- }
- if (imports == oldImports) {
- ERRMSG(0) "Unknown entity \"%s\" imported from module \"%s\"",
- textToStr(t),
- textToStr(module(exporter ).text)
- EEND;
- }
- return imports;
-}
-
-static List local resolveImportList(m,impList)
-Module m; /* exporting module */
-Cell impList; {
- List imports = NIL;
- if (DOTDOT == impList) {
- List es = module(m).exports;
- for(; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isName(e)) {
- imports = cons(e,imports);
- } else {
- Cell c = fst(e);
- List subentities = NIL;
- imports = cons(c,imports);
- if (isTycon(c)
- && (tycon(c).what == DATATYPE
- || tycon(c).what == NEWTYPE))
- subentities = tycon(c).defn;
- else if (isClass(c))
- subentities = cclass(c).members;
- if (DOTDOT == snd(e)) {
- imports = dupOnto(subentities,imports);
- }
- }
- }
- } else {
- map1Accum(checkImportEntity,imports,m,impList);
- }
- return imports;
-}
-
-static Void local checkImportList(importSpec) /*Import a module unqualified*/
-Pair importSpec; {
- Module m = fst(importSpec);
- Cell impList = snd(importSpec);
-
- List imports = NIL; /* entities we want to import */
- List hidden = NIL; /* entities we want to hide */
-
- if (isPair(impList) && HIDDEN == fst(impList)) {
- /* Somewhat inefficient - but obviously correct:
- * imports = importsOf("module Foo") `setDifference` hidden;
- */
- hidden = resolveImportList(m, snd(impList));
- imports = resolveImportList(m, DOTDOT);
- } else {
- imports = resolveImportList(m, impList);
- }
-
- for(; nonNull(imports); imports=tl(imports)) {
- Cell e = hd(imports);
- if (!cellIsMember(e,hidden))
- importEntity(m,e);
- }
- /* ToDo: hang onto the imports list for processing export list entries
- * of the form "module Foo"
- */
-}
-
-static Void local importEntity(source,e)
-Module source;
-Cell e; {
- switch (whatIs(e)) {
- case NAME : importName(source,e);
- break;
- case TUPLE:
- case TYCON : importTycon(source,e);
- break;
- case CLASS : importClass(source,e);
- break;
- default: internal("importEntity");
- }
-}
-
-static Void local importName(source,n)
-Module source;
-Name n; {
- Name clash = addName(n);
- if (nonNull(clash) && clash!=n) {
- ERRMSG(0) "Entity \"%s\" imported from module \"%s\""
- " already defined in module \"%s\"",
- textToStr(name(n).text),
- textToStr(module(source).text),
- textToStr(module(name(clash).mod).text)
- EEND;
- }
-}
-
-static Void local importTycon(source,tc)
-Module source;
-Tycon tc; {
- Tycon clash=addTycon(tc);
- if (nonNull(clash) && clash!=tc) {
- ERRMSG(0) "Tycon \"%s\" imported from \"%s\" already defined in module \"%s\"",
- textToStr(tycon(tc).text),
- textToStr(module(source).text),
- textToStr(module(tycon(clash).mod).text)
- EEND;
- }
- if (nonNull(findClass(tycon(tc).text))) {
- ERRMSG(0) "Import of type constructor \"%s\" clashes with class in module \"%s\"",
- textToStr(tycon(tc).text),
- textToStr(module(tycon(tc).mod).text)
- EEND;
- }
-}
-
-static Void local importClass(source,c)
-Module source;
-Class c; {
- Class clash=addClass(c);
- if (nonNull(clash) && clash!=c) {
- ERRMSG(0) "Class \"%s\" imported from \"%s\" already defined in module \"%s\"",
- textToStr(cclass(c).text),
- textToStr(module(source).text),
- textToStr(module(cclass(clash).mod).text)
- EEND;
- }
- if (nonNull(findTycon(cclass(c).text))) {
- ERRMSG(0) "Import of class \"%s\" clashes with type constructor in module \"%s\"",
- textToStr(cclass(c).text),
- textToStr(module(source).text)
- EEND;
- }
-}
-
-static List local checkExportTycon(exports,mt,spec,tc)
-List exports;
-Text mt;
-Cell spec;
-Tycon tc; {
- if (DOTDOT == spec || SYNONYM == tycon(tc).what) {
- return cons(pair(tc,DOTDOT), exports);
- } else {
- return cons(pair(tc,NIL), exports);
- }
-}
-
-static List local checkExportClass(exports,mt,spec,cl)
-List exports;
-Text mt;
-Class cl;
-Cell spec; {
- if (DOTDOT == spec) {
- return cons(pair(cl,DOTDOT), exports);
- } else {
- return cons(pair(cl,NIL), exports);
- }
-}
-
-static List local checkExport(exports,mt,e) /* Process entry in export list*/
-List exports;
-Text mt;
-Cell e; {
- if (isIdent(e)) {
- Cell export = NIL;
- List origExports = exports;
- if (nonNull(export=findQualName(e))) {
- exports=cons(export,exports);
- }
- if (isQCon(e) && nonNull(export=findQualTycon(e))) {
- exports = checkExportTycon(exports,mt,NIL,export);
- }
- if (isQCon(e) && nonNull(export=findQualClass(e))) {
- /* opaque class export */
- exports = checkExportClass(exports,mt,NIL,export);
- }
- if (exports == origExports) {
- ERRMSG(0) "Unknown entity \"%s\" exported from module \"%s\"",
- identToStr(e),
- textToStr(mt)
- EEND;
- }
- return exports;
- } else if (MODULEENT == fst(e)) {
- Module m = findModid(snd(e));
- /* ToDo: shouldn't allow export of module we didn't import */
- if (isNull(m)) {
- ERRMSG(0) "Unknown module \"%s\" exported from module \"%s\"",
- textToStr(textOf(snd(e))),
- textToStr(mt)
- EEND;
- }
- if (m == currentModule) {
- /* Exporting the current module exports local definitions */
- List xs;
- for(xs=module(m).classes; nonNull(xs); xs=tl(xs)) {
- if (cclass(hd(xs)).mod==m)
- exports = checkExportClass(exports,mt,DOTDOT,hd(xs));
- }
- for(xs=module(m).tycons; nonNull(xs); xs=tl(xs)) {
- if (tycon(hd(xs)).mod==m)
- exports = checkExportTycon(exports,mt,DOTDOT,hd(xs));
- }
- for(xs=module(m).names; nonNull(xs); xs=tl(xs)) {
- if (name(hd(xs)).mod==m)
- exports = cons(hd(xs),exports);
- }
- } else {
- /* Exporting other modules imports all things imported
- * unqualified from it.
- * ToDo: we reexport everything exported by a module -
- * whether we imported it or not. This gives the wrong
- * result for "module M(module N) where import N(x)"
- */
- exports = dupOnto(module(m).exports,exports);
- }
- return exports;
- } else {
- Cell ident = fst(e); /* class name or type name */
- Cell parts = snd(e); /* members or constructors */
- Cell nm;
- if (isQCon(ident) && nonNull(nm=findQualTycon(ident))) {
- switch (tycon(nm).what) {
- case SYNONYM:
- if (DOTDOT!=parts) {
- ERRMSG(0) "Explicit constructor list given for type synonym"
- " \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- }
- return cons(pair(nm,DOTDOT),exports);
- case RESTRICTSYN:
- ERRMSG(0) "Transparent export of restricted type synonym"
- " \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- return exports; /* Not reached */
- case NEWTYPE:
- case DATATYPE:
- if (DOTDOT==parts) {
- return cons(pair(nm,DOTDOT),exports);
- } else {
- exports = checkSubentities(exports,parts,tycon(nm).defn,
- "constructor of type",
- tycon(nm).text);
- return cons(pair(nm,DOTDOT), exports);
- }
- default:
- internal("checkExport1");
- }
- } else if (isQCon(ident) && nonNull(nm=findQualClass(ident))) {
- if (DOTDOT == parts) {
- return cons(pair(nm,DOTDOT),exports);
- } else {
- exports = checkSubentities(exports,parts,cclass(nm).members,
- "member of class",cclass(nm).text);
- return cons(pair(nm,DOTDOT), exports);
- }
- } else {
- ERRMSG(0) "Explicit export list given for non-class/datatype \"%s\" in export list of module \"%s\"",
- identToStr(ident),
- textToStr(mt)
- EEND;
- }
- }
- return exports; /* NOTUSED */
-}
-
-static List local checkExports ( List exports, Module thisModule )
-{
- Module m = thisModule;
- Text mt = module(m).text;
- List es = NIL;
-
- map1Accum(checkExport,es,mt,exports);
-
-#if DEBUG_MODULES
- for(xs=es; nonNull(xs); xs=tl(xs)) {
- Printf(" %s", textToStr(textOfEntity(hd(xs))));
- }
-#endif
- return es;
-}
-
-
-/* --------------------------------------------------------------------------
- * Static analysis of type declarations:
- *
- * Type declarations come in two forms:
- * - data declarations - define new constructed data types
- * - type declarations - define new type synonyms
- *
- * A certain amount of work is carried out as the declarations are
- * read during parsing. In particular, for each type constructor
- * definition encountered:
- * - check that there is no previous definition of constructor
- * - ensure type constructor not previously used as a class name
- * - make a new entry in the type constructor table
- * - record line number of declaration
- * - Build separate lists of newly defined constructors for later use.
- * ------------------------------------------------------------------------*/
-
-Void tyconDefn(line,lhs,rhs,what) /* process new type definition */
-Int line; /* definition line number */
-Cell lhs; /* left hand side of definition */
-Cell rhs; /* right hand side of definition */
-Cell what; { /* SYNONYM/DATATYPE/etc... */
- Text t = textOf(getHead(lhs));
-
- if (nonNull(findTycon(t))) {
- ERRMSG(line) "Repeated definition of type constructor \"%s\"",
- textToStr(t)
- EEND;
- }
- else if (nonNull(findClass(t))) {
- ERRMSG(line) "\"%s\" used as both class and type constructor",
- textToStr(t)
- EEND;
- }
- else {
- Tycon nw = newTycon(t);
- tyconDefns = cons(nw,tyconDefns);
- tycon(nw).line = line;
- tycon(nw).arity = argCount;
- tycon(nw).what = what;
- if (what==RESTRICTSYN) {
- h98DoesntSupport(line,"restricted type synonyms");
- typeInDefns = cons(pair(nw,snd(rhs)),typeInDefns);
- rhs = fst(rhs);
- }
- tycon(nw).defn = pair(lhs,rhs);
- }
-}
-
-Void setTypeIns(bs) /* set local synonyms for given */
-List bs; { /* binding group */
- List cvs = typeInDefns;
- for (; nonNull(cvs); cvs=tl(cvs)) {
- Tycon c = fst(hd(cvs));
- List vs = snd(hd(cvs));
- for (tycon(c).what = RESTRICTSYN; nonNull(vs); vs=tl(vs)) {
- if (nonNull(findBinding(textOf(hd(vs)),bs))) {
- tycon(c).what = SYNONYM;
- break;
- }
- }
- }
-}
-
-Void clearTypeIns() { /* clear list of local synonyms */
- for (; nonNull(typeInDefns); typeInDefns=tl(typeInDefns))
- tycon(fst(hd(typeInDefns))).what = RESTRICTSYN;
-}
-
-/* --------------------------------------------------------------------------
- * Further analysis of Type declarations:
- *
- * In order to allow the definition of mutually recursive families of
- * data types, the static analysis of the right hand sides of type
- * declarations cannot be performed until all of the type declarations
- * have been read.
- *
- * Once parsing is complete, we carry out the following:
- *
- * - check format of lhs, extracting list of bound vars and ensuring that
- * there are no repeated variables and no Skolem variables.
- * - run dependency analysis on rhs to check that only bound type vars
- * appear in type and that all constructors are defined.
- * Replace type variables by offsets, constructors by Tycons.
- * - use list of dependents to sort into strongly connected components.
- * - ensure that there is not more than one synonym in each group.
- * - kind-check each group of type definitions.
- *
- * - check that there are no previous definitions for constructor
- * functions in data type definitions.
- * - install synonym expansions and constructor definitions.
- * ------------------------------------------------------------------------*/
-
-static List tcDeps = NIL; /* list of dependent tycons/classes*/
-
-static Void local checkTyconDefn(d) /* validate type constructor defn */
-Tycon d; {
- Cell lhs = fst(tycon(d).defn);
- Cell rhs = snd(tycon(d).defn);
- Int line = tycon(d).line;
- List tyvars = getArgs(lhs);
- List temp;
- /* check for repeated tyvars on lhs*/
- for (temp=tyvars; nonNull(temp); temp=tl(temp))
- if (nonNull(varIsMember(textOf(hd(temp)),tl(temp)))) {
- ERRMSG(line) "Repeated type variable \"%s\" on left hand side",
- textToStr(textOf(hd(temp)))
- EEND;
- }
-
- tcDeps = NIL; /* find dependents */
- switch (whatIs(tycon(d).what)) {
- case RESTRICTSYN :
- case SYNONYM : rhs = depTypeExp(line,tyvars,rhs);
- if (cellIsMember(d,tcDeps)) {
- ERRMSG(line) "Recursive type synonym \"%s\"",
- textToStr(tycon(d).text)
- EEND;
- }
- break;
-
- case DATATYPE :
- case NEWTYPE : depConstrs(d,tyvars,rhs);
- rhs = fst(rhs);
- break;
-
- default : internal("checkTyconDefn");
- break;
- }
-
- tycon(d).defn = rhs;
- tycon(d).kind = tcDeps;
- tcDeps = NIL;
-}
-
-static Void local depConstrs(t,tyvars,cd)
-Tycon t; /* Define constructor functions and*/
-List tyvars; /* do dependency analysis for data */
-Cell cd; { /* definitions (w or w/o deriving) */
- Int line = tycon(t).line;
- List ctxt = NIL;
- Int conNo = 1;
- Type lhs = t;
- List cs = fst(cd);
- List derivs = snd(cd);
- List compTypes = NIL;
- List sels = NIL;
- Int i;
-
- for (i=0; i<tycon(t).arity; ++i) /* build representation for tycon */
- lhs = ap(lhs,mkOffset(i)); /* applied to full comp. of args */
-
- if (isQualType(cs)) { /* allow for possible context */
- ctxt = fst(snd(cs));
- cs = snd(snd(cs));
- map2Over(depPredExp,line,tyvars,ctxt);
- h98CheckCtxt(line,"context",TRUE,ctxt,NIL);
- }
-
- if (nonNull(cs) && isNull(tl(cs))) /* Single constructor datatype? */
- conNo = 0;
-
- for (; nonNull(cs); cs=tl(cs)) { /* For each constructor function: */
- Cell con = hd(cs);
- List sig = dupList(tyvars);
- List evs = NIL; /* locally quantified vars */
- List lps = NIL; /* locally bound predicates */
- List ctxt1 = ctxt; /* constructor function context */
- List scs = NIL; /* strict components */
- List fs = NONE; /* selector names */
- Type type = lhs; /* constructor function type */
- Int arity = 0; /* arity of constructor function */
- Int nr2 = 0; /* Number of rank 2 args */
- Name n; /* name for constructor function */
-
- if (whatIs(con)==POLYTYPE) { /* Locally quantified vars */
- evs = fst(snd(con));
- con = snd(snd(con));
- sig = checkQuantVars(line,evs,sig,con);
- }
-
- if (isQualType(con)) { /* Local predicates */
- List us;
- lps = fst(snd(con));
- for (us = typeVarsIn(lps,NIL,NIL,NIL); nonNull(us); us=tl(us))
- if (!varIsMember(textOf(hd(us)),evs)) {
- ERRMSG(line)
- "Variable \"%s\" in constraint is not locally bound",
- textToStr(textOf(hd(us)))
- EEND;
- }
- map2Over(depPredExp,line,sig,lps);
- con = snd(snd(con));
- arity = length(lps);
- }
-
- if (whatIs(con)==LABC) { /* Skeletize constr components */
- Cell fls = snd(snd(con)); /* get field specifications */
- con = fst(snd(con));
- fs = NIL;
- for (; nonNull(fls); fls=tl(fls)) { /* for each field spec: */
- List vs = fst(hd(fls));
- Type t = snd(hd(fls)); /* - scrutinize type */
- Bool banged = whatIs(t)==BANG;
- t = depCompType(line,sig,(banged ? arg(t) : t));
- while (nonNull(vs)) { /* - add named components */
- Cell us = tl(vs);
- tl(vs) = fs;
- fs = vs;
- vs = us;
- con = ap(con,t);
- arity++;
- if (banged)
- scs = cons(mkInt(arity),scs);
- }
- }
- fs = rev(fs);
- scs = rev(scs); /* put strict comps in ascend ord */
- }
- else { /* Non-labelled constructor */
- Cell c = con;
- Int compNo;
- for (; isAp(c); c=fun(c))
- arity++;
- for (compNo=arity, c=con; isAp(c); c=fun(c)) {
- Type t = arg(c);
- if (whatIs(t)==BANG) {
- scs = cons(mkInt(compNo),scs);
- t = arg(t);
- }
- compNo--;
- arg(c) = depCompType(line,sig,t);
- }
- }
-
- if (nonNull(ctxt1)) /* Extract relevant part of context*/
- ctxt1 = selectCtxt(ctxt1,offsetTyvarsIn(con,NIL));
-
- for (i=arity; isAp(con); i--) { /* Calculate type of constructor */
- Type ty = fun(con);
- Type cmp = arg(con);
- fun(con) = typeArrow;
- if (isPolyOrQualType(cmp)) {
- if (nonNull(derivs)) {
- ERRMSG(line) "Cannot derive instances for types" ETHEN
- ERRTEXT " with polymorphic or qualified components"
- EEND;
- }
- if (nr2==0)
- nr2 = i;
- }
- if (nonNull(derivs)) /* and build list of components */
- compTypes = cons(cmp,compTypes);
- type = ap(con,type);
- con = ty;
- }
-
- if (nr2>0) { /* Add rank 2 annotation */
- type = ap(RANK2,pair(mkInt(nr2-length(lps)),type));
- }
-
- if (nonNull(evs)) { /* Add existential annotation */
- if (nonNull(derivs)) {
- ERRMSG(line) "Cannot derive instances for types" ETHEN
- ERRTEXT " with existentially typed components"
- EEND;
- }
- if (fs!=NONE) {
- ERRMSG(line)
- "Cannot use selectors with existentially typed components"
- EEND;
- }
- type = ap(EXIST,pair(mkInt(length(evs)),type));
- }
-
- if (nonNull(lps)) { /* Add local preds part to type */
- type = ap(CDICTS,pair(lps,type));
- }
-
- if (nonNull(ctxt1)) { /* Add context part to type */
- type = ap(QUAL,pair(ctxt1,type));
- }
-
- if (nonNull(sig)) { /* Add quantifiers to type */
- List ts1 = sig;
- for (; nonNull(ts1); ts1=tl(ts1)) {
- hd(ts1) = NIL;
- }
- type = mkPolyType(sig,type);
- }
-
- n = findName(textOf(con)); /* Allocate constructor fun name */
- if (isNull(n)) {
- n = newName(textOf(con),NIL);
- } else if (name(n).defn!=PREDEFINED) {
- duplicateError(line,name(n).mod,name(n).text,
- "constructor function");
- }
- name(n).arity = arity; /* Save constructor fun details */
- name(n).line = line;
- name(n).parent = t;
- name(n).number = cfunNo(conNo++);
- name(n).type = type;
- if (tycon(t).what==NEWTYPE) {
- if (nonNull(lps)) {
- ERRMSG(line)
- "A newtype constructor cannot have class constraints"
- EEND;
- }
- if (arity!=1) {
- ERRMSG(line)
- "A newtype constructor must have exactly one argument"
- EEND;
- }
- if (nonNull(scs)) {
- ERRMSG(line)
- "Illegal strictess annotation for newtype constructor"
- EEND;
- }
- name(n).defn = nameId;
- } else {
- implementCfun(n,scs);
- name(n).hasStrict = nonNull(scs);
- }
-
- hd(cs) = n;
- if (fs!=NONE) {
- sels = addSels(line,n,fs,sels);
- }
- }
-
- if (nonNull(sels)) {
- sels = rev(sels);
- fst(cd) = appendOnto(fst(cd),sels);
- selDefns = cons(sels,selDefns);
- }
-
- if (nonNull(derivs)) { /* Generate derived instances */
- map3Proc(checkDerive,t,ctxt,compTypes,derivs);
- }
-}
-
-Int userArity(c) /* Find arity for cfun, ignoring */
-Name c; { /* CDICTS parameters */
- Int a = name(c).arity;
- Type t = name(c).type;
- Int w;
- if (isPolyType(t)) {
- t = monotypeOf(t);
- }
- if ((w=whatIs(t))==QUAL) {
- w = whatIs(t=snd(snd(t)));
- }
- if (w==CDICTS) {
- a -= length(fst(snd(t)));
- }
- return a;
-}
-
-
-static List local addSels(line,c,fs,ss) /* Add fields to selector list */
-Int line; /* line number of constructor */
-Name c; /* corresponding constr function */
-List fs; /* list of fields (varids) */
-List ss; { /* list of existing selectors */
- Int sn = 1;
- cfunSfuns = cons(pair(c,fs),cfunSfuns);
- for (; nonNull(fs); fs=tl(fs), ++sn) {
- List ns = ss;
- Text t = textOf(hd(fs));
-
- if (nonNull(varIsMember(t,tl(fs)))) {
- ERRMSG(line) "Repeated field name \"%s\" for constructor \"%s\"",
- textToStr(t), textToStr(name(c).text)
- EEND;
- }
-
- while (nonNull(ns) && t!=name(hd(ns)).text) {
- ns = tl(ns);
- }
-
- if (nonNull(ns)) {
- name(hd(ns)).defn = cons(pair(c,mkInt(sn)),name(hd(ns)).defn);
- } else {
- Name n = findName(t);
- if (nonNull(n)) {
- ERRMSG(line) "Repeated definition for selector \"%s\"",
- textToStr(t)
- EEND;
- }
- n = newName(t,c);
- name(n).line = line;
- name(n).number = SELNAME;
- name(n).defn = singleton(pair(c,mkInt(sn)));
- ss = cons(n,ss);
- }
- }
- return ss;
-}
-
-static List local selectCtxt(ctxt,vs) /* calculate subset of context */
-List ctxt;
-List vs; {
- if (isNull(vs)) {
- return NIL;
- } else {
- List ps = NIL;
- for (; nonNull(ctxt); ctxt=tl(ctxt)) {
- List us = offsetTyvarsIn(hd(ctxt),NIL);
- for (; nonNull(us) && cellIsMember(hd(us),vs); us=tl(us)) {
- }
- if (isNull(us)) {
- ps = cons(hd(ctxt),ps);
- }
- }
- return rev(ps);
- }
-}
-
-static Void local checkSynonyms(ts) /* Check for mutually recursive */
-List ts; { /* synonyms */
- List syns = NIL;
- for (; nonNull(ts); ts=tl(ts)) { /* build list of all synonyms */
- Tycon t = hd(ts);
- switch (whatIs(tycon(t).what)) {
- case SYNONYM :
- case RESTRICTSYN : syns = cons(t,syns);
- break;
- }
- }
- while (nonNull(syns)) { /* then visit each synonym */
- syns = visitSyn(NIL,hd(syns),syns);
- }
-}
-
-static List local visitSyn(path,t,syns) /* visit synonym definition to look*/
-List path; /* for cycles */
-Tycon t;
-List syns; {
- if (cellIsMember(t,path)) { /* every elt in path depends on t */
- ERRMSG(tycon(t).line)
- "Type synonyms \"%s\" and \"%s\" are mutually recursive",
- textToStr(tycon(t).text), textToStr(tycon(hd(path)).text)
- EEND;
- } else {
- List ds = tycon(t).kind;
- List path1 = NIL;
- for (; nonNull(ds); ds=tl(ds)) {
- if (cellIsMember(hd(ds),syns)) {
- if (isNull(path1)) {
- path1 = cons(t,path);
- }
- syns = visitSyn(path1,hd(ds),syns);
- }
- }
- }
- tycon(t).defn = fullExpand(tycon(t).defn);
- return removeCell(t,syns);
-}
-
-/* --------------------------------------------------------------------------
- * Expanding out all type synonyms in a type expression:
- * ------------------------------------------------------------------------*/
-
-Type fullExpand(t) /* find full expansion of type exp */
-Type t; { /* assuming that all relevant */
- Cell h = t; /* synonym defns of lower rank have*/
- Int n = 0; /* already been fully expanded */
- List args;
- for (args=NIL; isAp(h); h=fun(h), n++) {
- args = cons(fullExpand(arg(h)),args);
- }
- t = applyToArgs(h,args);
- if (isSynonym(h) && n>=tycon(h).arity) {
- if (n==tycon(h).arity) {
- t = instantiateSyn(tycon(h).defn,t);
- } else {
- Type p = t;
- while (--n > tycon(h).arity) {
- p = fun(p);
- }
- fun(p) = instantiateSyn(tycon(h).defn,fun(p));
- }
- }
- return t;
-}
-
-static Type local instantiateSyn(t,env) /* instantiate type according using*/
-Type t; /* env to determine appropriate */
-Type env; { /* values for OFFSET type vars */
- switch (whatIs(t)) {
- case AP : return ap(instantiateSyn(fun(t),env),
- instantiateSyn(arg(t),env));
-
- case OFFSET : return nthArg(offsetOf(t),env);
-
- default : return t;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Static analysis of class declarations:
- *
- * Performed in a similar manner to that used for type declarations.
- *
- * The first part of the static analysis is performed as the declarations
- * are read during parsing. The parser ensures that:
- * - the class header and all superclass predicates are of the form
- * ``Class var''
- *
- * The classDefn() function:
- * - ensures that there is no previous definition for class
- * - checks that class name has not previously been used as a type constr.
- * - make new entry in class table
- * - record line number of declaration
- * - build list of classes defined in current script for use in later
- * stages of static analysis.
- * ------------------------------------------------------------------------*/
-
-Void classDefn(line,head,ms,fds) /* process new class definition */
-Int line; /* definition line number */
-Cell head; /* class header :: ([Supers],Class) */
-List ms; /* class definition body */
-List fds; { /* functional dependencies */
- Text ct = textOf(getHead(snd(head)));
- Int arity = argCount;
-
- if (nonNull(findClass(ct))) {
- ERRMSG(line) "Repeated definition of class \"%s\"",
- textToStr(ct)
- EEND;
- } else if (nonNull(findTycon(ct))) {
- ERRMSG(line) "\"%s\" used as both class and type constructor",
- textToStr(ct)
- EEND;
- } else {
- Class nw = newClass(ct);
- cclass(nw).line = line;
- cclass(nw).arity = arity;
- cclass(nw).head = snd(head);
- cclass(nw).supers = fst(head);
- cclass(nw).members = ms;
- cclass(nw).level = 0;
- cclass(nw).fds = fds;
- cclass(nw).xfds = NIL;
- classDefns = cons(nw,classDefns);
- if (arity!=1)
- h98DoesntSupport(line,"multiple parameter classes");
- }
-}
-
-/* --------------------------------------------------------------------------
- * Further analysis of class declarations:
- *
- * Full static analysis of class definitions must be postponed until the
- * complete script has been read and all static analysis on type definitions
- * has been completed.
- *
- * Once this has been achieved, we carry out the following checks on each
- * class definition:
- * - check that variables in header are distinct
- * - replace head by skeleton
- * - check superclass declarations, replace by skeletons
- * - split body of class into members and declarations
- * - make new name entry for each member function
- * - record member function number (eventually an offset into dictionary!)
- * - no member function has a previous definition ...
- * - no member function is mentioned more than once in the list of members
- * - each member function type is valid, replace vars by offsets
- * - qualify each member function type by class header
- * - only bindings for members appear in defaults
- * - only function bindings appear in defaults
- * - check that extended class hierarchy does not contain any cycles
- * ------------------------------------------------------------------------*/
-
-static Void local checkClassDefn(c) /* validate class definition */
-Class c; {
- List tyvars = NIL;
- Int args = cclass(c).arity - 1;
- Cell temp = cclass(c).head;
- List fs = NIL;
- List ss = NIL;
-
- for (; isAp(temp); temp=fun(temp)) {
- if (!isVar(arg(temp))) {
- ERRMSG(cclass(c).line) "Type variable required in class head"
- EEND;
- }
- if (nonNull(varIsMember(textOf(arg(temp)),tyvars))) {
- ERRMSG(cclass(c).line)
- "Repeated type variable \"%s\" in class head",
- textToStr(textOf(arg(temp)))
- EEND;
- }
- tyvars = cons(arg(temp),tyvars);
- }
-
- for (fs=cclass(c).fds; nonNull(fs); fs=tl(fs)) {
- Pair fd = hd(fs);
- List vs = snd(fd);
-
- /* Check for trivial dependency
- */
- if (isNull(vs)) {
- ERRMSG(cclass(c).line) "Functional dependency is trivial"
- EEND;
- }
-
- /* Check for duplicated vars on right hand side, and for vars on
- * right that also appear on the left:
- */
- for (vs=snd(fd); nonNull(vs); vs=tl(vs)) {
- if (varIsMember(textOf(hd(vs)),fst(fd))) {
- ERRMSG(cclass(c).line)
- "Trivial dependency for variable \"%s\"",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- if (varIsMember(textOf(hd(vs)),tl(vs))) {
- ERRMSG(cclass(c).line)
- "Repeated variable \"%s\" in functional dependency",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
- }
-
- /* Check for duplicated vars on left hand side:
- */
- for (vs=fst(fd); nonNull(vs); vs=tl(vs)) {
- if (varIsMember(textOf(hd(vs)),tl(vs))) {
- ERRMSG(cclass(c).line)
- "Repeated variable \"%s\" in functional dependency",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- hd(vs) = depTypeVar(cclass(c).line,tyvars,textOf(hd(vs)));
- }
- }
-
- /* add in the tyvars from the `supers' so that we don't
- prematurely complain about undefined tyvars */
- tyvars = typeVarsIn(cclass(c).supers,NIL,NIL,tyvars);
-
- if (cclass(c).arity==0) {
- cclass(c).head = c;
- } else {
- Int args = cclass(c).arity - 1;
- for (temp=cclass(c).head; args>0; temp=fun(temp), args--) {
- arg(temp) = mkOffset(args);
- }
- arg(temp) = mkOffset(0);
- fun(temp) = c;
- }
-
- tcDeps = NIL; /* find dependents */
- map2Over(depPredExp,cclass(c).line,tyvars,cclass(c).supers);
-
- { /* depPredExp instantiates class names to class structs, so
- * now we have enough info to check for ambiguity
- */
- List tvts = offsetTyvarsIn(cclass(c).head,NIL);
- List tvps = offsetTyvarsIn(cclass(c).supers,NIL);
- List fds = calcFunDeps(cclass(c).supers);
- tvts = oclose(fds,tvts);
- tvts = odiff(tvps,tvts);
-
- if (!isNull(tvts)) {
- ERRMSG(cclass(c).line) "Undefined type variable \"%s\"",
- textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars)))
- EEND;
- }
- }
-
- h98CheckCtxt(cclass(c).line,"class definition",FALSE,cclass(c).supers,NIL);
- cclass(c).numSupers = length(cclass(c).supers);
- cclass(c).defaults = extractBindings(cclass(c).members); /* defaults*/
- ss = extractSigdecls(cclass(c).members);
- fs = extractFixdecls(cclass(c).members);
- cclass(c).members = pair(ss,fs);
- map2Proc(checkMems,c,tyvars,ss);
-
- cclass(c).kinds = tcDeps;
- tcDeps = NIL;
-}
-
-
-/* --------------------------------------------------------------------------
- * Functional dependencies are inherited from superclasses.
- * For example, if I've got the following classes:
- *
- * class C a b | a -> b
- * class C [b] a => D a b
- *
- * then C will have the dependency ([a], [b]) as expected, and D will inherit
- * the dependency ([b], [a]) from C.
- * When doing pairwise improvement, we have to consider not just improving
- * when we see a pair of Cs or a pair of Ds in the context, but when we've
- * got a C and a D as well. In this case, we only improve when the
- * predicate in question matches the type skeleton in the relevant superclass
- * constraint. E.g., we improve the pair (C [Int] a, D b Int) (unifying
- * a and b), but we don't improve the pair (C Int a, D b Int).
- * To implement functional dependency inheritance, we calculate
- * the closure of all functional dependencies, and store the result
- * in an additional field `xfds' (extended functional dependencies).
- * The `xfds' field is a list of functional dependency lists, annotated
- * with a list of predicate skeletons constraining when improvement can
- * happen against this dependency list. For example, the xfds field
- * for C above would be:
- * [([C a b], [([a], [b])])]
- * and the xfds field for D would be:
- * [([C [b] a, D a b], [([b], [a])])]
- * Self-improvement (of a C with a C, or a D with a D) is treated as a
- * special case of an inherited dependency.
- * ------------------------------------------------------------------------*/
-static List local inheritFundeps ( Class c, Cell pi, Int o )
-{
- Int alpha = newKindedVars(cclass(c).kinds);
- List scs = cclass(c).supers;
- List xfds = NIL;
- Cell this = NIL;
- /* better not fail ;-) */
- if (!matchPred(pi,o,cclass(c).head,alpha))
- internal("inheritFundeps - predicate failed to match it's own head!");
- this = copyPred(pi,o);
- for (; nonNull(scs); scs=tl(scs)) {
- Class s = getHead(hd(scs));
- if (isClass(s)) {
- List sfds = inheritFundeps(s,hd(scs),alpha);
- for (; nonNull(sfds); sfds=tl(sfds)) {
- Cell h = hd(sfds);
- xfds = cons(pair(cons(this,fst(h)),snd(h)),xfds);
- }
- }
- }
- if (nonNull(cclass(c).fds)) {
- List fds = NIL, fs = cclass(c).fds;
- for (; nonNull(fs); fs=tl(fs)) {
- fds = cons(pair(otvars(this,fst(hd(fs))),
- otvars(this,snd(hd(fs)))),fds);
- }
- xfds = cons(pair(cons(this,NIL),fds),xfds);
- }
- return xfds;
-}
-
-static Void local extendFundeps ( Class c )
-{
- Int alpha;
- emptySubstitution();
- alpha = newKindedVars(cclass(c).kinds);
- cclass(c).xfds = inheritFundeps(c,cclass(c).head,alpha);
-
- /* we can now check for ambiguity */
- map1Proc(checkMems2,c,fst(cclass(c).members));
-}
-
-
-static Cell local depPredExp(line,tyvars,pred)
-Int line;
-List tyvars;
-Cell pred; {
- Int args = 0;
- Cell prev = NIL;
- Cell h = pred;
- for (; isAp(h); args++) {
- arg(h) = depTypeExp(line,tyvars,arg(h));
- prev = h;
- h = fun(h);
- }
-
- if (args==0) {
- h98DoesntSupport(line,"tag classes");
- } else if (args!=1) {
- h98DoesntSupport(line,"multiple parameter classes");
- }
-
- if (isQCon(h)) { /* standard class constraint */
- Class c = findQualClass(h);
- if (isNull(c)) {
- ERRMSG(line) "Undefined class \"%s\"", identToStr(h)
- EEND;
- }
- if (isNull(prev)) {
- pred = c;
- } else {
- fun(prev) = c;
- }
- if (args!=cclass(c).arity) {
- ERRMSG(line) "Wrong number of arguments for class \"%s\"",
- textToStr(cclass(c).text)
- EEND;
- }
- if (cellIsMember(c,classDefns) && !cellIsMember(c,tcDeps)) {
- tcDeps = cons(c,tcDeps);
- }
- }
-#if TREX
- else if (isExt(h)) { /* Lacks predicate */
- if (args!=1) { /* parser shouldn't let this happen*/
- ERRMSG(line) "Wrong number of arguments for lacks predicate"
- EEND;
- }
- }
-#endif
- else
-#if IPARAM
- if (whatIs(h) != IPCELL)
-#endif
- {
- internal("depPredExp");
- }
- return pred;
-}
-
-static Void local checkMems(c,tyvars,m) /* check member function details */
-Class c;
-List tyvars;
-Cell m; {
- Int line = intOf(fst3(m));
- List vs = snd3(m);
- Type t = thd3(m);
- List sig = NIL;
- List tvs = NIL;
- List xtvs = NIL;
-
- if (isPolyType(t)) {
- xtvs = fst(snd(t));
- t = monotypeOf(t);
- }
-
-
- tyvars = typeVarsIn(t,NIL,xtvs,tyvars);
- /* Look for extra type vars. */
- checkOptQuantVars(line,xtvs,tyvars);
-
- if (isQualType(t)) { /* Overloaded member signatures? */
- map2Over(depPredExp,line,tyvars,fst(snd(t)));
- } else {
- t = ap(QUAL,pair(NIL,t));
- }
-
- fst(snd(t)) = cons(cclass(c).head,fst(snd(t)));/* Add main predicate */
- snd(snd(t)) = depTopType(line,tyvars,snd(snd(t)));
-
- for (tvs=tyvars; nonNull(tvs); tvs=tl(tvs)){/* Quantify */
- sig = ap(NIL,sig);
- }
- if (nonNull(sig)) {
- t = mkPolyType(sig,t);
- }
- thd3(m) = t; /* Save type */
- take(cclass(c).arity,tyvars); /* Delete extra type vars */
-
- h98CheckType(line,"member type",hd(vs),t);
-}
-
-static Void local checkMems2(c,m) /* check member function details */
-Class c;
-Cell m; {
- Int line = intOf(fst3(m));
- List vs = snd3(m);
- Type t = thd3(m);
-
- if (isAmbiguous(t)) {
- ambigError(line,"class declaration",hd(vs),t);
- }
-}
-
-static Void local addMembers(c) /* Add definitions of member funs */
-Class c; { /* and other parts of class struct.*/
- List ms = fst(cclass(c).members);
- List fs = snd(cclass(c).members);
- List ns = NIL; /* List of names */
- Int mno; /* Member function number */
-
- for (mno=0; mno<cclass(c).numSupers; mno++) {
- ns = cons(newDSel(c,mno),ns);
- }
- cclass(c).dsels = rev(ns); /* Save dictionary selectors */
-
- for (mno=1, ns=NIL; nonNull(ms); ms=tl(ms)) {
- Int line = intOf(fst3(hd(ms)));
- List vs = rev(snd3(hd(ms)));
- Type t = thd3(hd(ms));
- for (; nonNull(vs); vs=tl(vs)) {
- ns = cons(newMember(line,mno++,hd(vs),t,c),ns);
- }
- }
- cclass(c).members = rev(ns); /* Save list of members */
- cclass(c).numMembers = length(cclass(c).members);
-
- for (; nonNull(fs); fs=tl(fs)) { /* fixity declarations */
- Int line = intOf(fst3(hd(fs)));
- List ops = snd3(hd(fs));
- Syntax s = intOf(thd3(hd(fs)));
- for (; nonNull(ops); ops=tl(ops)) {
- Name n = nameIsMember(textOf(hd(ops)),cclass(c).members);
- if (isNull(n)) {
- missFixity(line,textOf(hd(ops)));
- } else if (name(n).syntax!=NO_SYNTAX) {
- dupFixity(line,textOf(hd(ops)));
- }
- name(n).syntax = s;
- }
- }
-
-/* Not actually needed just yet; for the time being, dictionary code will
- not be passed through the type checker.
-
- cclass(c).dtycon = addPrimTycon(generateText("Dict.%s",c),
- NIL,
- cclass(c).arity,
- DATATYPE,
- NIL);
-*/
-
- mno = cclass(c).numSupers + cclass(c).numMembers;
- /* cclass(c).dcon = addPrimCfun(generateText("Make.%s",c),mno,0,NIL); */
- cclass(c).dcon = addPrimCfun(generateText(":D%s",c),mno,0,NIL);
- /* implementCfun(cclass(c).dcon,NIL);
- Don't manufacture a wrapper fn for dictionary constructors.
- Applications of dictionary constructors are always saturated,
- and translate.c:stgExpr() special-cases saturated constructor apps.
- */
-
- if (mno==1) { /* Single entry dicts use newtype */
- name(cclass(c).dcon).defn = nameId;
- if (nonNull(cclass(c).members)) {
- name(hd(cclass(c).members)).number = mfunNo(0);
- }
- }
- cclass(c).defaults = classBindings("class",c,cclass(c).defaults);
-}
-
-static Name local newMember(l,no,v,t,parent)
-Int l; /* Make definition for member fn */
-Int no;
-Cell v;
-Type t;
-Class parent; {
- Name m = findName(textOf(v));
-
- if (isNull(m)) {
- m = newName(textOf(v),parent);
- } else if (name(m).defn!=PREDEFINED) {
- ERRMSG(l) "Repeated definition for member function \"%s\"",
- textToStr(name(m).text)
- EEND;
- }
-
- name(m).line = l;
- name(m).arity = 1;
- name(m).number = mfunNo(no);
- name(m).type = t;
- return m;
-}
-
-Name newDSel(c,no) /* Make definition for dict selectr*/
-Class c;
-Int no; {
- Name s;
- char buf[16];
-
- /* sprintf(buf,"sc%d.%s",no,"%s"); */
- sprintf(buf,"$p%d%s",no+1,"%s");
- s = newName(generateText(buf,c),c);
- name(s).line = cclass(c).line;
- name(s).arity = 1;
- name(s).number = DFUNNAME;
- return s;
-}
-
-#define MAX_GEN 128
-
-static Text local generateText(sk,c) /* We need to generate names for */
-String sk; /* certain objects corresponding */
-Class c; { /* to each class. */
- String cname = textToStr(cclass(c).text);
- char buffer[MAX_GEN+1];
-
- if ((strlen(sk)+strlen(cname))>=MAX_GEN) {
- ERRMSG(0) "Please use a shorter name for class \"%s\"", cname
- EEND;
- }
- sprintf(buffer,sk,cname);
- return findText(buffer);
-}
-
- Int visitClass(c) /* visit class defn to check that */
-Class c; { /* class hierarchy is acyclic */
-#if TREX
- if (isExt(c)) { /* special case for lacks preds */
- return 0;
- }
-#endif
- if (cclass(c).level < 0) { /* already visiting this class? */
- ERRMSG(cclass(c).line) "Class hierarchy for \"%s\" is not acyclic",
- textToStr(cclass(c).text)
- EEND;
- } else if (cclass(c).level == 0) { /* visiting class for first time */
- List scs = cclass(c).supers;
- Int lev = 0;
- cclass(c).level = (-1);
- for (; nonNull(scs); scs=tl(scs)) {
- Int l = visitClass(getHead(hd(scs)));
- if (l>lev) lev=l;
- }
- cclass(c).level = 1+lev; /* level = 1 + max level of supers */
- }
- return cclass(c).level;
-}
-
-/* --------------------------------------------------------------------------
- * Process class and instance declaration binding groups:
- * ------------------------------------------------------------------------*/
-
-static List local classBindings(where,c,bs)
-String where; /* Check validity of bindings bs */
-Class c; /* for class c (or an inst of c) */
-List bs; { /* sort into approp. member order */
- List nbs = NIL;
-
- for (; nonNull(bs); bs=tl(bs)) {
- Cell b = hd(bs);
- Cell body = snd(snd(b));
- Name mnm;
-
- if (!isVar(fst(b))) { /* Only allow function bindings */
- ERRMSG(rhsLine(snd(body)))
- "Pattern binding illegal in %s declaration", where
- EEND;
- }
-
- if (isNull(mnm=memberName(c,textOf(fst(b))))) {
- ERRMSG(rhsLine(snd(hd(body))))
- "No member \"%s\" in class \"%s\"",
- textToStr(textOf(fst(b))), textToStr(cclass(c).text)
- EEND;
- }
- snd(b) = body;
- nbs = numInsert(mfunOf(mnm)-1,b,nbs);
- }
- return nbs;
-}
-
-static Name local memberName(c,t) /* return name of member function */
-Class c; /* with name t in class c */
-Text t; { /* return NIL if not a member */
- List ms = cclass(c).members;
- for (; nonNull(ms); ms=tl(ms)) {
- if (t==name(hd(ms)).text) {
- return hd(ms);
- }
- }
- return NIL;
-}
-
-static List local numInsert(n,x,xs) /* insert x at nth position in xs, */
-Int n; /* filling gaps with NIL */
-Cell x;
-List xs; {
- List start = isNull(xs) ? cons(NIL,NIL) : xs;
-
- for (xs=start; 0<n--; xs=tl(xs)) {
- if (isNull(tl(xs))) {
- tl(xs) = cons(NIL,NIL);
- }
- }
- hd(xs) = x;
- return start;
-}
-
-/* --------------------------------------------------------------------------
- * Calculate set of variables appearing in a given type expression (possibly
- * qualified) as a list of distinct values. The order in which variables
- * appear in the list is the same as the order in which those variables
- * occur in the type expression when read from left to right.
- * ------------------------------------------------------------------------*/
-
-List local typeVarsIn(ty,us,ws,vs) /*Calculate list of type variables*/
-Cell ty; /* used in type expression, reading*/
-List us; /* from left to right ignoring any */
-List ws; /* listed in us. */
-List vs; { /* ws = explicitly quantified vars */
- if (isNull(ty)) return vs;
- switch (whatIs(ty)) {
- case DICTAP : return typeVarsIn(snd(snd(ty)),us,ws,vs);
- case UNBOXEDTUP: return typeVarsIn(snd(ty),us,ws,vs);
-
- case AP : return typeVarsIn(snd(ty),us,ws,
- typeVarsIn(fst(ty),us,ws,vs));
-
- case VARIDCELL :
- case VAROPCELL : if ((nonNull(findBtyvs(textOf(ty)))
- && !varIsMember(textOf(ty),ws))
- || varIsMember(textOf(ty),us)) {
- return vs;
- } else {
- return maybeAppendVar(ty,vs);
- }
-
- case POLYTYPE : return typeVarsIn(monotypeOf(ty),polySigOf(ty),ws,vs);
-
- case QUAL : { vs = typeVarsIn(fst(snd(ty)),us,ws,vs);
- return typeVarsIn(snd(snd(ty)),us,ws,vs);
- }
-
- case BANG : return typeVarsIn(snd(ty),us,ws,vs);
-
- case LABC : { List fs = snd(snd(ty));
- for (; nonNull(fs); fs=tl(fs)) {
- vs = typeVarsIn(snd(hd(fs)),us,ws,vs);
- }
- return vs;
- }
- case TUPLE:
- case TYCON:
- case CONIDCELL:
- case QUALIDENT: return vs;
-
- default: fprintf(stderr, " bad tag = %d\n", whatIs(ty));internal("typeVarsIn");
- }
- assert(0);
-}
-
-static List local maybeAppendVar(v,vs) /* append variable to list if not */
-Cell v; /* already included */
-List vs; {
- Text t = textOf(v);
- List p = NIL;
- List c = vs;
-
- while (nonNull(c)) {
- if (textOf(hd(c))==t) {
- return vs;
- }
- p = c;
- c = tl(c);
- }
-
- if (nonNull(p)) {
- tl(p) = cons(v,NIL);
- } else {
- vs = cons(v,NIL);
- }
-
- return vs;
-}
-
-/* --------------------------------------------------------------------------
- * Static analysis for type expressions is required to:
- * - ensure that each type constructor or class used has been defined.
- * - replace type variables by offsets, constructor names by Tycons.
- * - ensure that the type is well-kinded.
- * ------------------------------------------------------------------------*/
-
-static Type local checkSigType(line,where,e,type)
-Int line; /* Check validity of type expr in */
-String where; /* explicit type signature */
-Cell e;
-Type type; {
- List tvs = NIL;
- List sunk = NIL;
- List xtvs = NIL;
-
- if (isPolyType(type)) {
- xtvs = fst(snd(type));
- type = monotypeOf(type);
- }
- tvs = typeVarsIn(type,NIL,xtvs,NIL);
- sunk = unkindTypes;
- checkOptQuantVars(line,xtvs,tvs);
-
- if (isQualType(type)) {
- map2Over(depPredExp,line,tvs,fst(snd(type)));
- snd(snd(type)) = depTopType(line,tvs,snd(snd(type)));
-
- if (isAmbiguous(type)) {
- ambigError(line,where,e,type);
- }
- } else {
- type = depTopType(line,tvs,type);
- }
-
- if (nonNull(tvs)) {
- if (length(tvs) >= (OFF_MAX-OFF_MIN+1)) {
- ERRMSG(line) "Too many type variables in %s\n", where
- EEND;
- } else {
- List ts = tvs;
- for (; nonNull(ts); ts=tl(ts)) {
- hd(ts) = NIL;
- }
- type = mkPolyType(tvs,type);
- }
- }
-
- unkindTypes = NIL;
- kindType(line,"type expression",type);
- fixKinds();
- unkindTypes = sunk;
-
- h98CheckType(line,where,e,type);
- return type;
-}
-
-static Void local checkOptQuantVars(line,xtvs,tvs)
-Int line;
-List xtvs; /* Explicitly quantified vars */
-List tvs; { /* Implicitly quantified vars */
- if (nonNull(xtvs)) {
- List vs = tvs;
- for (; nonNull(vs); vs=tl(vs)) {
- if (!varIsMember(textOf(hd(vs)),xtvs)) {
- ERRMSG(line) "Quantifier does not mention type variable \"%s\"",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- }
- for (vs=xtvs; nonNull(vs); vs=tl(vs)) {
- if (!varIsMember(textOf(hd(vs)),tvs)) {
- ERRMSG(line) "Quantified type variable \"%s\" is not used",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- if (varIsMember(textOf(hd(vs)),tl(vs))) {
- ERRMSG(line) "Quantified type variable \"%s\" is repeated",
- textToStr(textOf(hd(vs)))
- EEND;
- }
- }
- }
-}
-
-static Type local depTopType(l,tvs,t) /* Check top-level of type sig */
-Int l;
-List tvs;
-Type t; {
- Type prev = NIL;
- Type t1 = t;
- Int nr2 = 0;
- Int i = 1;
- for (; getHead(t1)==typeArrow && argCount==2; ++i) {
- arg(fun(t1)) = depCompType(l,tvs,arg(fun(t1)));
- if (isPolyOrQualType(arg(fun(t1)))) {
- nr2 = i;
- }
- prev = t1;
- t1 = arg(t1);
- }
- if (nonNull(prev)) {
- arg(prev) = depTypeExp(l,tvs,t1);
- } else {
- t = depTypeExp(l,tvs,t1);
- }
- if (nr2>0) {
- t = ap(RANK2,pair(mkInt(nr2),t));
- }
- return t;
-}
-
-static Type local depCompType(l,tvs,t) /* Check component type for constr */
-Int l;
-List tvs;
-Type t; {
- Int ntvs = length(tvs);
- List nfr = NIL;
- if (isPolyType(t)) {
- List vs = fst(snd(t));
- t = monotypeOf(t);
- tvs = checkQuantVars(l,vs,tvs,t);
- nfr = replicate(length(vs),NIL);
- }
- if (isQualType(t)) {
- map2Over(depPredExp,l,tvs,fst(snd(t)));
- snd(snd(t)) = depTypeExp(l,tvs,snd(snd(t)));
- if (isAmbiguous(t)) {
- ambigError(l,"type component",NIL,t);
- }
- } else {
- t = depTypeExp(l,tvs,t);
- }
- if (isNull(nfr)) {
- return t;
- }
- take(ntvs,tvs);
- return mkPolyType(nfr,t);
-}
-
-static Type local depTypeExp(line,tyvars,type)
-Int line;
-List tyvars;
-Type type; {
- switch (whatIs(type)) {
- case AP : fst(type) = depTypeExp(line,tyvars,fst(type));
- snd(type) = depTypeExp(line,tyvars,snd(type));
- break;
-
- case VARIDCELL : return depTypeVar(line,tyvars,textOf(type));
-
- case QUALIDENT : if (isQVar(type)) {
- ERRMSG(line) "Qualified type variables not allowed"
- EEND;
- }
- /* deliberate fall through */
- case CONIDCELL : { Tycon tc = findQualTycon(type);
- if (isNull(tc)) {
- ERRMSG(line)
- "Undefined type constructor \"%s\"",
- identToStr(type)
- EEND;
- }
- if (cellIsMember(tc,tyconDefns) &&
- !cellIsMember(tc,tcDeps)) {
- tcDeps = cons(tc,tcDeps);
- }
- return tc;
- }
-
-#if TREX
- case EXT : h98DoesntSupport(line,"extensible records");
-#endif
- case TYCON :
- case TUPLE : break;
-
- default : internal("depTypeExp");
- }
- return type;
-}
-
-static Type local depTypeVar(line,tyvars,tv)
-Int line;
-List tyvars;
-Text tv; {
- Int offset = 0;
- Int found = (-1);
-
- for (; nonNull(tyvars); offset++) {
- if (tv==textOf(hd(tyvars))) {
- found = offset;
- }
- tyvars = tl(tyvars);
- }
- if (found<0) {
- Cell vt = findBtyvs(tv);
- if (nonNull(vt)) {
- return fst(vt);
- }
- ERRMSG(line) "Undefined type variable \"%s\"", textToStr(tv)
- EEND;
- }
- return mkOffset(found);
-}
-
-static List local checkQuantVars(line,vs,tvs,body)
-Int line;
-List vs; /* variables to quantify over */
-List tvs; /* variables already in scope */
-Cell body; { /* type/constr for scope of vars */
- if (nonNull(vs)) {
- List bvs = typeVarsIn(body,NIL,NIL,NIL);
- List us = vs;
- for (; nonNull(us); us=tl(us)) {
- Text u = textOf(hd(us));
- if (varIsMember(u,tl(us))) {
- ERRMSG(line) "Duplicated quantified variable %s",
- textToStr(u)
- EEND;
- }
-#if 0
- if (varIsMember(u,tvs)) {
- ERRMSG(line) "Local quantifier for %s hides an outer use",
- textToStr(u)
- EEND;
- }
-#endif
- if (!varIsMember(u,bvs)) {
- ERRMSG(line) "Locally quantified variable %s is not used",
- textToStr(u)
- EEND;
- }
- }
- tvs = appendOnto(tvs,vs);
- }
- return tvs;
-}
-
-/* --------------------------------------------------------------------------
- * Check for ambiguous types:
- * A type Preds => type is ambiguous if not (TV(P) `subset` TV(type))
- * ------------------------------------------------------------------------*/
-
-List offsetTyvarsIn(t,vs) /* add list of offset tyvars in t */
-Type t; /* to list vs */
-List vs; {
- switch (whatIs(t)) {
- case AP : return offsetTyvarsIn(fun(t),
- offsetTyvarsIn(arg(t),vs));
-
- case OFFSET : if (cellIsMember(t,vs))
- return vs;
- else
- return cons(t,vs);
-
- case QUAL : return offsetTyvarsIn(snd(t),vs);
-
- case POLYTYPE : return offsetTyvarsIn(monotypeOf(t),vs);
- /* slightly inaccurate, but won't matter here */
-
- case EXIST :
- case RANK2 : return offsetTyvarsIn(snd(snd(t)),vs);
-
- default : return vs;
- }
-}
-
-List zonkTyvarsIn(t,vs)
-Type t;
-List vs; {
- switch (whatIs(t)) {
- case AP : return zonkTyvarsIn(fun(t),
- zonkTyvarsIn(arg(t),vs));
-
- case INTCELL : if (cellIsMember(t,vs))
- return vs;
- else
- return cons(t,vs);
-
- /* this case will lead to a type error --
- much better than reporting an internal error ;-) */
- /* case OFFSET : internal("zonkTyvarsIn"); */
-
- default : return vs;
- }
-}
-
-static List local otvars(pi,os) /* os is a list of offsets that */
-Cell pi; /* refer to the arguments of pi; */
-List os; { /* find list of offsets in those */
- List us = NIL; /* positions */
- for (; nonNull(os); os=tl(os)) {
- us = offsetTyvarsIn(nthArg(offsetOf(hd(os)),pi),us);
- }
- return us;
-}
-
-static List local otvarsZonk(pi,os,o) /* same as above, but zonks */
-Cell pi;
-List os; {
- List us = NIL;
- for (; nonNull(os); os=tl(os)) {
- Type t = zonkType(nthArg(offsetOf(hd(os)),pi),o);
- us = zonkTyvarsIn(t,us);
- }
- return us;
-}
-
-static Bool local odiff(us,vs)
-List us, vs; {
- while (nonNull(us) && cellIsMember(hd(us),vs)) {
- us = tl(us);
- }
- return us;
-}
-
-static Bool local osubset(us,vs) /* Determine whether us is subset */
-List us, vs; { /* of vs */
- while (nonNull(us) && cellIsMember(hd(us),vs)) {
- us = tl(us);
- }
- return isNull(us);
-}
-
-List oclose(fds,vs) /* Compute closure of vs wrt to fds*/
-List fds;
-List vs; {
- Bool changed = TRUE;
- while (changed) {
- List fds1 = NIL;
- changed = FALSE;
- while (nonNull(fds)) {
- Cell fd = hd(fds);
- List next = tl(fds);
- if (osubset(fst(fd),vs)) { /* Test if fd applies */
- List os = snd(fd);
- for (; nonNull(os); os=tl(os)) {
- if (!cellIsMember(hd(os),vs)) {
- vs = cons(hd(os),vs);
- changed = TRUE;
- }
- }
- } else { /* Didn't apply this time, so keep */
- tl(fds) = fds1;
- fds1 = fds;
- }
- fds = next;
- }
- fds = fds1;
- }
- return vs;
-}
-
-Bool isAmbiguous(type) /* Determine whether type is */
-Type type; { /* ambiguous */
- if (isPolyType(type)) {
- type = monotypeOf(type);
- }
- if (isQualType(type)) { /* only qualified types can be */
- List ps = fst(snd(type)); /* ambiguous */
- List tvps = offsetTyvarsIn(ps,NIL);
- List tvts = offsetTyvarsIn(snd(snd(type)),NIL);
- List fds = calcFunDeps(ps);
-
- tvts = oclose(fds,tvts); /* Close tvts under fds */
- return !osubset(tvps,tvts);
- }
- return FALSE;
-}
-
-List calcFunDeps(ps)
-List ps; {
- List fds = NIL;
- for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
- Cell pi = hd(ps);
- Cell c = getHead(pi);
- if (isClass(c)) {
- List xfs = cclass(c).xfds;
- for (; nonNull(xfs); xfs=tl(xfs)) {
- List fs = snd(hd(xfs));
- for (; nonNull(fs); fs=tl(fs)) {
- fds = cons(pair(otvars(pi,fst(hd(fs))),
- otvars(pi,snd(hd(fs)))),fds);
- }
- }
- }
-#if IPARAM
- else if (isIP(c)) {
- fds = cons(pair(NIL,offsetTyvarsIn(arg(pi),NIL)),fds);
- }
-#endif
- }
- return fds;
-}
-
-List calcFunDepsPreds(ps)
-List ps; {
- List fds = NIL;
- for (; nonNull(ps); ps=tl(ps)) {/* Calc functional dependencies */
- Cell pi3 = hd(ps);
- Cell pi = fst3(pi3);
- Cell c = getHead(pi);
- Int o = intOf(snd3(pi3));
- if (isClass(c)) {
- List xfs = cclass(c).xfds;
- for (; nonNull(xfs); xfs=tl(xfs)) {
- List fs = snd(hd(xfs));
- for (; nonNull(fs); fs=tl(fs)) {
- fds = cons(pair(otvarsZonk(pi,fst(hd(fs)),o),
- otvarsZonk(pi,snd(hd(fs)),o)),fds);
- }
- }
- }
-#if IPARAM
- else if (isIP(c)) {
- fds = cons(pair(NIL,zonkTyvarsIn(arg(pi),NIL)),fds);
- }
-#endif
- }
- return fds;
-}
-
-Void ambigError(line,where,e,type) /* produce error message for */
-Int line; /* ambiguity */
-String where;
-Cell e;
-Type type; {
- ERRMSG(line) "Ambiguous type signature in %s", where ETHEN
- ERRTEXT "\n*** ambiguous type : " ETHEN ERRTYPE(type);
- if (nonNull(e)) {
- ERRTEXT "\n*** assigned to : " ETHEN ERREXPR(e);
- }
- ERRTEXT "\n"
- EEND;
-}
-
-/* --------------------------------------------------------------------------
- * Kind inference for simple types:
- * ------------------------------------------------------------------------*/
-
-static Void local kindConstr(line,alpha,m,c)
-Int line; /* Determine kind of constructor */
-Int alpha;
-Int m;
-Cell c; {
- Cell h = getHead(c);
- Int n = argCount;
-
-#ifdef DEBUG_KINDS
- Printf("kindConstr: alpha=%d, m=%d, c=",alpha,m);
- printType(stdout,c);
- Printf("\n");
-#endif
-
- switch (whatIs(h)) {
- case POLYTYPE : if (n!=0) {
- internal("kindConstr1");
- } else {
- static String pt = "polymorphic type";
- Type t = dropRank1(c,alpha,m);
- Kinds ks = polySigOf(t);
- Int m1 = 0;
- Int beta;
- for (; isAp(ks); ks=tl(ks)) {
- m1++;
- }
- beta = newKindvars(m1);
- unkindTypes = cons(pair(mkInt(beta),t),unkindTypes);
- checkKind(line,beta,m1,monotypeOf(t),NIL,pt,STAR,0);
- }
- return;
-
- case CDICTS :
- case QUAL : if (n!=0) {
- internal("kindConstr2");
- }
- map3Proc(kindPred,line,alpha,m,fst(snd(c)));
- kindConstr(line,alpha,m,snd(snd(c)));
- return;
-
- case EXIST :
- case RANK2 : kindConstr(line,alpha,m,snd(snd(c)));
- return;
-
-#if TREX
- case EXT : if (n!=2) {
- ERRMSG(line)
- "Illegal use of row in " ETHEN ERRTYPE(c);
- ERRTEXT "\n"
- EEND;
- }
- break;
-#endif
-
- case TYCON : if (isSynonym(h) && n<tycon(h).arity) {
- ERRMSG(line)
- "Not enough arguments for type synonym \"%s\"",
- textToStr(tycon(h).text)
- EEND;
- }
- break;
- }
-
- if (n==0) { /* trivial case, no arguments */
- typeIs = kindAtom(alpha,c);
- } else { /* non-trivial application */
- static String app = "constructor application";
- Cell a = c;
- Int i;
- Kind k;
- Int beta;
-
- varKind(n);
- beta = typeOff;
- k = typeIs;
-
- typeIs = kindAtom(alpha,h); /* h :: v1 -> ... -> vn -> w */
- shouldKind(line,h,c,app,k,beta);
-
- for (i=n; i>0; --i) { /* ci :: vi for each 1 <- 1..n */
- checkKind(line,alpha,m,arg(a),c,app,aVar,beta+i-1);
- a = fun(a);
- }
- tyvarType(beta+n); /* inferred kind is w */
- }
-}
-
-static Kind local kindAtom(alpha,c) /* Find kind of atomic constructor */
-Int alpha;
-Cell c; {
- switch (whatIs(c)) {
- case TUPLE : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
- case OFFSET : return mkInt(alpha+offsetOf(c));
- case TYCON : return tycon(c).kind;
- case INTCELL : return c;
- case VARIDCELL :
- case VAROPCELL : { Cell vt = findBtyvs(textOf(c));
- if (nonNull(vt)) {
- return snd(vt);
- }
- }
-#if TREX
- case EXT : return extKind;
-#endif
- }
-#if DEBUG_KINDS
- Printf("kindAtom(%d,whatIs(%d)) on ",alpha,whatIs(c));
- printType(stdout,c);
- Printf("\n");
-#endif
- internal("kindAtom");
- return STAR;/* not reached */
-}
-
-static Void local kindPred(l,alpha,m,pi)/* Check kinds of arguments in pred*/
-Int l;
-Int alpha;
-Int m;
-Cell pi; {
-#if TREX
- if (isAp(pi) && isExt(fun(pi))) {
- static String lackspred = "lacks predicate";
- checkKind(l,alpha,m,arg(pi),NIL,lackspred,ROW,0);
- return;
- }
-#endif
-#if IPARAM
- if (isAp(pi) && whatIs(fun(pi)) == IPCELL) {
- static String ippred = "iparam predicate";
- checkKind(l,alpha,m,arg(pi),NIL,ippred,STAR,0);
- return;
- }
-#endif
- { static String predicate = "class constraint";
- Class c = getHead(pi);
- List as = getArgs(pi);
- Kinds ks = cclass(c).kinds;
-
- while (nonNull(ks)) {
- checkKind(l,alpha,m,hd(as),NIL,predicate,hd(ks),0);
- ks = tl(ks);
- as = tl(as);
- }
- }
-}
-
-static Void local kindType(line,wh,type)/* check that (poss qualified) type*/
-Int line; /* is well-kinded */
-String wh;
-Type type; {
- checkKind(line,0,0,type,NIL,wh,STAR,0);
-}
-
-static Void local fixKinds() { /* add kind annotations to types */
- for (; nonNull(unkindTypes); unkindTypes=tl(unkindTypes)) {
- Pair pr = hd(unkindTypes);
- Int beta = intOf(fst(pr));
- Cell qts = polySigOf(snd(pr));
- for (;;) {
- if (isNull(hd(qts))) {
- hd(qts) = copyKindvar(beta++);
- } else {
- internal("fixKinds");
- }
- if (nonNull(tl(qts))) {
- qts = tl(qts);
- } else {
- tl(qts) = STAR;
- break;
- }
- }
-#ifdef DEBUG_KINDS
- Printf("Type expression: ");
- printType(stdout,snd(pr));
- Printf(" :: ");
- printKind(stdout,polySigOf(snd(pr)));
- Printf("\n");
-#endif
- }
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of groups of type constructors and classes:
- * ------------------------------------------------------------------------*/
-
-static Void local kindTCGroup(tcs) /* find kinds for mutually rec. gp */
-List tcs; { /* of tycons and classes */
- emptySubstitution();
- unkindTypes = NIL;
- mapProc(initTCKind,tcs);
- mapProc(kindTC,tcs);
- mapProc(genTC,tcs);
- fixKinds();
- emptySubstitution();
-}
-
-static Void local initTCKind(c) /* build initial kind/arity for c */
-Cell c; {
- if (isTycon(c)) { /* Initial kind of tycon is: */
- Int beta = newKindvars(1); /* v1 -> ... -> vn -> vn+1 */
- varKind(tycon(c).arity); /* where n is the arity of c. */
- bindTv(beta,typeIs,typeOff); /* For data definitions, vn+1 == * */
- switch (whatIs(tycon(c).what)) {
- case NEWTYPE :
- case DATATYPE : bindTv(typeOff+tycon(c).arity,STAR,0);
- }
- tycon(c).kind = mkInt(beta);
- } else {
- Int n = cclass(c).arity;
- Int beta = newKindvars(n);
- cclass(c).kinds = NIL;
- while (n>0) {
- n--;
- cclass(c).kinds = pair(mkInt(beta+n),cclass(c).kinds);
- }
- }
-}
-
-static Void local kindTC(c) /* check each part of a tycon/class*/
-Cell c; { /* is well-kinded */
- if (isTycon(c)) {
- static String cfun = "constructor function";
- static String tsyn = "synonym definition";
- Int line = tycon(c).line;
- Int beta = tyvar(intOf(tycon(c).kind))->offs;
- Int m = tycon(c).arity;
- switch (whatIs(tycon(c).what)) {
- case NEWTYPE :
- case DATATYPE : { List cs = tycon(c).defn;
- if (isQualType(cs)) {
- map3Proc(kindPred,line,beta,m,
- fst(snd(cs)));
- tycon(c).defn = cs = snd(snd(cs));
- }
- for (; hasCfun(cs); cs=tl(cs)) {
- kindType(line,cfun,name(hd(cs)).type);
- }
- break;
- }
-
- default : checkKind(line,beta,m,tycon(c).defn,NIL,
- tsyn,aVar,beta+m);
- }
- }
- else { /* scan type exprs in class defn to*/
- List ms = fst(cclass(c).members);
- Int m = cclass(c).arity; /* determine the class signature */
- Int beta = newKindvars(m);
- kindPred(cclass(c).line,beta,m,cclass(c).head);
- map3Proc(kindPred,cclass(c).line,beta,m,cclass(c).supers);
- for (; nonNull(ms); ms=tl(ms)) {
- Int line = intOf(fst3(hd(ms)));
- Type type = thd3(hd(ms));
- kindType(line,"member function type signature",type);
- }
- }
-}
-
-static Void local genTC(c) /* generalise kind inferred for */
-Cell c; { /* given tycon/class */
- if (isTycon(c)) {
- tycon(c).kind = copyKindvar(intOf(tycon(c).kind));
-#ifdef DEBUG_KINDS
- Printf("%s :: ",textToStr(tycon(c).text));
- printKind(stdout,tycon(c).kind);
- Putchar('\n');
-#endif
- } else {
- Kinds ks = cclass(c).kinds;
- for (; nonNull(ks); ks=tl(ks)) {
- hd(ks) = copyKindvar(intOf(hd(ks)));
- }
-#ifdef DEBUG_KINDS
- Printf("%s :: ",textToStr(cclass(c).text));
- printKinds(stdout,cclass(c).kinds);
- Putchar('\n');
-#endif
- }
-}
-
-/* --------------------------------------------------------------------------
- * Static analysis of instance declarations:
- *
- * The first part of the static analysis is performed as the declarations
- * are read during parsing:
- * - make new entry in instance table
- * - record line number of declaration
- * - build list of instances defined in current script for use in later
- * stages of static analysis.
- * ------------------------------------------------------------------------*/
-
-Void instDefn(line,head,ms) /* process new instance definition */
-Int line; /* definition line number */
-Cell head; /* inst header :: (context,Class) */
-List ms; { /* instance members */
- Inst nw = newInst();
- inst(nw).line = line;
- inst(nw).specifics = fst(head);
- inst(nw).head = snd(head);
- inst(nw).implements = ms;
- instDefns = cons(nw,instDefns);
-}
-
-/* --------------------------------------------------------------------------
- * Further static analysis of instance declarations:
- *
- * Makes the following checks:
- * - Class part of header has form C (T a1 ... an) where C is a known
- * class, and T is a known datatype constructor (or restricted synonym),
- * and there is no previous C-T instance, and (T a1 ... an) has a kind
- * appropriate for the class C.
- * - Each element of context is a valid class expression, with type vars
- * drawn from a1, ..., an.
- * - All bindings are function bindings
- * - All bindings define member functions for class C
- * - Arrange bindings into appropriate order for member list
- * - No top level type signature declarations
- * ------------------------------------------------------------------------*/
-
-Bool allowOverlap = FALSE; /* TRUE => allow overlapping insts */
-Name nameListMonad = NIL; /* builder function for List Monad */
-
-static Void local checkInstDefn(in) /* Validate instance declaration */
-Inst in; {
- Int line = inst(in).line;
- List tyvars = typeVarsIn(inst(in).head,NIL,NIL,NIL);
- List tvps = NIL, tvts = NIL;
- List fds = NIL;
-
- if (haskell98) { /* Check for `simple' type */
- List tvs = NIL;
- Cell t = arg(inst(in).head);
- for (; isAp(t); t=fun(t)) {
- if (!isVar(arg(t))) {
- ERRMSG(line)
- "syntax error in instance head (variable expected)"
- EEND;
- }
- if (varIsMember(textOf(arg(t)),tvs)) {
- ERRMSG(line) "repeated type variable \"%s\" in instance head",
- textToStr(textOf(arg(t)))
- EEND;
- }
- tvs = cons(arg(t),tvs);
- }
- if (isVar(t)) {
- ERRMSG(line)
- "syntax error in instance head (constructor expected)"
- EEND;
- }
- }
-
- /* add in the tyvars from the `specifics' so that we don't
- prematurely complain about undefined tyvars */
- tyvars = typeVarsIn(inst(in).specifics,NIL,NIL,tyvars);
- inst(in).head = depPredExp(line,tyvars,inst(in).head);
-
- if (haskell98) {
- Type h = getHead(arg(inst(in).head));
- if (isSynonym(h)) {
- ERRMSG(line) "Cannot use type synonym in instance head"
- EEND;
- }
- }
-
- map2Over(depPredExp,line,tyvars,inst(in).specifics);
-
- /* OK, now we start over, and test for ambiguity */
- tvts = offsetTyvarsIn(inst(in).head,NIL);
- tvps = offsetTyvarsIn(inst(in).specifics,NIL);
- fds = calcFunDeps(inst(in).specifics);
- tvts = oclose(fds,tvts);
- tvts = odiff(tvps,tvts);
- if (!isNull(tvts)) {
- ERRMSG(line) "Undefined type variable \"%s\"",
- textToStr(textOf(nth(offsetOf(hd(tvts)),tyvars)))
- EEND;
- }
-
- h98CheckCtxt(line,"instance definition",FALSE,inst(in).specifics,NIL);
- inst(in).numSpecifics = length(inst(in).specifics);
- inst(in).c = getHead(inst(in).head);
- if (!isClass(inst(in).c)) {
- ERRMSG(line) "Illegal predicate in instance declaration"
- EEND;
- }
-
- if (nonNull(cclass(inst(in).c).fds)) {
- List fds = cclass(inst(in).c).fds;
- for (; nonNull(fds); fds=tl(fds)) {
- List as = otvars(inst(in).head, fst(hd(fds)));
- List bs = otvars(inst(in).head, snd(hd(fds)));
- List fs = calcFunDeps(inst(in).specifics);
- as = oclose(fs,as);
- if (!osubset(bs,as)) {
- ERRMSG(inst(in).line)
- "Instance is more general than a dependency allows"
- ETHEN
- ERRTEXT "\n*** Instance : "
- ETHEN ERRPRED(inst(in).head);
- ERRTEXT "\n*** For class : "
- ETHEN ERRPRED(cclass(inst(in).c).head);
- ERRTEXT "\n*** Under dependency : "
- ETHEN ERRFD(hd(fds));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
-
- kindInst(in,length(tyvars));
- insertInst(in);
-
- if (nonNull(extractSigdecls(inst(in).implements))) {
- ERRMSG(line)
- "Type signature declarations not permitted in instance declaration"
- EEND;
- }
- if (nonNull(extractFixdecls(inst(in).implements))) {
- ERRMSG(line)
- "Fixity declarations not permitted in instance declaration"
- EEND;
- }
- inst(in).implements = classBindings("instance",
- inst(in).c,
- extractBindings(inst(in).implements));
- inst(in).builder = newInstImp(in);
- if (!preludeLoaded && isNull(nameListMonad) && isAp(inst(in).head)
- && fun(inst(in).head)==classMonad && arg(inst(in).head)==typeList) {
- nameListMonad = inst(in).builder;
- }
-}
-
-static Void local insertInst(in) /* Insert instance into class */
-Inst in; {
- Class c = inst(in).c;
- List ins = cclass(c).instances;
- List prev = NIL;
-
- if (nonNull(cclass(c).fds)) { /* Check for conflicts with fds */
- List ins1 = cclass(c).instances;
- for (; nonNull(ins1); ins1=tl(ins1)) {
- List fds = cclass(c).fds;
- substitution(RESET);
- for (; nonNull(fds); fds=tl(fds)) {
- Int alpha = newKindedVars(inst(in).kinds);
- Int beta = newKindedVars(inst(hd(ins1)).kinds);
- List as = fst(hd(fds));
- Bool same = TRUE;
- for (; same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- same &= unify(nthArg(n,inst(in).head),alpha,
- nthArg(n,inst(hd(ins1)).head),beta);
- }
- if (isNull(as) && same) {
- for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- same &= sameType(nthArg(n,inst(in).head),alpha,
- nthArg(n,inst(hd(ins1)).head),beta);
- }
- if (!same) {
- ERRMSG(inst(in).line)
- "Instances are not consistent with dependencies"
- ETHEN
- ERRTEXT "\n*** This instance : "
- ETHEN ERRPRED(inst(in).head);
- ERRTEXT "\n*** Conflicts with : "
- ETHEN ERRPRED(inst(hd(ins)).head);
- ERRTEXT "\n*** For class : "
- ETHEN ERRPRED(cclass(c).head);
- ERRTEXT "\n*** Under dependency : "
- ETHEN ERRFD(hd(fds));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- }
- }
-
-
- substitution(RESET);
- while (nonNull(ins)) { /* Look for overlap w/ other insts */
- Int alpha = newKindedVars(inst(in).kinds);
- Int beta = newKindedVars(inst(hd(ins)).kinds);
- if (unifyPred(inst(in).head,alpha,inst(hd(ins)).head,beta)) {
- Cell pi = copyPred(inst(in).head,alpha);
- if (allowOverlap && !haskell98) {
- Bool bef = instCompare(in,hd(ins));
- Bool aft = instCompare(hd(ins),in);
- if (bef && !aft) { /* in comes strictly before hd(ins)*/
- break;
- }
- if (aft && !bef) { /* in comes strictly after hd(ins) */
- prev = ins;
- ins = tl(ins);
- continue;
- }
- }
-#if MULTI_INST
- if (multiInstRes && nonNull(inst(in).specifics)) {
- break;
- } else {
-#endif
- ERRMSG(inst(in).line) "Overlapping instances for class \"%s\"",
- textToStr(cclass(c).text)
- ETHEN
- ERRTEXT "\n*** This instance : " ETHEN ERRPRED(inst(in).head);
- ERRTEXT "\n*** Overlaps with : " ETHEN
- ERRPRED(inst(hd(ins)).head);
- ERRTEXT "\n*** Common instance : " ETHEN
- ERRPRED(pi);
- ERRTEXT "\n"
- EEND;
- }
-#if MULTI_INST
- }
-#endif
- prev = ins; /* No overlap detected, so move on */
- ins = tl(ins); /* to next instance */
- }
- substitution(RESET);
-
- if (nonNull(prev)) { /* Insert instance at this point */
- tl(prev) = cons(in,ins);
- } else {
- cclass(c).instances = cons(in,ins);
- }
-}
-
-static Bool local instCompare(ia,ib) /* See if ia is an instance of ib */
-Inst ia, ib;{
- Int alpha = newKindedVars(inst(ia).kinds);
- Int beta = newKindedVars(inst(ib).kinds);
- return matchPred(inst(ia).head,alpha,inst(ib).head,beta);
-}
-
-static Name local newInstImp(in) /* Make definition for inst builder*/
-Inst in; {
- Name b = newName(inventText(),in);
- name(b).line = inst(in).line;
- name(b).arity = inst(in).numSpecifics;
- name(b).number = DFUNNAME;
- return b;
-}
-
-/* --------------------------------------------------------------------------
- * Kind checking of instance declaration headers:
- * ------------------------------------------------------------------------*/
-
-static Void local kindInst(in,freedom) /* check predicates in instance */
-Inst in;
-Int freedom; {
- Int beta;
-
- emptySubstitution();
- beta = newKindvars(freedom);
- kindPred(inst(in).line,beta,freedom,inst(in).head);
- if (whatIs(inst(in).specifics)!=DERIVE) {
- map3Proc(kindPred,inst(in).line,beta,freedom,inst(in).specifics);
- }
- for (inst(in).kinds = NIL; 0<freedom--; ) {
- inst(in).kinds = cons(copyKindvar(beta+freedom),inst(in).kinds);
- }
-#ifdef DEBUG_KINDS
- Printf("instance ");
- printPred(stdout,inst(in).head);
- Printf(" :: ");
- printKinds(stdout,inst(in).kinds);
- Putchar('\n');
-#endif
- emptySubstitution();
-}
-
-/* --------------------------------------------------------------------------
- * Process derived instance requests:
- * ------------------------------------------------------------------------*/
-
-static List derivedInsts; /* list of derived instances */
-
-static Void local checkDerive(t,p,ts,ct)/* verify derived instance request */
-Tycon t; /* for tycon t, with explicit */
-List p; /* context p, component types ts */
-List ts; /* and named class ct */
-Cell ct; {
- Int line = tycon(t).line;
- Class c = findQualClass(ct);
- if (isNull(c)) {
- ERRMSG(line) "Unknown class \"%s\" in derived instance",
- identToStr(ct)
- EEND;
- }
- addDerInst(line,c,p,dupList(ts),t,tycon(t).arity);
-}
-
-static Void local addDerInst(line,c,p,cts,t,a) /* Add a derived instance */
-Int line;
-Class c;
-List p, cts;
-Type t;
-Int a; {
- Inst in;
- Cell head = t; /* Build instance head */
- Int i = 0;
-
- for (; i<a; i++) {
- head = ap(head,mkOffset(i));
- }
- head = ap(c,head);
-
- in = newInst();
- inst(in).c = c;
- inst(in).line = line;
- inst(in).head = head;
- inst(in).specifics = ap(DERIVE,pair(dupList(p),cts));
- inst(in).implements = NIL;
- inst(in).kinds = mkInt(a);
- derivedInsts = cons(in,derivedInsts);
-}
-
-Void addTupInst(c,n) /* Request derived instance of c */
-Class c; /* for mkTuple(n) constructor */
-Int n; {
- Int m = n;
- List cts = NIL;
- while (0<m--) {
- cts = cons(mkOffset(m),cts);
- }
- cts = rev(cts);
- addDerInst(0,c,NIL,cts,mkTuple(n),n);
-}
-
-#if TREX
-Inst addRecShowInst(c,e) /* Generate instance for ShowRecRow*/
-Class c; /* c *must* be ShowRecRow */
-Ext e; {
- Inst in = newInst();
- inst(in).c = c;
- inst(in).head = ap(c,ap2(e,aVar,bVar));
- inst(in).kinds = extKind;
- inst(in).specifics = cons(ap(classShow,aVar),
- cons(ap(e,bVar),
- cons(ap(c,bVar),NIL)));
- inst(in).numSpecifics = 3;
- inst(in).builder = implementRecShw(extText(e),in);
- cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
- return in;
-}
-
-Inst addRecEqInst(c,e) /* Generate instance for EqRecRow */
-Class c; /* c *must* be EqRecRow */
-Ext e; {
- Inst in = newInst();
- inst(in).c = c;
- inst(in).head = ap(c,ap2(e,aVar,bVar));
- inst(in).kinds = extKind;
- inst(in).specifics = cons(ap(classEq,aVar),
- cons(ap(e,bVar),
- cons(ap(c,bVar),NIL)));
- inst(in).numSpecifics = 3;
- inst(in).builder = implementRecEq(extText(e),in);
- cclass(c).instances = appendOnto(cclass(c).instances,singleton(in));
- return in;
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * Calculation of contexts for derived instances:
- *
- * Allowing arbitrary types to appear in contexts makes it rather harder
- * to decide what the context for a derived instance should be. For
- * example, given:
- *
- * data T a = MkT [a] deriving Show,
- *
- * we could have either of the following:
- *
- * instance (Show [a]) => Show (T a) where ...
- * instance (Show a) => Show (T a) where ...
- *
- * (assuming, of course, that instance (Show a) => Show [a]). For now, we
- * choose to reduce contexts in the hope of detecting errors at an earlier
- * stage---in contrast with value definitions, there is no way for a user
- * to provide something analogous to a `type signature' by which they might
- * be able to control this behaviour themselves. We eliminate tautological
- * predicates, but only allow predicates to appear in the final result if
- * they have at least one argument with a variable at its head.
- *
- * In general, we have to deal with mutually recursive instance declarations.
- * We find a solution in the obvious way by iterating to find a fixed point.
- * Of course, without restrictions on the form of instance declarations, we
- * cannot be sure that this will always terminate!
- *
- * For each instance we maintain a pair of the form DERIVE (ctxt,ps).
- * Ctxt is a list giving the parts of the context that have been produced
- * so far in the form of predicate skeletons. During the calculation of
- * derived instances, we attach a dummy NIL value to the end of the list
- * which acts as a kind of `variable': other parts of the system maintain
- * pointers to this variable, and use it to detect when the context has
- * been extended with new elements. Meanwhile, ps is a list containing
- * predicates (pi,o) together with (delayed) substitutions of the form
- * (o,xs) where o is an offset and xs is one of the context variables
- * described above, which may have been partially instantiated.
- * ------------------------------------------------------------------------*/
-
-static Bool instsChanged;
-
-static Void local deriveContexts(is) /* Calc contexts for derived insts */
-List is; {
- emptySubstitution();
- mapProc(initDerInst,is); /* Prepare derived instances */
-
- do { /* Main calculation of contexts */
- instsChanged = FALSE;
- mapProc(calcInstPreds,is);
- } while (instsChanged);
-
- mapProc(tidyDerInst,is); /* Tidy up results */
-}
-
-static Void local initDerInst(in) /* Prepare instance for calculation*/
-Inst in; { /* of derived instance context */
- Cell spcs = inst(in).specifics;
- Int beta = newKindedVars(inst(in).kinds);
- if (whatIs(spcs)!=DERIVE) {
- internal("initDerInst");
- }
- fst(snd(spcs)) = appendOnto(fst(snd(spcs)),singleton(NIL));
- for (spcs=snd(snd(spcs)); nonNull(spcs); spcs=tl(spcs)) {
- hd(spcs) = ap2(inst(in).c,hd(spcs),mkInt(beta));
- }
- inst(in).numSpecifics = beta;
-
-#ifdef DEBUG_DERIVING
- Printf("initDerInst: ");
- printPred(stdout,inst(in).head);
- Printf("\n");
- printContext(stdout,snd(snd(inst(in).specifics)));
- Printf("\n");
-#endif
-}
-
-static Void local calcInstPreds(in) /* Calculate next approximation */
-Inst in; { /* of the context for a derived */
- List retain = NIL; /* instance */
- List ps = snd(snd(inst(in).specifics));
- List spcs = fst(snd(inst(in).specifics));
- Int beta = inst(in).numSpecifics;
- Int its = 1;
- Int factor = 1+length(ps);
-
-#ifdef DEBUG_DERIVING
- Printf("calcInstPreds: ");
- printPred(stdout,inst(in).head);
- Printf("\n");
-#endif
-
- while (nonNull(ps)) {
- Cell p = hd(ps);
- ps = tl(ps);
- if (its++ >= factor*cutoff) {
- Cell bpi = inst(in).head;
- ERRMSG(inst(in).line) "\n*** Cannot derive " ETHEN ERRPRED(bpi);
- ERRTEXT " after %d iterations.", its-1 ETHEN
- ERRTEXT
- "\n*** This may indicate that the problem is undecidable. However,\n"
- ETHEN ERRTEXT
- "*** you may still try to increase the cutoff limit using the -c\n"
- ETHEN ERRTEXT
- "*** option and then try again. (The current setting is -c%d)\n",
- cutoff
- EEND;
- }
- if (isInt(fst(p))) { /* Delayed substitution? */
- List qs = snd(p);
- for (; nonNull(hd(qs)); qs=tl(qs)) {
- ps = cons(pair(hd(qs),fst(p)),ps);
- }
- retain = cons(pair(fst(p),qs),retain);
- }
-#if TREX
- else if (isExt(fun(fst(p)))) { /* Lacks predicate */
- Text l = extText(fun(fst(p)));
- Type t = arg(fst(p));
- Int o = intOf(snd(p));
- Type h;
- Tyvar *tyv;
-
- deRef(tyv,t,o);
- h = getDerefHead(t,o);
- while (isExt(h) && argCount==2 && l!=extText(h)) {
- t = arg(t);
- deRef(tyv,t,o);
- h = getDerefHead(t,o);
- }
- if (argCount==0 && isOffset(h)) {
- maybeAddPred(ap(fun(fun(p)),h),o,beta,spcs);
- } else if (argCount!=0 || h!=typeNoRow) {
- Cell bpi = inst(in).head;
- Cell pi = copyPred(fun(p),intOf(snd(p)));
- ERRMSG(inst(in).line) "Cannot derive " ETHEN ERRPRED(bpi);
- ERRTEXT " because predicate " ETHEN ERRPRED(pi);
- ERRTEXT " does not hold\n"
- EEND;
- }
- }
-#endif
- else { /* Class predicate */
- Cell pi = fst(p);
- Int o = intOf(snd(p));
- Inst in1 = findInstFor(pi,o);
- if (nonNull(in1)) {
- List qs = inst(in1).specifics;
- Int off = mkInt(typeOff);
- if (whatIs(qs)==DERIVE) { /* Still being derived */
- for (qs=fst(snd(qs)); nonNull(hd(qs)); qs=tl(qs)) {
- ps = cons(pair(hd(qs),off),ps);
- }
- retain = cons(pair(off,qs),retain);
- } else { /* Previously def'd inst */
- for (; nonNull(qs); qs=tl(qs)) {
- ps = cons(pair(hd(qs),off),ps);
- }
- }
- } else { /* No matching instance */
- Cell qi = pi;
- while (isAp(qi) && isOffset(getDerefHead(arg(qi),o))) {
- qi = fun(qi);
- }
- if (isAp(qi)) {
- Cell bpi = inst(in).head;
- pi = copyPred(pi,o);
- ERRMSG(inst(in).line) "An instance of " ETHEN ERRPRED(pi);
- ERRTEXT " is required to derive " ETHEN ERRPRED(bpi);
- ERRTEXT "\n"
- EEND;
- } else {
- maybeAddPred(pi,o,beta,spcs);
- }
- }
- }
- }
- snd(snd(inst(in).specifics)) = retain;
-}
-
-static Void local maybeAddPred(pi,o,beta,ps)
-Cell pi; /* Add predicate pi to the list ps,*/
-Int o; /* setting the instsChanged flag if*/
-Int beta; /* pi is not already a member and */
-List ps; { /* using beta to adjust vars */
- Cell c = getHead(pi);
- for (; nonNull(ps); ps=tl(ps)) {
- if (isNull(hd(ps))) { /* reached the `dummy' end of list?*/
- hd(ps) = copyAdj(pi,o,beta);
- tl(ps) = pair(NIL,NIL);
- instsChanged = TRUE;
- return;
- } else if (c==getHead(hd(ps)) && samePred(pi,o,hd(ps),beta)) {
- return;
- }
- }
-}
-
-static Cell local copyAdj(c,o,beta) /* Copy (c,o), replacing vars with */
-Cell c; /* offsets relative to beta. */
-Int o;
-Int beta; {
- switch (whatIs(c)) {
- case AP : { Cell l = copyAdj(fst(c),o,beta);
- Cell r = copyAdj(snd(c),o,beta);
- return ap(l,r);
- }
-
- case OFFSET : { Int vn = o+offsetOf(c);
- Tyvar *tyv = tyvar(vn);
- if (isBound(tyv)) {
- return copyAdj(tyv->bound,tyv->offs,beta);
- }
- vn -= beta;
- if (vn<0 || vn>=(OFF_MAX-OFF_MIN+1)) {
- internal("copyAdj");
- }
- return mkOffset(vn);
- }
- }
- return c;
-}
-
-static Void local tidyDerInst(in) /* Tidy up results of derived inst */
-Inst in; { /* calculations */
- Int o = inst(in).numSpecifics;
- List ps = tl(rev(fst(snd(inst(in).specifics))));
- clearMarks();
- copyPred(inst(in).head,o);
- inst(in).specifics = simpleContext(ps,o);
- h98CheckCtxt(inst(in).line,"derived instance",FALSE,inst(in).specifics,in);
- inst(in).numSpecifics = length(inst(in).specifics);
-
-#ifdef DEBUG_DERIVING
- Printf("Derived instance: ");
- printContext(stdout,inst(in).specifics);
- Printf(" ||- ");
- printPred(stdout,inst(in).head);
- Printf("\n");
-#endif
-}
-
-/* --------------------------------------------------------------------------
- * Generate code for derived instances:
- * ------------------------------------------------------------------------*/
-
-static Void local addDerivImp(in)
-Inst in; {
- List imp = NIL;
- Type t = getHead(arg(inst(in).head));
- Class c = inst(in).c;
- if (c==classEq) {
- imp = deriveEq(t);
- } else if (c==classOrd) {
- imp = deriveOrd(t);
- } else if (c==classEnum) {
- imp = deriveEnum(t);
- } else if (c==classIx) {
- imp = deriveIx(t);
- } else if (c==classShow) {
- imp = deriveShow(t);
- } else if (c==classRead) {
- imp = deriveRead(t);
- } else if (c==classBounded) {
- imp = deriveBounded(t);
- } else {
- ERRMSG(inst(in).line) "Cannot derive instances of class \"%s\"",
- textToStr(cclass(inst(in).c).text)
- EEND;
- }
-
- kindInst(in,intOf(inst(in).kinds));
- insertInst(in);
- inst(in).builder = newInstImp(in);
- inst(in).implements = classBindings("derived instance",
- inst(in).c,
- imp);
-}
-
-
-/* --------------------------------------------------------------------------
- * Default definitions; only one default definition is permitted in a
- * given script file. If no default is supplied, then a standard system
- * default will be used where necessary.
- * ------------------------------------------------------------------------*/
-
-Void defaultDefn(line,defs) /* Handle default types definition */
-Int line;
-List defs; {
- if (defaultLine!=0) {
- ERRMSG(line) "Multiple default declarations are not permitted in" ETHEN
- ERRTEXT "a single script file.\n"
- EEND;
- }
- defaultDefns = defs;
- defaultLine = line;
-}
-
-static Void local checkDefaultDefns() { /* check that default types are */
- List ds = NIL; /* well-kinded instances of Num */
-
- if (defaultLine!=0) {
- map2Over(depTypeExp,defaultLine,NIL,defaultDefns);
- emptySubstitution();
- unkindTypes = NIL;
- map2Proc(kindType,defaultLine,"default type",defaultDefns);
- fixKinds();
- emptySubstitution();
- mapOver(fullExpand,defaultDefns);
- } else {
- defaultDefns = stdDefaults;
- }
-
- if (isNull(classNum)) {
- classNum = findClass(findText("Num"));
- }
-
- for (ds=defaultDefns; nonNull(ds); ds=tl(ds)) {
- if (isNull(provePred(NIL,NIL,ap(classNum,hd(ds))))) {
- ERRMSG(defaultLine)
- "Default types must be instances of the Num class"
- EEND;
- }
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Foreign import declarations are Hugs' equivalent of GHC's ccall mechanism.
- * They are used to "import" C functions into a module.
- * They are usually not written by hand but, rather, generated automatically
- * by GreenCard, IDL compilers or whatever. We support foreign import
- * (static) and foreign import dynamic. In the latter case, extName==NIL.
- *
- * Foreign export declarations generate C wrappers for Hugs functions.
- * Hugs only provides "foreign export dynamic" because it's not obvious
- * what "foreign export static" would mean in an interactive setting.
- * ------------------------------------------------------------------------*/
-
-Void foreignImport(line,callconv,extName,intName,type)
- /* Handle foreign imports */
-Cell line;
-Text callconv;
-Pair extName;
-Cell intName;
-Cell type; {
- Text t = textOf(intName);
- Name n = findName(t);
-
- if (isNull(n)) {
- n = newName(t,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Redeclaration of foreign \"%s\"", textToStr(t)
- EEND;
- }
- name(n).line = line;
- name(n).defn = extName;
- name(n).type = type;
- name(n).callconv = callconv;
- foreignImports = cons(n,foreignImports);
-}
-
-static Void local checkForeignImport(p) /* Check foreign import */
-Name p; {
- emptySubstitution();
- name(p).type = checkSigType(name(p).line,
- "foreign import declaration",
- p,
- name(p).type);
- /* We don't expand synonyms here because we don't want the IO
- * part to be expanded.
- * name(p).type = fullExpand(name(p).type);
- */
- implementForeignImport(p);
-}
-
-Void foreignExport(line,callconv,extName,intName,type)
- /* Handle foreign exports */
-Cell line;
-Text callconv;
-Cell extName;
-Cell intName;
-Cell type; {
- Text t = textOf(intName);
- Name n = findName(t);
-
- if (isNull(n)) {
- n = newName(t,NIL);
- } else if (name(n).defn!=PREDEFINED) {
- ERRMSG(line) "Redeclaration of foreign \"%s\"", textToStr(t)
- EEND;
- }
- name(n).line = line;
- name(n).defn = NIL; /* nothing to say */
- name(n).type = type;
- name(n).callconv = callconv;
- foreignExports = cons(n,foreignExports);
-}
-
-static Void local checkForeignExport(p) /* Check foreign export */
-Name p; {
- emptySubstitution();
- name(p).type = checkSigType(name(p).line,
- "foreign export declaration",
- p,
- name(p).type);
- implementForeignExport(p);
-}
-
-
-
-/* --------------------------------------------------------------------------
- * Static analysis of patterns:
- *
- * Patterns are parsed as ordinary (atomic) expressions. Static analysis
- * makes the following checks:
- * - Patterns are well formed (according to pattern syntax), including the
- * special case of (n+k) patterns.
- * - All constructor functions have been defined and are used with the
- * correct number of arguments.
- * - No variable name is used more than once in a pattern.
- *
- * The list of pattern variables occuring in each pattern is accumulated in
- * a global list `patVars', which must be initialised to NIL at appropriate
- * points before using these routines to check for valid patterns. This
- * mechanism enables the pattern checking routine to be mapped over a list
- * of patterns, ensuring that no variable occurs more than once in the
- * complete pattern list (as is required on the lhs of a function defn).
- * ------------------------------------------------------------------------*/
-
-static List patVars; /* List of vars bound in pattern */
-
-static Cell local checkPat(line,p) /* Check valid pattern syntax */
-Int line;
-Cell p; {
- switch (whatIs(p)) {
- case VARIDCELL :
- case VAROPCELL : addToPatVars(line,p);
- break;
-
- case INFIX : return checkPat(line,tidyInfix(line,snd(p)));
-
- case AP : return checkMaybeCnkPat(line,p);
-
- case NAME :
- case QUALIDENT :
- case CONIDCELL :
- case CONOPCELL : return checkApPat(line,0,p);
-
- case WILDCARD :
- case STRCELL :
- case CHARCELL :
- case FLOATCELL : break;
- case INTCELL : break;
-
- case ASPAT : addToPatVars(line,fst(snd(p)));
- snd(snd(p)) = checkPat(line,snd(snd(p)));
- break;
-
- case LAZYPAT : snd(p) = checkPat(line,snd(p));
- break;
-
- case FINLIST : map1Over(checkPat,line,snd(p));
- break;
-
- case CONFLDS : depConFlds(line,p,TRUE);
- break;
-
- case ESIGN : snd(snd(p)) = checkPatType(line,
- "pattern",
- fst(snd(p)),
- snd(snd(p)));
- fst(snd(p)) = checkPat(line,fst(snd(p)));
- break;
-
- default : ERRMSG(line) "Illegal pattern syntax"
- EEND;
- }
- return p;
-}
-
-static Cell local checkMaybeCnkPat(l,p)/* Check applicative pattern with */
-Int l; /* the possibility of n+k pattern */
-Cell p; {
- Cell h = getHead(p);
-
- if (argCount==2 && isVar(h) && textOf(h)==textPlus) { /* n+k */
- Cell v = arg(fun(p));
- if (!isInt(arg(p))) {
- ERRMSG(l) "Second argument in (n+k) pattern must be an integer"
- EEND;
- }
- if (intOf(arg(p))<=0) {
- ERRMSG(l) "Integer k in (n+k) pattern must be > 0"
- EEND;
- }
- fst(fun(p)) = ADDPAT;
- intValOf(fun(p)) = intOf(arg(p));
- arg(p) = checkPat(l,v);
- return p;
- }
- return checkApPat(l,0,p);
-}
-
-static Cell local checkApPat(line,args,p)
-Int line; /* check validity of application */
-Int args; /* of constructor to arguments */
-Cell p; {
- switch (whatIs(p)) {
- case AP : fun(p) = checkApPat(line,args+1,fun(p));
- arg(p) = checkPat(line,arg(p));
- break;
-
- case TUPLE : if (tupleOf(p)!=args) {
- ERRMSG(line) "Illegal tuple pattern"
- EEND;
- }
- break;
-
-#if TREX
- case EXT : h98DoesntSupport(line,"extensible records");
- if (args!=2) {
- ERRMSG(line) "Illegal record pattern"
- EEND;
- }
- break;
-#endif
-
- case QUALIDENT : if (!isQCon(p)) {
- ERRMSG(line)
- "Illegal use of qualified variable in pattern"
- EEND;
- }
- /* deliberate fall through */
- case CONIDCELL :
- case CONOPCELL : p = conDefined(line,p);
- checkCfunArgs(line,p,args);
- break;
-
- case NAME : checkIsCfun(line,p);
- checkCfunArgs(line,p,args);
- break;
-
- default : ERRMSG(line) "Illegal pattern syntax"
- EEND;
- }
- return p;
-}
-
-static Void local addToPatVars(line,v) /* Add variable v to list of vars */
-Int line; /* in current pattern, checking */
-Cell v; { /* for repeated variables. */
- Text t = textOf(v);
- List p = NIL;
- List n = patVars;
-
- for (; nonNull(n); p=n, n=tl(n)) {
- if (textOf(hd(n))==t) {
- ERRMSG(line) "Repeated variable \"%s\" in pattern",
- textToStr(t)
- EEND;
- }
- }
-
- if (isNull(p)) {
- patVars = cons(v,NIL);
- } else {
- tl(p) = cons(v,NIL);
- }
-}
-
-static Name local conDefined(line,nm) /* check that nm is the name of a */
-Int line; /* previously defined constructor */
-Cell nm; { /* function. */
- Name n = findQualName(nm);
- if (isNull(n)) {
- ERRMSG(line) "Undefined constructor function \"%s\"", identToStr(nm)
- EEND;
- }
- checkIsCfun(line,n);
- return n;
-}
-
-static Void local checkIsCfun(line,c) /* Check that c is a constructor fn */
-Int line;
-Name c; {
- if (!isCfun(c)) {
- ERRMSG(line) "\"%s\" is not a constructor function",
- textToStr(name(c).text)
- EEND;
- }
-}
-
-static Void local checkCfunArgs(line,c,args)
-Int line; /* Check constructor applied with */
-Cell c; /* correct number of arguments */
-Int args; {
- Int a = userArity(c);
- if (a!=args) {
- ERRMSG(line)
- "Constructor \"%s\" must have exactly %d argument%s in pattern",
- textToStr(name(c).text), a, ((a==1)?"":"s")
- EEND;
- }
-}
-
-static Cell local checkPatType(l,wh,e,t)/* Check type appearing in pattern */
-Int l;
-String wh;
-Cell e;
-Type t; {
- List tvs = typeVarsIn(t,NIL,NIL,NIL);
- h98DoesntSupport(l,"pattern type annotations");
- for (; nonNull(tvs); tvs=tl(tvs)) {
- Int beta = newKindvars(1);
- hd(btyvars) = cons(pair(hd(tvs),mkInt(beta)), hd(btyvars));
- }
- t = checkSigType(l,"pattern type",e,t);
- if (isPolyOrQualType(t) || whatIs(t)==RANK2) {
- ERRMSG(l) "Illegal syntax in %s type annotation", wh
- EEND;
- }
- return t;
-}
-
-static Cell local applyBtyvs(pat) /* Record bound type vars in pat */
-Cell pat; {
- List bts = hd(btyvars);
- leaveBtyvs();
- if (nonNull(bts)) {
- pat = ap(BIGLAM,pair(bts,pat));
- for (; nonNull(bts); bts=tl(bts)) {
- snd(hd(bts)) = copyKindvar(intOf(snd(hd(bts))));
- }
- }
- return pat;
-}
-
-/* --------------------------------------------------------------------------
- * Maintaining lists of bound variables and local definitions, for
- * dependency and scope analysis.
- * ------------------------------------------------------------------------*/
-
-static List bounds; /* list of lists of bound vars */
-static List bindings; /* list of lists of binds in scope */
-static List depends; /* list of lists of dependents */
-
-/* bounds :: [[Var]] -- var equality used on Vars */
-/* bindings :: [[([Var],?)]] -- var equality used on Vars */
-/* depends :: [[Var]] -- pointer equality used on Vars */
-
-#define saveBvars() hd(bounds) /* list of bvars in current scope */
-#define restoreBvars(bs) hd(bounds)=bs /* restore list of bound variables */
-
-static Cell local bindPat(line,p) /* add new bound vars for pattern */
-Int line;
-Cell p; {
- patVars = NIL;
- p = checkPat(line,p);
- hd(bounds) = revOnto(patVars,hd(bounds));
- return p;
-}
-
-static Void local bindPats(line,ps) /* add new bound vars for patterns */
-Int line;
-List ps; {
- patVars = NIL;
- map1Over(checkPat,line,ps);
- hd(bounds) = revOnto(patVars,hd(bounds));
-}
-
-/* --------------------------------------------------------------------------
- * Before processing value and type signature declarations, all data and
- * type definitions have been processed so that:
- * - all valid type constructors (with their arities) are known.
- * - all valid constructor functions (with their arities and types) are
- * known.
- *
- * The result of parsing a list of value declarations is a list of Eqns:
- * Eqn ::= (SIGDECL,(Line,[Var],type))
- * | (FIXDECL,(Line,[Op],SyntaxInt))
- * | (Expr,Rhs)
- * The ordering of the equations in this list is the reverse of the original
- * ordering in the script parsed. This is a consequence of the structure of
- * the parser ... but also turns out to be most convenient for the static
- * analysis.
- *
- * As the first stage of the static analysis of value declarations, each
- * list of Eqns is converted to a list of Bindings. As part of this
- * process:
- * - The ordering of the list of Bindings produced is the same as in the
- * original script.
- * - When a variable (function) is defined over a number of lines, all
- * of the definitions should appear together and each should give the
- * same arity to the variable being defined.
- * - No variable can have more than one definition.
- * - For pattern bindings:
- * - Each lhs is a valid pattern/function lhs, all constructor functions
- * have been defined and are used with the correct number of arguments.
- * - Each lhs contains no repeated pattern variables.
- * - Each equation defines at least one variable (e.g. True = False is
- * not allowed).
- * - Types appearing in type signatures are well formed:
- * - Type constructors used are defined and used with correct number
- * of arguments.
- * - type variables are replaced by offsets, type constructor names
- * by Tycons.
- * - Every variable named in a type signature declaration is defined by
- * one or more equations elsewhere in the script.
- * - No variable has more than one type declaration.
- * - Similar properties for fixity declarations.
- *
- * ------------------------------------------------------------------------*/
-
-#define bindingAttr(b) fst(snd(b)) /* type(s)/fixity(ies) for binding */
-#define fbindAlts(b) snd(snd(b)) /* alternatives for function binding*/
-
-static List local extractSigdecls(es) /* Extract the SIGDECLS from list */
-List es; { /* of equations */
- List sigdecls = NIL; /* :: [(Line,[Var],Type)] */
-
- for(; nonNull(es); es=tl(es)) {
- if (fst(hd(es))==SIGDECL) { /* type-declaration? */
- Pair sig = snd(hd(es));
- Int line = intOf(fst3(sig));
- List vs = snd3(sig);
- for(; nonNull(vs); vs=tl(vs)) {
- if (isQualIdent(hd(vs))) {
- ERRMSG(line) "Type signature for qualified variable \"%s\" is not allowed",
- identToStr(hd(vs))
- EEND;
- }
- }
- sigdecls = cons(sig,sigdecls); /* discard SIGDECL tag*/
- }
- }
- return sigdecls;
-}
-
-static List local extractFixdecls(es) /* Extract the FIXDECLS from list */
-List es; { /* of equations */
- List fixdecls = NIL; /* :: [(Line,SyntaxInt,[Op])] */
-
- for(; nonNull(es); es=tl(es)) {
- if (fst(hd(es))==FIXDECL) { /* fixity declaration?*/
- fixdecls = cons(snd(hd(es)),fixdecls); /* discard FIXDECL tag*/
- }
- }
- return fixdecls;
-}
-
-static List local extractBindings(ds) /* extract untyped bindings from */
-List ds; { /* given list of equations */
- Cell lastVar = NIL; /* = var def'd in last eqn (if any)*/
- Int lastArity = 0; /* = number of args in last defn */
- List bs = NIL; /* :: [Binding] */
-
- for(; nonNull(ds); ds=tl(ds)) {
- Cell d = hd(ds);
- if (fst(d)==FUNBIND) { /* Function bindings */
- Cell rhs = snd(snd(d));
- Int line = rhsLine(rhs);
- Cell lhs = fst(snd(d));
- Cell v = getHead(lhs);
- Cell newAlt = pair(getArgs(lhs),rhs);
- if (!isVar(v)) {
- internal("FUNBIND");
- }
- if (nonNull(lastVar) && textOf(v)==textOf(lastVar)) {
- if (argCount!=lastArity) {
- ERRMSG(line) "Equations give different arities for \"%s\"",
- textToStr(textOf(v))
- EEND;
- }
- fbindAlts(hd(bs)) = cons(newAlt,fbindAlts(hd(bs)));
- }
- else {
- lastVar = v;
- lastArity = argCount;
- notDefined(line,bs,v);
- bs = cons(pair(v,pair(NIL,singleton(newAlt))),bs);
- }
-
- } else if (fst(d)==PATBIND) { /* Pattern bindings */
- Cell rhs = snd(snd(d));
- Int line = rhsLine(rhs);
- Cell pat = fst(snd(d));
- while (whatIs(pat)==ESIGN) {/* Move type annotations to rhs */
- Cell p = fst(snd(pat));
- fst(snd(pat)) = rhs;
- snd(snd(d)) = rhs = pat;
- fst(snd(d)) = pat = p;
- fst(rhs) = RSIGN;
- }
- if (isVar(pat)) { /* Convert simple pattern bind to */
- notDefined(line,bs,pat);/* a function binding */
- bs = cons(pair(pat,pair(NIL,singleton(pair(NIL,rhs)))),bs);
- } else {
- List vs = getPatVars(line,pat,NIL);
- if (isNull(vs)) {
- ERRMSG(line) "No variables defined in lhs pattern"
- EEND;
- }
- map2Proc(notDefined,line,bs,vs);
- bs = cons(pair(vs,pair(NIL,snd(d))),bs);
- }
- lastVar = NIL;
- }
- }
- return bs;
-}
-
-static List local getPatVars(line,p,vs) /* Find list of variables bound in */
-Int line; /* pattern p */
-Cell p;
-List vs; {
- switch (whatIs(p)) {
- case AP : do {
- vs = getPatVars(line,arg(p),vs);
- p = fun(p);
- } while (isAp(p));
- return vs; /* Ignore head of application */
-
- case CONFLDS : { List pfs = snd(snd(p));
- for (; nonNull(pfs); pfs=tl(pfs)) {
- if (isVar(hd(pfs))) {
- vs = addPatVar(line,hd(pfs),vs);
- } else {
- vs = getPatVars(line,snd(hd(pfs)),vs);
- }
- }
- }
- return vs;
-
- case FINLIST : { List ps = snd(p);
- for (; nonNull(ps); ps=tl(ps)) {
- vs = getPatVars(line,hd(ps),vs);
- }
- }
- return vs;
-
- case ESIGN : return getPatVars(line,fst(snd(p)),vs);
-
- case LAZYPAT :
- case NEG :
- case ONLY :
- case INFIX : return getPatVars(line,snd(p),vs);
-
- case ASPAT : return addPatVar(line,fst(snd(p)),
- getPatVars(line,snd(snd(p)),vs));
-
- case VARIDCELL :
- case VAROPCELL : return addPatVar(line,p,vs);
-
- case CONIDCELL :
- case CONOPCELL :
- case QUALIDENT :
- case INTCELL :
- case FLOATCELL :
- case CHARCELL :
- case STRCELL :
- case NAME :
- case WILDCARD : return vs;
-
- default : internal("getPatVars");
- }
- return vs;
-}
-
-static List local addPatVar(line,v,vs) /* Add var to list of previously */
-Int line; /* encountered variables */
-Cell v;
-List vs; {
- if (varIsMember(textOf(v),vs)) {
- ERRMSG(line) "Repeated use of variable \"%s\" in pattern binding",
- textToStr(textOf(v))
- EEND;
- }
- return cons(v,vs);
-}
-
-static List local eqnsToBindings(es,ts,cs,ps)
-List es; /* Convert list of equations to */
-List ts; /* list of typed bindings */
-List cs;
-List ps; {
- List bs = extractBindings(es);
- map1Proc(addSigdecl,bs,extractSigdecls(es));
- map4Proc(addFixdecl,bs,ts,cs,ps,extractFixdecls(es));
- return bs;
-}
-
-static Void local notDefined(line,bs,v)/* check if name already defined in */
-Int line; /* list of bindings */
-List bs;
-Cell v; {
- if (nonNull(findBinding(textOf(v),bs))) {
- ERRMSG(line) "\"%s\" multiply defined", textToStr(textOf(v))
- EEND;
- }
-}
-
-static Cell local findBinding(t,bs) /* look for binding for variable t */
-Text t; /* in list of bindings bs */
-List bs; {
- for (; nonNull(bs); bs=tl(bs)) {
- if (isVar(fst(hd(bs)))) { /* function-binding? */
- if (textOf(fst(hd(bs)))==t) {
- return hd(bs);
- }
- } else if (nonNull(varIsMember(t,fst(hd(bs))))){/* pattern-binding?*/
- return hd(bs);
- }
- }
- return NIL;
-}
-
-static Cell local getAttr(bs,v) /* Locate type/fixity attribute */
-List bs; /* for variable v in bindings bs */
-Cell v; {
- Text t = textOf(v);
- Cell b = findBinding(t,bs);
-
- if (isNull(b)) { /* No binding */
- return NIL;
- } else if (isVar(fst(b))) { /* func binding? */
- if (isNull(bindingAttr(b))) {
- bindingAttr(b) = pair(NIL,NIL);
- }
- return bindingAttr(b);
- } else { /* pat binding? */
- List vs = fst(b);
- List as = bindingAttr(b);
-
- if (isNull(as)) {
- bindingAttr(b) = as = replicate(length(vs),NIL);
- }
-
- while (nonNull(vs) && t!=textOf(hd(vs))) {
- vs = tl(vs);
- as = tl(as);
- }
-
- if (isNull(vs)) {
- internal("getAttr");
- } else if (isNull(hd(as))) {
- hd(as) = pair(NIL,NIL);
- }
- return hd(as);
- }
-}
-
-static Void local addSigdecl(bs,sigdecl)/* add type information to bindings*/
-List bs; /* :: [Binding] */
-Cell sigdecl; { /* :: (Line,[Var],Type) */
- Int l = intOf(fst3(sigdecl));
- List vs = snd3(sigdecl);
- Type type = checkSigType(l,"type declaration",hd(vs),thd3(sigdecl));
-
- for (; nonNull(vs); vs=tl(vs)) {
- Cell v = hd(vs);
- Pair attr = getAttr(bs,v);
- if (isNull(attr)) {
- ERRMSG(l) "Missing binding for variable \"%s\" in type signature",
- textToStr(textOf(v))
- EEND;
- } else if (nonNull(fst(attr))) {
- ERRMSG(l) "Repeated type signature for \"%s\"",
- textToStr(textOf(v))
- EEND;
- }
- fst(attr) = type;
- }
-}
-
-static Void local addFixdecl(bs,ts,cs,ps,fixdecl)
-List bs;
-List ts;
-List cs;
-List ps;
-Triple fixdecl; {
- Int line = intOf(fst3(fixdecl));
- List ops = snd3(fixdecl);
- Cell sy = thd3(fixdecl);
-
- for (; nonNull(ops); ops=tl(ops)) {
- Cell op = hd(ops);
- Text t = textOf(op);
- Cell attr = getAttr(bs,op);
- if (nonNull(attr)) { /* Found name in binding? */
- if (nonNull(snd(attr))) {
- dupFixity(line,t);
- }
- snd(attr) = sy;
- } else { /* Look in tycons, classes, prims */
- Name n = NIL;
- List ts1 = ts;
- List cs1 = cs;
- List ps1 = ps;
- for (; isNull(n) && nonNull(ts1); ts1=tl(ts1)) { /* tycons */
- Tycon tc = hd(ts1);
- if (tycon(tc).what==DATATYPE || tycon(tc).what==NEWTYPE) {
- n = nameIsMember(t,tycon(tc).defn);
- }
- }
- for (; isNull(n) && nonNull(cs1); cs1=tl(cs1)) { /* classes */
- n = nameIsMember(t,cclass(hd(cs1)).members);
- }
- for (; isNull(n) && nonNull(ps1); ps1=tl(ps1)) { /* prims */
- n = nameIsMember(t,hd(ps1));
- }
-
- if (isNull(n)) {
- missFixity(line,t);
- } else if (name(n).syntax!=NO_SYNTAX) {
- dupFixity(line,t);
- }
- name(n).syntax = intOf(sy);
- }
- }
-}
-
-static Void local dupFixity(line,t) /* Report repeated fixity decl */
-Int line;
-Text t; {
- ERRMSG(line)
- "Repeated fixity declaration for operator \"%s\"", textToStr(t)
- EEND;
-}
-
-static Void local missFixity(line,t) /* Report missing op for fixity */
-Int line;
-Text t; {
- ERRMSG(line)
- "Cannot find binding for operator \"%s\" in fixity declaration",
- textToStr(t)
- EEND;
-}
-
-/* --------------------------------------------------------------------------
- * Dealing with infix operators:
- *
- * Expressions involving infix operators or unary minus are parsed as
- * elements of the following type:
- *
- * data InfixExp = Only Exp | Neg InfixExp | Infix InfixExp Op Exp
- *
- * (The algorithms here do not assume that negation can be applied only once,
- * i.e., that - - x is a syntax error, as required by the Haskell report.
- * Instead, that restriction is captured by the grammar itself, given above.)
- *
- * There are rules of precedence and grouping, expressed by two functions:
- *
- * prec :: Op -> Int; assoc :: Op -> Assoc (Assoc = {L, N, R})
- *
- * InfixExp values are rearranged accordingly when a complete expression
- * has been read using a simple shift-reduce parser whose result may be taken
- * to be a value of the following type:
- *
- * data Exp = Atom Int | Negate Exp | Apply Op Exp Exp | Error String
- *
- * The machine on which this parser is based can be defined as follows:
- *
- * tidy :: InfixExp -> [(Op,Exp)] -> Exp
- * tidy (Only a) [] = a
- * tidy (Only a) ((o,b):ss) = tidy (Only (Apply o a b)) ss
- * tidy (Infix a o b) [] = tidy a [(o,b)]
- * tidy (Infix a o b) ((p,c):ss)
- * | shift o p = tidy a ((o,b):(p,c):ss)
- * | red o p = tidy (Infix a o (Apply p b c)) ss
- * | ambig o p = Error "ambiguous use of operators"
- * tidy (Neg e) [] = tidy (tidyNeg e) []
- * tidy (Neg e) ((o,b):ss)
- * | nshift o = tidy (Neg (underNeg o b e)) ss
- * | nred o = tidy (tidyNeg e) ((o,b):ss)
- * | nambig o = Error "illegal use of negation"
- *
- * At each stage, the parser can either shift, reduce, accept, or error.
- * The transitions when dealing with juxtaposed operators o and p are
- * determined by the following rules:
- *
- * shift o p = (prec o > prec p)
- * || (prec o == prec p && assoc o == L && assoc p == L)
- *
- * red o p = (prec o < prec p)
- * || (prec o == prec p && assoc o == R && assoc p == R)
- *
- * ambig o p = (prec o == prec p)
- * && (assoc o == N || assoc p == N || assoc o /= assoc p)
- *
- * The transitions when dealing with juxtaposed unary minus and infix
- * operators are as follows. The precedence of unary minus (infixl 6) is
- * hardwired in to these definitions, as it is to the definitions of the
- * Haskell grammar in the official report.
- *
- * nshift o = (prec o > 6)
- * nred o = (prec o < 6) || (prec o == 6 && assoc o == L)
- * nambig o = prec o == 6 && (assoc o == R || assoc o == N)
- *
- * An InfixExp of the form (Neg e) means negate the last thing in
- * the InfixExp e; we can force this negation using:
- *
- * tidyNeg :: OpExp -> OpExp
- * tidyNeg (Only e) = Only (Negate e)
- * tidyNeg (Infix a o b) = Infix a o (Negate b)
- * tidyNeg (Neg e) = tidyNeg (tidyNeg e)
- *
- * On the other hand, if we want to sneak application of an infix operator
- * under a negation, then we use:
- *
- * underNeg :: Op -> Exp -> OpExp -> OpExp
- * underNeg o b (Only e) = Only (Apply o e b)
- * underNeg o b (Neg e) = Neg (underNeg o b e)
- * underNeg o b (Infix e p f) = Infix e p (Apply o f b)
- *
- * As a concession to efficiency, we lower the number of calls to syntaxOf
- * by keeping track of the values of sye, sys throughout the process. The
- * value APPLIC is used to indicate that the syntax value is unknown.
- * ------------------------------------------------------------------------*/
-
-static Cell local tidyInfix(line,e) /* Convert infixExp to Exp */
-Int line;
-Cell e; { /* :: OpExp */
- Cell s = NIL; /* :: [(Op,Exp)] */
- Syntax sye = APPLIC; /* Syntax of op in e (init unknown)*/
- Syntax sys = APPLIC; /* Syntax of op in s (init unknown)*/
- Cell d = e;
-
- while (fst(d)!=ONLY) { /* Attach fixities to operators */
- if (fst(d)==NEG) {
- d = snd(d);
- } else {
- fun(fun(d)) = attachFixity(line,fun(fun(d)));
- d = arg(fun(d));
- }
- }
-
- for (;;)
- switch (whatIs(e)) {
- case ONLY : e = snd(e);
- while (nonNull(s)) {
- Cell next = arg(fun(s));
- arg(fun(s)) = e;
- fun(fun(s)) = snd(fun(fun(s)));
- e = s;
- s = next;
- }
- return e;
-
- case NEG : if (nonNull(s)) {
- if (sys==APPLIC) { /* calculate sys */
- sys = intOf(fst(fun(fun(s))));
- }
-
- if (precOf(sys)==UMINUS_PREC && /* nambig */
- assocOf(sys)!=UMINUS_ASSOC) {
- ERRMSG(line)
- "Ambiguous use of unary minus with \""
- ETHEN ERREXPR(snd(fun(fun(s))));
- ERRTEXT "\""
- EEND;
- }
-
- if (precOf(sys)>UMINUS_PREC) { /* nshift */
- Cell e1 = snd(e);
- Cell t = s;
- s = arg(fun(s));
- while (whatIs(e1)==NEG)
- e1 = snd(e1);
- arg(fun(t)) = arg(e1);
- fun(fun(t)) = snd(fun(fun(t)));
- arg(e1) = t;
- sys = APPLIC;
- continue;
- }
- }
-
- /* Intentional fall-thru for nreduce and isNull(s) */
-
- { Cell prev = e; /* e := tidyNeg e */
- Cell temp = arg(prev);
- Int nneg = 1;
- for (; whatIs(temp)==NEG; nneg++) {
- fun(prev) = nameNegate;
- prev = temp;
- temp = arg(prev);
- }
- if (isInt(arg(temp))) { /* special cases */
- if (nneg&1) /* for literals */
- arg(temp) = mkInt(-intOf(arg(temp)));
- }
- else if (isFloat(arg(temp))) {
- if (nneg&1)
- arg(temp) = floatNegate(arg(temp));
- //mkFloat(-floatOf(arg(temp)));
- }
- else {
- fun(prev) = nameNegate;
- arg(prev) = arg(temp);
- arg(temp) = e;
- }
- e = temp;
- }
- continue;
-
- default : if (isNull(s)) {/* Move operation onto empty stack */
- Cell next = arg(fun(e));
- s = e;
- arg(fun(s)) = NIL;
- e = next;
- sys = sye;
- sye = APPLIC;
- }
- else { /* deal with pair of operators */
-
- if (sye==APPLIC) { /* calculate sys and sye */
- sye = intOf(fst(fun(fun(e))));
- }
- if (sys==APPLIC) {
- sys = intOf(fst(fun(fun(s))));
- }
-
- if (precOf(sye)==precOf(sys) && /* ambig */
- (assocOf(sye)!=assocOf(sys) ||
- assocOf(sye)==NON_ASS)) {
- ERRMSG(line) "Ambiguous use of operator \""
- ETHEN ERREXPR(snd(fun(fun(e))));
- ERRTEXT "\" with \""
- ETHEN ERREXPR(snd(fun(fun(s))));
- ERRTEXT "\""
- EEND;
- }
-
- if (precOf(sye)>precOf(sys) || /* shift */
- (precOf(sye)==precOf(sys) &&
- assocOf(sye)==LEFT_ASS &&
- assocOf(sys)==LEFT_ASS)) {
- Cell next = arg(fun(e));
- arg(fun(e)) = s;
- s = e;
- e = next;
- sys = sye;
- sye = APPLIC;
- }
- else { /* reduce */
- Cell next = arg(fun(s));
- arg(fun(s)) = arg(e);
- fun(fun(s)) = snd(fun(fun(s)));
- arg(e) = s;
- s = next;
- sys = APPLIC;
- /* sye unchanged */
- }
- }
- continue;
- }
-}
-
-static Pair local attachFixity(line,op) /* Attach fixity to operator in an */
-Int line; /* infix expression */
-Cell op; {
- Syntax sy = DEF_OPSYNTAX;
-
- switch (whatIs(op)) {
- case VAROPCELL :
- case VARIDCELL : if ((sy=lookupSyntax(textOf(op)))==NO_SYNTAX) {
- Name n = findName(textOf(op));
- if (isNull(n)) {
- ERRMSG(line) "Undefined variable \"%s\"",
- textToStr(textOf(op))
- EEND;
- }
- sy = syntaxOf(n);
- op = n;
- }
- break;
-
- case CONOPCELL :
- case CONIDCELL : sy = syntaxOf(op = conDefined(line,op));
- break;
-
- case QUALIDENT : { Name n = findQualName(op);
- if (nonNull(n)) {
- op = n;
- sy = syntaxOf(n);
- } else {
- ERRMSG(line)
- "Undefined qualified variable \"%s\"",
- identToStr(op)
- EEND;
- }
- }
- break;
- }
- if (sy==APPLIC) {
- sy = DEF_OPSYNTAX;
- }
- return pair(mkInt(sy),op); /* Pair fixity with (possibly) */
- /* translated operator */
-}
-
-static Syntax local lookupSyntax(t) /* Try to find fixity for var in */
-Text t; { /* enclosing bindings */
- List bounds1 = bounds;
- List bindings1 = bindings;
-
- while (nonNull(bindings1)) {
- if (nonNull(varIsMember(t,hd(bounds1)))) {
- return DEF_OPSYNTAX;
- } else {
- Cell b = findBinding(t,hd(bindings1));
- if (nonNull(b)) {
- Cell a = fst(snd(b));
- if (isVar(fst(b))) { /* Function binding */
- if (nonNull(a) && nonNull(snd(a))) {
- return intOf(snd(a));
- }
- } else { /* Pattern binding */
- List vs = fst(b);
- while (nonNull(vs) && nonNull(a)) {
- if (t==textOf(hd(vs))) {
- if (nonNull(hd(a)) && isInt(snd(hd(a)))) {
- return intOf(snd(hd(a)));
- }
- break;
- }
- vs = tl(vs);
- a = tl(a);
- }
- }
- return DEF_OPSYNTAX;
- }
- }
- bounds1 = tl(bounds1);
- bindings1 = tl(bindings1);
- }
- return NO_SYNTAX;
-}
-
-/* --------------------------------------------------------------------------
- * To facilitate dependency analysis, lists of bindings are temporarily
- * augmented with an additional field, which is used in two ways:
- * - to build the `adjacency lists' for the dependency graph. Represented by
- * a list of pointers to other bindings in the same list of bindings.
- * - to hold strictly positive integer values (depth first search numbers) of
- * elements `on the stack' during the strongly connected components search
- * algorithm, or a special value mkInt(0), once the binding has been added
- * to a particular strongly connected component.
- *
- * Using this extra field, the type of each list of declarations during
- * dependency analysis is [Binding'] where:
- *
- * Binding' ::= (Var, (Attr, (Dep, [Alt]))) -- function binding
- * | ([Var], ([Attr], (Dep, (Pat,Rhs)))) -- pattern binding
- *
- * ------------------------------------------------------------------------*/
-
-#define depVal(d) (fst(snd(snd(d)))) /* Access to dependency information*/
-
-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*/
- mapProc(remDepField,bs); /* remove dependency info field */
- return bs;
-}
-
-static List local topDependAnal(bs) /* Like dependencyAnal(), but at */
-List bs; { /* top level, reporting on progress*/
- List xs;
- Int i = 0;
-
- setGoal("Dependency analysis",(Target)(length(bs)));
-
- mapProc(addDepField,bs); /* add extra field for dependents */
- for (xs=bs; nonNull(xs); xs=tl(xs)) {
- emptySubstitution();
- depBinding(hd(xs));
- soFar((Target)(i++));
- }
- bs = bscc(bs); /* sort to strongly connected comps */
- mapProc(remDepField,bs); /* remove dependency info field */
- done();
- return bs;
-}
-
-static Void local addDepField(b) /* add extra field to binding to */
-Cell b; { /* hold list of dependents */
- snd(snd(b)) = pair(NIL,snd(snd(b)));
-}
-
-static Void local remDepField(bs) /* remove dependency field from */
-List bs; { /* list of bindings */
- mapProc(remDepField1,bs);
-}
-
-static Void local remDepField1(b) /* remove dependency field from */
-Cell b; { /* single binding */
- snd(snd(b)) = snd(snd(snd(b)));
-}
-
-static Void local clearScope() { /* initialise dependency scoping */
- bounds = NIL;
- bindings = NIL;
- depends = NIL;
-}
-
-static Void local withinScope(bs) /* Enter scope of bindings bs */
-List bs; {
- bounds = cons(NIL,bounds);
- bindings = cons(bs,bindings);
- depends = cons(NIL,depends);
-}
-
-static Void local leaveScope() { /* Leave scope of last withinScope */
- List bs = hd(bindings); /* Remove fixity info from binds */
- Bool toplevel = isNull(tl(bindings));
- for (; nonNull(bs); bs=tl(bs)) {
- Cell b = hd(bs);
- if (isVar(fst(b))) { /* Variable binding */
- Cell a = fst(snd(b));
- if (isPair(a)) {
- if (toplevel) {
- saveSyntax(fst(b),snd(a));
- }
- fst(snd(b)) = fst(a);
- }
- } else { /* Pattern binding */
- List vs = fst(b);
- List as = fst(snd(b));
- while (nonNull(vs) && nonNull(as)) {
- if (isPair(hd(as))) {
- if (toplevel) {
- saveSyntax(hd(vs),snd(hd(as)));
- }
- hd(as) = fst(hd(as));
- }
- vs = tl(vs);
- as = tl(as);
- }
- }
- }
- bounds = tl(bounds);
- bindings = tl(bindings);
- depends = tl(depends);
-}
-
-static Void local saveSyntax(v,sy) /* Save syntax of top-level var */
-Cell v; /* in corresponding Name */
-Cell sy; {
- Name n = findName(textOf(v));
- if (isNull(n) || name(n).syntax!=NO_SYNTAX) {
- internal("saveSyntax");
- }
- if (nonNull(sy)) {
- name(n).syntax = intOf(sy);
- }
-}
-
-/* --------------------------------------------------------------------------
- * As a side effect of the dependency analysis we also make the following
- * checks:
- * - Each lhs is a valid pattern/function lhs, all constructor functions
- * have been defined and are used with the correct number of arguments.
- * - No lhs contains repeated pattern variables.
- * - Expressions used on the rhs of an eqn should be well formed. This
- * includes:
- * - Checking for valid patterns (including repeated vars) in lambda,
- * case, and list comprehension expressions.
- * - Recursively checking local lists of equations.
- * - No free (i.e. unbound) variables are used in the declaration list.
- * ------------------------------------------------------------------------*/
-
-static Void local depBinding(b) /* find dependents of binding */
-Cell b; {
- Cell defpart = snd(snd(snd(b))); /* definition part of binding */
-
- hd(depends) = NIL;
-
- if (isVar(fst(b))) { /* function-binding? */
- mapProc(depAlt,defpart);
- if (isNull(fst(snd(b)))) { /* Save dep info if no type sig */
- fst(snd(b)) = pair(ap(IMPDEPS,hd(depends)),NIL);
- } else if (isNull(fst(fst(snd(b))))) {
- fst(fst(snd(b))) = ap(IMPDEPS,hd(depends));
- }
- } else { /* pattern-binding? */
- Int line = rhsLine(snd(defpart));
- enterBtyvs();
- patVars = NIL;
- fst(defpart) = checkPat(line,fst(defpart));
- depRhs(snd(defpart));
-#if 0
- if (nonNull(hd(btyvars))) {
- ERRMSG(line)
- "Sorry, no type variables are allowed in pattern binding type annotations"
- EEND;
- }
-#endif
- fst(defpart) = applyBtyvs(fst(defpart));
- }
- depVal(b) = hd(depends);
-}
-
-static Void local depDefaults(c) /* dependency analysis on defaults */
-Class c; { /* from class definition */
- depClassBindings(cclass(c).defaults);
-}
-
-static Void local depInsts(in) /* dependency analysis on instance */
-Inst in; { /* bindings */
- depClassBindings(inst(in).implements);
-}
-
-static Void local depClassBindings(bs) /* dependency analysis on list of */
-List bs; { /* bindings, possibly containing */
- for (; nonNull(bs); bs=tl(bs)) { /* NIL bindings ... */
- if (nonNull(hd(bs))) { /* No need to add extra field for */
- mapProc(depAlt,snd(hd(bs)));/* dependency information... */
- }
- }
-}
-
-static Void local depAlt(a) /* Find dependents of alternative */
-Cell a; {
- List obvs = saveBvars(); /* Save list of bound variables */
- enterBtyvs();
- bindPats(rhsLine(snd(a)),fst(a)); /* add new bound vars for patterns */
- depRhs(snd(a)); /* find dependents of rhs */
- fst(a) = applyBtyvs(fst(a));
- restoreBvars(obvs); /* restore original list of bvars */
-}
-
-static Void local depRhs(r) /* Find dependents of rhs */
-Cell r; {
- switch (whatIs(r)) {
- case GUARDED : mapProc(depGuard,snd(r));
- break;
-
- case LETREC : fst(snd(r)) = eqnsToBindings(fst(snd(r)),NIL,NIL,NIL);
- withinScope(fst(snd(r)));
- fst(snd(r)) = dependencyAnal(fst(snd(r)));
- hd(depends) = fst(snd(r));
- depRhs(snd(snd(r)));
- leaveScope();
- break;
-
- case RSIGN : snd(snd(r)) = checkPatType(rhsLine(fst(snd(r))),
- "result",
- rhsExpr(fst(snd(r))),
- snd(snd(r)));
- depRhs(fst(snd(r)));
- break;
-
- default : snd(r) = depExpr(intOf(fst(r)),snd(r));
- break;
- }
-}
-
-static Void local depGuard(g) /* find dependents of single guarded*/
-Cell g; { /* expression */
- depPair(intOf(fst(g)),snd(g));
-}
-
-static Cell local depExpr(line,e) /* find dependents of expression */
-Int line;
-Cell e; {
- //Printf( "\n\n"); print(e,100); Printf("\n");
- //printExp(stdout,e);
- switch (whatIs(e)) {
-
- case VARIDCELL :
- case VAROPCELL : return depVar(line,e);
-
- case CONIDCELL :
- case CONOPCELL : return conDefined(line,e);
-
- case QUALIDENT : if (isQVar(e)) {
- return depQVar(line,e);
- } else { /* QConOrConOp */
- return conDefined(line,e);
- }
-
- case INFIX : return depExpr(line,tidyInfix(line,snd(e)));
-
-#if TREX
- case RECSEL : break;
-
- case AP : if (isAp(e) && isAp(fun(e)) && isExt(fun(fun(e)))) {
- return depRecord(line,e);
- } else {
- Cell nx = e;
- Cell a;
- do {
- a = nx;
- arg(a) = depExpr(line,arg(a));
- nx = fun(a);
- } while (isAp(nx));
- fun(a) = depExpr(line,fun(a));
- }
- break;
-#else
- case AP : depPair(line,e);
- break;
-#endif
-
-#if IPARAM
- case IPVAR :
-#endif
-
- case NAME :
- case TUPLE :
- case STRCELL :
- case CHARCELL :
- case FLOATCELL :
- case BIGCELL :
- case INTCELL : break;
-
- case COND : depTriple(line,snd(e));
- break;
-
- case FINLIST : map1Over(depExpr,line,snd(e));
- break;
-
- case LETREC : fst(snd(e)) = eqnsToBindings(fst(snd(e)),NIL,NIL,NIL);
- withinScope(fst(snd(e)));
- fst(snd(e)) = dependencyAnal(fst(snd(e)));
- hd(depends) = fst(snd(e));
- snd(snd(e)) = depExpr(line,snd(snd(e)));
- leaveScope();
- break;
-
- case LAMBDA : depAlt(snd(e));
- break;
-
- case DOCOMP : /* fall-thru */
- case COMP : depComp(line,snd(e),snd(snd(e)));
- break;
-
- case ESIGN : fst(snd(e)) = depExpr(line,fst(snd(e)));
- snd(snd(e)) = checkSigType(line,
- "expression",
- fst(snd(e)),
- snd(snd(e)));
- break;
-
- case CASE : fst(snd(e)) = depExpr(line,fst(snd(e)));
- map1Proc(depCaseAlt,line,snd(snd(e)));
- break;
-
- case CONFLDS : depConFlds(line,e,FALSE);
- break;
-
- case UPDFLDS : depUpdFlds(line,e);
- break;
-
-#if IPARAM
- case WITHEXP : depWith(line,e);
- break;
-#endif
-
- case ASPAT : ERRMSG(line) "Illegal `@' in expression"
- EEND;
-
- case LAZYPAT : ERRMSG(line) "Illegal `~' in expression"
- EEND;
-
- case WILDCARD : ERRMSG(line) "Illegal `_' in expression"
- EEND;
-
-#if TREX
- case EXT : ERRMSG(line) "Illegal application of record"
- EEND;
-#endif
-
- default : internal("depExpr");
- }
- return e;
-}
-
-static Void local depPair(line,e) /* find dependents of pair of exprs*/
-Int line;
-Cell e; {
- fst(e) = depExpr(line,fst(e));
- snd(e) = depExpr(line,snd(e));
-}
-
-static Void local depTriple(line,e) /* find dependents of triple exprs */
-Int line;
-Cell e; {
- fst3(e) = depExpr(line,fst3(e));
- snd3(e) = depExpr(line,snd3(e));
- thd3(e) = depExpr(line,thd3(e));
-}
-
-static Void local depComp(l,e,qs) /* find dependents of comprehension*/
-Int l;
-Cell e;
-List qs; {
- if (isNull(qs)) {
- fst(e) = depExpr(l,fst(e));
- } else {
- Cell q = hd(qs);
- List qs1 = tl(qs);
- switch (whatIs(q)) {
- case FROMQUAL : { List obvs = saveBvars();
- snd(snd(q)) = depExpr(l,snd(snd(q)));
- enterBtyvs();
- fst(snd(q)) = bindPat(l,fst(snd(q)));
- depComp(l,e,qs1);
- fst(snd(q)) = applyBtyvs(fst(snd(q)));
- restoreBvars(obvs);
- }
- break;
-
- case QWHERE : snd(q) = eqnsToBindings(snd(q),NIL,NIL,NIL);
- withinScope(snd(q));
- snd(q) = dependencyAnal(snd(q));
- hd(depends) = snd(q);
- depComp(l,e,qs1);
- leaveScope();
- break;
-
- case DOQUAL : /* fall-thru */
- case BOOLQUAL : snd(q) = depExpr(l,snd(q));
- depComp(l,e,qs1);
- break;
- }
- }
-}
-
-static Void local depCaseAlt(line,a) /* Find dependents of case altern. */
-Int line;
-Cell a; {
- List obvs = saveBvars(); /* Save list of bound variables */
- enterBtyvs();
- fst(a) = bindPat(line,fst(a)); /* Add new bound vars for pats */
- depRhs(snd(a)); /* Find dependents of rhs */
- fst(a) = applyBtyvs(fst(a));
- restoreBvars(obvs); /* Restore original list of bvars */
-}
-
-static Cell local depVar(line,e) /* Register occurrence of variable */
-Int line;
-Cell e; {
- List bounds1 = bounds;
- List bindings1 = bindings;
- List depends1 = depends;
- Text t = textOf(e);
- Cell n;
-
- while (nonNull(bindings1)) {
- n = varIsMember(t,hd(bounds1)); /* look for t in bound variables */
- if (nonNull(n)) {
- return n;
- }
- n = findBinding(t,hd(bindings1)); /* look for t in var bindings */
- if (nonNull(n)) {
- if (!cellIsMember(n,hd(depends1))) {
- hd(depends1) = cons(n,hd(depends1));
- }
- return (isVar(fst(n)) ? fst(n) : e);
- }
-
- bounds1 = tl(bounds1);
- bindings1 = tl(bindings1);
- depends1 = tl(depends1);
- }
-
- if (isNull(n=findName(t))) { /* check global definitions */
- ERRMSG(line) "Undefined variable \"%s\"", textToStr(t)
- EEND;
- }
-
- /* Later phases of the system cannot cope if we resolve references
- * to unprocessed objects too early. This is the main reason that
- * we cannot cope with recursive modules at the moment.
- */
- return e;
-}
-
-static Cell local depQVar(line,e)/* register occurrence of qualified variable */
-Int line;
-Cell e; {
- Name n = findQualName(e);
- if (isNull(n)) { /* check global definitions */
- ERRMSG(line) "Undefined qualified variable \"%s\"", identToStr(e)
- EEND;
- }
- if (name(n).mod != currentModule) {
- return n;
- }
- if (fst(e) == VARIDCELL) {
- e = mkVar(qtextOf(e));
- } else {
- e = mkVarop(qtextOf(e));
- }
- return depVar(line,e);
-}
-
-static Void local depConFlds(line,e,isP)/* check construction using fields */
-Int line;
-Cell e;
-Bool isP; {
- Name c = conDefined(line,fst(snd(e)));
- if (isNull(snd(snd(e))) ||
- nonNull(cellIsMember(c,depFields(line,e,snd(snd(e)),isP)))) {
- fst(snd(e)) = c;
- } else {
- ERRMSG(line) "Constructor \"%s\" does not have selected fields in ",
- textToStr(name(c).text)
- ETHEN ERREXPR(e);
- ERRTEXT "\n"
- EEND;
- }
- if (!isP && isPair(name(c).defn)) { /* Check that banged fields defined*/
- List scs = fst(name(c).defn); /* List of strict components */
- Type t = name(c).type;
- Int a = userArity(c);
- List fs = snd(snd(e));
- List ss;
- if (isPolyType(t)) { /* Find tycon that c belongs to */
- t = monotypeOf(t);
- }
- if (isQualType(t)) {
- t = snd(snd(t));
- }
- if (whatIs(t)==CDICTS) {
- t = snd(snd(t));
- }
- while (0<a--) {
- t = arg(t);
- }
- while (isAp(t)) {
- t = fun(t);
- }
- for (ss=tycon(t).defn; hasCfun(ss); ss=tl(ss)) {
- }
- /* Now we know the tycon t that c belongs to, and the corresponding
- * list of selectors for that type, ss. Now we have to check that
- * each of the fields identified by scs appears in fs, using ss to
- * cross reference, and convert integers to selector names.
- */
- for (; nonNull(scs); scs=tl(scs)) {
- Int i = intOf(hd(scs));
- List ss1 = ss;
- for (; nonNull(ss1); ss1=tl(ss1)) {
- List cns = name(hd(ss1)).defn;
- for (; nonNull(cns); cns=tl(cns)) {
- if (fst(hd(cns))==c) {
- break;
- }
- }
- if (nonNull(cns) && intOf(snd(hd(cns)))==i) {
- break;
- }
- }
- if (isNull(ss1)) {
- internal("depConFlds");
- } else {
- Name s = hd(ss1);
- List fs1 = fs;
- for (; nonNull(fs1) && s!=fst(hd(fs1)); fs1=tl(fs1)) {
- }
- if (isNull(fs1)) {
- ERRMSG(line) "Construction does not define strict field"
- ETHEN
- ERRTEXT "\nExpression : " ETHEN ERREXPR(e);
- ERRTEXT "\nField : " ETHEN ERREXPR(s);
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- }
-}
-
-static Void local depUpdFlds(line,e) /* check update using fields */
-Int line;
-Cell e; {
- if (isNull(thd3(snd(e)))) {
- ERRMSG(line) "Empty field list in update"
- EEND;
- }
- fst3(snd(e)) = depExpr(line,fst3(snd(e)));
- snd3(snd(e)) = depFields(line,e,thd3(snd(e)),FALSE);
-}
-
-static List local depFields(l,e,fs,isP) /* check field binding list */
-Int l;
-Cell e;
-List fs;
-Bool isP; {
- List cs = NIL;
- List ss = NIL;
-
- for (; nonNull(fs); fs=tl(fs)) { /* for each field binding */
- Cell fb = hd(fs);
- Name s;
-
- if (isVar(fb)) { /* expand var to var = var */
- h98DoesntSupport(l,"missing field bindings");
- fb = hd(fs) = pair(fb,fb);
- }
-
- s = findQualName(fst(fb)); /* check for selector */
- if (nonNull(s) && isSfun(s)) {
- fst(fb) = s;
- } else {
- ERRMSG(l) "\"%s\" is not a selector function/field name",
- textToStr(textOf(fst(fb)))
- EEND;
- }
-
- if (isNull(ss)) { /* for first named selector */
- List scs = name(s).defn; /* calculate list of constructors */
- for (; nonNull(scs); scs=tl(scs)) {
- cs = cons(fst(hd(scs)),cs);
- }
- ss = singleton(s); /* initialize selector list */
- } else { /* for subsequent selectors */
- List ds = cs; /* intersect constructor lists */
- for (cs=NIL; nonNull(ds); ) {
- List scs = name(s).defn;
- while (nonNull(scs) && fst(hd(scs))!=hd(ds)) {
- scs = tl(scs);
- }
- if (isNull(scs)) {
- ds = tl(ds);
- } else {
- List next = tl(ds);
- tl(ds) = cs;
- cs = ds;
- ds = next;
- }
- }
-
- if (cellIsMember(s,ss)) { /* check for repeated uses */
- ERRMSG(l) "Repeated field name \"%s\" in field list",
- textToStr(name(s).text)
- EEND;
- }
- ss = cons(s,ss);
- }
-
- if (isNull(cs)) { /* Are there any matching constrs? */
- ERRMSG(l) "No constructor has all of the fields specified in "
- ETHEN ERREXPR(e);
- ERRTEXT "\n"
- EEND;
- }
-
- snd(fb) = (isP ? checkPat(l,snd(fb)) : depExpr(l,snd(fb)));
- }
- return cs;
-}
-
-#if IPARAM
-static Void local depWith(line,e) /* check with using fields */
-Int line;
-Cell e; {
- fst(snd(e)) = depExpr(line,fst(snd(e)));
- snd(snd(e)) = depDwFlds(line,e,snd(snd(e)));
-}
-
-static List local depDwFlds(l,e,fs)/* check field binding list */
-Int l;
-Cell e;
-List fs;
-{
- Cell c = fs;
- for (; nonNull(c); c=tl(c)) { /* for each field binding */
- snd(hd(c)) = depExpr(l,snd(hd(c)));
- }
- return fs;
-}
-#endif
-
-#if TREX
-static Cell local depRecord(line,e) /* find dependents of record and */
-Int line; /* sort fields into approp. order */
-Cell e; { /* to make construction and update */
- List exts = NIL; /* more efficient. */
- Cell r = e;
-
- h98DoesntSupport(line,"extensible records");
- do { /* build up list of extensions */
- Text t = extText(fun(fun(r)));
- String s = textToStr(t);
- List prev = NIL;
- List nx = exts;
- while (nonNull(nx) && strcmp(textToStr(extText(fun(fun(nx)))),s)>0) {
- prev = nx;
- nx = extRow(nx);
- }
- if (nonNull(nx) && t==extText(fun(fun(nx)))) {
- ERRMSG(line) "Repeated label \"%s\" in record ", s
- ETHEN ERREXPR(e);
- ERRTEXT "\n"
- EEND;
- }
- if (isNull(prev)) {
- exts = cons(fun(r),exts);
- } else {
- tl(prev) = cons(fun(r),nx);
- }
- extField(r) = depExpr(line,extField(r));
- r = extRow(r);
- } while (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r))));
- r = depExpr(line,r);
- return revOnto(exts,r);
-}
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Several parts of this program require an algorithm for sorting a list
- * of values (with some added dependency information) into a list of strongly
- * connected components in which each value appears before its dependents.
- *
- * Each of these algorithms is obtained by parameterising a standard
- * algorithm in "scc.c" as shown below.
- * ------------------------------------------------------------------------*/
-
-#define SCC2 tcscc /* make scc algorithm for Tycons */
-#define LOWLINK tclowlink
-#define DEPENDS(c) (isTycon(c) ? tycon(c).kind : cclass(c).kinds)
-#define SETDEPENDS(c,v) if(isTycon(c)) tycon(c).kind=v; else cclass(c).kinds=v
-#include "scc.c"
-#undef SETDEPENDS
-#undef DEPENDS
-#undef LOWLINK
-#undef SCC2
-
-#define SCC bscc /* make scc algorithm for Bindings */
-#define LOWLINK blowlink
-#define DEPENDS(t) depVal(t)
-#define SETDEPENDS(c,v) depVal(c)=v
-#include "scc.c"
-#undef SETDEPENDS
-#undef DEPENDS
-#undef LOWLINK
-#undef SCC
-
-/* --------------------------------------------------------------------------
- * Main static analysis:
- * ------------------------------------------------------------------------*/
-
-Void checkExp() { /* Top level static check on Expr */
- staticAnalysis(RESET);
- clearScope(); /* Analyse expression in the scope */
- withinScope(NIL); /* of no local bindings */
- inputExpr = depExpr(0,inputExpr);
- leaveScope();
- staticAnalysis(RESET);
-}
-
-#if EXPLAIN_INSTANCE_RESOLUTION
-Void checkContext(void) { /* Top level static check on Expr */
- List vs, qs;
-
- staticAnalysis(RESET);
- clearScope(); /* Analyse expression in the scope */
- withinScope(NIL); /* of no local bindings */
- qs = inputContext;
- for (vs = NIL; nonNull(qs); qs=tl(qs)) {
- vs = typeVarsIn(hd(qs),NIL,NIL,vs);
- }
- map2Proc(depPredExp,0,vs,inputContext);
- leaveScope();
- staticAnalysis(RESET);
-}
-#endif
-
-Void checkDefns ( Module thisModule ) { /* Top level static analysis */
- Text modName = module(thisModule).text;
-
- staticAnalysis(RESET);
-
- setCurrModule(thisModule);
-
- /* Resolve module references */
- mapProc(checkQualImport, module(thisModule).qualImports);
- mapProc(checkUnqualImport,unqualImports);
- /* Add "import Prelude" if there`s no explicit import */
- if (modName == textPrelPrim || modName == textPrelude) {
- /* Nothing. */
- } else if (isNull(cellAssoc(modulePrelude,unqualImports))
- && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
- unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
- } else {
- /* Every module implicitly contains "import qualified Prelude"
- */
- module(thisModule).qualImports
- =cons(pair(mkCon(textPrelude),modulePrelude),
- module(thisModule).qualImports);
- }
- mapProc(checkImportList, unqualImports);
-
- /* Note: there's a lot of side-effecting going on here, so
- don't monkey about with the order of operations here unless
- you know what you are doing */
- if (!combined) linkPreludeTC(); /* Get prelude tycons and classes */
-
- mapProc(checkTyconDefn,tyconDefns); /* validate tycon definitions */
- checkSynonyms(tyconDefns); /* check synonym definitions */
- mapProc(checkClassDefn,classDefns); /* process class definitions */
- mapProc(kindTCGroup,tcscc(tyconDefns,classDefns)); /* attach kinds */
- mapProc(visitClass,classDefns); /* check class hierarchy */
- mapProc(extendFundeps,classDefns); /* finish class definitions */
- /* (convenient if we do this after */
- /* calling `visitClass' so that we */
- /* know the class hierarchy is */
- /* acyclic) */
-
- mapProc(addMembers,classDefns); /* add definitions for member funs */
-
- if (!combined) linkPreludeCM(); /* Get prelude cfuns and mfuns */
-
- instDefns = rev(instDefns); /* process instance definitions */
- mapProc(checkInstDefn,instDefns);
-
- setCurrModule(thisModule);
- mapProc(addRSsigdecls,typeInDefns); /* add sigdecls for RESTRICTSYN */
- valDefns = eqnsToBindings(valDefns,tyconDefns,classDefns,/*primDefns*/NIL);
- mapProc(allNoPrevDef,valDefns); /* check against previous defns */
- mapProc(addDerivImp,derivedInsts); /* Add impls for derived instances */
- deriveContexts(derivedInsts); /* Calculate derived inst contexts */
- instDefns = appendOnto(instDefns,derivedInsts);
- checkDefaultDefns(); /* validate default definitions */
-
- mapProc(allNoPrevDef,valDefns); /* check against previous defns */
-
- if (!combined) linkPrimNames(); /* link primitive names */
-
- mapProc(checkForeignImport,foreignImports); /* check foreign imports */
- mapProc(checkForeignExport,foreignExports); /* check foreign exports */
- foreignImports = NIL;
- foreignExports = NIL;
-
- /* Every top-level name has now been created - so we can build the */
- /* export list. Note that this has to happen before dependency */
- /* analysis so that references to Prelude.foo will be resolved */
- /* when compiling the prelude. */
- module(thisModule).exports
- = checkExports ( module(thisModule).exports, thisModule );
-
- mapProc(checkTypeIn,typeInDefns); /* check restricted synonym defns */
-
- clearScope();
- withinScope(valDefns);
- valDefns = topDependAnal(valDefns); /* top level dependency ordering */
- mapProc(depDefaults,classDefns); /* dep. analysis on class defaults */
- mapProc(depInsts,instDefns); /* dep. analysis on inst defns */
- leaveScope();
-
- /* ToDo: evalDefaults should match current evaluation module */
- evalDefaults = defaultDefns; /* Set defaults for evaluator */
-
- staticAnalysis(RESET);
-}
-
-
-
-
-static Void local addRSsigdecls(pr) /* add sigdecls from TYPE ... IN ..*/
-Pair pr; {
- List vs = snd(pr); /* get list of variables */
- for (; nonNull(vs); vs=tl(vs)) {
- if (fst(hd(vs))==SIGDECL) { /* find a sigdecl */
- valDefns = cons(hd(vs),valDefns); /* add to valDefns */
- hd(vs) = hd(snd3(snd(hd(vs)))); /* and replace with var */
- }
- }
-}
-
-static Void local allNoPrevDef(b) /* ensure no previous bindings for*/
-Cell b; { /* variables in new binding */
- if (isVar(fst(b))) {
- noPrevDef(rhsLine(snd(hd(snd(snd(b))))),fst(b));
- } else {
- Int line = rhsLine(snd(snd(snd(b))));
- map1Proc(noPrevDef,line,fst(b));
- }
-}
-
-static Void local noPrevDef(line,v) /* ensure no previous binding for */
-Int line; /* new variable */
-Cell v; {
- Name n = findName(textOf(v));
-
- if (isNull(n)) {
- n = newName(textOf(v),NIL);
- name(n).defn = PREDEFINED;
- } else if (name(n).defn!=PREDEFINED) {
- duplicateError(line,name(n).mod,name(n).text,"variable");
- }
- name(n).line = line;
-}
-
-static Void local duplicateErrorAux(line,mod,t,kind)/* report duplicate defn */
-Int line;
-Module mod;
-Text t;
-String kind; {
- if (mod == currentModule) {
- ERRMSG(line) "Repeated definition for %s \"%s\"", kind,
- textToStr(t)
- EEND;
- } else {
- ERRMSG(line) "Definition of %s \"%s\" clashes with import", kind,
- textToStr(t)
- EEND;
- }
-}
-
-static Void local checkTypeIn(cvs) /* Check that vars in restricted */
-Pair cvs; { /* synonym are defined */
- Tycon c = fst(cvs);
- List vs = snd(cvs);
-
- for (; nonNull(vs); vs=tl(vs)) {
- if (isNull(findName(textOf(hd(vs))))) {
- ERRMSG(tycon(c).line)
- "No top level binding of \"%s\" for restricted synonym \"%s\"",
- textToStr(textOf(hd(vs))), textToStr(tycon(c).text)
- EEND;
- }
- }
-}
-
-/* --------------------------------------------------------------------------
- * Haskell 98 compatibility tests:
- * ------------------------------------------------------------------------*/
-
-Bool h98Pred(allowArgs,pi) /* Check syntax of Hask98 predicate*/
-Bool allowArgs;
-Cell pi; {
- return isClass(getHead(pi)) && argCount==1 &&
- isOffset(getHead(arg(pi))) && (argCount==0 || allowArgs);
-}
-
-Cell h98Context(allowArgs,ps) /* Check syntax of Hask98 context */
-Bool allowArgs;
-List ps; {
- for (; nonNull(ps); ps=tl(ps)) {
- if (!h98Pred(allowArgs,hd(ps))) {
- return hd(ps);
- }
- }
- return NIL;
-}
-
-Void h98CheckCtxt(line,wh,allowArgs,ps,in)
-Int line; /* Report illegal context/predicate*/
-String wh;
-Bool allowArgs;
-List ps;
-Inst in; {
- if (haskell98) {
- Cell pi = h98Context(allowArgs,ps);
- if (nonNull(pi)) {
- ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh ETHEN
- if (nonNull(in)) {
- ERRTEXT "\n*** Instance : " ETHEN ERRPRED(inst(in).head);
- }
- ERRTEXT "\n*** Constraint : " ETHEN ERRPRED(pi);
- if (nonNull(ps) && nonNull(tl(ps))) {
- ERRTEXT "\n*** Context : " ETHEN ERRCONTEXT(ps);
- }
- ERRTEXT "\n"
- EEND;
- }
- }
-}
-
-Void h98CheckType(line,wh,e,t) /* Check for Haskell 98 type */
-Int line;
-String wh;
-Cell e;
-Type t; {
- if (haskell98) {
- Type ty = t;
- if (isPolyType(t))
- t = monotypeOf(t);
- if (isQualType(t)) {
- Cell pi = h98Context(TRUE,fst(snd(t)));
- if (nonNull(pi)) {
- ERRMSG(line) "Illegal Haskell 98 class constraint in %s",wh
- ETHEN
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(ty);
- ERRTEXT "\n"
- EEND;
- }
- }
- }
-}
-
-Void h98DoesntSupport(line,wh) /* Report feature missing in H98 */
-Int line;
-String wh; {
- if (haskell98) {
- ERRMSG(line) "Haskell 98 does not support %s", wh
- EEND;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Static Analysis control:
- * ------------------------------------------------------------------------*/
-
-Void staticAnalysis(what)
-Int what; {
- switch (what) {
- case RESET : cfunSfuns = NIL;
- daSccs = NIL;
- patVars = NIL;
- bounds = NIL;
- bindings = NIL;
- depends = NIL;
- tcDeps = NIL;
- derivedInsts = NIL;
- diVars = NIL;
- diNum = 0;
- unkindTypes = NIL;
- break;
-
- case MARK : mark(daSccs);
- mark(patVars);
- mark(bounds);
- mark(bindings);
- mark(depends);
- mark(tcDeps);
- mark(derivedInsts);
- mark(diVars);
- mark(cfunSfuns);
- mark(unkindTypes);
-#if TREX
- mark(extKind);
-#endif
- break;
-
- case POSTPREL: break;
-
- case PREPREL : staticAnalysis(RESET);
-#if TREX
- extKind = pair(STAR,pair(ROW,ROW));
-#endif
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * STG syntax
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: stg.c,v $
- * $Revision: 1.16 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h" /* for AsmRep and primops */
-
-/* --------------------------------------------------------------------------
- * Utility functions
- * ------------------------------------------------------------------------*/
-
-/* Make an info table for a constructor or tuple. */
-void* stgConInfo ( StgDiscr d )
-{
- int tag;
- switch (whatIs(d)) {
- case NAME: {
- tag = cfunOf(d);
- if (tag > 0) tag--;
- if (!name(d).itbl)
- name(d).itbl = asmMkInfo(tag,name(d).arity);
- return name(d).itbl;
- }
- case TUPLE: {
- tag = 0;
- if (!tycon(d).itbl)
- tycon(d).itbl = asmMkInfo(tag,tupleOf(d));
- return tycon(d).itbl;
- }
- default:
- internal("stgConInfo");
- }
-}
-
-/* Return the tag for a constructor or tuple, starting at zero. */
-int stgDiscrTag ( StgDiscr d )
-{
- int tag;
- switch (whatIs(d)) {
- case NAME: tag = cfunOf(d); break;
- case TUPLE: tag = 0;
- default: internal("stgDiscrTag");
- }
- if (tag > 0) tag--;
- return tag;
-}
-
-/* --------------------------------------------------------------------------
- * Utility functions for manipulating STG syntax trees.
- * ------------------------------------------------------------------------*/
-
-List makeArgs( Int n )
-{
- List args = NIL;
- for(; n>0; --n) {
- args = cons(mkStgVar(NIL,NIL),args);
- }
- return args;
-}
-
-StgExpr makeStgLambda( List args, StgExpr body )
-{
- if (isNull(args)) {
- return body;
- } else {
- if (whatIs(body) == LAMBDA) {
- return mkStgLambda(dupListOnto(args,stgLambdaArgs(body)),
- stgLambdaBody(body));
- } else {
- return mkStgLambda(args,body);
- }
- }
-}
-
-StgExpr makeStgApp( StgVar fun, List args )
-{
- if (isNull(args)) {
- return fun;
- } else {
- return mkStgApp(fun,args);
- }
-}
-
-StgExpr makeStgLet( List binds, StgExpr body )
-{
- if (isNull(binds)) {
- return body;
- } else {
- return mkStgLet(binds,body);
- }
-}
-
-StgExpr makeStgIf( StgExpr cond, StgExpr e1, StgExpr e2 )
-{
- if (cond == nameTrue) {
- return e1;
- } else if (cond == nameFalse) {
- return e2;
- } else {
- return mkStgCase(cond,doubleton(mkStgCaseAlt(nameTrue,NIL,e1),
- mkStgCaseAlt(nameFalse,NIL,e2)));
- }
-}
-
-Bool isStgVar(e)
-StgRhs e; {
- switch (whatIs(e)) {
- case STGVAR:
- return TRUE;
- default:
- return FALSE;
- }
-}
-
-Bool isAtomic(e)
-StgRhs e; {
- switch (whatIs(e)) {
- case STGVAR:
- case NAME:
- case CHARCELL:
- case INTCELL:
- case BIGCELL:
- case FLOATCELL:
- case STRCELL:
- case ADDRCELL:
- return TRUE;
- default:
- return FALSE;
- }
-}
-
-StgVar mkStgVar( StgRhs rhs, Cell info )
-{
- return ap(STGVAR,triple(rhs,mkStgRep(PTR_REP),info));
-}
-
-
-/* --------------------------------------------------------------------------
- * STG pretty printer
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Local functions
- * ------------------------------------------------------------------------*/
-
-static Void local pIndent ( Int );
-static Void local putStgVar ( StgVar );
-static Void local putStgVars ( List );
-static Void local putStgAtom ( StgAtom a );
-static Void local putStgAtoms ( List as );
-static Void local putStgBinds ( List );
-static Void local putStgExpr ( StgExpr );
-static Void local putStgRhs ( StgRhs );
-static Void local putStgPat ( StgCaseAlt );
-static Void local putStgPrimPat ( StgPrimAlt );
-
-
-
-/* --------------------------------------------------------------------------
- * Indentation and showing names/constants
- * ------------------------------------------------------------------------*/
-
-static Void local pIndent(n) /* indent to particular position */
-Int n; {
- outColumn = n;
- while (0<n--) {
- Putc(' ',outputStream);
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Pretty printer for stg code:
- * ------------------------------------------------------------------------*/
-
-static Void putStgAlts ( Int left, List alts );
-
-static Void local putStgVar(StgVar v)
-{
- if (isTuple(v)) {
- putStr("Tuple");
- putInt(tupleOf(v));
- } else
- if (isName(v)) {
- unlexVar(name(v).text);
- } else {
- putStr("id");
- putInt(-v);
- putStr("<");
- putChr(charOf(stgVarRep(v)));
- putStr(">");
- if (isInt(stgVarInfo(v))) {
- putStr("(");
- putInt(intOf(stgVarInfo(v)));
- putStr(")");
- }
- }
-}
-
-static Void local putStgVars( List vs )
-{
- for(; nonNull(vs); vs=tl(vs)) {
- putStgVar(hd(vs));
- putChr(' ');
- }
-}
-
-static Void local putStgAtom( StgAtom a )
-{
- switch (whatIs(a)) {
- case STGVAR:
- case NAME:
- putStgVar(a);
- break;
- case CHARCELL:
- unlexCharConst(charOf(a));
- putChr('#');
- break;
- case INTCELL:
- putInt(intOf(a));
- putChr('#');
- break;
- case BIGCELL:
- putStr(bignumToString(a));
- putChr('#');
- break;
- case FLOATCELL:
- putStr(floatToString(a));
- putChr('#');
- break;
- case STRCELL:
- unlexStrConst(textOf(a));
- break;
- case ADDRCELL:
- putPtr(addrOf(a));
- putChr('#');
- break;
- case LETREC: case LAMBDA: case CASE: case PRIMCASE:
- case STGAPP: case STGPRIM: case STGCON:
- putStgExpr(a);
- break;
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,a);
- internal("putStgAtom");
- }
-}
-
-Void putStgAtoms( List as )
-{
- putChr('{');
- while (nonNull(as)) {
- putStgAtom(hd(as));
- as=tl(as);
- if (nonNull(as)) {
- putChr(',');
- }
- }
- putChr('}');
-}
-
-Void putStgPat( StgCaseAlt alt )
-{
- if (whatIs(alt)==DEEFALT) {
- putStgVar(stgDefaultVar(alt));
- }
- else
- if (whatIs(alt)==CASEALT) {
- List vs = stgCaseAltVars(alt);
- if (whatIs(stgCaseAltCon(alt))==TUPLE) {
- putChr('(');
- putStgVar(hd(vs));
- vs=tl(vs);
- while (nonNull(vs)) {
- putChr(',');
- putStgVar(hd(vs));
- vs=tl(vs);
- }
- putChr(')');
- }
- else
- if (whatIs(stgCaseAltCon(alt))==NAME) {
- unlexVar(name(stgCaseAltCon(alt)).text);
- for (; nonNull(vs); vs=tl(vs)) {
- putChr(' ');
- putStgVar(hd(vs));
- }
- }
- else
- internal("putStgPat(2)");
- }
- else
- internal("putStgPat(1)");
-}
-
-Void putStgPrimPat( StgVar v )
-{
- if (nonNull(stgVarBody(v))) {
- StgExpr d = stgVarBody(v);
- switch (whatIs(d)) {
- case INTCELL:
- {
- putInt(intOf(d));
- putChr('#');
- break;
- }
- default:
- fprintf(stderr,"\nYoiks: "); printExp(stderr,d);
- internal("putStgPrimPat");
- }
- } else {
- putStgVar(v);
- }
- putChr(' ');
-}
-
-Void putStgBinds(binds) /* pretty print locals */
-List binds; {
- Int left = outColumn;
-
- putStr("let { ");
- while (nonNull(binds)) {
- Cell bind = hd(binds);
- putStgVar(bind);
- putStr(" = ");
- putStgRhs(stgVarBody(bind));
- putStr("\n");
- binds = tl(binds);
- if (nonNull(binds))
- pIndent(left+6);
- }
- pIndent(left);
- putStr("} in ");
-}
-
-static Void putStgAlts( Int left, List alts )
-{
- if (length(alts) == 1) {
- StgCaseAlt alt = hd(alts);
- putStr("{ ");
- putStgPat(alt);
- putStr(" ->\n");
- pIndent(left);
- if (isDefaultAlt(alt))
- putStgExpr(stgDefaultBody(alt)); else
- putStgExpr(stgCaseAltBody(alt));
- putStr("}");
- } else {
- putStr("{\n");
- for (; nonNull(alts); alts=tl(alts)) {
- StgCaseAlt alt = hd(alts);
- pIndent(left+2);
- putStgPat(alt);
-
- putStr(" ->\n");
- pIndent(left+4);
-
- if (isDefaultAlt(alt))
- putStgExpr(stgDefaultBody(alt)); else
- putStgExpr(stgCaseAltBody(alt));
-
- putStr("\n");
- }
- pIndent(left);
- putStr("}\n");
- }
-}
-
-static Void putStgPrimAlts( Int left, List alts )
-{
- if (length(alts) == 1) {
- StgPrimAlt alt = hd(alts);
- putStr("{ ");
- mapProc(putStgPrimPat,stgPrimAltVars(alt));
- putStr(" ->\n");
- pIndent(left);
- putStgExpr(stgPrimAltBody(alt));
- putStr("}");
- } else {
- putStr("{\n");
- for (; nonNull(alts); alts=tl(alts)) {
- StgPrimAlt alt = hd(alts);
- pIndent(left+2);
- mapProc(putStgPrimPat,stgPrimAltVars(alt));
- putStr(" -> ");
- putStgExpr(stgPrimAltBody(alt));
- putStr("\n");
- }
- pIndent(left);
- putStr("}\n");
- }
-}
-
-Void putStgExpr( StgExpr e ) /* pretty print expr */
-{
- if (isNull(e)) {
- putStr("(putStgExpr:NIL)");
- return;
- }
-
- switch (whatIs(e)) {
- case LETREC:
- {
- Int left = outColumn;
- putStgBinds(stgLetBinds(e));
- if (whatIs(stgLetBody(e))==LETREC) {
- putStr("\n"); pIndent(left);
- } else
- if (whatIs(stgLetBody(e))==CASE) {
- putStr("\n"); pIndent(left+2);
- }
- putStgExpr(stgLetBody(e));
- break;
- }
- case LAMBDA:
- {
- Int left = outColumn;
- putStr("\\ ");
- putStgVars(stgLambdaArgs(e));
- putStr("->\n");
- pIndent(left+2);
- putStgExpr(stgLambdaBody(e));
- break;
- }
- case CASE:
- {
- Int left = outColumn;
- putStr("case ");
- putStgExpr(stgCaseScrut(e));
- putStr(" of ");
- putStgAlts(left,stgCaseAlts(e));
- break;
- }
- case DEEFALT:
- case CASEALT:
- /* a hack; not for regular use */
- putStgAlts(outColumn,singleton(e));
- break;
- case PRIMALT:
- /* a hack; not for regular use */
- putStgPrimAlts(outColumn,singleton(e));
- break;
- case PRIMCASE:
- {
- Int left = outColumn;
- putStr("case# ");
- putStgExpr(stgPrimCaseScrut(e));
- putStr(" of ");
- putStgPrimAlts(left,stgPrimCaseAlts(e));
- break;
- }
- case STGPRIM:
- {
- Cell op = stgPrimOp(e);
- unlexVarStr(asmGetPrimopName(name(op).primop));
- putStgAtoms(stgPrimArgs(e));
- break;
- }
- case STGAPP:
- putStgExpr(stgAppFun(e));
- putStgAtoms(stgAppArgs(e));
- break;
- case STGCON:
- putStgRhs(e);
- break;
- case STGVAR:
- case NAME:
- case TUPLE:
- putStgVar(e);
- break;
- case CHARCELL:
- case INTCELL:
- case BIGCELL:
- case FLOATCELL:
- case STRCELL:
- case ADDRCELL:
- putStgAtom(e);
- break;
- case AP:
- /* hope that it's really a list of StgExprs, so map putStgExpr
- over it */
- for (;nonNull(e);e=tl(e)) {
- putStgExpr(hd(e));
- putStr("\n");
- }
- break;
- default:
- internal("putStgExpr");
- /* Pretend it's a list of algebraic case alternatives. Used for
- printing the case-alt lists attached to BCOs which are return
- continuations. Very useful for debugging. An appalling hack tho.
- */
- /* fprintf(stderr, " "); putStgAlts(3,e); */
- }
-}
-
-Void putStgRhs( StgRhs e ) /* print lifted definition */
-{
- switch (whatIs(e)) {
- case STGCON:
- {
- Name con = stgConCon(e);
- if (isTuple(con)) {
- putStr("Tuple");
- putInt(tupleOf(con));
- } else {
- unlexVar(name(con).text);
- }
- putStgAtoms(stgConArgs(e));
- break;
- }
- default:
- putStgExpr(e);
- break;
- }
-}
-
-static void beginStgPP( FILE* fp );
-static void endStgPP( FILE* fp );
-
-static void beginStgPP( FILE* fp )
-{
- outputStream = fp;
- outColumn = 0;
- fflush(stderr); fflush(stdout);
-}
-
-static void endStgPP( FILE* fp )
-{
- fflush(fp);
-}
-
-Void printStg(fp,b) /* Pretty print sc defn on fp */
-FILE *fp;
-StgVar b;
-{
- Name n;
- beginStgPP(fp);
- n = NIL; /* nameFromStgVar(b); */
- if (nonNull(n)) {
- putStr(textToStr(name(n).text));
- } else {
- putStgVar(b);
- }
- putStr(" = ");
- putStgRhs(stgVarBody(b));
- putStr("\n");
- endStgPP(fp);
-}
-
-Void ppStg( StgVar v )
-{
- printStg(stdout,v);
-}
-
-Void ppStgExpr( StgExpr e )
-{
- beginStgPP(stdout);
- putStgExpr(e);
- endStgPP(stdout);
-}
-
-Void ppStgRhs( StgRhs rhs )
-{
- beginStgPP(stdout);
- putStgRhs(rhs);
- endStgPP(stdout);
-}
-
-Void ppStgAlts( List alts )
-{
- beginStgPP(stdout);
- putStgAlts(0,alts);
- endStgPP(stdout);
-}
-
-extern Void ppStgPrimAlts( List alts )
-{
- beginStgPP(stdout);
- putStgPrimAlts(0,alts);
- endStgPP(stdout);
-}
-
-extern Void ppStgVars( List vs )
-{
- beginStgPP(stdout);
- printf("Vars: ");
- putStgVars(vs);
- printf("\n");
- endStgPP(stdout);
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Substitute variables in an expression
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: stgSubst.c,v $
- * $Revision: 1.9 $
- * $Date: 2000/04/28 13:03:47 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static StgVar substVar ( List sub, StgVar v );
-static StgAtom substAtom ( List sub, StgAtom a );
-static void substBind ( List sub, StgVar bind );
-static void substAlt ( List sub, StgCaseAlt alt );
-static void substPrimAlt ( List sub, StgPrimAlt alt );
-
-/* --------------------------------------------------------------------------
- * Substitute variables throughout an expression - updating in place.
- * ------------------------------------------------------------------------*/
-
-static StgVar substVar( List sub, StgVar v )
-{
- Pair p = cellAssoc(v,sub);
- if (nonNull(p)) {
- return snd(p);
- } else {
- return v;
- }
-}
-
-static StgAtom substAtom ( List sub, StgAtom a )
-{
- switch (whatIs(a)) {
- case STGVAR:
- return substVar(sub,a);
- default:
- return a;
- }
-}
-
-static Void substBind( List sub, StgVar bind )
-{
- StgRhs rhs = stgVarBody(bind);
- switch (whatIs(rhs)) {
- case STGCON:
- map1Over(substAtom,sub,stgConArgs(rhs));
- return;
- default:
- stgVarBody(bind) = substExpr(sub,rhs);
- return;
- }
-}
-
-static Void substAlt( List sub, StgCaseAlt alt )
-{
- if (isDefaultAlt(alt))
- stgDefaultBody(alt) = substExpr(sub,stgDefaultBody(alt)); else
- stgCaseAltBody(alt) = substExpr(sub,stgCaseAltBody(alt));
-}
-
-static Void substPrimAlt( List sub, StgPrimAlt alt )
-{
- stgPrimAltBody(alt) = substExpr(sub,stgPrimAltBody(alt));
-}
-
-StgExpr substExpr( List sub, StgExpr e )
-{
- switch (whatIs(e)) {
- case LETREC:
- map1Proc(substBind,sub,stgLetBinds(e));
- stgLetBody(e) = substExpr(sub,stgLetBody(e));
- break;
- case LAMBDA:
- stgLambdaBody(e) = substExpr(sub,stgLambdaBody(e));
- break;
- case CASE:
- stgCaseScrut(e) = substExpr(sub,stgCaseScrut(e));
- map1Proc(substAlt,sub,stgCaseAlts(e));
- break;
- case PRIMCASE:
- stgPrimCaseScrut(e) = substExpr(sub,stgPrimCaseScrut(e));
- map1Proc(substPrimAlt,sub,stgPrimCaseAlts(e));
- break;
- case STGPRIM:
- map1Over(substAtom,sub,stgPrimArgs(e));
- break;
- case STGAPP:
- stgAppFun(e) = substVar(sub,stgAppFun(e));
- map1Over(substAtom,sub,stgAppArgs(e));
- break;
- case STGCON:
- map1Over(substAtom,sub,stgConArgs(e));
- break;
- case STGVAR:
- case NAME:
- case TUPLE:
- return substVar(sub,e);
- default:
- internal("substExpr");
- }
- return e;
-}
-
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Primitives for manipulating global data structures
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: storage.c,v $
- * $Revision: 1.78 $
- * $Date: 2000/06/23 13:13:10 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-#include "object.h"
-#include <setjmp.h>
-#include "Stg.h"
-
-/* #include "Storage.h"
- We'd like to, but Storage.h and storage.h look the same under
- Cygwin, alas, causing compilation chaos. So just copy what
- we need to know, which is ...
-*/
-extern StgClosure* MarkRoot ( StgClosure* );
-
-/*#define DEBUG_SHOWUSE*/
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Int local hash ( String );
-static Int local saveText ( Text );
-static Module local findQualifier ( Text );
-static Void local hashTycon ( Tycon );
-static List local insertTycon ( Tycon,List );
-static Void local hashName ( Name );
-static List local insertName ( Name,List );
-static Void local patternError ( String );
-static Bool local stringMatch ( String,String );
-static Bool local typeInvolves ( Type,Type );
-static Cell local markCell ( Cell );
-static Void local markSnd ( Cell );
-static Cell local lowLevelLastIn ( Cell );
-static Cell local lowLevelLastOut ( Cell );
-
-
-/* --------------------------------------------------------------------------
- * Text storage:
- *
- * provides storage for the characters making up identifier and symbol
- * names, string literals, character constants etc...
- *
- * All character strings are stored in a large character array, with textHw
- * pointing to the next free position. Lookup in the array is improved using
- * a hash table. Internally, text strings are represented by integer offsets
- * from the beginning of the array to the string in question.
- *
- * Where memory permits, the use of multiple hashtables gives a significant
- * increase in performance, particularly when large source files are used.
- *
- * Each string in the array is terminated by a zero byte. No string is
- * stored more than once, so that it is safe to test equality of strings by
- * comparing the corresponding offsets.
- *
- * Special text values (beyond the range of the text array table) are used
- * to generate unique `new variable names' as required.
- *
- * The same text storage is also used to hold text values stored in a saved
- * expression. This grows downwards from the top of the text table (and is
- * not included in the hash table).
- * ------------------------------------------------------------------------*/
-
-#define TEXTHSZ 512 /* Size of Text hash table */
-#define NOTEXT ((Text)(~0)) /* Empty bucket in Text hash table */
-static Text textHw; /* Next unused position */
-static Text savedText = TEXT_SIZE; /* Start of saved portion of text */
-static Text nextNewText; /* Next new text value */
-static Text nextNewDText; /* Next new dict text value */
-static char text[TEXT_SIZE]; /* Storage of character strings */
-static Text textHash[TEXTHSZ][NUM_TEXTH]; /* Hash table storage */
-
-String textToStr(t) /* find string corresp to given Text*/
-Text t; {
- static char newVar[16];
-
- if (isText(t)) /* standard char string */
- return text + t - TEXT_BASE_ADDR;
- if (isInventedDictVar(t)) {
- sprintf(newVar,"d%d",
- t-INDVAR_BASE_ADDR); /* dictionary variable */
- return newVar;
- }
- if (isInventedVar(t)) {
- sprintf(newVar,"v%d",
- t-INVAR_BASE_ADDR); /* normal variable */
- return newVar;
- }
- internal("textToStr");
-}
-
-String identToStr(v) /*find string corresp to given ident or qualified name*/
-Cell v; {
- if (!isPair(v)) {
- internal("identToStr");
- }
- switch (whatIs(v)) {
- case VARIDCELL :
- case VAROPCELL :
- case CONIDCELL :
- case CONOPCELL : return textToStr(textOf(v));
-
- case QUALIDENT : { String qmod = textToStr(qmodOf(v));
- String qtext = textToStr(qtextOf(v));
- Text pos = textHw;
-
- while (pos+1 < savedText && *qmod!=0) {
- text[pos++] = *qmod++;
- }
- if (pos+1 < savedText) {
- text[pos++] = '.';
- }
- while (pos+1 < savedText && *qtext!=0) {
- text[pos++] = *qtext++;
- }
- text[pos] = '\0';
- return text+textHw;
- }
- }
- internal("identToStr2");
- return 0; /* NOTREACHED */
-}
-
-Text inventText() { /* return new unused variable name */
- if (nextNewText >= INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
- internal("inventText: too many invented variables");
- return nextNewText++;
-}
-
-Text inventDictText() { /* return new unused dictvar name */
- if (nextNewDText >= INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
- internal("inventDictText: too many invented variables");
- return nextNewDText++;
-}
-
-Bool inventedText(t) /* Signal TRUE if text has been */
-Text t; { /* generated internally */
- return isInventedVar(t) || isInventedDictVar(t);
-}
-
-#define MAX_FIXLIT 100
-Text fixLitText(t) /* fix literal text that might include \ */
-Text t; {
- String s = textToStr(t);
- char p[MAX_FIXLIT];
- Int i;
- for(i = 0;i < MAX_FIXLIT-2 && *s;s++) {
- p[i++] = *s;
- if (*s == '\\') {
- p[i++] = '\\';
- }
- }
- if (i < MAX_FIXLIT-2) {
- p[i] = 0;
- } else {
- ERRMSG(0) "storage space exhausted for internal literal string"
- EEND;
- }
- return (findText(p));
-}
-#undef MAX_FIXLIT
-
-static Int local hash(s) /* Simple hash function on strings */
-String s; {
- int v, j = 3;
-
- for (v=((int)(*s))*8; *s; s++)
- v += ((int)(*s))*(j++);
- if (v<0)
- v = (-v);
- return(v%TEXTHSZ);
-}
-
-Text findText(s) /* Locate string in Text array */
-String s; {
- int h = hash(s);
- int hashno = 0;
- Text textPos = textHash[h][hashno];
-
-# define TryMatch { Text originalTextPos = textPos; \
- String t; \
- for (t=s; *t==text[textPos]; textPos++,t++) \
- if (*t=='\0') \
- return originalTextPos+TEXT_BASE_ADDR; \
- }
-# define Skip while (text[textPos++]) ;
-
- while (textPos!=NOTEXT) {
- TryMatch
- if (++hashno<NUM_TEXTH) /* look in next hashtable entry */
- textPos = textHash[h][hashno];
- else {
- Skip
- while (textPos < textHw) {
- TryMatch
- Skip
- }
- break;
- }
- }
-
-#undef TryMatch
-#undef Skip
-
- textPos = textHw; /* if not found, save in array */
- if (textHw + (Int)strlen(s) + 1 > savedText) {
- ERRMSG(0) "Character string storage space exhausted"
- EEND;
- }
- while ((text[textHw++] = *s++) != 0) {
- }
- if (hashno<NUM_TEXTH) { /* updating hash table as necessary */
- textHash[h][hashno] = textPos;
- if (hashno<NUM_TEXTH-1)
- textHash[h][hashno+1] = NOTEXT;
- }
-
- return textPos+TEXT_BASE_ADDR;
-}
-
-static Int local saveText(t) /* Save text value in buffer */
-Text t; { /* at top of text table */
- String s = textToStr(t);
- Int l = strlen(s);
- if (textHw + l + 1 > savedText) {
- ERRMSG(0) "Character string storage space exhausted"
- EEND;
- }
- savedText -= l+1;
- strcpy(text+savedText,s);
- return savedText;
-}
-
-
-static int fromHexDigit ( char c )
-{
- switch (c) {
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- return c - '0';
- case 'a': case 'A': return 10;
- case 'b': case 'B': return 11;
- case 'c': case 'C': return 12;
- case 'd': case 'D': return 13;
- case 'e': case 'E': return 14;
- case 'f': case 'F': return 15;
- default: return -1;
- }
-}
-
-
-/* returns findText (unZencode s) */
-Text unZcodeThenFindText ( String s )
-{
- unsigned char* p;
- Int n, nn, i;
- Text t;
-
- assert(s);
- nn = 100 + 10 * strlen(s);
- p = malloc ( nn );
- if (!p) internal ("unZcodeThenFindText: malloc failed");
- n = 0;
-
- while (1) {
- if (!(*s)) break;
- if (n > nn-90) internal ("unZcodeThenFindText: result is too big");
- if (*s != 'z' && *s != 'Z') {
- p[n] = *s; n++; s++;
- continue;
- }
- s++;
- if (!(*s)) goto parse_error;
- switch (*s++) {
- case 'Z': p[n++] = 'Z'; break;
- case 'C': p[n++] = ':'; break;
- case 'L': p[n++] = '('; break;
- case 'R': p[n++] = ')'; break;
- case 'M': p[n++] = '['; break;
- case 'N': p[n++] = ']'; break;
- case 'z': p[n++] = 'z'; break;
- case 'a': p[n++] = '&'; break;
- case 'b': p[n++] = '|'; break;
- case 'd': p[n++] = '$'; break;
- case 'e': p[n++] = '='; break;
- case 'g': p[n++] = '>'; break;
- case 'h': p[n++] = '#'; break;
- case 'i': p[n++] = '.'; break;
- case 'l': p[n++] = '<'; break;
- case 'm': p[n++] = '-'; break;
- case 'n': p[n++] = '!'; break;
- case 'p': p[n++] = '+'; break;
- case 'q': p[n++] = '\\'; break;
- case 'r': p[n++] = '\''; break;
- case 's': p[n++] = '/'; break;
- case 't': p[n++] = '*'; break;
- case 'u': p[n++] = '^'; break;
- case 'v': p[n++] = '%'; break;
- case 'x':
- if (!s[0] || !s[1]) goto parse_error;
- if (fromHexDigit(s[0]) < 0 || fromHexDigit(s[1]) < 0) goto parse_error;
- p[n++] = 16 * fromHexDigit(s[0]) + fromHexDigit(s[1]);
- p += 2; s += 2;
- break;
- case '0': case '1': case '2': case '3': case '4':
- case '5': case '6': case '7': case '8': case '9':
- i = 0;
- s--;
- while (*s && isdigit((int)(*s))) {
- i = 10 * i + (*s - '0');
- s++;
- }
- if (*s != 'T') goto parse_error;
- s++;
- p[n++] = '(';
- while (i > 0) { p[n++] = ','; i--; };
- p[n++] = ')';
- break;
- default:
- goto parse_error;
- }
- }
- p[n] = 0;
- t = findText(p);
- free(p);
- return t;
-
- parse_error:
- free(p);
- fprintf ( stderr, "\nstring = `%s'\n", s );
- internal ( "unZcodeThenFindText: parse error on above string");
- return NIL; /*notreached*/
-}
-
-
-Text enZcodeThenFindText ( String s )
-{
- unsigned char* p;
- Int n, nn;
- Text t;
- char toHex[16] = "0123456789ABCDEF";
-
- assert(s);
- nn = 100 + 10 * strlen(s);
- p = malloc ( nn );
- if (!p) internal ("enZcodeThenFindText: malloc failed");
- n = 0;
- while (1) {
- if (!(*s)) break;
- if (n > nn-90) internal ("enZcodeThenFindText: result is too big");
- if (*s != 'z'
- && *s != 'Z'
- && (isalnum((int)(*s)) || *s == '_')) {
- p[n] = *s; n++; s++;
- continue;
- }
- if (*s == '(') {
- int tup = 0;
- char num[12];
- s++;
- while (*s && *s==',') { s++; tup++; };
- if (*s != ')') internal("enZcodeThenFindText: invalid tuple type");
- s++;
- p[n++] = 'Z';
- sprintf(num,"%d",tup);
- p[n] = 0; strcat ( &(p[n]), num ); n += strlen(num);
- p[n++] = 'T';
- continue;
- }
- switch (*s++) {
- case '(': p[n++] = 'Z'; p[n++] = 'L'; break;
- case ')': p[n++] = 'Z'; p[n++] = 'R'; break;
- case '[': p[n++] = 'Z'; p[n++] = 'M'; break;
- case ']': p[n++] = 'Z'; p[n++] = 'N'; break;
- case ':': p[n++] = 'Z'; p[n++] = 'C'; break;
- case 'Z': p[n++] = 'Z'; p[n++] = 'Z'; break;
- case 'z': p[n++] = 'z'; p[n++] = 'z'; break;
- case '&': p[n++] = 'z'; p[n++] = 'a'; break;
- case '|': p[n++] = 'z'; p[n++] = 'b'; break;
- case '$': p[n++] = 'z'; p[n++] = 'd'; break;
- case '=': p[n++] = 'z'; p[n++] = 'e'; break;
- case '>': p[n++] = 'z'; p[n++] = 'g'; break;
- case '#': p[n++] = 'z'; p[n++] = 'h'; break;
- case '.': p[n++] = 'z'; p[n++] = 'i'; break;
- case '<': p[n++] = 'z'; p[n++] = 'l'; break;
- case '-': p[n++] = 'z'; p[n++] = 'm'; break;
- case '!': p[n++] = 'z'; p[n++] = 'n'; break;
- case '+': p[n++] = 'z'; p[n++] = 'p'; break;
- case '\'': p[n++] = 'z'; p[n++] = 'q'; break;
- case '\\': p[n++] = 'z'; p[n++] = 'r'; break;
- case '/': p[n++] = 'z'; p[n++] = 's'; break;
- case '*': p[n++] = 'z'; p[n++] = 't'; break;
- case '^': p[n++] = 'z'; p[n++] = 'u'; break;
- case '%': p[n++] = 'z'; p[n++] = 'v'; break;
- default: s--; p[n++] = 'z'; p[n++] = 'x';
- p[n++] = toHex[(int)(*s)/16];
- p[n++] = toHex[(int)(*s)%16];
- s++; break;
- }
- }
- p[n] = 0;
- t = findText(p);
- free(p);
- return t;
-}
-
-
-Text textOf ( Cell c )
-{
- Int wot = whatIs(c);
- Bool ok =
- (wot==VARIDCELL
- || wot==CONIDCELL
- || wot==VAROPCELL
- || wot==CONOPCELL
- || wot==STRCELL
- || wot==DICTVAR
- || wot==IPCELL
- || wot==IPVAR
- );
- if (!ok) {
- fprintf(stderr, "\ntextOf: bad tag %d\n",wot );
- internal("textOf: bad tag");
- }
- return snd(c);
-}
-
-/* --------------------------------------------------------------------------
- * Ext storage:
- *
- * Currently, the only attributes that we store for each Ext value is the
- * corresponding Text label. At some later stage, we may decide to cache
- * types, predicates, etc. here as a space saving gesture. Given that Text
- * comparison is cheap, and that this is an experimental implementation, we
- * will use a straightforward linear search to locate Ext values from their
- * corresponding Text labels; a hashing scheme can be introduced later if
- * this turns out to be a problem.
- * ------------------------------------------------------------------------*/
-
-#if TREX
-Text DEFTABLE(tabExt,NUM_EXT); /* Storage for Ext names */
-Ext extHw;
-
-Ext mkExt(t) /* Allocate or find an Ext value */
-Text t; {
- Ext e = EXTMIN;
- for (; e<extHw; e++)
- if (t==extText(e))
- return e;
- if (extHw-EXTMIN >= NUM_EXT) {
- ERRMSG(0) "Ext storage space exhausted"
- EEND;
- }
- extText(extHw) = t;
- return extHw++;
-}
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Expandable symbol tables. A template, which is instantiated for the name,
- * tycon, class, instance and module tables. Also, potentially, TREX Exts.
- * ------------------------------------------------------------------------*/
-
-#ifdef DEBUG_STORAGE_EXTRA
-static Bool debugStorageExtra = TRUE;
-#else
-static Bool debugStorageExtra = FALSE;
-#endif
-
-
-#define EXPANDABLE_SYMBOL_TABLE(type_name,struct_name, \
- proc_name,free_proc_name, \
- free_list,tab_name,tab_size,err_msg, \
- TAB_INIT_SIZE,TAB_MAX_SIZE, \
- TAB_BASE_ADDR) \
- \
- struct struct_name* tab_name = NULL; \
- int tab_size = 0; \
- static type_name free_list = TAB_BASE_ADDR-1; \
- \
- void free_proc_name ( type_name n ) \
- { \
- assert(TAB_BASE_ADDR <= n); \
- assert(n < TAB_BASE_ADDR+tab_size); \
- assert(tab_name[n-TAB_BASE_ADDR].inUse); \
- tab_name[n-TAB_BASE_ADDR].inUse = FALSE; \
- if (!debugStorageExtra) { \
- tab_name[n-TAB_BASE_ADDR].nextFree = free_list; \
- free_list = n; \
- } \
- } \
- \
- type_name proc_name ( void ) \
- { \
- Int i; \
- Int newSz; \
- struct struct_name* newTab; \
- struct struct_name* temp; \
- try_again: \
- if (free_list != TAB_BASE_ADDR-1) { \
- type_name t = free_list; \
- free_list = tab_name[free_list-TAB_BASE_ADDR].nextFree; \
- assert (!(tab_name[t-TAB_BASE_ADDR].inUse)); \
- tab_name[t-TAB_BASE_ADDR].inUse = TRUE; \
- return t; \
- } \
- \
- newSz = (tab_size == 0 ? TAB_INIT_SIZE : 2 * tab_size); \
- if (newSz > TAB_MAX_SIZE) goto cant_allocate; \
- newTab = malloc(newSz * sizeof(struct struct_name)); \
- if (!newTab) goto cant_allocate; \
- for (i = 0; i < tab_size; i++) \
- newTab[i] = tab_name[i]; \
- for (i = tab_size; i < newSz; i++) { \
- newTab[i].inUse = FALSE; \
- newTab[i].nextFree = i-1+TAB_BASE_ADDR; \
- } \
- if (0 && debugStorageExtra) \
- fprintf(stderr, "Expanding " #type_name \
- "table to size %d\n", newSz ); \
- newTab[tab_size].nextFree = TAB_BASE_ADDR-1; \
- free_list = newSz-1+TAB_BASE_ADDR; \
- tab_size = newSz; \
- temp = tab_name; \
- tab_name = newTab; \
- if (temp) free(temp); \
- goto try_again; \
- \
- cant_allocate: \
- ERRMSG(0) err_msg \
- EEND; \
- } \
-
-
-
-EXPANDABLE_SYMBOL_TABLE(Name,strName,allocNewName,freeName,
- nameFL,tabName,tabNameSz,
- "Name storage space exhausted",
- NAME_INIT_SIZE,NAME_MAX_SIZE,NAME_BASE_ADDR)
-
-
-EXPANDABLE_SYMBOL_TABLE(Tycon,strTycon,allocNewTycon,freeTycon,
- tyconFL,tabTycon,tabTyconSz,
- "Type constructor storage space exhausted",
- TYCON_INIT_SIZE,TYCON_MAX_SIZE,TYCON_BASE_ADDR)
-
-
-EXPANDABLE_SYMBOL_TABLE(Class,strClass,allocNewClass,freeClass,
- classFL,tabClass,tabClassSz,
- "Class storage space exhausted",
- CCLASS_INIT_SIZE,CCLASS_MAX_SIZE,CCLASS_BASE_ADDR)
-
-
-EXPANDABLE_SYMBOL_TABLE(Inst,strInst,allocNewInst,freeInst,
- instFL,tabInst,tabInstSz,
- "Instance storage space exhausted",
- INST_INIT_SIZE,INST_MAX_SIZE,INST_BASE_ADDR)
-
-
-EXPANDABLE_SYMBOL_TABLE(Module,strModule,allocNewModule,freeModule,
- moduleFL,tabModule,tabModuleSz,
- "Module storage space exhausted",
- MODULE_INIT_SIZE,MODULE_MAX_SIZE,MODULE_BASE_ADDR)
-
-#ifdef DEBUG_STORAGE
-struct strName* generate_name_ref ( Cell nm )
-{
- assert(isName(nm));
- nm -= NAME_BASE_ADDR;
- assert(tabName[nm].inUse);
- assert(isModule(tabName[nm].mod));
- return & tabName[nm];
-}
-struct strTycon* generate_tycon_ref ( Cell tc )
-{
- assert(isTycon(tc) || isTuple(tc));
- tc -= TYCON_BASE_ADDR;
- assert(tabTycon[tc].inUse);
- assert(isModule(tabTycon[tc].mod));
- return & tabTycon[tc];
-}
-struct strClass* generate_cclass_ref ( Cell cl )
-{
- assert(isClass(cl));
- cl -= CCLASS_BASE_ADDR;
- assert(tabClass[cl].inUse);
- assert(isModule(tabClass[cl].mod));
- return & tabClass[cl];
-}
-struct strInst* generate_inst_ref ( Cell in )
-{
- assert(isInst(in));
- in -= INST_BASE_ADDR;
- assert(tabInst[in].inUse);
- assert(isModule(tabInst[in].mod));
- return & tabInst[in];
-}
-struct strModule* generate_module_ref ( Cell mo )
-{
- assert(isModule(mo));
- mo -= MODULE_BASE_ADDR;
- assert(tabModule[mo].inUse);
- return & tabModule[mo];
-}
-#endif
-
-
-/* --------------------------------------------------------------------------
- * Tycon storage:
- *
- * A Tycon represents a user defined type constructor. Tycons are indexed
- * by Text values ... a very simple hash function is used to improve lookup
- * times. Tycon entries with the same hash code are chained together, with
- * the most recent entry at the front of the list.
- * ------------------------------------------------------------------------*/
-
-#define TYCONHSZ 256 /* Size of Tycon hash table*/
-static Tycon tyconHash[TYCONHSZ]; /* Hash table storage */
-
-static int tHash(Text x)
-{
- int r;
- assert(isText(x) || inventedText(x));
- x -= TEXT_BASE_ADDR;
- if (x < 0) x = -x;
- r= x%TYCONHSZ;
- assert(r>=0);
- assert(r<TYCONHSZ);
- return r;
-}
-
-static int RC_T ( int x )
-{
- assert (x >= 0 && x < TYCONHSZ);
- return x;
-}
-
-Tycon newTycon ( Text t ) /* add new tycon to tycon table */
-{
- Int h = tHash(t);
- Tycon tc = allocNewTycon();
- tabTycon
- [tc-TYCON_BASE_ADDR].tuple = -1;
- tabTycon
- [tc-TYCON_BASE_ADDR].mod = currentModule;
- tycon(tc).text = t; /* clear new tycon record */
- tycon(tc).kind = NIL;
- tycon(tc).defn = NIL;
- tycon(tc).what = NIL;
- tycon(tc).conToTag = NIL;
- tycon(tc).tagToCon = NIL;
- tycon(tc).itbl = NULL;
- tycon(tc).arity = 0;
- tycon(tc).closure = NIL;
- module(currentModule).tycons = cons(tc,module(currentModule).tycons);
- tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
- tyconHash[RC_T(h)] = tc;
- return tc;
-}
-
-Tycon findTycon(t) /* locate Tycon in tycon table */
-Text t; {
- Tycon tc = tyconHash[RC_T(tHash(t))];
- assert(isTycon(tc) || isTuple(tc) || isNull(tc));
- 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;
- assert(isTycon(tc) || isTuple(tc));
- oldtc = findTycon(tycon(tc).text);
- if (isNull(oldtc)) {
- hashTycon(tc);
- module(currentModule).tycons=cons(tc,module(currentModule).tycons);
- return tc;
- } else
- return oldtc;
-}
-
-static Void local hashTycon(tc) /* Insert Tycon into hash table */
-Tycon tc; {
- Text t;
- Int h;
- assert(isTycon(tc) || isTuple(tc));
- {int i; for (i = 0; i < TYCONHSZ; i++)
- assert (tyconHash[i] == 0
- || isTycon(tyconHash[i])
- || isTuple(tyconHash[i]));
- }
- t = tycon(tc).text;
- h = tHash(t);
- tycon(tc).nextTyconHash = tyconHash[RC_T(h)];
- tyconHash[RC_T(h)] = tc;
-}
-
-Tycon findQualTycon(id) /*locate (possibly qualified) Tycon in tycon table */
-Cell id; {
- if (!isPair(id)) internal("findQualTycon");
- switch (fst(id)) {
- case CONIDCELL :
- case CONOPCELL :
- return findTycon(textOf(id));
- case QUALIDENT : {
- Text t = qtextOf(id);
- Module m = findQualifier(qmodOf(id));
- List es = NIL;
- if (isNull(m)) return NIL;
- for(es=module(m).exports; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isPair(e) && isTycon(fst(e)) && tycon(fst(e)).text==t)
- return fst(e);
- }
- return NIL;
- }
- default : internal("findQualTycon2");
- }
- return NIL; /* NOTREACHED */
-}
-
-Tycon addPrimTycon(t,kind,ar,what,defn) /* add new primitive type constr */
-Text t;
-Kind kind;
-Int ar;
-Cell what;
-Cell defn; {
- Tycon tc = newTycon(t);
- tycon(tc).line = 0;
- tycon(tc).kind = kind;
- tycon(tc).what = what;
- tycon(tc).defn = defn;
- tycon(tc).arity = ar;
- return tc;
-}
-
-static List local insertTycon(tc,ts) /* insert tycon tc into sorted list*/
-Tycon tc; /* ts */
-List ts; {
- Cell prev = NIL;
- Cell curr = ts;
- String s = textToStr(tycon(tc).text);
-
- while (nonNull(curr) && strCompare(s,textToStr(tycon(hd(curr)).text))>=0) {
- if (hd(curr)==tc) /* just in case we get duplicates! */
- return ts;
- prev = curr;
- curr = tl(curr);
- }
- if (nonNull(prev)) {
- tl(prev) = cons(tc,curr);
- return ts;
- }
- else
- return cons(tc,curr);
-}
-
-List addTyconsMatching(pat,ts) /* Add tycons matching pattern pat */
-String pat; /* to list of Tycons ts */
-List ts; { /* Null pattern matches every tycon*/
- Tycon tc; /* (Tycons with NIL kind excluded) */
- for (tc = TYCON_BASE_ADDR;
- tc < TYCON_BASE_ADDR+tabTyconSz; ++tc)
- if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
- if (!pat || stringMatch(pat,textToStr(tycon(tc).text)))
- if (nonNull(tycon(tc).kind))
- ts = insertTycon(tc,ts);
- return ts;
-}
-
-Text ghcTupleText_n ( Int n )
-{
- Int i;
- Int x = 0;
- char buf[104];
- if (n < 0 || n >= 100) internal("ghcTupleText_n");
- if (n == 1) internal("ghcTupleText_n==1");
- buf[x++] = '(';
- for (i = 1; i <= n-1; i++) buf[x++] = ',';
- buf[x++] = ')';
- buf[x++] = 0;
- return findText(buf);
-}
-
-Text ghcTupleText(tup)
-Tycon tup; {
- if (!isTuple(tup)) {
- assert(isTuple(tup));
- }
- return ghcTupleText_n ( tupleOf(tup) );
-}
-
-
-Tycon mkTuple ( Int n )
-{
- Int i;
- if (n >= NUM_TUPLES)
- internal("mkTuple: request for tuple of unsupported size");
- for (i = TYCON_BASE_ADDR;
- i < TYCON_BASE_ADDR+tabTyconSz; i++)
- if (tabTycon[i-TYCON_BASE_ADDR].inUse)
- if (tycon(i).tuple == n) return i;
- internal("mkTuple: request for non-existent tuple");
-}
-
-
-/* --------------------------------------------------------------------------
- * Name storage:
- *
- * A Name represents a top level binding of a value to an identifier.
- * Such values may be a constructor function, a member function in a
- * class, a user-defined or primitive value/function.
- *
- * Names are indexed by Text values ... a very simple hash functions speeds
- * access to the table of Names and Name entries with the same hash value
- * are chained together, with the most recent entry at the front of the
- * list.
- * ------------------------------------------------------------------------*/
-
-#define NAMEHSZ 256 /* Size of Name hash table */
-static Name nameHash[NAMEHSZ]; /* Hash table storage */
-
-static int nHash(Text x)
-{
- assert(isText(x) || inventedText(x));
- x -= TEXT_BASE_ADDR;
- if (x < 0) x = -x;
- return x%NAMEHSZ;
-}
-
-int RC_N ( int x )
-{
- assert (x >= 0 && x < NAMEHSZ);
- return x;
-}
-
-void hashSanity ( void )
-{
- Int i, j;
- for (i = 0; i < TYCONHSZ; i++) {
- j = tyconHash[i];
- while (nonNull(j)) {
- assert(isTycon(j) || isTuple(j));
- j = tycon(j).nextTyconHash;
- }
- }
- for (i = 0; i < NAMEHSZ; i++) {
- j = nameHash[i];
- while (nonNull(j)) {
- assert(isName(j));
- j = name(j).nextNameHash;
- }
- }
-}
-
-Name newName ( Text t, Cell parent ) /* Add new name to name table */
-{
- Int h = nHash(t);
- Name nm = allocNewName();
- tabName
- [nm-NAME_BASE_ADDR].mod = currentModule;
- name(nm).text = t; /* clear new name record */
- name(nm).line = 0;
- name(nm).syntax = NO_SYNTAX;
- name(nm).parent = parent;
- name(nm).arity = 0;
- name(nm).number = EXECNAME;
- name(nm).defn = NIL;
- name(nm).hasStrict = FALSE;
- name(nm).callconv = NIL;
- name(nm).type = NIL;
- name(nm).primop = NULL;
- name(nm).itbl = NULL;
- name(nm).closure = NIL;
- module(currentModule).names = cons(nm,module(currentModule).names);
- name(nm).nextNameHash = nameHash[RC_N(h)];
- nameHash[RC_N(h)] = nm;
- return nm;
-}
-
-Name findName(t) /* Locate name in name table */
-Text t; {
- Name n = nameHash[RC_N(nHash(t))];
- assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
- assert(isName(n) || isNull(n));
- 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;
- assert(isName(nm));
- oldnm = findName(name(nm).text);
- if (isNull(oldnm)) {
- hashName(nm);
- module(currentModule).names=cons(nm,module(currentModule).names);
- return nm;
- } else
- return oldnm;
-}
-
-static Void local hashName(nm) /* Insert Name into hash table */
-Name nm; {
- Text t;
- Int h;
- assert(isName(nm));
- t = name(nm).text;
- h = nHash(t);
- name(nm).nextNameHash = nameHash[RC_N(h)];
- nameHash[RC_N(h)] = nm;
-}
-
-Name findQualName(id) /* Locate (possibly qualified) name*/
-Cell id; { /* in name table */
- if (!isPair(id))
- internal("findQualName");
- switch (fst(id)) {
- case VARIDCELL :
- case VAROPCELL :
- case CONIDCELL :
- case CONOPCELL :
- return findName(textOf(id));
- case QUALIDENT : {
- Text t = qtextOf(id);
- Module m = findQualifier(qmodOf(id));
- List es = NIL;
- if (isNull(m)) return NIL;
- for(es=module(m).exports; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isName(e) && name(e).text==t)
- return e;
- else if (isPair(e) && DOTDOT==snd(e)) {
- List subentities = NIL;
- Cell c = fst(e);
- if (isTycon(c)
- && (tycon(c).what==DATATYPE || tycon(c).what==NEWTYPE))
- subentities = tycon(c).defn;
- else if (isClass(c))
- subentities = cclass(c).members;
- for(; nonNull(subentities); subentities=tl(subentities)) {
- if (!isName(hd(subentities)))
- internal("findQualName3");
- if (name(hd(subentities)).text == t)
- return hd(subentities);
- }
- }
- }
- return NIL;
- }
- default : internal("findQualName2");
- }
- return 0; /* NOTREACHED */
-}
-
-
-void* /* StgClosure* */ getHugs_BCO_cptr_for ( char* s )
-{
- Text t = findText(s);
- Name n = NIL;
- for (n = NAME_BASE_ADDR;
- n < NAME_BASE_ADDR+tabNameSz; n++)
- if (tabName[n-NAME_BASE_ADDR].inUse && name(n).text == t)
- break;
- if (n == NAME_BASE_ADDR+tabNameSz) {
- fprintf ( stderr, "can't find `%s' in ...\n", s );
- internal("getHugs_BCO_cptr_for(1)");
- }
- if (!isCPtr(name(n).closure))
- internal("getHugs_BCO_cptr_for(2)");
- return cptrOf(name(n).closure);
-}
-
-/* --------------------------------------------------------------------------
- * Primitive functions:
- * ------------------------------------------------------------------------*/
-
-Module findFakeModule ( Text t )
-{
- Module m = findModule(t);
- if (nonNull(m)) {
- if (!module(m).fake) internal("findFakeModule");
- } else {
- m = newModule(t);
- module(m).fake = TRUE;
- }
- return m;
-}
-
-
-Name addWiredInBoxingTycon
- ( String modNm, String typeNm, String constrNm,
- Int rep, Kind kind )
-{
- Name n;
- Tycon t;
- Text modT = findText(modNm);
- Text typeT = findText(typeNm);
- Text conT = findText(constrNm);
- Module m = findFakeModule(modT);
- setCurrModule(m);
-
- n = newName(conT,NIL);
- name(n).arity = 1;
- name(n).number = cfunNo(0);
- name(n).type = NIL;
- name(n).primop = (void*)rep;
-
- t = newTycon(typeT);
- tycon(t).what = DATATYPE;
- tycon(t).kind = kind;
- return n;
-}
-
-
-Tycon addTupleTycon ( Int n )
-{
- Int i;
- Kind k;
- Tycon t;
- Module m;
- Name nm;
-
- for (i = TYCON_BASE_ADDR;
- i < TYCON_BASE_ADDR+tabTyconSz; i++)
- if (tabTycon[i-TYCON_BASE_ADDR].inUse)
- if (tycon(i).tuple == n) return i;
-
- if (combined)
- m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
- m = findModule(findText("PrelPrim"));
-
- setCurrModule(m);
- k = STAR;
- for (i = 0; i < n; i++) k = ap(STAR,k);
- t = newTycon(ghcTupleText_n(n));
- tycon(t).kind = k;
- tycon(t).tuple = n;
- tycon(t).what = DATATYPE;
-
- if (n == 0) {
- /* maybe we want to do this for all n ? */
- nm = newName(ghcTupleText_n(n), t);
- name(nm).type = t; /* ummm ... for n > 0 */
- }
-
- return t;
-}
-
-
-Tycon addWiredInEnumTycon ( String modNm, String typeNm,
- List /*of Text*/ constrs )
-{
- Int i;
- Tycon t;
- Text modT = findText(modNm);
- Text typeT = findText(typeNm);
- Module m = findFakeModule(modT);
- setCurrModule(m);
-
- t = newTycon(typeT);
- tycon(t).kind = STAR;
- tycon(t).what = DATATYPE;
-
- constrs = reverse(constrs);
- i = length(constrs);
- for (; nonNull(constrs); constrs=tl(constrs),i--) {
- Text conT = hd(constrs);
- Name con = newName(conT,t);
- name(con).number = cfunNo(i);
- name(con).type = t;
- name(con).parent = t;
- tycon(t).defn = cons(con, tycon(t).defn);
- }
- return t;
-}
-
-
-Name addPrimCfunREP(t,arity,no,rep) /* add primitive constructor func */
-Text t; /* sets rep, not type */
-Int arity;
-Int no;
-Int rep; { /* Really AsmRep */
- Name n = newName(t,NIL);
- name(n).arity = arity;
- name(n).number = cfunNo(no);
- name(n).type = NIL;
- name(n).primop = (void*)rep;
- return n;
-}
-
-
-Name addPrimCfun(t,arity,no,type) /* add primitive constructor func */
-Text t;
-Int arity;
-Int no;
-Cell type; {
- Name n = newName(t,NIL);
- name(n).arity = arity;
- name(n).number = cfunNo(no);
- name(n).type = type;
- return n;
-}
-
-
-Int sfunPos(s,c) /* Find position of field with */
-Name s; /* selector s in constructor c. */
-Name c; {
- List cns;
- cns = name(s).defn;
- for (; nonNull(cns); cns=tl(cns))
- if (fst(hd(cns))==c)
- return intOf(snd(hd(cns)));
- internal("sfunPos");
- return 0;/* NOTREACHED */
-}
-
-static List local insertName(nm,ns) /* insert name nm into sorted list */
-Name nm; /* ns */
-List ns; {
- Cell prev = NIL;
- Cell curr = ns;
- String s = textToStr(name(nm).text);
-
- while (nonNull(curr) && strCompare(s,textToStr(name(hd(curr)).text))>=0) {
- if (hd(curr)==nm) /* just in case we get duplicates! */
- return ns;
- prev = curr;
- curr = tl(curr);
- }
- if (nonNull(prev)) {
- tl(prev) = cons(nm,curr);
- return ns;
- }
- else
- return cons(nm,curr);
-}
-
-List addNamesMatching(pat,ns) /* Add names matching pattern pat */
-String pat; /* to list of names ns */
-List ns; { /* Null pattern matches every name */
- Name nm; /* (Names with NIL type, or hidden */
- /* or invented names are excluded) */
-#if 1
- for (nm = NAME_BASE_ADDR;
- nm < NAME_BASE_ADDR+tabNameSz; ++nm)
- if (tabName[nm-NAME_BASE_ADDR].inUse) {
- if (!inventedText(name(nm).text) && nonNull(name(nm).type)) {
- String str = textToStr(name(nm).text);
- if (str[0]!='_' && (!pat || stringMatch(pat,str)))
- ns = insertName(nm,ns);
- }
- }
- return ns;
-#else
- List mns = module(currentModule).names;
- for(; nonNull(mns); mns=tl(mns)) {
- Name nm = hd(mns);
- if (!inventedText(name(nm).text)) {
- String str = textToStr(name(nm).text);
- if (str[0]!='_' && (!pat || stringMatch(pat,str)))
- ns = insertName(nm,ns);
- }
- }
- return ns;
-#endif
-}
-
-/* --------------------------------------------------------------------------
- * A simple string matching routine
- * `*' matches any sequence of zero or more characters
- * `?' matches any single character exactly
- * `@str' matches the string str exactly (ignoring any special chars)
- * `\c' matches the character c only (ignoring special chars)
- * c matches the character c only
- * ------------------------------------------------------------------------*/
-
-static Void local patternError(s) /* report error in pattern */
-String s; {
- ERRMSG(0) "%s in pattern", s
- EEND;
-}
-
-static Bool local stringMatch(pat,str) /* match string against pattern */
-String pat;
-String str; {
-
- for (;;)
- switch (*pat) {
- case '\0' : return (*str=='\0');
-
- case '*' : do {
- if (stringMatch(pat+1,str))
- return TRUE;
- } while (*str++);
- return FALSE;
-
- case '?' : if (*str++=='\0')
- return FALSE;
- pat++;
- break;
-
- case '[' : { Bool found = FALSE;
- while (*++pat!='\0' && *pat!=']')
- if (!found && ( pat[0] == *str ||
- (pat[1] == '-' &&
- pat[2] != ']' &&
- pat[2] != '\0' &&
- pat[0] <= *str &&
- pat[2] >= *str)))
-
- found = TRUE;
- if (*pat != ']')
- patternError("missing `]'");
- if (!found)
- return FALSE;
- pat++;
- str++;
- }
- break;
-
- case '\\' : if (*++pat == '\0')
- patternError("extra trailing `\\'");
- /*fallthru!*/
- default : if (*pat++ != *str++)
- return FALSE;
- break;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Storage of type classes, instances etc...:
- * ------------------------------------------------------------------------*/
-
-static List classes; /* list of classes in current scope */
-
-Class newClass ( Text t ) /* add new class to class table */
-{
- Class cl = allocNewClass();
- tabClass
- [cl-CCLASS_BASE_ADDR].mod = currentModule;
- cclass(cl).text = t;
- cclass(cl).arity = 0;
- cclass(cl).kinds = NIL;
- cclass(cl).head = NIL;
- cclass(cl).fds = NIL;
- cclass(cl).xfds = NIL;
- cclass(cl).dcon = NIL;
- cclass(cl).supers = NIL;
- cclass(cl).dsels = NIL;
- cclass(cl).members = NIL;
- cclass(cl).defaults = NIL;
- cclass(cl).instances = NIL;
- classes = cons(cl,classes);
- module(currentModule).classes
- = cons(cl,module(currentModule).classes);
- return cl;
-}
-
-Class findClass(t) /* look for named class in table */
-Text t; {
- Class cl;
- List cs;
- for (cs=classes; nonNull(cs); cs=tl(cs)) {
- cl=hd(cs);
- if (cclass(cl).text==t)
- return cl;
- }
- return NIL;
-}
-
-Class addClass(c) /* Insert Class in class list */
-Class c; { /* - if no clash caused */
- Class oldc;
- assert(whatIs(c)==CLASS);
- oldc = findClass(cclass(c).text);
- if (isNull(oldc)) {
- classes=cons(c,classes);
- module(currentModule).classes=cons(c,module(currentModule).classes);
- return c;
- }
- else
- return oldc;
-}
-
-Class findQualClass(c) /* Look for (possibly qualified) */
-Cell c; { /* class in class list */
- if (!isQualIdent(c)) {
- return findClass(textOf(c));
- } else {
- Text t = qtextOf(c);
- Module m = findQualifier(qmodOf(c));
- List es = NIL;
- if (isNull(m))
- return NIL;
- for (es=module(m).exports; nonNull(es); es=tl(es)) {
- Cell e = hd(es);
- if (isPair(e) && isClass(fst(e)) && cclass(fst(e)).text==t)
- return fst(e);
- }
- }
- return NIL;
-}
-
-Inst newInst() { /* Add new instance to table */
- Inst in = allocNewInst();
- tabInst
- [in-INST_BASE_ADDR].mod = currentModule;
- inst(in).kinds = NIL;
- inst(in).head = NIL;
- inst(in).specifics = NIL;
- inst(in).numSpecifics = 0;
- inst(in).implements = NIL;
- inst(in).builder = NIL;
- return in;
-}
-
-#ifdef DEBUG_DICTS
-extern Void printInst ( Inst));
-
-Void printInst(in)
-Inst in; {
- Class cl = inst(in).c;
- Printf("%s-", textToStr(cclass(cl).text));
- printType(stdout,inst(in).t);
-}
-#endif /* DEBUG_DICTS */
-
-Inst findFirstInst(tc) /* look for 1st instance involving */
-Tycon tc; { /* the type constructor tc */
- return findNextInst(tc,INST_BASE_ADDR-1);
-}
-
-Inst findNextInst(tc,in) /* look for next instance involving*/
-Tycon tc; /* the type constructor tc */
-Inst in; { /* starting after instance in */
- Cell pi;
- while (++in < INST_BASE_ADDR+tabInstSz) {
- if (!tabInst[in-INST_BASE_ADDR].inUse) continue;
- assert(isModule(inst(in).mod));
- pi = inst(in).head;
- for (; isAp(pi); pi=fun(pi))
- if (typeInvolves(arg(pi),tc))
- return in;
- }
- return NIL;
-}
-
-static Bool local typeInvolves(ty,tc) /* Test to see if type ty involves */
-Type ty; /* type constructor/tuple tc. */
-Type tc; {
- return (ty==tc)
- || (isAp(ty) && (typeInvolves(fun(ty),tc)
- || typeInvolves(arg(ty),tc)));
-}
-
-
-/* Needed by finishGHCInstance to find classes, before the
- export list has been built -- so we can't use
- findQualClass.
-*/
-Class findQualClassWithoutConsultingExportList ( QualId q )
-{
- Class cl;
- Text t_mod;
- Text t_class;
-
- assert(isQCon(q));
-
- if (isCon(q)) {
- t_mod = NIL;
- t_class = textOf(q);
- } else {
- t_mod = qmodOf(q);
- t_class = qtextOf(q);
- }
-
- for (cl = CCLASS_BASE_ADDR;
- cl < CCLASS_BASE_ADDR+tabClassSz; cl++) {
- if (tabClass[cl-CCLASS_BASE_ADDR].inUse)
- if (cclass(cl).text == t_class) {
- /* Class name is ok, but is this the right module? */
- if (isNull(t_mod) /* no module name specified */
- || (nonNull(t_mod)
- && t_mod == module(cclass(cl).mod).text)
- )
- return cl;
- }
- }
- return NIL;
-}
-
-/* Same deal, except for Tycons. */
-Tycon findQualTyconWithoutConsultingExportList ( QualId q )
-{
- Tycon tc;
- Text t_mod;
- Text t_tycon;
-
- assert(isQCon(q));
-
- if (isCon(q)) {
- t_mod = NIL;
- t_tycon = textOf(q);
- } else {
- t_mod = qmodOf(q);
- t_tycon = qtextOf(q);
- }
-
- for (tc = TYCON_BASE_ADDR;
- tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
- if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
- if (tycon(tc).text == t_tycon) {
- /* Tycon name is ok, but is this the right module? */
- if (isNull(t_mod) /* no module name specified */
- || (nonNull(t_mod)
- && t_mod == module(tycon(tc).mod).text)
- )
- return tc;
- }
- }
- return NIL;
-}
-
-/* Same deal, except for Names. */
-Name findQualNameWithoutConsultingExportList ( QualId q )
-{
- Name nm;
- Text t_mod;
- Text t_name;
-
- assert(isQVar(q) || isQCon(q));
-
- if (isCon(q) || isVar(q)) {
- t_mod = NIL;
- t_name = textOf(q);
- } else {
- t_mod = qmodOf(q);
- t_name = qtextOf(q);
- }
-
- for (nm = NAME_BASE_ADDR;
- nm < NAME_BASE_ADDR+tabNameSz; nm++) {
- if (tabName[nm-NAME_BASE_ADDR].inUse)
- if (name(nm).text == t_name) {
- /* Name is ok, but is this the right module? */
- if (isNull(t_mod) /* no module name specified */
- || (nonNull(t_mod)
- && t_mod == module(name(nm).mod).text)
- )
- return nm;
- }
- }
- return NIL;
-}
-
-
-Tycon findTyconInAnyModule ( Text t )
-{
- Tycon tc;
- for (tc = TYCON_BASE_ADDR;
- tc < TYCON_BASE_ADDR+tabTyconSz; tc++)
- if (tabTycon[tc-TYCON_BASE_ADDR].inUse)
- if (tycon(tc).text == t) return tc;
- return NIL;
-}
-
-Class findClassInAnyModule ( Text t )
-{
- Class cc;
- for (cc = CCLASS_BASE_ADDR;
- cc < CCLASS_BASE_ADDR+tabClassSz; cc++)
- if (tabClass[cc-CCLASS_BASE_ADDR].inUse)
- if (cclass(cc).text == t) return cc;
- return NIL;
-}
-
-Name findNameInAnyModule ( Text t )
-{
- Name nm;
- for (nm = NAME_BASE_ADDR;
- nm < NAME_BASE_ADDR+tabNameSz; nm++)
- if (tabName[nm-NAME_BASE_ADDR].inUse)
- if (name(nm).text == t) return nm;
- return NIL;
-}
-
-
-/* returns List of QualId */
-List getAllKnownTyconsAndClasses ( void )
-{
- Tycon tc;
- Class nw;
- List xs = NIL;
- for (tc = TYCON_BASE_ADDR;
- tc < TYCON_BASE_ADDR+tabTyconSz; tc++) {
- if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
- /* almost certainly undue paranoia about duplicate avoidance */
- QualId q = mkQCon( module(tycon(tc).mod).text, tycon(tc).text );
- if (!qualidIsMember(q,xs))
- xs = cons ( q, xs );
- }
- }
- for (nw = CCLASS_BASE_ADDR;
- nw < CCLASS_BASE_ADDR+tabClassSz; nw++) {
- if (tabClass[nw-CCLASS_BASE_ADDR].inUse) {
- QualId q = mkQCon( module(cclass(nw).mod).text, cclass(nw).text );
- if (!qualidIsMember(q,xs))
- xs = cons ( q, xs );
- }
- }
- return xs;
-}
-
-Int numQualifiers ( Type t )
-{
- if (isPolyType(t)) t = monotypeOf(t);
- if (isQualType(t))
- return length ( fst(snd(t)) ); else
- return 0;
-}
-
-
-/* Purely for debugging. */
-void locateSymbolByName ( Text t )
-{
- Int i;
- for (i = NAME_BASE_ADDR;
- i < NAME_BASE_ADDR+tabNameSz; i++)
- if (tabName[i-NAME_BASE_ADDR].inUse && name(i).text == t)
- fprintf ( stderr, "name(%d)\n", i-NAME_BASE_ADDR);
- for (i = TYCON_BASE_ADDR;
- i < TYCON_BASE_ADDR+tabTyconSz; i++)
- if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).text == t)
- fprintf ( stderr, "tycon(%d)\n", i-TYCON_BASE_ADDR);
- for (i = CCLASS_BASE_ADDR;
- i < CCLASS_BASE_ADDR+tabClassSz; i++)
- if (tabClass[i-CCLASS_BASE_ADDR].inUse && cclass(i).text == t)
- fprintf ( stderr, "class(%d)\n", i-CCLASS_BASE_ADDR);
-}
-
-/* --------------------------------------------------------------------------
- * Control stack:
- *
- * Various parts of the system use a stack of cells. Most of the stack
- * operations are defined as macros, expanded inline.
- * ------------------------------------------------------------------------*/
-
-Cell cellStack[NUM_STACK]; /* Storage for cells on stack */
-StackPtr sp; /* stack pointer */
-
-Void hugsStackOverflow() { /* Report stack overflow */
- ERRMSG(0) "Control stack overflow"
- EEND;
-}
-
-
-/* --------------------------------------------------------------------------
- * Module storage:
- *
- * A Module represents a user defined module.
- *
- * Note: there are now two lookup mechanisms in the system:
- *
- * 1) The exports from a module are stored in a big list.
- * We resolve qualified names, and import lists by linearly scanning
- * through this list.
- *
- * 2) Unqualified imports and local definitions for the current module
- * are stored in hash tables (tyconHash and nameHash) or linear lists
- * (classes).
- *
- * ------------------------------------------------------------------------*/
-
-Module currentModule; /* Module currently being processed*/
-
-Bool isValidModule(m) /* is m a legitimate module id? */
-Module m; {
- return isModule(m);
-}
-
-Module newModule ( Text t ) /* add new module to module table */
-{
- Module mod = allocNewModule();
- module(mod).text = t; /* clear new module record */
-
- module(mod).tycons = NIL;
- module(mod).names = NIL;
- module(mod).classes = NIL;
- module(mod).exports = NIL;
- module(mod).qualImports = NIL;
- module(mod).codeList = NIL;
- module(mod).fake = FALSE;
-
- module(mod).tree = NIL;
- module(mod).completed = FALSE;
- module(mod).lastStamp = 0; /* ???? */
-
- module(mod).mode = NIL;
- module(mod).srcExt = findText("");
- module(mod).uses = NIL;
-
- module(mod).objName = findText("");
- module(mod).objSize = 0;
-
- module(mod).object = NULL;
- module(mod).objectExtras = NULL;
- module(mod).objectExtraNames = NIL;
- return mod;
-}
-
-
-Bool nukeModule_needs_major_gc = TRUE;
-
-void nukeModule ( Module m )
-{
- ObjectCode* oc;
- ObjectCode* oc2;
- Int i;
-
- if (!isModule(m)) internal("nukeModule");
-
- /* fprintf ( stderr, "NUKE MODULE %s\n", textToStr(module(m).text) ); */
-
- /* see comment in compiler.c about this,
- and interaction with info tables */
- if (nukeModule_needs_major_gc) {
- /* fprintf ( stderr, "doing major GC in nukeModule\n"); */
- /* performMajorGC(); */
- nukeModule_needs_major_gc = FALSE;
- }
-
- oc = module(m).object;
- while (oc) {
- oc2 = oc->next;
- ocFree(oc);
- oc = oc2;
- }
- oc = module(m).objectExtras;
- while (oc) {
- oc2 = oc->next;
- ocFree(oc);
- oc = oc2;
- }
-
- for (i = NAME_BASE_ADDR; i < NAME_BASE_ADDR+tabNameSz; i++)
- if (tabName[i-NAME_BASE_ADDR].inUse && name(i).mod == m) {
- if (name(i).itbl &&
- module(name(i).mod).mode == FM_SOURCE) {
- free(name(i).itbl);
- }
- name(i).itbl = NULL;
- name(i).closure = NIL;
- freeName(i);
- }
-
- for (i = TYCON_BASE_ADDR; i < TYCON_BASE_ADDR+tabTyconSz; i++)
- if (tabTycon[i-TYCON_BASE_ADDR].inUse && tycon(i).mod == m) {
- if (tycon(i).itbl &&
- module(tycon(i).mod).mode == FM_SOURCE) {
- free(tycon(i).itbl);
- }
- tycon(i).itbl = NULL;
- freeTycon(i);
- }
-
- for (i = CCLASS_BASE_ADDR; i < CCLASS_BASE_ADDR+tabClassSz; i++)
- if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
- if (cclass(i).mod == m) {
- freeClass(i);
- } else {
- List /* Inst */ ins;
- List /* Inst */ ins2 = NIL;
- for (ins = cclass(i).instances; nonNull(ins); ins=tl(ins))
- if (inst(hd(ins)).mod != m)
- ins2 = cons(hd(ins),ins2);
- cclass(i).instances = ins2;
- }
- }
-
-
- for (i = INST_BASE_ADDR; i < INST_BASE_ADDR+tabInstSz; i++)
- if (tabInst[i-INST_BASE_ADDR].inUse && inst(i).mod == m)
- freeInst(i);
-
- freeModule(m);
- //for (i = 0; i < TYCONHSZ; i++) tyconHash[i] = 0;
- //for (i = 0; i < NAMEHSZ; i++) nameHash[i] = 0;
- //classes = NIL;
- //hashSanity();
-}
-
-void ppModules ( void )
-{
- Int i;
- fflush(stderr); fflush(stdout);
- printf ( "begin MODULES\n" );
- for (i = MODULE_BASE_ADDR+tabModuleSz-1;
- i >= MODULE_BASE_ADDR; i--)
- if (tabModule[i-MODULE_BASE_ADDR].inUse)
- printf ( " %2d: %16s\n",
- i-MODULE_BASE_ADDR, textToStr(module(i).text)
- );
- printf ( "end MODULES\n" );
- fflush(stderr); fflush(stdout);
-}
-
-
-Module findModule(t) /* locate Module in module table */
-Text t; {
- Module m;
- for(m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; ++m) {
- if (tabModule[m-MODULE_BASE_ADDR].inUse)
- if (module(m).text==t)
- return m;
- }
- return NIL;
-}
-
-Module findModid(c) /* Find module by name or filename */
-Cell c; {
- switch (whatIs(c)) {
- case STRCELL : internal("findModid-STRCELL unimp");
- case CONIDCELL : return findModule(textOf(c));
- default : internal("findModid");
- }
- return NIL;/*NOTUSED*/
-}
-
-static local Module findQualifier(t) /* locate Module in import list */
-Text t; {
- Module ms;
- for (ms=module(currentModule).qualImports; nonNull(ms); ms=tl(ms)) {
- if (textOf(fst(hd(ms)))==t)
- return snd(hd(ms));
- }
- if (module(currentModule).text==t)
- return currentModule;
- return NIL;
-}
-
-Void setCurrModule(m) /* set lookup tables for current module */
-Module m; {
- Int i;
- assert(isModule(m));
- /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
- {List t;
- for (t = module(m).names; nonNull(t); t=tl(t))
- assert(isName(hd(t)));
- for (t = module(m).tycons; nonNull(t); t=tl(t))
- assert(isTycon(hd(t)) || isTuple(hd(t)));
- for (t = module(m).classes; nonNull(t); t=tl(t))
- assert(isClass(hd(t)));
- }
-
- currentModule = m; /* This is the only assignment to currentModule */
- for (i=0; i<TYCONHSZ; ++i)
- tyconHash[RC_T(i)] = NIL;
- mapProc(hashTycon,module(m).tycons);
- for (i=0; i<NAMEHSZ; ++i)
- nameHash[RC_N(i)] = NIL;
- mapProc(hashName,module(m).names);
- classes = module(m).classes;
- hashSanity();
-}
-
-void addToCodeList ( Module m, Cell c )
-{
- assert(isName(c) || isTuple(c));
- if (nonNull(getNameOrTupleClosure(c)))
- module(m).codeList = cons ( c, module(m).codeList );
- /* fprintf ( stderr, "addToCodeList %s %s\n",
- textToStr(module(m).text),
- textToStr( isTuple(c) ? tycon(c).text : name(c).text ) );
- */
-}
-
-Cell getNameOrTupleClosure ( Cell c )
-{
- if (isName(c)) return name(c).closure;
- else if (isTuple(c)) return tycon(c).closure;
- else internal("getNameOrTupleClosure");
-}
-
-void setNameOrTupleClosure ( Cell c, Cell closure )
-{
- if (isName(c)) name(c).closure = closure;
- else if (isTuple(c)) tycon(c).closure = closure;
- else internal("setNameOrTupleClosure");
-}
-
-/* This function is used in ghc/rts/Assembler.c. */
-void* /* StgClosure* */ getNameOrTupleClosureCPtr ( Cell c )
-{
- return cptrOf(getNameOrTupleClosure(c));
-}
-
-/* used in codegen.c */
-void setNameOrTupleClosureCPtr ( Cell c, void* /* StgClosure* */ cptr )
-{
- if (isName(c)) name(c).closure = mkCPtr(cptr);
- else if (isTuple(c)) tycon(c).closure = mkCPtr(cptr);
- else internal("setNameOrTupleClosureCPtr");
-}
-
-
-
-Name jrsFindQualName ( Text mn, Text sn )
-{
- Module m;
- List ns;
-
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++)
- if (tabModule[m-MODULE_BASE_ADDR].inUse
- && module(m).text == mn) break;
-
- if (m == MODULE_BASE_ADDR+tabModuleSz) return NIL;
-
- for (ns = module(m).names; nonNull(ns); ns=tl(ns))
- if (name(hd(ns)).text == sn) return hd(ns);
-
- return NIL;
-}
-
-
-char* nameFromOPtr ( void* p )
-{
- int i;
- Module m;
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++) {
- if (tabModule[m-MODULE_BASE_ADDR].inUse && module(m).object) {
- char* nm = ocLookupAddr ( module(m).object, p );
- if (nm) return nm;
- }
- }
-# if 0
- /* A kludge to assist Win32 debugging; not actually necessary. */
- { char* nm = nameFromStaticOPtr(p);
- if (nm) return nm;
- }
-# endif
- return NULL;
-}
-
-
-void* lookupOTabName ( Module m, char* sym )
-{
- assert(isModule(m));
- if (module(m).object)
- return ocLookupSym ( module(m).object, sym );
- return NULL;
-}
-
-
-void* lookupOExtraTabName ( char* sym )
-{
- ObjectCode* oc;
- Module m;
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++) {
- if (tabModule[m-MODULE_BASE_ADDR].inUse)
- for (oc = module(m).objectExtras; oc; oc=oc->next) {
- void* ad = ocLookupSym ( oc, sym );
- if (ad) return ad;
- }
- }
- return NULL;
-}
-
-
-/* Only call this if in dire straits; searches every object symtab
- in the system -- so is therefore slow.
-*/
-void* lookupOTabNameAbsolutelyEverywhere ( char* sym )
-{
- ObjectCode* oc;
- Module m;
- void* ad;
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++) {
- if (tabModule[m-MODULE_BASE_ADDR].inUse) {
- if (module(m).object) {
- ad = ocLookupSym ( module(m).object, sym );
- if (ad) return ad;
- }
- for (oc = module(m).objectExtras; oc; oc=oc->next) {
- ad = ocLookupSym ( oc, sym );
- if (ad) return ad;
- }
- }
- }
- return NULL;
-}
-
-
-OSectionKind lookupSection ( void* ad )
-{
- int i;
- Module m;
- ObjectCode* oc;
- OSectionKind sect;
-
- /* speedup hack */
- if (!combined) return HUGS_SECTIONKIND_OTHER;
-
- for (m = MODULE_BASE_ADDR;
- m < MODULE_BASE_ADDR+tabModuleSz; m++) {
- if (tabModule[m-MODULE_BASE_ADDR].inUse) {
- if (tabModule[m-MODULE_BASE_ADDR].object) {
- sect = ocLookupSection ( tabModule[m-MODULE_BASE_ADDR].object, ad );
- if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
- return sect;
- }
- for (oc = tabModule[m-MODULE_BASE_ADDR].objectExtras; oc; oc=oc->next) {
- sect = ocLookupSection ( oc, ad );
- if (sect != HUGS_SECTIONKIND_NOINFOAVAIL)
- return sect;
- }
- }
- }
- return HUGS_SECTIONKIND_OTHER;
-}
-
-
-/* Called by the evaluator's GC to tell Hugs to mark stuff in the
- run-time heap.
-*/
-void markHugsObjects( void )
-{
- Name nm;
- Tycon tc;
-
- for ( nm = NAME_BASE_ADDR;
- nm < NAME_BASE_ADDR+tabNameSz; ++nm ) {
- if (tabName[nm-NAME_BASE_ADDR].inUse) {
- Cell cl = tabName[nm-NAME_BASE_ADDR].closure;
- if (nonNull(cl)) {
- assert(isCPtr(cl));
- snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
- }
- }
- }
-
- for ( tc = TYCON_BASE_ADDR;
- tc < TYCON_BASE_ADDR+tabTyconSz; ++tc ) {
- if (tabTycon[tc-TYCON_BASE_ADDR].inUse) {
- Cell cl = tabTycon[tc-TYCON_BASE_ADDR].closure;
- if (nonNull(cl)) {
- assert(isCPtr(cl));
- snd(cl) = (Cell)MarkRoot ( (StgClosure*)(snd(cl)) );
- }
- }
- }
-}
-
-
-/* --------------------------------------------------------------------------
- * Heap storage:
- *
- * Provides a garbage collectable heap for storage of expressions etc.
- *
- * Now incorporates a flat resource: A two-space collected extension of
- * the heap that provides storage for contiguous arrays of Cell storage,
- * cooperating with the garbage collection mechanisms for the main heap.
- * ------------------------------------------------------------------------*/
-
-Int heapSize = DEFAULTHEAP; /* number of cells in heap */
-Heap heapFst; /* array of fst component of pairs */
-Heap heapSnd; /* array of snd component of pairs */
-Heap heapTopFst;
-Heap heapTopSnd;
-Bool consGC = TRUE; /* Set to FALSE to turn off gc from*/
- /* C stack; use with extreme care! */
-Long numCells;
-int numEnters;
-Int numGcs; /* number of garbage collections */
-Int cellsRecovered; /* number of cells recovered */
-
-static Cell freeList; /* free list of unused cells */
-static Cell lsave, rsave; /* save components of pair */
-
-#if GC_STATISTICS
-
-static Int markCount, stackRoots;
-
-#define initStackRoots() stackRoots = 0
-#define recordStackRoot() stackRoots++
-
-#define startGC() \
- if (gcMessages) { \
- Printf("\n"); \
- fflush(stdout); \
- }
-#define endGC() \
- if (gcMessages) { \
- Printf("\n"); \
- fflush(stdout); \
- }
-
-#define start() markCount = 0
-#define end(thing,rs) \
- if (gcMessages) { \
- Printf("GC: %-18s: %4d cells, %4d roots.\n", thing, markCount, rs); \
- fflush(stdout); \
- }
-#define recordMark() markCount++
-
-#else /* !GC_STATISTICS */
-
-#define startGC()
-#define endGC()
-
-#define initStackRoots()
-#define recordStackRoot()
-
-#define start()
-#define end(thing,root)
-#define recordMark()
-
-#endif /* !GC_STATISTICS */
-
-Cell pair(l,r) /* Allocate pair (l, r) from */
-Cell l, r; { /* heap, garbage collecting first */
- Cell c = freeList; /* if necessary ... */
- if (isNull(c)) {
- lsave = l;
- rsave = r;
- garbageCollect();
- l = lsave;
- lsave = NIL;
- r = rsave;
- rsave = NIL;
- c = freeList;
- }
- freeList = snd(freeList);
- fst(c) = l;
- snd(c) = r;
- numCells++;
- return c;
-}
-
-static Int *marks;
-static Int marksSize;
-
-void mark ( Cell root )
-{
- Cell c;
- Cell mstack[NUM_MSTACK];
- Int msp = -1;
- Int msp_max = -1;
-
- mstack[++msp] = root;
-
- while (msp >= 0) {
- if (msp > msp_max) msp_max = msp;
- c = mstack[msp--];
- if (!isGenPair(c)) continue;
- if (fst(c)==FREECELL) continue;
- {
- register int place = placeInSet(c);
- register int mask = maskInSet(c);
- if (!(marks[place]&mask)) {
- marks[place] |= mask;
- if (msp >= NUM_MSTACK-5) {
- fprintf ( stderr,
- "hugs: fatal stack overflow during GC. "
- "Increase NUM_MSTACK.\n" );
- exit(9);
- }
- mstack[++msp] = fst(c);
- mstack[++msp] = snd(c);
- }
- }
- }
- // fprintf(stderr, "%d ",msp_max);
-}
-
-
-Void garbageCollect() { /* Run garbage collector ... */
- /* disable break checking */
- Int i,j;
- register Int mask;
- register Int place;
- Int recovered;
- jmp_buf regs; /* save registers on stack */
- HugsBreakAction oldBrk
- = setBreakAction ( HugsIgnoreBreak );
-
- setjmp(regs);
-
- gcStarted();
-
- for (i=0; i<marksSize; ++i) /* initialise mark set to empty */
- marks[i] = 0;
-
- everybody(MARK); /* Mark all components of system */
-
- gcScanning(); /* scan mark set */
- mask = 1;
- place = 0;
- recovered = 0;
- j = 0;
-
- freeList = NIL;
- for (i=1; i<=heapSize; i++) {
- if ((marks[place] & mask) == 0) {
- snd(-i) = freeList;
- fst(-i) = FREECELL;
- freeList = -i;
- recovered++;
- }
- mask <<= 1;
- if (++j == bitsPerWord) {
- place++;
- mask = 1;
- j = 0;
- }
- }
-
- gcRecovered(recovered);
- setBreakAction ( oldBrk );
-
- everybody(GCDONE);
-
-#if defined(DEBUG_STORAGE) || defined(DEBUG_STORAGE_EXTRA)
- /* fprintf(stderr, "\n--- GC recovered %d\n",recovered ); */
-#endif
-
- /* can only return if freeList is nonempty on return. */
- if (recovered<minRecovery || isNull(freeList)) {
- ERRMSG(0) "Garbage collection fails to reclaim sufficient space"
- EEND;
- }
- cellsRecovered = recovered;
-}
-
-/* --------------------------------------------------------------------------
- * Code for saving last expression entered:
- *
- * This is a little tricky because some text values (e.g. strings or variable
- * names) may not be defined or have the same value when the expression is
- * recalled. These text values are therefore saved in the top portion of
- * the text table.
- * ------------------------------------------------------------------------*/
-
-static Cell lastExprSaved; /* last expression to be saved */
-
-Void setLastExpr(e) /* save expression for later recall*/
-Cell e; {
- lastExprSaved = NIL; /* in case attempt to save fails */
- savedText = TEXT_SIZE;
- lastExprSaved = lowLevelLastIn(e);
-}
-
-static Cell local lowLevelLastIn(c) /* Duplicate expression tree (i.e. */
-Cell c; { /* acyclic graph) for later recall */
- if (isPair(c)) { /* Duplicating any text strings */
- if (isTagNonPtr(fst(c))) /* in case these are lost at some */
- switch (fst(c)) { /* point before the expr is reused */
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR :
- case CONIDCELL :
- case CONOPCELL :
- case STRCELL : return pair(fst(c),saveText(textOf(c)));
- default : return pair(fst(c),snd(c));
- }
- else
- return pair(lowLevelLastIn(fst(c)),lowLevelLastIn(snd(c)));
- }
-#if TREX
- else if (isExt(c))
- return pair(EXTCOPY,saveText(extText(c)));
-#endif
- else
- return c;
-}
-
-Cell getLastExpr() { /* recover previously saved expr */
- return lowLevelLastOut(lastExprSaved);
-}
-
-static Cell local lowLevelLastOut(c) /* As with lowLevelLastIn() above */
-Cell c; { /* except that Cells refering to */
- if (isPair(c)) { /* Text values are restored to */
- if (isTagNonPtr(fst(c))) /* appropriate values */
- switch (fst(c)) {
- case VARIDCELL :
- case VAROPCELL :
- case DICTVAR :
- case CONIDCELL :
- case CONOPCELL :
- case STRCELL : return pair(fst(c),
- findText(text+intValOf(c)));
-#if TREX
- case EXTCOPY : return mkExt(findText(text+intValOf(c)));
-#endif
- default : return pair(fst(c),snd(c));
- }
- else
- return pair(lowLevelLastOut(fst(c)),lowLevelLastOut(snd(c)));
- }
- else
- return c;
-}
-
-/* --------------------------------------------------------------------------
- * Miscellaneous operations on heap cells:
- * ------------------------------------------------------------------------*/
-
-/* Reordered 2 May 00 to have most common options first. */
-Cell whatIs ( register Cell c )
-{
- if (isPair(c)) {
- register Cell fstc = fst(c);
- return isTag(fstc) ? fstc : AP;
- }
- if (isTycon(c)) return TYCON;
- if (isOffset(c)) return OFFSET;
- if (isName(c)) return NAME;
- if (isInt(c)) return INTCELL;
- if (isTuple(c)) return TUPLE;
- if (isSpec(c)) return c;
- if (isClass(c)) return CLASS;
- if (isChar(c)) return CHARCELL;
- if (isNull(c)) return c;
- if (isInst(c)) return INSTANCE;
- if (isModule(c)) return MODULE;
- if (isText(c)) return TEXTCELL;
- if (isInventedVar(c)) return INVAR;
- if (isInventedDictVar(c)) return INDVAR;
- fprintf ( stderr, "whatIs: unknown %d\n", c );
- internal("whatIs");
-}
-
-
-
-/* A very, very simple printer.
- * Output is uglier than from printExp - but the printer is more
- * robust and can be used on any data structure irrespective of
- * its type.
- */
-Void print ( Cell c, Int depth )
-{
- if (0 == depth) {
- Printf("...");
- }
- else if (isNull(c)) {
- Printf("NIL");
- }
- else if (isTagPtr(c)) {
- Printf("TagP(%d)", c);
- }
- else if (isTagNonPtr(c)) {
- Printf("TagNP(%d)", c);
- }
- else if (isSpec(c) && c != STAR) {
- Printf("TagS(%d)", c);
- }
- else if (isText(c)) {
- Printf("text(%d)=\"%s\"",c-TEXT_BASE_ADDR,textToStr(c));
- }
- else if (isInventedVar(c)) {
- Printf("invented(%d)", c-INVAR_BASE_ADDR);
- }
- else if (isInventedDictVar(c)) {
- Printf("inventedDict(%d)",c-INDVAR_BASE_ADDR);
- }
- else {
- Int tag = whatIs(c);
- switch (tag) {
- case AP:
- Putchar('(');
- print(fst(c), depth-1);
- Putchar(',');
- print(snd(c), depth-1);
- Putchar(')');
- break;
- case FREECELL:
- Printf("free(%d)", c);
- break;
- case INTCELL:
- Printf("int(%d)", intOf(c));
- break;
- case BIGCELL:
- Printf("bignum(%s)", bignumToString(c));
- break;
- case CHARCELL:
- Printf("char('%c')", charOf(c));
- break;
- case STRCELL:
- Printf("strcell(\"%s\")",textToStr(snd(c)));
- break;
- case MPTRCELL:
- Printf("mptr(%p)",mptrOf(c));
- break;
- case CPTRCELL:
- Printf("cptr(%p)",cptrOf(c));
- break;
- case ADDRCELL:
- Printf("addr(%p)",addrOf(c));
- break;
- case CLASS:
- Printf("class(%d)", c-CCLASS_BASE_ADDR);
- Printf("=\"%s\"", textToStr(cclass(c).text));
- break;
- case INSTANCE:
- Printf("instance(%d)", c - INST_BASE_ADDR);
- break;
- case NAME:
- Printf("name(%d)", c-NAME_BASE_ADDR);
- Printf("=\"%s\"", textToStr(name(c).text));
- break;
- case TYCON:
- Printf("tycon(%d)", c-TYCON_BASE_ADDR);
- Printf("=\"%s\"", textToStr(tycon(c).text));
- break;
- case MODULE:
- Printf("module(%d)", c - MODULE_BASE_ADDR);
- Printf("=\"%s\"", textToStr(module(c).text));
- break;
- case OFFSET:
- Printf("Offset %d", offsetOf(c));
- break;
- case TUPLE:
- Printf("%s", textToStr(ghcTupleText(c)));
- break;
- case POLYTYPE:
- Printf("Polytype");
- print(snd(c),depth-1);
- break;
- case QUAL:
- Printf("Qualtype");
- print(snd(c),depth-1);
- break;
- case RANK2:
- Printf("Rank2(");
- if (isPair(snd(c)) && isInt(fst(snd(c)))) {
- Printf("%d ", intOf(fst(snd(c))));
- print(snd(snd(c)),depth-1);
- } else {
- print(snd(c),depth-1);
- }
- Printf(")");
- break;
- case WILDCARD:
- Printf("_");
- break;
- case STAR:
- Printf("STAR");
- break;
- case DOTDOT:
- Printf("DOTDOT");
- break;
- case DICTVAR:
- Printf("{dict %d}",textOf(c));
- break;
- case VARIDCELL:
- case VAROPCELL:
- case CONIDCELL:
- case CONOPCELL:
- Printf("{id %s}",textToStr(textOf(c)));
- break;
-#if IPARAM
- case IPCELL :
- Printf("{ip %s}",textToStr(textOf(c)));
- break;
- case IPVAR :
- Printf("?%s",textToStr(textOf(c)));
- break;
-#endif
- case QUALIDENT:
- Printf("{qid %s.%s}",textToStr(qmodOf(c)),textToStr(qtextOf(c)));
- break;
- case LETREC:
- Printf("LetRec(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case LAMBDA:
- Printf("Lambda(");
- print(snd(c),depth-1);
- Putchar(')');
- break;
- case FINLIST:
- Printf("FinList(");
- print(snd(c),depth-1);
- Putchar(')');
- break;
- case COMP:
- Printf("Comp(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case ASPAT:
- Printf("AsPat(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case FROMQUAL:
- Printf("FromQual(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case STGVAR:
- Printf("StgVar%d=",-c);
- print(snd(c), depth-1);
- break;
- case STGAPP:
- Printf("StgApp(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case STGPRIM:
- Printf("StgPrim(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case STGCON:
- Printf("StgCon(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case PRIMCASE:
- Printf("PrimCase(");
- print(fst(snd(c)),depth-1);
- Putchar(',');
- print(snd(snd(c)),depth-1);
- Putchar(')');
- break;
- case DICTAP:
- Printf("(DICTAP,");
- print(snd(c),depth-1);
- Putchar(')');
- break;
- case UNBOXEDTUP:
- Printf("(UNBOXEDTUP,");
- print(snd(c),depth-1);
- Putchar(')');
- break;
- case ZTUP2:
- Printf("<ZPair ");
- print(zfst(c),depth-1);
- Putchar(' ');
- print(zsnd(c),depth-1);
- Putchar('>');
- break;
- case ZTUP3:
- Printf("<ZTriple ");
- print(zfst3(c),depth-1);
- Putchar(' ');
- print(zsnd3(c),depth-1);
- Putchar(' ');
- print(zthd3(c),depth-1);
- Putchar('>');
- break;
- case BANG:
- Printf("(BANG,");
- print(snd(c),depth-1);
- Putchar(')');
- break;
- default:
- if (isTagNonPtr(tag)) {
- Printf("(TagNP=%d,%d)", c, tag);
- } else if (isTagPtr(tag)) {
- Printf("(TagP=%d,",tag);
- print(snd(c), depth-1);
- Putchar(')');
- break;
- } else if (c == tag) {
- Printf("Tag(%d)", c);
- } else {
- Printf("Tag(%d)=%d", c, tag);
- }
- break;
- }
- }
- FlushStdout();
-}
-
-
-Bool isVar(c) /* is cell a VARIDCELL/VAROPCELL ? */
-Cell c; { /* also recognises DICTVAR cells */
- return isPair(c) &&
- (fst(c)==VARIDCELL || fst(c)==VAROPCELL || fst(c)==DICTVAR);
-}
-
-Bool isCon(c) /* is cell a CONIDCELL/CONOPCELL ? */
-Cell c; {
- return isPair(c) && (fst(c)==CONIDCELL || fst(c)==CONOPCELL);
-}
-
-Bool isQVar(c) /* is cell a [un]qualified varop/id? */
-Cell c; {
- if (!isPair(c)) return FALSE;
- switch (fst(c)) {
- case VARIDCELL :
- case VAROPCELL : return TRUE;
-
- case QUALIDENT : return isVar(snd(snd(c)));
-
- default : return FALSE;
- }
-}
-
-Bool isQCon(c) /*is cell a [un]qualified conop/id? */
-Cell c; {
- if (!isPair(c)) return FALSE;
- switch (fst(c)) {
- case CONIDCELL :
- case CONOPCELL : return TRUE;
-
- case QUALIDENT : return isCon(snd(snd(c)));
-
- default : return FALSE;
- }
-}
-
-Bool isQualIdent(c) /* is cell a qualified identifier? */
-Cell c; {
- return isPair(c) && (fst(c)==QUALIDENT);
-}
-
-Bool eqQualIdent ( QualId c1, QualId c2 )
-{
- assert(isQualIdent(c1));
- if (!isQualIdent(c2)) {
- assert(isQualIdent(c2));
- }
- return qmodOf(c1)==qmodOf(c2) &&
- qtextOf(c1)==qtextOf(c2);
-}
-
-Bool isIdent(c) /* is cell an identifier? */
-Cell c; {
- if (!isPair(c)) return FALSE;
- switch (fst(c)) {
- case VARIDCELL :
- case VAROPCELL :
- case CONIDCELL :
- case CONOPCELL : return TRUE;
-
- case QUALIDENT : return TRUE;
-
- default : return FALSE;
- }
-}
-
-Bool isInt(c) /* cell holds integer value? */
-Cell c; {
- return isSmall(c) || (isPair(c) && fst(c)==INTCELL);
-}
-
-Int intOf(c) /* find integer value of cell? */
-Cell c; {
- assert(isInt(c));
- return isPair(c) ? (Int)(snd(c)) : (Int)(c-SMALL_INT_ZERO);
-}
-
-Cell mkInt(n) /* make cell representing integer */
-Int n; {
- return (SMALL_INT_MIN <= SMALL_INT_ZERO+n &&
- SMALL_INT_ZERO+n <= SMALL_INT_MAX)
- ? SMALL_INT_ZERO+n
- : pair(INTCELL,n);
-}
-
-#if SIZEOF_VOID_P == SIZEOF_INT
-
-typedef union {Int i; Ptr p;} IntOrPtr;
-
-Cell mkAddr(p)
-Ptr p;
-{
- IntOrPtr x;
- x.p = p;
- return pair(ADDRCELL,x.i);
-}
-
-Ptr addrOf(c)
-Cell c;
-{
- IntOrPtr x;
- assert(fst(c) == ADDRCELL);
- x.i = snd(c);
- return x.p;
-}
-
-Cell mkMPtr(p)
-Ptr p;
-{
- IntOrPtr x;
- x.p = p;
- return pair(MPTRCELL,x.i);
-}
-
-Ptr mptrOf(c)
-Cell c;
-{
- IntOrPtr x;
- assert(fst(c) == MPTRCELL);
- x.i = snd(c);
- return x.p;
-}
-
-Cell mkCPtr(p)
-Ptr p;
-{
- IntOrPtr x;
- x.p = p;
- return pair(CPTRCELL,x.i);
-}
-
-Ptr cptrOf(c)
-Cell c;
-{
- IntOrPtr x;
- assert(fst(c) == CPTRCELL);
- x.i = snd(c);
- return x.p;
-}
-
-#elif SIZEOF_VOID_P == 2*SIZEOF_INT
-
-typedef union {struct {Int i1; Int i2;} i; Ptr p;} IntOrPtr;
-
-Cell mkPtr(p)
-Ptr p;
-{
- IntOrPtr x;
- x.p = p;
- return pair(PTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
-}
-
-Ptr ptrOf(c)
-Cell c;
-{
- IntOrPtr x;
- assert(fst(c) == PTRCELL);
- x.i.i1 = intOf(fst(snd(c)));
- x.i.i2 = intOf(snd(snd(c)));
- return x.p;
-}
-
-Cell mkCPtr(p)
-Ptr p;
-{
- IntOrPtr x;
- x.p = p;
- return pair(CPTRCELL,pair(mkInt(x.i.i1),mkInt(x.i.i2)));
-}
-
-Ptr cptrOf(c)
-Cell c;
-{
- IntOrPtr x;
- assert(fst(c) == CPTRCELL);
- x.i.i1 = intOf(fst(snd(c)));
- x.i.i2 = intOf(snd(snd(c)));
- return x.p;
-}
-
-#else
-
-#error "Can't implement mkPtr/ptrOf on this architecture."
-
-#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:
- * ------------------------------------------------------------------------*/
-
-Int length(xs) /* calculate length of list xs */
-List xs; {
- Int n = 0;
- for (; nonNull(xs); ++n)
- xs = tl(xs);
- return n;
-}
-
-List appendOnto(xs,ys) /* Destructively prepend xs onto */
-List xs, ys; { /* ys by modifying xs ... */
- if (isNull(xs))
- return ys;
- else {
- List zs = xs;
- while (nonNull(tl(zs)))
- zs = tl(zs);
- tl(zs) = ys;
- return xs;
- }
-}
-
-List dupOnto(xs,ys) /* non-destructively prepend xs backwards onto ys */
-List xs;
-List ys; {
- for (; nonNull(xs); xs=tl(xs))
- ys = cons(hd(xs),ys);
- return ys;
-}
-
-List dupListOnto(xs,ys) /* Duplicate spine of list xs onto ys */
-List xs;
-List ys; {
- return revOnto(dupOnto(xs,NIL),ys);
-}
-
-List dupList(xs) /* Duplicate spine of list xs */
-List xs; {
- List ys = NIL;
- for (; nonNull(xs); xs=tl(xs))
- ys = cons(hd(xs),ys);
- return rev(ys);
-}
-
-List revOnto(xs,ys) /* Destructively reverse elements of*/
-List xs, ys; { /* list xs onto list ys... */
- Cell zs;
-
- while (nonNull(xs)) {
- zs = tl(xs);
- tl(xs) = ys;
- ys = xs;
- xs = zs;
- }
- return ys;
-}
-
-QualId qualidIsMember ( QualId q, List xs )
-{
- for (; nonNull(xs); xs=tl(xs)) {
- if (eqQualIdent(q, hd(xs)))
- return hd(xs);
- }
- return NIL;
-}
-
-Cell varIsMember(t,xs) /* Test if variable is a member of */
-Text t; /* given list of variables */
-List xs; {
- assert(isText(t) || isInventedVar(t) || isInventedDictVar(t));
- for (; nonNull(xs); xs=tl(xs))
- if (t==textOf(hd(xs)))
- return hd(xs);
- return NIL;
-}
-
-Name nameIsMember(t,ns) /* Test if name with text t is a */
-Text t; /* member of list of names xs */
-List ns; {
- for (; nonNull(ns); ns=tl(ns))
- if (t==name(hd(ns)).text)
- return hd(ns);
- return NIL;
-}
-
-Cell intIsMember(n,xs) /* Test if integer n is member of */
-Int n; /* given list of integers */
-List xs; {
- for (; nonNull(xs); xs=tl(xs))
- if (n==intOf(hd(xs)))
- return hd(xs);
- return NIL;
-}
-
-Cell cellIsMember(x,xs) /* Test for membership of specific */
-Cell x; /* cell x in list xs */
-List xs; {
- for (; nonNull(xs); xs=tl(xs))
- if (x==hd(xs))
- return hd(xs);
- return NIL;
-}
-
-Cell cellAssoc(c,xs) /* Lookup cell in association list */
-Cell c;
-List xs; {
- for (; nonNull(xs); xs=tl(xs))
- if (c==fst(hd(xs)))
- return hd(xs);
- return NIL;
-}
-
-Cell cellRevAssoc(c,xs) /* Lookup cell in range of */
-Cell c; /* association lists */
-List xs; {
- for (; nonNull(xs); xs=tl(xs))
- if (c==snd(hd(xs)))
- return hd(xs);
- return NIL;
-}
-
-List replicate(n,x) /* create list of n copies of x */
-Int n;
-Cell x; {
- List xs=NIL;
- while (0<n--)
- xs = cons(x,xs);
- return xs;
-}
-
-List diffList(from,take) /* list difference: from\take */
-List from, take; { /* result contains all elements of */
- List result = NIL; /* `from' not appearing in `take' */
-
- while (nonNull(from)) {
- List next = tl(from);
- if (!cellIsMember(hd(from),take)) {
- tl(from) = result;
- result = from;
- }
- from = next;
- }
- return rev(result);
-}
-
-List deleteCell(xs, y) /* copy xs deleting pointers to y */
-List xs;
-Cell y; {
- List result = NIL;
- for(;nonNull(xs);xs=tl(xs)) {
- Cell x = hd(xs);
- if (x != y) {
- result=cons(x,result);
- }
- }
- return rev(result);
-}
-
-List take(n,xs) /* destructively truncate list to */
-Int n; /* specified length */
-List xs; {
- List ys = xs;
-
- if (n==0)
- return NIL;
- while (1<n-- && nonNull(xs))
- xs = tl(xs);
- if (nonNull(xs))
- tl(xs) = NIL;
- return ys;
-}
-
-List splitAt(n,xs) /* drop n things from front of list*/
-Int n;
-List xs; {
- for(; n>0; --n) {
- xs = tl(xs);
- }
- return xs;
-}
-
-Cell nth(n,xs) /* extract n'th element of list */
-Int n;
-List xs; {
- for(; n>0 && nonNull(xs); --n, xs=tl(xs)) {
- }
- if (isNull(xs))
- internal("nth");
- return hd(xs);
-}
-
-List removeCell(x,xs) /* destructively remove cell from */
-Cell x; /* list */
-List xs; {
- if (nonNull(xs)) {
- if (hd(xs)==x)
- return tl(xs); /* element at front of list */
- else {
- List prev = xs;
- List curr = tl(xs);
- for (; nonNull(curr); prev=curr, curr=tl(prev))
- if (hd(curr)==x) {
- tl(prev) = tl(curr);
- return xs; /* element in middle of list */
- }
- }
- }
- return xs; /* here if element not found */
-}
-
-List nubList(xs) /* nuke dups in list */
-List xs; { /* non destructive */
- List outs = NIL;
- for (; nonNull(xs); xs=tl(xs))
- if (isNull(cellIsMember(hd(xs),outs)))
- outs = cons(hd(xs),outs);
- outs = rev(outs);
- return outs;
-}
-
-
-/* --------------------------------------------------------------------------
- * Tagged tuples (experimental)
- * ------------------------------------------------------------------------*/
-
-static void z_tag_check ( Cell x, int tag, char* caller )
-{
- char buf[100];
- if (isNull(x)) {
- sprintf(buf,"z_tag_check(%s): null\n", caller);
- internal(buf);
- }
- if (whatIs(x) != tag) {
- sprintf(buf,
- "z_tag_check(%s): tag was %d, expected %d\n",
- caller, whatIs(x), tag );
- internal(buf);
- }
-}
-
-Cell zpair ( Cell x1, Cell x2 )
-{ return ap(ZTUP2,ap(x1,x2)); }
-Cell zfst ( Cell zpair )
-{ z_tag_check(zpair,ZTUP2,"zfst"); return fst( snd(zpair) ); }
-Cell zsnd ( Cell zpair )
-{ z_tag_check(zpair,ZTUP2,"zsnd"); return snd( snd(zpair) ); }
-
-Cell ztriple ( Cell x1, Cell x2, Cell x3 )
-{ return ap(ZTUP3,ap(x1,ap(x2,x3))); }
-Cell zfst3 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP3,"zfst3"); return fst( snd(zpair) ); }
-Cell zsnd3 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP3,"zsnd3"); return fst(snd( snd(zpair) )); }
-Cell zthd3 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP3,"zthd3"); return snd(snd( snd(zpair) )); }
-
-Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 )
-{ return ap(ZTUP4,ap(x1,ap(x2,ap(x3,x4)))); }
-Cell zsel14 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP4,"zsel14"); return fst( snd(zpair) ); }
-Cell zsel24 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP4,"zsel24"); return fst(snd( snd(zpair) )); }
-Cell zsel34 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP4,"zsel34"); return fst(snd(snd( snd(zpair) ))); }
-Cell zsel44 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP4,"zsel44"); return snd(snd(snd( snd(zpair) ))); }
-
-Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 )
-{ return ap(ZTUP5,ap(x1,ap(x2,ap(x3,ap(x4,x5))))); }
-Cell zsel15 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP5,"zsel15"); return fst( snd(zpair) ); }
-Cell zsel25 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP5,"zsel25"); return fst(snd( snd(zpair) )); }
-Cell zsel35 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP5,"zsel35"); return fst(snd(snd( snd(zpair) ))); }
-Cell zsel45 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP5,"zsel45"); return fst(snd(snd(snd( snd(zpair) )))); }
-Cell zsel55 ( Cell zpair )
-{ z_tag_check(zpair,ZTUP5,"zsel55"); return snd(snd(snd(snd( snd(zpair) )))); }
-
-
-Cell unap ( int tag, Cell c )
-{
- char buf[100];
- if (whatIs(c) != tag) {
- sprintf(buf, "unap: specified %d, actual %d\n",
- tag, whatIs(c) );
- internal(buf);
- }
- return snd(c);
-}
-
-/* --------------------------------------------------------------------------
- * Operations on applications:
- * ------------------------------------------------------------------------*/
-
-Int argCount; /* number of args in application */
-
-Cell getHead(e) /* get head cell of application */
-Cell e; { /* set number of args in argCount */
- for (argCount=0; isAp(e); e=fun(e))
- argCount++;
- return e;
-}
-
-List getArgs(e) /* get list of arguments in function*/
-Cell e; { /* application: */
- List as; /* getArgs(f e1 .. en) = [e1,..,en] */
-
- for (as=NIL; isAp(e); e=fun(e))
- as = cons(arg(e),as);
- return as;
-}
-
-Cell nthArg(n,e) /* return nth arg in application */
-Int n; /* of function to m args (m>=n) */
-Cell e; { /* nthArg n (f x0 x1 ... xm) = xn */
- for (n=numArgs(e)-n-1; n>0; n--)
- e = fun(e);
- return arg(e);
-}
-
-Int numArgs(e) /* find number of arguments to expr */
-Cell e; {
- Int n;
- for (n=0; isAp(e); e=fun(e))
- n++;
- return n;
-}
-
-Cell applyToArgs(f,args) /* destructively apply list of args */
-Cell f; /* to function f */
-List args; {
- while (nonNull(args)) {
- Cell temp = tl(args);
- tl(args) = hd(args);
- hd(args) = f;
- f = args;
- args = temp;
- }
- return f;
-}
-
-/* --------------------------------------------------------------------------
- * debugging support
- * ------------------------------------------------------------------------*/
-
-/* Given the address of an info table, find the constructor/tuple
- that it belongs to, and return the name. Only needed for debugging.
-*/
-char* lookupHugsItblName ( void* v )
-{
- int i;
- for (i = TYCON_BASE_ADDR;
- i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
- if (tabTycon[i-TYCON_BASE_ADDR].inUse
- && tycon(i).itbl == v)
- return textToStr(tycon(i).text);
- }
- for (i = NAME_BASE_ADDR;
- i < NAME_BASE_ADDR+tabNameSz; ++i) {
- if (tabName[i-NAME_BASE_ADDR].inUse
- && name(i).itbl == v)
- return textToStr(name(i).text);
- }
- return NULL;
-}
-
-static String maybeModuleStr ( Module m )
-{
- if (isModule(m)) return textToStr(module(m).text); else return "??";
-}
-
-static String maybeNameStr ( Name n )
-{
- if (isName(n)) return textToStr(name(n).text); else return "??";
-}
-
-static String maybeTyconStr ( Tycon t )
-{
- if (isTycon(t)) return textToStr(tycon(t).text); else return "??";
-}
-
-static String maybeClassStr ( Class c )
-{
- if (isClass(c)) return textToStr(cclass(c).text); else return "??";
-}
-
-static String maybeText ( Text t )
-{
- if (isNull(t)) return "(nil)";
- return textToStr(t);
-}
-
-static void print100 ( Int x )
-{
- print ( x, 100); printf("\n");
-}
-
-void dumpTycon ( Int t )
-{
- if (isTycon(TYCON_BASE_ADDR+t) && !isTycon(t)) t += TYCON_BASE_ADDR;
- if (!isTycon(t)) {
- printf ( "dumpTycon %d: not a tycon\n", t);
- return;
- }
- printf ( "{\n" );
- printf ( " text: %s\n", textToStr(tycon(t).text) );
- printf ( " line: %d\n", tycon(t).line );
- printf ( " mod: %s\n", maybeModuleStr(tycon(t).mod));
- printf ( " tuple: %d\n", tycon(t).tuple);
- printf ( " arity: %d\n", tycon(t).arity);
- printf ( " kind: "); print100(tycon(t).kind);
- printf ( " what: %d\n", tycon(t).what);
- printf ( " defn: "); print100(tycon(t).defn);
- printf ( " cToT: %d %s\n", tycon(t).conToTag,
- maybeNameStr(tycon(t).conToTag));
- printf ( " tToC: %d %s\n", tycon(t).tagToCon,
- maybeNameStr(tycon(t).tagToCon));
- printf ( " itbl: %p\n", tycon(t).itbl);
- printf ( " nextTH: %d %s\n", tycon(t).nextTyconHash,
- maybeTyconStr(tycon(t).nextTyconHash));
- printf ( "}\n" );
-}
-
-void dumpName ( Int n )
-{
- if (isName(NAME_BASE_ADDR+n) && !isName(n)) n += NAME_BASE_ADDR;
- if (!isName(n)) {
- printf ( "dumpName %d: not a name\n", n);
- return;
- }
- printf ( "{\n" );
- printf ( " text: %s\n", textToStr(name(n).text) );
- printf ( " line: %d\n", name(n).line );
- printf ( " mod: %s\n", maybeModuleStr(name(n).mod));
- printf ( " syntax: %d\n", name(n).syntax );
- printf ( " parent: %d\n", name(n).parent );
- printf ( " arity: %d\n", name(n).arity );
- printf ( " number: %d\n", name(n).number );
- printf ( " type: "); print100(name(n).type);
- printf ( " defn: %d\n", name(n).defn );
- printf ( " cconv: %d\n", name(n).callconv );
- printf ( " primop: %p\n", name(n).primop );
- printf ( " itbl: %p\n", name(n).itbl );
- printf ( " closure: %d\n", name(n).closure );
- printf ( " nextNH: %d\n", name(n).nextNameHash );
- printf ( "}\n" );
-}
-
-
-void dumpClass ( Int c )
-{
- if (isClass(CCLASS_BASE_ADDR+c) && !isClass(c)) c += CCLASS_BASE_ADDR;
- if (!isClass(c)) {
- printf ( "dumpClass %d: not a class\n", c);
- return;
- }
- printf ( "{\n" );
- printf ( " text: %s\n", textToStr(cclass(c).text) );
- printf ( " line: %d\n", cclass(c).line );
- printf ( " mod: %s\n", maybeModuleStr(cclass(c).mod));
- printf ( " arity: %d\n", cclass(c).arity );
- printf ( " level: %d\n", cclass(c).level );
- printf ( " kinds: "); print100( cclass(c).kinds );
- printf ( " fds: %d\n", cclass(c).fds );
- printf ( " xfds: %d\n", cclass(c).xfds );
- printf ( " head: "); print100( cclass(c).head );
- printf ( " dcon: "); print100( cclass(c).dcon );
- printf ( " supers: "); print100( cclass(c).supers );
- printf ( " #supers: %d\n", cclass(c).numSupers );
- printf ( " dsels: "); print100( cclass(c).dsels );
- printf ( " members: "); print100( cclass(c).members );
- printf ( "#members: %d\n", cclass(c).numMembers );
- printf ( "defaults: "); print100( cclass(c).defaults );
- printf ( " insts: "); print100( cclass(c).instances );
- printf ( "}\n" );
-}
-
-
-void dumpInst ( Int i )
-{
- if (isInst(INST_BASE_ADDR+i) && !isInst(i)) i += INST_BASE_ADDR;
- if (!isInst(i)) {
- printf ( "dumpInst %d: not an instance\n", i);
- return;
- }
- printf ( "{\n" );
- printf ( " class: %s\n", maybeClassStr(inst(i).c) );
- printf ( " line: %d\n", inst(i).line );
- printf ( " mod: %s\n", maybeModuleStr(inst(i).mod));
- printf ( " kinds: "); print100( inst(i).kinds );
- printf ( " head: "); print100( inst(i).head );
- printf ( " specs: "); print100( inst(i).specifics );
- printf ( " #specs: %d\n", inst(i).numSpecifics );
- printf ( " impls: "); print100( inst(i).implements );
- printf ( " builder: %s\n", maybeNameStr( inst(i).builder ) );
- printf ( "}\n" );
-}
-
-
-/* --------------------------------------------------------------------------
- * storage control:
- * ------------------------------------------------------------------------*/
-
-Void storage(what)
-Int what; {
- Int i;
-
- switch (what) {
- case POSTPREL: break;
-
- case RESET : clearStack();
-
- /* the next 2 statements are particularly important
- * if you are using GLOBALfst or GLOBALsnd since the
- * corresponding registers may be reset to their
- * uninitialised initial values by a longjump.
- */
- heapTopFst = heapFst + heapSize;
- heapTopSnd = heapSnd + heapSize;
- consGC = TRUE;
- lsave = NIL;
- rsave = NIL;
- if (isNull(lastExprSaved))
- savedText = TEXT_SIZE;
- break;
-
- case MARK :
- start();
- for (i = NAME_BASE_ADDR;
- i < NAME_BASE_ADDR+tabNameSz; ++i) {
- if (tabName[i-NAME_BASE_ADDR].inUse) {
- mark(name(i).parent);
- mark(name(i).type);
- mark(name(i).defn);
- mark(name(i).closure);
- }
- }
- end("Names", nameHw-NAMEMIN);
-
- start();
- for (i = MODULE_BASE_ADDR;
- i < MODULE_BASE_ADDR+tabModuleSz; ++i) {
- if (tabModule[i-MODULE_BASE_ADDR].inUse) {
- mark(module(i).tycons);
- mark(module(i).names);
- mark(module(i).classes);
- mark(module(i).exports);
- mark(module(i).qualImports);
- mark(module(i).codeList);
- mark(module(i).tree);
- mark(module(i).uses);
- mark(module(i).objectExtraNames);
- }
- }
- mark(moduleGraph);
- mark(prelModules);
- mark(targetModules);
- end("Modules", moduleHw-MODMIN);
-
- start();
- for (i = TYCON_BASE_ADDR;
- i < TYCON_BASE_ADDR+tabTyconSz; ++i) {
- if (tabTycon[i-TYCON_BASE_ADDR].inUse) {
- mark(tycon(i).kind);
- mark(tycon(i).what);
- mark(tycon(i).defn);
- mark(tycon(i).closure);
- }
- }
- end("Type constructors", tyconHw-TYCMIN);
-
- start();
- for (i = CCLASS_BASE_ADDR;
- i < CCLASS_BASE_ADDR+tabClassSz; ++i) {
- if (tabClass[i-CCLASS_BASE_ADDR].inUse) {
- mark(cclass(i).kinds);
- mark(cclass(i).fds);
- mark(cclass(i).xfds);
- mark(cclass(i).head);
- mark(cclass(i).supers);
- mark(cclass(i).dsels);
- mark(cclass(i).members);
- mark(cclass(i).defaults);
- mark(cclass(i).instances);
- }
- }
- mark(classes);
- end("Classes", classHw-CLASSMIN);
-
- start();
- for (i = INST_BASE_ADDR;
- i < INST_BASE_ADDR+tabInstSz; ++i) {
- if (tabInst[i-INST_BASE_ADDR].inUse) {
- mark(inst(i).kinds);
- mark(inst(i).head);
- mark(inst(i).specifics);
- mark(inst(i).implements);
- }
- }
- end("Instances", instHw-INSTMIN);
-
- start();
- for (i=0; i<=sp; ++i)
- mark(stack(i));
- end("Stack", sp+1);
-
- start();
- mark(lastExprSaved);
- mark(lsave);
- mark(rsave);
- end("Last expression", 3);
-
- if (consGC) {
- start();
- gcCStack();
- end("C stack", stackRoots);
- }
-
- break;
-
- case PREPREL : heapFst = heapAlloc(heapSize);
- heapSnd = heapAlloc(heapSize);
-
- if (heapFst==(Heap)0 || heapSnd==(Heap)0) {
- ERRMSG(0) "Cannot allocate heap storage (%d cells)",
- heapSize
- EEND;
- }
-
- heapTopFst = heapFst + heapSize;
- heapTopSnd = heapSnd + heapSize;
- for (i=1; i<heapSize; ++i) {
- fst(-i) = FREECELL;
- snd(-i) = -(i+1);
- }
- snd(-heapSize) = NIL;
- freeList = -1;
- numGcs = 0;
- consGC = TRUE;
- lsave = NIL;
- rsave = NIL;
-
- marksSize = bitArraySize(heapSize);
- if ((marks=(Int *)calloc(marksSize, sizeof(Int)))==0) {
- ERRMSG(0) "Unable to allocate gc markspace"
- EEND;
- }
-
- clearStack();
-
- textHw = 0;
- nextNewText = INVAR_BASE_ADDR;
- nextNewDText = INDVAR_BASE_ADDR;
- lastExprSaved = NIL;
- savedText = TEXT_SIZE;
-
- for (i=0; i<TEXTHSZ; ++i) textHash[i][0] = NOTEXT;
- for (i=0; i<TYCONHSZ; ++i) tyconHash[RC_T(i)] = NIL;
- for (i=0; i<NAMEHSZ; ++i) nameHash[RC_N(i)] = NIL;
-
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Defines storage datatypes: Text, Name, Module, Tycon, Cell, List, Pair,
- * Triple, ...
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: storage.h,v $
- * $Revision: 1.45 $
- * $Date: 2000/04/27 16:35:29 $
- * ------------------------------------------------------------------------*/
-
-#define DEBUG_STORAGE /* a moderate level of sanity checking */
-#define DEBUG_STORAGE_EXTRA /* max paranoia in sanity checks */
-
-/* --------------------------------------------------------------------------
- * Typedefs for main data types:
- * Many of these type names are used to indicate the intended us of a data
- * item, rather than for type checking purposes. Sadly (although sometimes,
- * fortunately), the C compiler cannot distinguish between the use of two
- * different names defined to be synonyms for the same types.
- * ------------------------------------------------------------------------*/
-
-typedef Int Text; /* text string */
-typedef Unsigned Syntax; /* syntax (assoc,preced) */
-typedef Int Cell; /* general cell value */
-typedef Cell far *Heap; /* storage of heap */
-typedef Cell Pair; /* pair cell */
-typedef Int StackPtr; /* stack pointer */
-typedef Cell Offset; /* offset/generic variable*/
-typedef Int Module; /* module */
-typedef Cell Tycon; /* type constructor */
-typedef Cell Type; /* type expression */
-typedef Cell Kind; /* kind expression */
-typedef Cell Kinds; /* list of kinds */
-typedef Cell Constr; /* constructor expression */
-typedef Cell Name; /* named value */
-typedef Cell Class; /* type class */
-typedef Cell Inst; /* instance of type class */
-typedef Cell Triple; /* triple of cell values */
-typedef Cell List; /* list of cells */
-typedef Cell Bignum; /* bignum integer */
-typedef Cell Float; /* floating pt literal */
-#if TREX
-typedef Cell Ext; /* extension label */
-#endif
-
-typedef Cell ConId;
-typedef Cell VarId;
-typedef Cell QualId;
-typedef Cell ConVarId;
-
-/* --------------------------------------------------------------------------
- * Address ranges.
- *
- * -heapSize .. -1 cells in the heap
- * 0 NIL
- *
- * TAG_NONPTR_MIN(100) .. TAG_NONPTR_MAX(116) non pointer tags
- * TAG_PTR_MIN(200) .. TAG_PTR_MAX(298) pointer tags
- * TAG_SPEC_MIN(400) .. TAG_SPEC_MAX(431) special tags
- * OFF_MIN(1,000) .. OFF_MAX(1,999) offsets
- * CHARR_MIN(3,000) .. CHARR_MAX(3,255) chars
- *
- * SMALL_INT_MIN(100,000) .. SMALL_INT_MAX(499,999) smallish ints
- * (300,000 denotes 0)
- *
- * NAME_BASE_ADDR (1,000,000 .. 1,899,999) names
- * TYCON_BASE_ADDR (2,000,000 .. 2,899,999) tycons
- * CCLASS_BASE_ADDR (3,000,000 .. 3,899,999) classes
- * INST_BASE_ADDR (4,000,000 .. 4,899,999) instances
- * MODULE_BASE_ADDR (5,000,000 .. 5,899,999) modules
- * INVAR_BASE_ADDR (6,000,000 .. 6,899,999) invented var names
- * INDVAR_BASE_ADDR (7,000,000 .. 7,899,999) invented dict var names
- * TEXT_BASE_ADDR (8,000,000 .. 8M +TEXT_SIZE-1) text
- * ------------------------------------------------------------------------*/
-
-/* --------------------------------------------------------------------------
- * Text storage:
- * provides storage for the characters making up identifier and symbol
- * names, string literals, character constants etc...
- * ------------------------------------------------------------------------*/
-
-extern String textToStr ( Text );
-extern Text findText ( String );
-extern Text inventText ( Void );
-extern Text inventDictText ( Void );
-extern Bool inventedText ( Text );
-extern Text enZcodeThenFindText ( String );
-extern Text unZcodeThenFindText ( String );
-
-/* Variants of textToStr and syntaxOf which work for idents, ops whether
- * qualified or unqualified.
- */
-extern String identToStr ( Cell );
-extern Text fixLitText ( Text );
-extern Syntax identSyntax ( Cell );
-extern Syntax defaultSyntax ( Text );
-
-#define INVAR_BASE_ADDR 6000000
-#define INVAR_MAX_AVAIL 900000
-#define isInventedVar(c) (INVAR_BASE_ADDR<=(c) \
- && (c)<INVAR_BASE_ADDR+INVAR_MAX_AVAIL)
-
-#define INDVAR_BASE_ADDR 7000000
-#define INDVAR_MAX_AVAIL 900000
-#define isInventedDictVar(c) (INDVAR_BASE_ADDR<=(c) \
- && (c)<INDVAR_BASE_ADDR+INDVAR_MAX_AVAIL)
-
-#define TEXT_BASE_ADDR 8000000
-#define isText(c) (TEXT_BASE_ADDR<=(c) \
- && (c)<TEXT_BASE_ADDR+TEXT_SIZE)
-
-/* --------------------------------------------------------------------------
- * Specification of syntax (i.e. default written form of application)
- * ------------------------------------------------------------------------*/
-
-#define MIN_PREC 0 /* weakest binding operator */
-#define MAX_PREC 9 /* strongest binding operator */
-#define FUN_PREC (MAX_PREC+2) /* binding of function symbols */
-#define DEF_PREC MAX_PREC
-#define APPLIC 0 /* written applicatively */
-#define LEFT_ASS 1 /* left associative infix */
-#define RIGHT_ASS 2 /* right associative infix */
-#define NON_ASS 3 /* non associative infix */
-#define DEF_ASS LEFT_ASS
-
-#define UMINUS_PREC 6 /* Change these settings at your */
-#define UMINUS_ASSOC LEFT_ASS /* own risk; they may not work! */
-
-#define assocOf(x) ((x)&NON_ASS)
-#define precOf(x) ((x)>>2)
-#define mkSyntax(a,p) ((a)|((p)<<2))
-#define DEF_OPSYNTAX mkSyntax(DEF_ASS,DEF_PREC)
-#define NO_SYNTAX (-1)
-
-extern Void addSyntax ( Int,Text,Syntax );
-extern Syntax syntaxOf ( Text );
-
-/* --------------------------------------------------------------------------
- * Heap storage:
- * Provides a garbage collectable heap for storage of expressions etc.
- * ------------------------------------------------------------------------*/
-
-#define heapAlloc(s) (Heap)(farCalloc(s,sizeof(Cell)))
-extern Int heapSize;
-extern Heap heapFst, heapSnd;
-extern Heap heapTopFst;
-extern Heap heapTopSnd;
-extern Bool consGC; /* Set to FALSE to turn off gc from*/
- /* C stack; use with extreme care! */
-extern Int cellsRecovered; /* cells recovered by last gc */
-
-#define fst(c) heapTopFst[c]
-#define snd(c) heapTopSnd[c]
-
-extern Pair pair ( Cell,Cell );
-extern Void garbageCollect ( Void );
-extern Void mark ( Cell );
-
-#define isPair(c) ((c)<0)
-#define isGenPair(c) ((c)<0 && -heapSize<=(c))
-
-extern Cell whatIs ( Cell );
-
-/* --------------------------------------------------------------------------
- * Pairs in the heap fall into three categories.
- *
- * pair(TAG_NONPTR,y)
- * used to denote that the second element of the pair is to be treated
- * in some special way (eg is a integer or Text), and specifically is not
- * a heap pointer
- *
- * pair(TAG_PTR,y)
- * to indicate that the second element of the pair is a normal
- * heap pointer, which should be followed at GC time
- *
- * pair(x,y)
- * is a genuine pair, where both components are heap pointers.
- * ------------------------------------------------------------------------*/
-
-#if !defined(SIZEOF_VOID_P) || !defined(SIZEOF_INT)
-#error SIZEOF_VOID_P or SIZEOF_INT is not defined
-#endif
-
-#define isTagNonPtr(c) (TAG_NONPTR_MIN<=(c) && (c)<=TAG_NONPTR_MAX)
-#define isTagPtr(c) (TAG_PTR_MIN<=(c) && (c)<=TAG_PTR_MAX)
-#define isTag(c) (isTagNonPtr(c) || isTagPtr(c))
-
-/* --------------------------------------------------------------------------
- * Tags for non-pointer cells.
- * ------------------------------------------------------------------------*/
-
-#define TAG_NONPTR_MIN 100
-#define TAG_NONPTR_MAX 116
-
-#define FREECELL 100 /* Free list cell: snd :: Cell */
-#define VARIDCELL 101 /* Identifier variable: snd :: Text */
-#define VAROPCELL 102 /* Operator variable: snd :: Text */
-#define DICTVAR 103 /* Dictionary variable: snd :: Text */
-#define CONIDCELL 104 /* Identifier constructor: snd :: Text */
-#define CONOPCELL 105 /* Operator constructor: snd :: Text */
-#define STRCELL 106 /* String literal: snd :: Text */
-#define INTCELL 107 /* Int literal: snd :: Int */
-#define ADDPAT 108 /* (_+k) pattern discr: snd :: Int */
-#define FLOATCELL 109 /* Floating Pt literal: snd :: Text */
-#define BIGCELL 110 /* Integer literal: snd :: Text */
-#define ADDRCELL 111 /* Address literal snd :: Ptr */
-#define MPTRCELL 112 /* C (malloc) Heap Pointer snd :: Ptr */
-#define CPTRCELL 113 /* Closure pointer snd :: Ptr */
-
-#if IPARAM
-#define IPCELL 114 /* Imp Param Cell: snd :: Text */
-#define IPVAR 115 /* ?x: snd :: Text */
-#endif
-
-#if TREX
-#define EXTCOPY 116 /* Copy of an Ext: snd :: Text */
-#endif
-
-#define qmodOf(c) (textOf(fst(snd(c)))) /* c :: QUALIDENT */
-#define qtextOf(c) (textOf(snd(snd(c)))) /* c :: QUALIDENT */
-#define mkVar(t) ap(VARIDCELL,t)
-#define mkVarop(t) ap(VAROPCELL,t)
-#define mkCon(t) ap(CONIDCELL,t)
-#define mkConop(t) ap(CONOPCELL,t)
-#define mkQVar(m,t) ap(QUALIDENT,pair(mkCon(m),mkVar(t)))
-#define mkQCon(m,t) ap(QUALIDENT,pair(mkCon(m),mkCon(t)))
-#define mkQVarOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkVarop(t)))
-#define mkQConOp(m,t) ap(QUALIDENT,pair(mkCon(m),mkConop(t)))
-#define mkQualId(m,t) ap(QUALIDENT,pair(m,t))
-#define intValOf(c) (snd(c))
-#define inventVar() mkVar(inventText())
-#define mkDictVar(t) ap(DICTVAR,t)
-#define inventDictVar() mkDictVar(inventDictText())
-#define mkStr(t) ap(STRCELL,t)
-#if IPARAM
-#define mkIParam(c) ap(IPCELL,snd(c))
-#define isIP(p) (whatIs(p) == IPCELL)
-#define ipMatch(pi, t) (isIP(fun(pi)) && textOf(fun(pi)) == t)
-#define ipVar(pi) textOf(fun(pi))
-#else
-#define isIP(p) FALSE
-#endif
-
-extern Bool isVar ( Cell );
-extern Bool isCon ( Cell );
-extern Bool isQVar ( Cell );
-extern Bool isQCon ( Cell );
-extern Bool isQualIdent ( Cell );
-extern Bool eqQualIdent ( QualId c1, QualId c2 );
-extern Bool isIdent ( Cell );
-extern String stringNegate ( String );
-extern Text textOf ( Cell );
-
-#define isFloat(c) (isPair(c) && fst(c)==FLOATCELL)
-#define stringToFloat(s) pair(FLOATCELL,findText(s))
-#define floatToString(f) textToStr(snd(f))
-#define floatOf(f) atof(floatToString(f))
-#define mkFloat(f) (f) /* ToDo: is this right? */
-#define floatNegate(f) stringToFloat(stringNegate(floatToString(f)))
-
-#define stringToBignum(s) pair(BIGCELL,findText(s))
-#define bignumToString(b) textToStr(snd(b))
-
-#define isMPtr(c) (isPair(c) && fst(c)==MPTRCELL)
-extern Cell mkMPtr ( Ptr );
-extern Ptr mptrOf ( Cell );
-#define isCPtr(c) (isPair(c) && fst(c)==CPTRCELL)
-extern Cell mkCPtr ( Ptr );
-extern Ptr cptrOf ( Cell );
-#define isAddr(c) (isPair(c) && fst(c)==ADDRCELL)
-extern Cell mkAddr ( Ptr );
-extern Ptr addrOf ( Cell );
-
-/* --------------------------------------------------------------------------
- * Tags for pointer cells.
- * ------------------------------------------------------------------------*/
-
-#define TAG_PTR_MIN 200
-#define TAG_PTR_MAX 299
-
-#define LETREC 200 /* LETREC snd :: ([Decl],Exp) */
-#define COND 201 /* COND snd :: (Exp,Exp,Exp) */
-#define LAMBDA 202 /* LAMBDA snd :: Alt */
-#define FINLIST 203 /* FINLIST snd :: [Exp] */
-#define DOCOMP 204 /* DOCOMP snd :: (Exp,[Qual]) */
-#define BANG 205 /* BANG snd :: Type */
-#define COMP 206 /* COMP snd :: (Exp,[Qual]) */
-#define ASPAT 207 /* ASPAT snd :: (Var,Exp) */
-#define ESIGN 208 /* ESIGN snd :: (Exp,Type) */
-#define RSIGN 209 /* RSIGN snd :: (Rhs,Type) */
-#define CASE 210 /* CASE snd :: (Exp,[Alt]) */
-#define NUMCASE 211 /* NUMCASE snd :: (Exp,Disc,Rhs) */
-#define FATBAR 212 /* FATBAR snd :: (Exp,Exp) */
-#define LAZYPAT 213 /* LAZYPAT snd :: Exp */
-#define DERIVE 214 /* DERIVE snd :: Cell */
-#define BOOLQUAL 215 /* BOOLQUAL snd :: Exp */
-#define QWHERE 216 /* QWHERE snd :: [Decl] */
-#define FROMQUAL 217 /* FROMQUAL snd :: (Exp,Exp) */
-#define DOQUAL 218 /* DOQUAL snd :: Exp */
-#define MONADCOMP 219 /* MONADCOMP snd :: ((m,m0),(Exp,[Qual])*/
-#define GUARDED 220 /* GUARDED snd :: [guarded exprs] */
-#define ARRAY 221 /* Array snd :: (Bounds,[Values]) */
-#define MUTVAR 222 /* Mutvar snd :: Cell */
-#define HUGSOBJECT 223 /* HUGSOBJECT snd :: Cell */
-
-#if IPARAM
-#define WITHEXP 224 /* WITHEXP snd :: [(Var,Exp)] */
-#endif
-
-#define POLYTYPE 225 /* POLYTYPE snd :: (Kind,Type) */
-#define QUAL 226 /* QUAL snd :: ([Classes],Type) */
-#define RANK2 227 /* RANK2 snd :: (Int,Type) */
-#define EXIST 228 /* EXIST snd :: (Int,Type) */
-#define POLYREC 229 /* POLYREC snd :: (Int,Type) */
-#define BIGLAM 230 /* BIGLAM snd :: (vars,patterns) */
-#define CDICTS 231 /* CDICTS snd :: ([Pred],Type) */
-
-#define LABC 232 /* LABC snd :: (con,[(Vars,Type)]) */
-#define CONFLDS 233 /* CONFLDS snd :: (con,[Field]) */
-#define UPDFLDS 234 /* UPDFLDS snd :: (Exp,[con],[Field]) */
-#if TREX
-#define RECORD 235 /* RECORD snd :: [Val] */
-#define EXTCASE 236 /* EXTCASE snd :: (Exp,Disc,Rhs) */
-#define RECSEL 237 /* RECSEL snd :: Ext */
-#endif
-#define IMPDEPS 238 /* IMPDEPS snd :: [Binding] */
-
-#define QUALIDENT 239 /* Qualified identifier snd :: (Id,Id) */
-#define HIDDEN 240 /* hiding import list snd :: [Entity] */
-#define MODULEENT 241 /* module in export list snd :: con */
-
-#define INFIX 242 /* INFIX snd :: (see tidyInfix) */
-#define ONLY 243 /* ONLY snd :: Exp */
-#define NEG 244 /* NEG snd :: Exp */
-
-/* Used when parsing GHC interface files */
-#define DICTAP 245 /* DICTAP snd :: (QClassId,[Type]) */
-#define UNBOXEDTUP 246 /* UNBOXEDTUP snd :: [Type] */
-
-#if SIZEOF_VOID_P != SIZEOF_INT
-#define PTRCELL 247 /* C Heap Pointer snd :: (Int,Int) */
-#endif
-
-/* STG syntax */
-#define STGVAR 248 /* STGVAR snd :: (StgRhs,info) */
-#define STGAPP 249 /* STGAPP snd :: (StgVar,[Arg]) */
-#define STGPRIM 250 /* STGPRIM snd :: (PrimOp,[Arg]) */
-#define STGCON 251 /* STGCON snd :: (StgCon,[Arg]) */
-#define PRIMCASE 252 /* PRIMCASE snd :: (Expr,[PrimAlt]) */
-#define DEEFALT 253 /* DEEFALT snd :: (Var,Expr) */
-#define CASEALT 254 /* CASEALT snd :: (Con,[Var],Expr) */
-#define PRIMALT 255 /* PRIMALT snd :: ([Var],Expr) */
-
-/* Module groups */
-#define GRP_REC 256 /* GRP_REC snd :: [CONID] */
-#define GRP_NONREC 257 /* GRP_NONREC snd :: CONID */
-
-
-/*
- Top-level interface entities
- type Line = Int -- a line number
- type ConVarId = CONIDCELL | VARIDCELL
- type ExportListEntry = ConVarId | (ConId, [ConVarId])
- type Associativity = mkInt of LEFT_ASS | RIGHT_ASS | NON_ASS
- type Constr = ((ConId, [((Type,VarId,Int))]))
- ((constr name, [((type, field name if any, strictness))]))
- strictness: 0 => none, 1 => !, 2 => !! (unpacked)
- All 2/3/4/5 tuples in the interface abstract syntax are done with
- z-tuples.
-*/
-
-#define I_INTERFACE 260 /* snd :: ((ConId, [I_IMPORT..I_VALUE]))
- interface name, list of iface entities */
-
-#define I_IMPORT 261 /* snd :: ((ConId, [ConVarId]))
- module name, list of entities */
-
-#define I_INSTIMPORT 262 /* snd :: NIL -- not used at present */
-
-#define I_EXPORT 263 /* snd :: ((ConId, [ExportListEntry]))
- this module name?, entities to export */
-
-#define I_FIXDECL 264 /* snd :: ((NIL|Int, Associativity, ConVarId))
- fixity, associativity, name */
-
-#define I_INSTANCE 265 /* snd :: ((Line,
- [((VarId,Kind))],
- Type, VarId, Inst))
- lineno,
- forall-y bit (eg __forall [a b] =>),
- other bit, eg { C a1 } -> { C2 a2 } -> ... -> { Cn an },
- name of dictionary builder,
- (after startGHCInstance) the instance table location */
-
-#define I_TYPE 266 /* snd :: ((Line, ConId, [((VarId,Kind))], Type))
- lineno, tycon, kinded tyvars, the type expr */
-
-#define I_DATA 267 /* snd :: ((Line, [((QConId,VarId))], ConId,
- [((VarId,Kind))], [Constr])
- lineno, context, tycon, kinded tyvars, constrs
- An empty constr list means exported abstractly. */
-
-#define I_NEWTYPE 268 /* snd :: ((Line, [((QConId,VarId))], ConId,
- [((VarId,Kind))], ((ConId,Type)) ))
- lineno, context, tycon, kinded tyvars, constr
- constr==NIL means exported abstractly. */
-
-#define I_CLASS 269 /* snd :: ((Line, [((QConId,VarId))], ConId,
- [((VarId,Kind))], [((VarId,Type))]))
- lineno, context, classname,
- kinded tyvars, method sigs */
-
-#define I_VALUE 270 /* snd :: ((Line, VarId, Type)) */
-
-/*
- Top-level module entities.
-
- type Export = ?
-*/
-#define M_MODULE 280 /* snd :: ((ConId, [Export],
- M_IMPORT_Q .. M_VALUE]))
- module name, export spec, top level entities */
-
-#define M_IMPORT_Q 281 /* snd :: ((?,?)) */
-#define M_IMPORT_UNQ 282 /* snd :: ((?,?)) */
-#define M_TYCON 283 /* snd :: ((Line,?,?,?)) */
-#define M_CLASS 284 /* snd :: ((Line,?,?,?)) */
-#define M_INST 285 /* snd :: ((Line,?,?)) */
-#define M_DEFAULT 286 /* snd :: ((Line,?)) */
-#define M_FOREIGN_EX 289 /* snd :: ((Line,?,?,?,?)) */
-#define M_FOREIGN_IM 290 /* snd :: ((Line,?,?,?,?)) */
-#define M_VALUE 291 /* snd :: ? */
-
-
-
-
-/*
- Tagged tuples.
-*/
-#define ZTUP2 295 /* snd :: (Cell,Cell) */
-#define ZTUP3 296 /* snd :: (Cell,(Cell,Cell)) */
-#define ZTUP4 297 /* snd :: (Cell,(Cell,(Cell,Cell))) */
-#define ZTUP5 298 /* snd :: (Cell,(Cell,(Cell,(Cell,Cell)))) */
-
-#define MDOCOMP 299 /* MDOCOMP snd :: (Exp,[Qual]) */
-
-
-/* --------------------------------------------------------------------------
- * Special cell values.
- * ------------------------------------------------------------------------*/
-
-#define TAG_SPEC_MIN 400
-#define TAG_SPEC_MAX 431
-
-#define isSpec(c) (TAG_SPEC_MIN<=(c) && (c)<=TAG_SPEC_MAX)
-
-#define NONE 400 /* Dummy stub */
-#define STAR 401 /* Representing the kind of types */
-#if TREX
-#define ROW 402 /* Representing the kind of rows */
-#endif
-#define WILDCARD 403 /* Wildcard pattern */
-#define SKOLEM 404 /* Skolem constant */
-
-#define DOTDOT 405 /* ".." in import/export list */
-
-#define NAME 406 /* whatIs code for isName */
-#define TYCON 407 /* whatIs code for isTycon */
-#define CLASS 408 /* whatIs code for isClass */
-#define MODULE 409 /* whatIs code for isModule */
-#define INSTANCE 410 /* whatIs code for isInst */
-#define TUPLE 411 /* whatIs code for tuple constructor */
-#define OFFSET 412 /* whatis code for offset */
-#define AP 413 /* whatIs code for application node */
-#define CHARCELL 414 /* whatIs code for isChar */
-#if TREX
-#define EXT 415 /* whatIs code for isExt */
-#endif
-
-#define SIGDECL 416 /* Signature declaration */
-#define FIXDECL 417 /* Fixity declaration */
-#define FUNBIND 418 /* Function binding */
-#define PATBIND 419 /* Pattern binding */
-
-#define DATATYPE 420 /* Datatype type constructor */
-#define NEWTYPE 421 /* Newtype type constructor */
-#define SYNONYM 422 /* Synonym type constructor */
-#define RESTRICTSYN 423 /* Synonym with restricted scope */
-
-#define NODEPENDS 424 /* Stop calculation of deps in type check*/
-#define PREDEFINED 425 /* Predefined name, not yet filled */
-#define TEXTCELL 426 /* whatIs code for isText */
-#define INVAR 427 /* whatIs code for isInventedVar */
-#define INDVAR 428 /* whatIs code for isInventedDictVar */
-
-#define FM_SOURCE 429 /* denotes source module (FileMode) */
-#define FM_OBJECT 430 /* denotes object module */
-#define FM_EITHER 431 /* no restriction; either is allowed */
-
-
-/* --------------------------------------------------------------------------
- * Tuple data/type constructors:
- * ------------------------------------------------------------------------*/
-
-extern Text ghcTupleText ( Tycon );
-extern Text ghcTupleText_n ( Int );
-
-
-
-#if TREX
-#error TREX not supported
-#define EXTMIN 301
-#define isExt(c) (EXTMIN<=(c) && (c)<OFFMIN)
-#define extText(e) tabExt[(e)-EXTMIN]
-#define extField(c) arg(fun(c))
-#define extRow(c) arg(c)
-
-extern Text DECTABLE(tabExt);
-extern Ext mkExt ( Text );
-#else
-#define mkExt(t) NIL
-#endif
-
-extern Module findFakeModule ( Text t );
-extern Tycon addTupleTycon ( Int n );
-extern Name addWiredInBoxingTycon
- ( String modNm, String typeNm, String constrNm,
- Int rep, Kind kind );
-extern Tycon addWiredInEnumTycon
- ( String modNm, String typeNm,
- List /*of Text*/ constrs );
-
-/* --------------------------------------------------------------------------
- * Offsets: (generic types/stack offsets)
- * ------------------------------------------------------------------------*/
-
-#define OFF_MIN 1000
-#define OFF_MAX 1999
-
-#define isOffset(c) (OFF_MIN<=(c) && (c)<=OFF_MAX)
-#define offsetOf(c) ((c)-OFF_MIN)
-#define mkOffset(o) (OFF_MIN+(o))
-
-
-/* --------------------------------------------------------------------------
- * Modules:
- * ------------------------------------------------------------------------*/
-
-#define MODULE_BASE_ADDR 5000000
-#define MODULE_MAX_SIZE 900000
-#define MODULE_INIT_SIZE 4
-
-#ifdef DEBUG_STORAGE
-extern struct strModule* generate_module_ref ( Cell );
-#define module(mod) (*generate_module_ref(mod))
-#else
-#define module(mod) tabModule[(mod)-MODULE_BASE_ADDR]
-#endif
-
-#define mkModule(n) (MODULE_BASE_ADDR+(n))
-#define isModule(c) (MODULE_BASE_ADDR<=(c) \
- && (c)<MODULE_BASE_ADDR+tabModuleSz \
- && tabModule[(c)-MODULE_BASE_ADDR].inUse)
-
-
-/* Import defns for the ObjectCode struct in Module. */
-#include "object.h"
-
-/* Import a machine-dependent definition of Time, for module timestamps. */
-#include "machdep_time.h"
-
-/* Under Haskell 1.3, the list of qualified imports is always a subset
- * of the list of unqualified imports. For simplicity and flexibility,
- * we do not attempt to exploit this fact - when a module is imported
- * unqualified, it is added to both the qualified and unqualified
- * import lists.
- * Similarily, Haskell 1.3 does not allow a constructor to be imported
- * or exported without exporting the type it belongs to but the export
- * list is just a flat list of Texts (before static analysis) or
- * Tycons, Names and Classes (after static analysis).
- */
-struct strModule {
- Bool inUse;
- Name nextFree;
-
- Text text; /* Name of this module */
-
- List tycons; /* Lists of top level objects ... */
- List names; /* (local defns + imports) */
- List classes;
- List exports; /* [ Entity | (Entity, NIL|DOTDOT) ] */
-
- List qualImports; /* Qualified imports. */
-
- List codeList; /* [ Name | StgTree ] before code generation,
- [ Name | CPtr ] afterwards */
-
- Bool fake; /* TRUE if module exists only via GHC primop */
- /* defn; usually FALSE */
-
- Cell tree; /* Parse tree for mod or iface */
- Bool completed; /* Fully loaded or just parsed? */
- Time lastStamp; /* Time of last parse */
-
- Cell mode; /* FM_SOURCE or FM_OBJECT */
- Text srcExt; /* if mode==FM_SOURCE ".lhs", ".hs", etc */
- List uses; /* :: [CONID] -- names of mods imported by this one */
-
- Text objName; /* Name of the primary object code file. */
- Int objSize; /* Size of the primary object code file. */
-
- ObjectCode* object; /* Primary object code for this module. */
- ObjectCode* objectExtras; /* And any extras it might need. */
- List objectExtraNames; /* :: [Text] -- names of extras */
-};
-
-extern struct strModule* tabModule;
-extern Int tabModuleSz;
-
-extern Module currentModule; /* Module currently being processed */
-extern List moduleGraph; /* :: [GRP_REC | GRP_NONREC] */
-extern List prelModules; /* :: [CONID] */
-extern List targetModules; /* :: [CONID] */
-extern Bool nukeModule_needs_major_gc; /* see comment in compiler.c */
-
-extern Bool isValidModule ( Module );
-extern Module newModule ( Text );
-extern Void nukeModule ( Module );
-extern Module findModule ( Text );
-extern Module findModid ( Cell );
-extern Void setCurrModule ( Module );
-extern void addToCodeList ( Module, Cell );
-extern void setNameOrTupleClosure ( Cell c, Cell closure );
-extern Cell getNameOrTupleClosure ( Cell c );
-extern void setNameOrTupleClosureCPtr ( Cell c,
- void* /* StgClosure* */ cptr );
-
-
-extern void addOTabName ( Module,char*,void* );
-extern void* lookupOTabName ( Module,char* );
-extern char* nameFromOPtr ( void* );
-
-extern void addSection ( Module,void*,void*,OSectionKind );
-extern OSectionKind lookupSection ( void* );
-extern void* lookupOExtraTabName ( char* sym );
-extern void* lookupOTabNameAbsolutelyEverywhere ( char* sym );
-
-#define isPrelude(m) (m==modulePrelude)
-
-#define N_PRELUDE_SCRIPTS (combined ? 32 : 1)
-
-/* --------------------------------------------------------------------------
- * Type constructor names:
- * ------------------------------------------------------------------------*/
-
-#define TYCON_BASE_ADDR 2000000
-#define TYCON_MAX_SIZE 900000
-#define TYCON_INIT_SIZE 4
-
-#ifdef DEBUG_STORAGE
-extern struct strTycon* generate_tycon_ref ( Cell );
-#define tycon(tc) (*generate_tycon_ref(tc))
-#else
-#define tycon(tc) tabTycon[(tc)-TYCON_BASE_ADDR]
-#endif
-
-#define isTycon(c) (TYCON_BASE_ADDR<=(c) \
- && (c)<TYCON_BASE_ADDR+tabTyconSz \
- && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
- && tabTycon[(c)-TYCON_BASE_ADDR].tuple==-1)
-#define isTuple(c) (TYCON_BASE_ADDR<=(c) \
- && (c)<TYCON_BASE_ADDR+tabTyconSz \
- && tabTycon[(c)-TYCON_BASE_ADDR].inUse \
- && tabTycon[(c)-TYCON_BASE_ADDR].tuple>=0)
-#define tupleOf(n) (tycon(n).tuple)
-
-extern Tycon mkTuple ( Int );
-
-
-struct strTycon {
- Bool inUse;
- Name nextFree;
- Text text;
- Int line;
- Module mod; /* module that defines it */
- Int tuple; /* tuple number, or -1 if not tuple */
- Int arity;
- Kind kind; /* kind (includes arity) of Tycon */
- Cell what; /* DATATYPE/SYNONYM/RESTRICTSYN... */
- Cell defn;
- Name conToTag; /* used in derived code */
- Name tagToCon;
- void* itbl; /* For tuples, the info tbl pointer */
- Cell closure; /* Either StgTree, or (later) CPtr, which is the
- address in the evaluator's heap. Only Tuples
- use the closure field; all other tycons which
- require actual code have associated name table
- entries. */
- Tycon nextTyconHash;
-};
-
-extern struct strTycon* tabTycon;
-extern Int tabTyconSz;
-
-extern Tycon newTycon ( Text );
-extern Tycon findTycon ( Text );
-extern Tycon addTycon ( Tycon );
-extern Tycon findQualTycon ( Cell );
-extern Tycon addPrimTycon ( Text,Kind,Int,Cell,Cell );
-
-#define isSynonym(h) (isTycon(h) && tycon(h).what==SYNONYM)
-#define isQualType(t) (isPair(t) && fst(t)==QUAL)
-#define mkPolyType(n,t) pair(POLYTYPE,pair(n,t))
-#define isPolyType(t) (isPair(t) && fst(t)==POLYTYPE)
-#define isPolyOrQualType(t) (isPair(t) && (fst(t)==POLYTYPE || fst(t)==QUAL))
-#define polySigOf(t) fst(snd(t))
-#define monotypeOf(t) snd(snd(t))
-#define bang(t) ap(BANG,t)
-
-extern Tycon findQualTyconWithoutConsultingExportList ( QualId q );
-
-extern Int numQualifiers ( Type );
-
-
-/* --------------------------------------------------------------------------
- * Globally defined name values:
- * ------------------------------------------------------------------------*/
-
-#define NAME_BASE_ADDR 1000000
-#define NAME_MAX_SIZE 900000
-#define NAME_INIT_SIZE 4
-
-#ifdef DEBUG_STORAGE
-extern struct strName* generate_name_ref ( Cell );
-#define name(nm) (*generate_name_ref(nm))
-#else
-#define name(nm) tabName[(nm)-NAME_BASE_ADDR]
-#endif
-
-#define mkName(n) (NAME_BASE_ADDR+(n))
-#define isName(c) (NAME_BASE_ADDR<=(c) \
- && (c)<NAME_BASE_ADDR+tabNameSz \
- && tabName[(c)-NAME_BASE_ADDR].inUse)
-
-struct strName {
- Bool inUse;
- Name nextFree;
- Text text;
- Int line;
- Module mod; /* module that defines it */
- Syntax syntax;
- Cell parent;
- Int arity;
- Int number;
- Cell type;
- Cell defn;
- Bool hasStrict; /* does constructor have strict components? */
- Text callconv; /* for foreign import/export */
- void* primop; /* really StgPrim* */
- void* itbl; /* For constructors, the info tbl pointer */
- Cell closure; /* Either StgTree, or (later) Ptr, an AsmBCO/
- AsmCAF/AsmCon thing, or CPtr, which is the
- address in the evaluator's heap */
- Name nextNameHash;
-};
-
-extern struct strName* tabName;
-extern Int tabNameSz;
-
-extern int numNames ( Void );
-
-/* The number field in a name is used to distinguish various kinds of name:
- * mfunNo(i) = code for member function, offset i
- * members that are sole elements of dict use mfunNo(0)
- * members of dicts with more than one elem use mfunNo(n), n>=1
- * EXECNAME = code for executable name (bytecodes or primitive)
- * SELNAME = code for selector function
- * DFUNNAME = code for dictionary builder or selector
- * cfunNo(i) = code for data constructor
- * datatypes with only one constructor uses cfunNo(0)
- * datatypes with multiple constructors use cfunNo(n), n>=1
- */
-
-#define EXECNAME 0
-#define SELNAME 1
-#define DFUNNAME 2
-#define CFUNNAME 3
-
-#define isSfun(n) (name(n).number==SELNAME)
-#define isDfun(n) (name(n).number==DFUNNAME)
-
-#define isCfun(n) (name(n).number>=CFUNNAME)
-#define cfunOf(n) (name(n).number-CFUNNAME)
-#define cfunNo(i) ((i)+CFUNNAME)
-#define hasCfun(cs) (nonNull(cs) && isCfun(hd(cs)))
-
-#define isMfun(n) (name(n).number<0)
-#define mfunOf(n) ((-1)-name(n).number)
-#define mfunNo(i) ((-1)-(i))
-
-extern Name newName ( Text,Cell );
-extern Name findName ( Text );
-extern Name addName ( Name );
-extern Name findQualName ( Cell );
-extern Name addPrimCfun ( Text,Int,Int,Cell );
-extern Name addPrimCfunREP ( Text,Int,Int,Int );
-extern Int sfunPos ( Name,Name );
-extern Name jrsFindQualName ( Text,Text );
-
-extern Name findQualNameWithoutConsultingExportList ( QualId q );
-
-/* --------------------------------------------------------------------------
- * Type class values:
- * ------------------------------------------------------------------------*/
-
-#define INST_BASE_ADDR 4000000
-#define INST_MAX_SIZE 900000
-#define INST_INIT_SIZE 4
-
-#ifdef DEBUG_STORAGE
-extern struct strInst* generate_inst_ref ( Cell );
-#define inst(in) (*generate_inst_ref(in))
-#else
-#define inst(in) tabInst[(in)-INST_BASE_ADDR]
-#endif
-
-#define mkInst(n) (INST_BASE_ADDR+(n))
-#define instOf(c) ((Int)((c)-INST_BASE_ADDR))
-#define isInst(c) (INST_BASE_ADDR<=(c) \
- && (c)<INST_BASE_ADDR+tabInstSz \
- && tabInst[(c)-INST_BASE_ADDR].inUse)
-
-struct strInst {
- Bool inUse;
- Name nextFree;
- Class c; /* class C */
- Int line;
- Module mod; /* module that defines it */
- Kinds kinds; /* Kinds of variables in head */
- Cell head; /* :: Pred */
- List specifics; /* :: [Pred] */
- Int numSpecifics; /* length(specifics) */
- List implements;
- Name builder; /* Dictionary constructor function */
-};
-
-extern struct strInst* tabInst;
-extern Int tabInstSz;
-
-/* a predicate (an element :: Pred) is an application of a Class to one or
- * more type expressions
- */
-
-#define CCLASS_BASE_ADDR 3000000
-#define CCLASS_MAX_SIZE 900000
-#define CCLASS_INIT_SIZE 4
-
-#ifdef DEBUG_STORAGE
-extern struct strClass* generate_cclass_ref ( Cell );
-#define cclass(cl) (*generate_cclass_ref(cl))
-#else
-#define cclass(cl) tabClass[(cl)-CCLASS_BASE_ADDR]
-#endif
-
-#define mkClass(n) (CCLASS_BASE_ADDR+(n))
-#define isClass(c) (CCLASS_BASE_ADDR<=(c) \
- && (c)<CCLASS_BASE_ADDR+tabClassSz \
- && tabClass[(c)-CCLASS_BASE_ADDR].inUse)
-
-struct strClass {
- Bool inUse;
- Name nextFree;
- Text text; /* Name of class */
- Int line; /* Line where declaration begins */
- Module mod; /* module that declares it */
- Int level; /* Level in class hierarchy */
- Int arity; /* Number of arguments */
- Kinds kinds; /* Kinds of constructors in class */
- List fds; /* Functional Dependencies */
- List xfds; /* Xpanded Functional Dependencies */
- Cell head; /* Head of class */
- Name dcon; /* Dictionary constructor function */
- List supers; /* :: [Pred] */
- Int numSupers; /* length(supers) */
- List dsels; /* Superclass dictionary selectors */
- List members; /* :: [Name] */
- Int numMembers; /* length(members) */
- List defaults; /* :: [Name] */
- List instances; /* :: [Inst] */
-};
-
-extern struct strClass* tabClass;
-extern Int tabClassSz;
-
-extern Class newClass ( Text );
-extern Class findClass ( Text );
-extern Class addClass ( Class );
-extern Class findQualClass ( Cell );
-extern Inst newInst ( Void );
-extern Inst findFirstInst ( Tycon );
-extern Inst findNextInst ( Tycon,Inst );
-extern List getAllKnownTyconsAndClasses ( void );
-extern Class findQualClassWithoutConsultingExportList ( QualId q );
-
-/* --------------------------------------------------------------------------
- * Character values:
- * ------------------------------------------------------------------------*/
-
-/* I think this assumes that NUM_CHARS==256. */
-#define CHARR_MIN 3000
-#define CHARR_MAX 3255
-#define isChar(c) (CHARR_MIN<=(c) && (c)<=CHARR_MAX)
-#define charOf(c) ((Char)((c)-CHARR_MIN))
-#define mkChar(c) (CHARR_MIN+(((Cell)(c)) & 0xFF))
-#define MAXCHARVAL (NUM_CHARS-1)
-
-/* --------------------------------------------------------------------------
- * Small Integer values:
- * ------------------------------------------------------------------------*/
-
-#define SMALL_INT_MIN 100000
-#define SMALL_INT_MAX 499999
-#define SMALL_INT_ZERO (1 + SMALL_INT_MIN/2 + SMALL_INT_MAX/2)
-#define isSmall(c) (SMALL_INT_MIN<=(c) && (c)<=SMALL_INT_MAX)
-extern Bool isInt ( Cell );
-extern Int intOf ( Cell );
-extern Cell mkInt ( Int );
-
-/* --------------------------------------------------------------------------
- * Implementation of triples:
- * ------------------------------------------------------------------------*/
-
-#define triple(x,y,z) pair(x,pair(y,z))
-#define fst3(c) fst(c)
-#define snd3(c) fst(snd(c))
-#define thd3(c) snd(snd(c))
-
-/* --------------------------------------------------------------------------
- * Implementation of lists:
- * ------------------------------------------------------------------------*/
-
-#define NIL 0
-#define isNull(c) ((c)==NIL)
-#define nonNull(c) (c)
-#define cons(x,xs) pair(x,xs)
-#define singleton(x) cons(x,NIL)
-#define doubleton(x,y) cons(x,cons(y,NIL))
-#define tripleton(x,y,z) cons(x,cons(y,cons(z,NIL)))
-#define hd(c) fst(c)
-#define tl(c) snd(c)
-
-extern Int length ( List );
-extern List appendOnto ( List,List ); /* destructive */
-extern List dupOnto ( List,List );
-extern List dupList ( List );
-extern List revOnto ( List, List ); /* destructive */
-#define rev(xs) revOnto((xs),NIL) /* destructive */
-#define reverse(xs) revOnto(dupList(xs),NIL) /* non-destructive */
-extern Cell cellIsMember ( Cell,List );
-extern Cell cellAssoc ( Cell,List );
-extern Cell cellRevAssoc ( Cell,List );
-extern Bool eqList ( List,List );
-extern Cell varIsMember ( Text,List );
-extern Name nameIsMember ( Text,List );
-extern QualId qualidIsMember ( QualId, List );
-extern Cell intIsMember ( Int,List );
-extern List replicate ( Int,Cell );
-extern List diffList ( List,List ); /* destructive */
-extern List deleteCell ( List,Cell ); /* non-destructive */
-extern List take ( Int,List ); /* destructive */
-extern List splitAt ( Int,List ); /* non-destructive */
-extern Cell nth ( Int,List );
-extern List removeCell ( Cell,List ); /* destructive */
-extern List dupListOnto ( List,List ); /* non-destructive */
-extern List nubList ( List ); /* non-destructive */
-
-/* The following macros provide `inline expansion' of some common ways of
- * traversing, using and modifying lists:
- *
- * N.B. We use the names _f, _a, _xs, Zs, in an attempt to avoid clashes
- * with identifiers used elsewhere.
- */
-
-#define mapBasic(_init,_step) {List Zs=(_init);\
- for(;nonNull(Zs);Zs=tl(Zs)) \
- _step;}
-#define mapModify(_init,_step) mapBasic(_init,hd(Zs)=_step)
-
-#define mapProc(_f,_xs) mapBasic(_xs,_f(hd(Zs)))
-#define map1Proc(_f,_a,_xs) mapBasic(_xs,_f(_a,hd(Zs)))
-#define map2Proc(_f,_a,_b,_xs) mapBasic(_xs,_f(_a,_b,hd(Zs)))
-#define map3Proc(_f,_a,_b,_c,_xs) mapBasic(_xs,_f(_a,_b,_c,hd(Zs)))
-#define map4Proc(_f,_a,_b,_c,_d,_xs) mapBasic(_xs,_f(_a,_b,_c,_d,hd(Zs)))
-
-#define mapOver(_f,_xs) mapModify(_xs,_f(hd(Zs)))
-#define map1Over(_f,_a,_xs) mapModify(_xs,_f(_a,hd(Zs)))
-#define map2Over(_f,_a,_b,_xs) mapModify(_xs,_f(_a,_b,hd(Zs)))
-#define map3Over(_f,_a,_b,_c,_xs) mapModify(_xs,_f(_a,_b,_c,hd(Zs)))
-#define map4Over(_f,_a,_b,_c,_d,_xs) mapModify(_xs,_f(_a,_b,_c,_d,hd(Zs)))
-
-/* This is just what you want for functions with accumulating parameters */
-#define mapAccum(_f,_acc,_xs) mapBasic(_xs,_acc=_f(_acc,hd(Zs)))
-#define map1Accum(_f,_acc,_a,_xs) mapBasic(_xs,_acc=_f(_acc,_a,hd(Zs)))
-#define map2Accum(_f,_acc,_a,_b,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,hd(Zs)))
-#define map3Accum(_f,_acc,_a,_b,_c,_xs) mapBasic(_xs,_acc=_f(_acc,_a,_b,_c,hd(Zs)))
-
-
-/* --------------------------------------------------------------------------
- * Strongly-typed lists (z-lists) and tuples (experimental)
- * ------------------------------------------------------------------------*/
-
-typedef Cell ZPair;
-typedef Cell ZTriple;
-typedef Cell Z4Ble;
-typedef Cell Z5Ble;
-
-#define isZPair(c) (whatIs((c))==ZTUP2)
-
-extern Cell zpair ( Cell x1, Cell x2 );
-extern Cell zfst ( Cell zpair );
-extern Cell zsnd ( Cell zpair );
-
-extern Cell ztriple ( Cell x1, Cell x2, Cell x3 );
-extern Cell zfst3 ( Cell zpair );
-extern Cell zsnd3 ( Cell zpair );
-extern Cell zthd3 ( Cell zpair );
-
-extern Cell z4ble ( Cell x1, Cell x2, Cell x3, Cell x4 );
-extern Cell zsel14 ( Cell zpair );
-extern Cell zsel24 ( Cell zpair );
-extern Cell zsel34 ( Cell zpair );
-extern Cell zsel44 ( Cell zpair );
-
-extern Cell z5ble ( Cell x1, Cell x2, Cell x3, Cell x4, Cell x5 );
-extern Cell zsel15 ( Cell zpair );
-extern Cell zsel25 ( Cell zpair );
-extern Cell zsel35 ( Cell zpair );
-extern Cell zsel45 ( Cell zpair );
-extern Cell zsel55 ( Cell zpair );
-
-extern Cell unap ( int tag, Cell c );
-
-
-/* --------------------------------------------------------------------------
- * Implementation of function application nodes:
- * ------------------------------------------------------------------------*/
-
-#define ap(f,x) pair(f,x)
-#define ap1(f,x) ap(f,x)
-#define ap2(f,x,y) ap(ap(f,x),y)
-#define ap3(f,x,y,z) ap(ap(ap(f,x),y),z)
-#define fun(c) fst(c)
-#define arg(c) snd(c)
-#define isAp(c) (isPair(c) && !isTag(fst(c)))
-
-extern Cell getHead ( Cell );
-extern List getArgs ( Cell );
-extern Cell nthArg ( Int,Cell );
-extern Int numArgs ( Cell );
-extern Cell applyToArgs ( Cell,List );
-extern Int argCount;
-
-/* --------------------------------------------------------------------------
- * Stack implementation:
- *
- * NB: Use of macros makes order of evaluation hard to predict.
- * For example, "push(1+pop());" doesn't increment TOS.
- * ------------------------------------------------------------------------*/
-
-extern Cell cellStack[];
-extern StackPtr sp;
-
-#define clearStack() sp=(-1)
-#define stackEmpty() (sp==(-1))
-#define stack(p) cellStack[p]
-#define chkStack(n) if (sp>=NUM_STACK-(n)) hugsStackOverflow()
-#define push(c) do { chkStack(1); onto(c); } while (0)
-#define onto(c) stack(++sp)=(c);
-#define pop() stack(sp--)
-#define drop() sp--
-#define top() stack(sp)
-#define pushed(n) stack(sp-(n))
-#define topfun(f) top()=ap((f),top())
-#define toparg(x) top()=ap(top(),(x))
-#define getsp() sp
-
-extern Void hugsStackOverflow ( Void );
-
-#if SYMANTEC_C
-#include <Memory.h>
-#define STACK_HEADROOM 16384
-#define STACK_CHECK if (StackSpace() <= STACK_HEADROOM) \
- internal("Macintosh function parameter stack overflow.");
-#else
-#define STACK_CHECK
-#endif
-
-/* --------------------------------------------------------------------------
- * Misc:
- * ------------------------------------------------------------------------*/
-
-extern Void setLastExpr ( Cell );
-extern Cell getLastExpr ( Void );
-extern List addTyconsMatching ( String,List );
-extern List addNamesMatching ( String,List );
-
-extern Tycon findTyconInAnyModule ( Text t );
-extern Class findClassInAnyModule ( Text t );
-extern Name findNameInAnyModule ( Text t );
-
-extern Void print ( Cell, Int );
-extern void dumpTycon ( Int t );
-extern void dumpName ( Int n );
-extern void dumpClass ( Int c );
-extern void dumpInst ( Int i );
-extern void locateSymbolByName ( Text t );
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Provides an implementation for the `current substitution' used during
- * type and kind inference in both static analysis and type checking.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: subst.c,v $
- * $Revision: 1.17 $
- * $Date: 2000/03/23 14:54:21 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-
-/*#define DEBUG_TYPES*/
-
-static Int numTyvars; /* no. type vars currently in use */
-static Int maxTyvars = 0;
-static Int nextGeneric; /* number of generics found so far */
-
-Tyvar *tyvars = 0; /* storage for type variables */
-Int typeOff; /* offset of result type */
-Type typeIs; /* skeleton of result type */
-Int typeFree; /* freedom in instantiated type */
-List predsAre; /* list of predicates in type */
-List genericVars; /* list of generic vars */
-List btyvars = NIL; /* explicitly scoped type vars */
-
-/* --------------------------------------------------------------------------
- * local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local expandSubst ( Int );
-static Int local findBtyvsInt ( Text );
-static Type local makeTupleType ( Int );
-static Kind local makeSimpleKind ( Int );
-static Kind local makeVarKind ( Int );
-static Void local expandSyn1 ( Tycon, Type *, Int * );
-static List local listTyvar ( Int,List );
-static List local listTyvars ( Type,Int,List );
-static Cell local dupTyvar ( Int,List );
-static Cell local dupTyvars ( Cell,Int,List );
-static Pair local copyNoMark ( Cell,Int );
-static Type local dropRank1Body ( Type,Int,Int );
-static Type local liftRank1Body ( Type,Int );
-static Bool local matchTypeAbove ( Type,Int,Type,Int,Int );
-
-static Bool local varToVarBind ( Tyvar *,Tyvar * );
-static Bool local varToTypeBind ( Tyvar *,Type,Int );
-#if TREX
-static Bool local inserter ( Type,Int,Type,Int );
-static Int local remover ( Text,Type,Int );
-static Int local tailVar ( Type,Int );
-#endif
-
-static Bool local improveAgainst ( Int,List,Cell,Int );
-static Bool local instImprove ( Int,Class,Cell,Int );
-static Bool local pairImprove ( Int,Class,Cell,Int,Cell,Int,Int );
-#if IPARAM
-static Bool local ipImprove ( Int,Cell,Int,Cell,Int );
-#endif
-
-static Bool local kvarToVarBind ( Tyvar *,Tyvar * );
-static Bool local kvarToTypeBind ( Tyvar *,Type,Int );
-
-/* --------------------------------------------------------------------------
- * The substitution, types, and kinds:
- *
- * In early versions of Gofer, the `substitution' data structure was only
- * used by the type checker, so it made sense to include support for it in
- * type.c. This changed when kinds and kind inference where introduced,
- * which required access to the substitution during static analysis. The
- * links between type.c and static.c that were intially used to accomplish
- * this have now been avoided by making the substitution visible as an
- * independent data structure in storage.c.
- *
- * In the same way that values have types, type constructors (and more
- * generally, expressions built from such constructors) have kinds.
- * The syntax of kinds in the current implementation is very simple:
- *
- * kind ::= STAR -- the kind of types
- * | kind => kind -- constructors
- * | variables -- either INTCELL or OFFSET
- *
- * For various reasons, this implementation uses structure sharing, instead
- * of a copying approach. In principal, this is fast and avoids the need to
- * build new type expressions. Unfortunately, this implementation will not
- * be able to handle *very* large expressions.
- *
- * The substitution is represented by an array of type variables each of
- * which is a triple:
- * bound a (skeletal) type expression, or NIL if the variable
- * is not bound, or SKOLEM for a Skolem constant (i.e., an
- * uninstantiable variable).
- * offs offset of skeleton in bound. If isNull(bound), then offs is
- * used to indicate whether that variable is generic (i.e. free
- * in the current assumption set) or fixed (i.e. bound in the
- * current assumption set). Generic variables are assigned
- * offset numbers whilst copying type expressions (t,o) to
- * obtain their most general form.
- * kind kind of value bound to type variable (`type variable' is
- * rather inaccurate -- `constructor variable' would be better).
- * ------------------------------------------------------------------------*/
-
-Void emptySubstitution() { /* clear current substitution */
- numTyvars = 0;
- if (maxTyvars!=NUM_TYVARS) {
- maxTyvars = 0;
- if (tyvars) {
- free(tyvars);
- tyvars = 0;
- }
- }
- nextGeneric = 0;
- genericVars = NIL;
- typeIs = NIL;
- predsAre = NIL;
- btyvars = NIL;
-}
-
-static Void local expandSubst(n) /* add further n type variables to */
-Int n; { /* current substituion */
- if (numTyvars+n>maxTyvars) { /* need to expand substitution */
- Int newMax = maxTyvars+NUM_TYVARS;
- Tyvar *newTvs;
- Int i;
-
- if (numTyvars+n>newMax) { /* safety precaution */
- ERRMSG(0) "Substitution expanding too quickly"
- EEND;
- }
-
- /* It would be better to realloc() here, but that isn't portable
- * enough for calloc()ed arrays. The following code could cause
- * a space leak if an interrupt occurs while we're copying the
- * array ... we won't worry about this for the time being because
- * we don't expect to have to go through this process much (if at
- * all) in normal use of the type checker.
- */
-
- newTvs = (Tyvar *)calloc(newMax,sizeof(Tyvar));
- if (!newTvs) {
- ERRMSG(0) "Too many variables (%d) in type checker", newMax
- EEND;
- }
- for (i=0; i<numTyvars;++i) { /* copy substitution */
- newTvs[i].offs = tyvars[i].offs;
- newTvs[i].bound = tyvars[i].bound;
- newTvs[i].kind = tyvars[i].kind;
- }
- maxTyvars = 0; /* protection from SIGINT? */
- if (tyvars) free(tyvars);
- tyvars = newTvs;
- maxTyvars = newMax;
- }
-}
-
-Int newTyvars(n) /* allocate new type variables */
-Int n; { /* all of kind STAR */
- Int beta = numTyvars;
-
- expandSubst(n);
- for (numTyvars+=n; n>0; n--) {
- tyvars[numTyvars-n].offs = UNUSED_GENERIC;
- tyvars[numTyvars-n].bound = NIL;
- tyvars[numTyvars-n].kind = STAR;
-#ifdef DEBUG_TYPES
- Printf("new type variable: _%d ::: ",numTyvars-n);
- printKind(stdout,tyvars[numTyvars-n].kind);
- Putchar('\n');
-#endif
- }
- return beta;
-}
-
-Int newKindedVars(k) /* allocate new variables with */
-Kind k; { /* specified kinds */
- Int beta = numTyvars; /* if k = k0 -> k1 -> ... -> kn */
- for (; isPair(k); k=snd(k)) { /* then allocate n vars with kinds */
- expandSubst(1); /* k0, k1, ..., k(n-1) */
- tyvars[numTyvars].offs = UNUSED_GENERIC;
- tyvars[numTyvars].bound = NIL;
- tyvars[numTyvars].kind = fst(k);
-#ifdef DEBUG_TYPES
- Printf("new type variable: _%d ::: ",numTyvars);
- printKind(stdout,tyvars[numTyvars].kind);
- Putchar('\n');
-#endif
- numTyvars++;
- }
- return beta;
-}
-
-Void instantiate(type) /* instantiate type, if nonNull */
-Type type; {
- predsAre = NIL;
- typeIs = type;
- typeFree = 0;
-
- if (nonNull(typeIs)) { /* instantiate type expression ? */
-
- if (isPolyType(typeIs)) { /* Polymorphic type scheme ? */
- Kinds ks = polySigOf(typeIs);
- typeOff = newKindedVars(ks);
- typeIs = monotypeOf(typeIs);
- for (; isAp(ks); ks=arg(ks))
- typeFree++;
- }
-
- if (isQualType(typeIs)) { /* Qualified type? */
- predsAre = fst(snd(typeIs));
- typeIs = snd(snd(typeIs));
- }
- }
-}
-
-/* --------------------------------------------------------------------------
- * Bound type variables:
- * ------------------------------------------------------------------------*/
-
-Pair findBtyvs(t) /* Look for bound tyvar */
-Text t; {
- List bts = btyvars;
- for (; nonNull(bts); bts=tl(bts)) {
- List bts1 = hd(bts);
- for (; nonNull(bts1); bts1=tl(bts1))
- if (t==textOf(fst(hd(bts1))))
- return hd(bts1);
- }
- return NIL;
-}
-
-static Int local findBtyvsInt(t) /* Look for bound type variable */
-Text t; { /* expecting to find an integer */
- Pair p = findBtyvs(t);
- if (isNull(p))
- internal("findBtyvsInt");
- return intOf(snd(p));
-}
-
-Void markBtyvs() { /* Mark explicitly scoped vars */
- List bts = btyvars;
- for (; nonNull(bts); bts=tl(bts)) {
- List bts1 = hd(bts);
- for (; nonNull(bts1); bts1=tl(bts1))
- markTyvar(intOf(snd(hd(bts1))));
- }
-}
-
-Type localizeBtyvs(t) /* Localize type to eliminate refs */
-Type t; { /* to explicitly scoped vars */
- switch (whatIs(t)) {
- case RANK2 :
- case POLYTYPE : snd(snd(t)) = localizeBtyvs(snd(snd(t)));
- break;
-
- case QUAL : fst(snd(t)) = localizeBtyvs(fst(snd(t)));
- snd(snd(t)) = localizeBtyvs(snd(snd(t)));
- break;
-
- case AP : fst(t) = localizeBtyvs(fst(t));
- snd(t) = localizeBtyvs(snd(t));
- break;
-
- case VARIDCELL:
- case VAROPCELL: return mkInt(findBtyvsInt(textOf(t)));
- }
- return t;
-}
-
-/* --------------------------------------------------------------------------
- * Dereference or bind types in subsitution:
- * ------------------------------------------------------------------------*/
-
-Tyvar *getTypeVar(t,o) /* get number of type variable */
-Type t; /* represented by (t,o) [if any]. */
-Int o; {
- switch (whatIs(t)) {
- case INTCELL : return tyvar(intOf(t));
- case OFFSET : return tyvar(o+offsetOf(t));
- case VARIDCELL :
- case VAROPCELL : return tyvar(findBtyvsInt(textOf(t)));
- }
- return ((Tyvar *)0);
-}
-
-Void tyvarType(vn) /* load type held in type variable */
-Int vn; { /* vn into (typeIs,typeOff) */
- Tyvar *tyv;
-
- while ((tyv=tyvar(vn)), isBound(tyv))
- switch(whatIs(tyv->bound)) {
- case INTCELL : vn = intOf(tyv->bound);
- break;
-
- case OFFSET : vn = offsetOf(tyv->bound)+(tyv->offs);
- break;
-
- case VARIDCELL :
- case VAROPCELL : vn = findBtyvsInt(textOf(tyv->bound));
- break;
-
- default : typeIs = tyv->bound;
- typeOff = tyv->offs;
- return;
- }
- typeIs = aVar;
- typeOff = vn;
-}
-
-Void bindTv(vn,t,o) /* set type variable vn to (t,o) */
-Int vn;
-Type t;
-Int o; {
- Tyvar *tyv = tyvar(vn);
- tyv->bound = t;
- tyv->offs = o;
-#ifdef DEBUG_TYPES
- Printf("binding type variable: _%d to ",vn);
- printType(stdout,debugType(t,o));
- Putchar('\n');
-#endif
-}
-
-Cell getDerefHead(t,o) /* get value at head of type exp. */
-Type t;
-Int o; {
- Tyvar *tyv;
- argCount = 0;
- for (;;) {
- while (isAp(t)) {
- argCount++;
- t = fun(t);
- }
- if ((tyv=getTypeVar(t,o)) && isBound(tyv)) {
- t = tyv->bound;
- o = tyv->offs;
- }
- else
- break;
- }
- return t;
-}
-
-/* --------------------------------------------------------------------------
- * Expand type synonyms:
- * ------------------------------------------------------------------------*/
-
-Void expandSyn(h,ar,at,ao) /* Expand type synonym with: */
-Tycon h; /* head h */
-Int ar; /* ar args (NB. ar>=tycon(h).arity)*/
-Type *at; /* original expression (*at,*ao) */
-Int *ao; { /* expansion returned in (*at,*ao) */
- ar -= tycon(h).arity; /* calculate surplus arguments */
- if (ar==0)
- expandSyn1(h,at,ao);
- else { /* if there are more args than the */
- Type t = *at; /* arity, we have to do a little */
- Int o = *ao; /* bit of work to isolate args that*/
- Type args = NIL; /* will not be changed by expansion*/
- Int i;
- while (ar-- > 0) { /* find part to expand, and the */
- Tyvar *tyv; /* unused arguments */
- args = cons(arg(t),args);
- t = fun(t);
- deRef(tyv,t,o);
- }
- expandSyn1(h,&t,&o); /* do the expansion */
- bindTv((i=newTyvars(1)),t,o); /* and embed the results back in */
- tyvar(i)->kind = getKind(t,o); /* (*at, *ao) as required */
- *at = applyToArgs(mkInt(i),args);
- }
-}
-
-static Void local expandSyn1(h,at,ao) /* Expand type synonym with: */
-Tycon h; /* head h, tycon(h).arity args, */
-Type *at; /* original expression (*at,*ao) */
-Int *ao; { /* expansion returned in (*at,*ao) */
- Int n = tycon(h).arity;
- Type t = *at;
- Int o = *ao;
- Tyvar *tyv;
-
- *at = tycon(h).defn;
- *ao = newKindedVars(tycon(h).kind);
- for (; 0<n--; t=fun(t)) {
- deRef(tyv,t,o);
- if (tyv || !isAp(t))
- internal("expandSyn1");
- bindTv(*ao+n,arg(t),o);
- }
-}
-
-/* --------------------------------------------------------------------------
- * Marking fixed variables in type expressions:
- * ------------------------------------------------------------------------*/
-
-Void clearMarks() { /* Set all unbound type vars to */
- Int i; /* unused generic variables */
- for (i=0; i<numTyvars; ++i)
- if (!isBound(tyvar(i)))
- tyvar(i)->offs = UNUSED_GENERIC;
- genericVars = NIL;
- nextGeneric = 0;
-}
-
-Void markAllVars() { /* Set all unbound type vars to */
- Int i; /* be fixed vars */
- for (i=0; i<numTyvars; ++i)
- if (!isBound(tyvar(i)))
- tyvar(i)->offs = FIXED_TYVAR;
- genericVars = NIL;
- nextGeneric = 0;
-}
-
-Void resetGenerics() { /* Reset all generic vars to unused*/
- Int i;
- for (i=0; i<numTyvars; ++i)
- if (!isBound(tyvar(i)) && tyvar(i)->offs>=GENERIC)
- tyvar(i)->offs = UNUSED_GENERIC;
- genericVars = NIL;
- nextGeneric = 0;
-}
-
-Void markTyvar(vn) /* mark fixed vars in type bound to*/
-Int vn; { /* given type variable */
- Tyvar *tyv = tyvar(vn);
-
- if (isBound(tyv))
- markType(tyv->bound, tyv->offs);
- else
- (tyv->offs) = FIXED_TYVAR;
-}
-
-Void markType(t,o) /* mark fixed vars in type (t,o) */
-Type t;
-Int o; {
- STACK_CHECK
- switch (whatIs(t)) {
- case POLYTYPE :
- case QUAL :
-#if TREX
- case EXT :
-#endif
- case TYCON :
- case TUPLE : return;
-
- case AP : markType(fst(t),o);
- markType(snd(t),o);
- return;
-
- case OFFSET : markTyvar(o+offsetOf(t));
- return;
-
- case INTCELL : markTyvar(intOf(t));
- return;
-
- case VARIDCELL :
- case VAROPCELL : markTyvar(findBtyvsInt(textOf(t)));
- return;
-
- case RANK2 : markType(snd(snd(t)),o);
- return;
-
- default : internal("markType");
- }
-}
-
-Void markPred(pi) /* Marked fixed type vars in pi */
-Cell pi; {
- Cell cl = fst3(pi);
- Int o = intOf(snd3(pi));
-
- for (; isAp(cl); cl=fun(cl))
- markType(arg(cl),o);
-}
-
-/* --------------------------------------------------------------------------
- * Copy type expression from substitution to make a single type expression:
- * ------------------------------------------------------------------------*/
-
-Type copyTyvar(vn) /* calculate most general form of */
-Int vn; { /* type bound to given type var */
- Tyvar *tyv = tyvar(vn);
-
- if ((tyv->bound)==SKOLEM) {
- return mkInt(vn);
- } else if (tyv->bound) {
- return copyType(tyv->bound,tyv->offs);
- }
-
- switch (tyv->offs) {
- case FIXED_TYVAR : return mkInt(vn);
-
- case UNUSED_GENERIC : (tyv->offs) = GENERIC + nextGeneric++;
- if (nextGeneric>=(OFF_MAX-OFF_MIN+1)) {
- ERRMSG(0)
- "Too many quantified type variables"
- EEND;
- }
- genericVars = cons(mkInt(vn),genericVars);
-
- default : return mkOffset(tyv->offs - GENERIC);
- }
-}
-
-Type copyType(t,o) /* calculate most general form of */
-Type t; /* type expression (t,o) */
-Int o; {
- STACK_CHECK
- switch (whatIs(t)) {
- case AP : { Type l = copyType(fst(t),o);/* ensure correct */
- Type r = copyType(snd(t),o);/* eval. order */
- return ap(l,r);
- }
- case OFFSET : return copyTyvar(o+offsetOf(t));
- case INTCELL : return copyTyvar(intOf(t));
- case VARIDCELL :
- case VAROPCELL : return copyTyvar(findBtyvsInt(textOf(t)));
- }
-
- return t;
-}
-
-Cell copyPred(pi,o) /* Copy single predicate (or part */
-Cell pi; /* thereof) ... */
-Int o; {
- if (isAp(pi)) {
- Cell temp = copyPred(fun(pi),o);/* to ensure correct order of eval.*/
- return ap(temp,copyType(arg(pi),o));
- }
- else
- return pi;
-}
-
-Type zonkTyvar(vn) /* flatten type by chasing all references */
-Int vn; { /* and collapsing OFFSETS to absolute indexes */
- Tyvar *tyv = tyvar(vn);
-
- if (tyv->bound)
- return zonkType(tyv->bound,tyv->offs);
- else
- return mkInt(vn);
-}
-
-Type zonkType(t,o) /* flatten type by chasing all references */
-Type t; /* and collapsing OFFSETS to absolute indexes */
-Int o; {
- STACK_CHECK
- switch (whatIs(t)) {
- case AP : { Type l = zonkType(fst(t),o);/* ensure correct */
- Type r = zonkType(snd(t),o);/* eval. order */
- return ap(l,r);
- }
- case OFFSET : return zonkTyvar(o+offsetOf(t));
- case INTCELL : return zonkTyvar(intOf(t));
- }
-
- return t;
-}
-
-#ifdef DEBUG_TYPES
-Type debugTyvar(vn) /* expand type structure in full */
-Int vn; { /* detail */
- Tyvar *tyv = tyvar(vn);
-
- if (isBound(tyv))
- return debugType(tyv->bound,tyv->offs);
- return mkInt(vn);
-}
-
-Type debugType(t,o)
-Type t;
-Int o; {
- STACK_CHECK
- switch (whatIs(t)) {
- case AP : { Type l = debugType(fst(t),o);
- Type r = debugType(snd(t),o);
- return ap(l,r);
- }
- case OFFSET : return debugTyvar(o+offsetOf(t));
- case INTCELL : return debugTyvar(intOf(t));
- case VARIDCELL :
- case VAROPCELL : return debugTyvar(findBtyvsInt(textOf(t)));
- }
-
- return t;
-}
-List debugContext(ps)
-List ps; {
- Cell p;
- List qs = NIL;
- for (; nonNull(ps); ps=tl(ps)) {
- p = debugPred(fst3(hd(ps)),intOf(snd3(hd(ps))));
- qs = cons(p,qs);
- }
- return rev(qs);
-}
-
-Cell debugPred(pi,o)
-Cell pi;
-Int o; {
- if (isAp(pi)) {
- return pair(debugPred(fun(pi),o),debugType(arg(pi),o));
- }
- return pi;
-}
-#endif /*DEBUG_TYPES*/
-
-Kind copyKindvar(vn) /* build kind attatched to variable*/
-Int vn; {
- Tyvar *tyv = tyvar(vn);
- if (tyv->bound)
- return copyKind(tyv->bound,tyv->offs);
- return STAR; /* any unbound variable defaults to*/
-} /* the kind of all types */
-
-Kind copyKind(k,o) /* build kind expression from */
-Kind k; /* given skeleton */
-Int o; {
- switch (whatIs(k)) {
- case AP : { Kind l = copyKind(fst(k),o); /* ensure correct */
- Kind r = copyKind(snd(k),o); /* eval. order */
- return ap(l,r);
- }
- case OFFSET : return copyKindvar(o+offsetOf(k));
- case INTCELL : return copyKindvar(intOf(k));
- }
- return k;
-}
-
-/* --------------------------------------------------------------------------
- * Copy type expression from substitution without marking:
- * ------------------------------------------------------------------------*/
-
-static List local listTyvar(vn,ns)
-Int vn;
-List ns; {
- Tyvar *tyv = tyvar(vn);
-
- if (isBound(tyv)) {
- return listTyvars(tyv->bound,tyv->offs,ns);
- } else if (!intIsMember(vn,ns)) {
- ns = cons(mkInt(vn),ns);
- }
- return ns;
-}
-
-static List local listTyvars(t,o,ns)
-Cell t;
-Int o;
-List ns; {
- switch (whatIs(t)) {
- case AP : return listTyvars(fst(t),o,
- listTyvars(snd(t),o,
- ns));
- case OFFSET : return listTyvar(o+offsetOf(t),ns);
- case INTCELL : return listTyvar(intOf(t),ns);
- default : break;
- }
- return ns;
-}
-
-static Cell local dupTyvar(vn,ns)
-Int vn;
-List ns; {
- Tyvar *tyv = tyvar(vn);
-
- if (isBound(tyv)) {
- return dupTyvars(tyv->bound,tyv->offs,ns);
- } else {
- Int i = 0;
- for (; nonNull(ns) && vn!=intOf(hd(ns)); ns=tl(ns)) {
- i++;
- }
- return mkOffset(i);
- }
-}
-
-static Cell local dupTyvars(t,o,ns)
-Cell t;
-Int o;
-List ns; {
- switch (whatIs(t)) {
- case AP : { Type l = dupTyvars(fst(t),o,ns);
- Type r = dupTyvars(snd(t),o,ns);
- return ap(l,r);
- }
- case OFFSET : return dupTyvar(o+offsetOf(t),ns);
- case INTCELL : return dupTyvar(intOf(t),ns);
- }
- return t;
-}
-
-static Cell local copyNoMark(t,o) /* Copy a type or predicate without*/
-Cell t; /* changing marks */
-Int o; {
- List ns = listTyvars(t,o,NIL);
- Cell result = pair(ns,dupTyvars(t,o,ns));
- for (; nonNull(ns); ns=tl(ns)) {
- hd(ns) = tyvar(intOf(hd(ns)))->kind;
- }
- return result;
-}
-
-/* --------------------------------------------------------------------------
- * Droping and lifting of type schemes that appear in rank 2 position:
- * ------------------------------------------------------------------------*/
-
-Type dropRank2(t,alpha,n) /* Drop a (potentially) rank2 type */
-Type t;
-Int alpha;
-Int n; {
- if (whatIs(t)==RANK2) {
- Cell r = fst(snd(t));
- Int i = intOf(r);
- Type as = NIL;
- for (t=snd(snd(t)); i>0; i--) {
- Type a = arg(fun(t));
- if (isPolyType(a))
- a = dropRank1(a,alpha,n);
- as = fn(a,as);
- t = arg(t);
- }
- t = ap(RANK2,pair(r,revOnto(as,t)));
- }
- return t;
-}
-
-Type dropRank1(t,alpha,n) /* Copy rank1 argument type t to */
-Type t; /* make a rank1 type scheme */
-Int alpha;
-Int n; {
- if (n>0 && isPolyType(t))
- t = mkPolyType(polySigOf(t),dropRank1Body(monotypeOf(t),alpha,n));
- return t;
-}
-
-static Type local dropRank1Body(t,alpha,n)
-Type t;
-Int alpha;
-Int n; {
- switch (whatIs(t)) {
- case OFFSET : { Int m = offsetOf(t);
- return (m>=n) ? mkOffset(m-n) : mkInt(alpha+m);
- }
-
- case POLYTYPE : return mkPolyType(polySigOf(t),
- dropRank1Body(monotypeOf(t),alpha,n));
-
- case QUAL : return ap(QUAL,dropRank1Body(snd(t),alpha,n));
-
- case RANK2 : return ap(RANK2,pair(fst(snd(t)),
- dropRank1Body(snd(snd(t)),
- alpha,
- n)));
-
- case AP : return ap(dropRank1Body(fun(t),alpha,n),
- dropRank1Body(arg(t),alpha,n));
-
- default : return t;
- }
-}
-
-Void liftRank2Args(as,alpha,m)
-List as;
-Int alpha;
-Int m; {
- Int i = 0;
- for (; i<m; i++)
- copyTyvar(alpha+i);
- for (m=nextGeneric; nonNull(as); as=tl(as)) {
- Type ta = arg(fun(as));
- ta = isPolyType(ta) ? liftRank1Body(ta,m) : copyType(ta,alpha);
- arg(fun(as))
- = ta;
- }
-}
-
-Type liftRank2(t,alpha,m)
-Type t;
-Int alpha;
-Int m; {
- if (whatIs(t)==RANK2) {
- Cell r = fst(snd(t));
- Int i = 0;
- Type as = NIL;
- for (; i<m; i++)
- copyTyvar(alpha+i);
- m = nextGeneric;
- t = snd(snd(t));
- for (i=intOf(r); i>0; i--) {
- Type a = arg(fun(t));
- a = isPolyType(a) ? liftRank1Body(a,m) : copyType(a,alpha);
- as = fn(a,as);
- t = arg(t);
- }
- t = ap(RANK2,pair(r,revOnto(as,copyType(t,alpha))));
- }
- else
- t = copyType(t,alpha);
- return t;
-}
-
-Type liftRank1(t,alpha,m)
-Type t;
-Int alpha;
-Int m; {
- if (m>0 && isPolyType(t)) {
- Int i = 0;
- resetGenerics();
- for (; i<m; i++)
- copyTyvar(alpha+i);
- t = liftRank1Body(t,nextGeneric);
- }
- return t;
-}
-
-static Type local liftRank1Body(t,n)
-Type t;
-Int n; {
- switch (whatIs(t)) {
- case OFFSET : return mkOffset(n+offsetOf(t));
-
- case INTCELL : return copyTyvar(intOf(t));
-
- case VARIDCELL :
- case VAROPCELL : return copyTyvar(findBtyvsInt(textOf(t)));
-
- case POLYTYPE : return mkPolyType(polySigOf(t),
- liftRank1Body(monotypeOf(t),n));
-
- case QUAL : return ap(QUAL,liftRank1Body(snd(t),n));
-
- case RANK2 : return ap(RANK2,pair(fst(snd(t)),
- liftRank1Body(snd(snd(t)),n)));
-
- case AP : return ap(liftRank1Body(fun(t),n),
- liftRank1Body(arg(t),n));
-
- default : return t;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Support for `kind preserving substitutions' from unification:
- * ------------------------------------------------------------------------*/
-
-Bool eqKind(k1,k2) /* check that two (mono)kinds are */
-Kind k1, k2; { /* equal */
- return k1==k2
- || (isPair(k1) && isPair(k2)
- && eqKind(fst(k1),fst(k2))
- && eqKind(snd(k1),snd(k2)));
-}
-
-Kind getKind(c,o) /* Find kind of constr during type */
-Cell c; /* checking process */
-Int o; {
- if (isAp(c)) /* application */
- return snd(getKind(fst(c),o));
- switch (whatIs(c)) {
- case TUPLE : return simpleKind(tupleOf(c)); /*(,)::* -> * -> * */
- case OFFSET : return tyvar(o+offsetOf(c))->kind;
- case INTCELL : return tyvar(intOf(c))->kind;
- case VARIDCELL :
- case VAROPCELL : return tyvar(findBtyvsInt(textOf(c)))->kind;
- case TYCON : return tycon(c).kind;
-#if TREX
- case EXT : return extKind;
-#endif
- }
-#ifdef DEBUG_KINDS
- Printf("getKind c = %d, whatIs=%d\n",c,whatIs(c));
-#endif
- internal("getKind");
- return STAR;/* not reached */
-}
-
-/* --------------------------------------------------------------------------
- * Find generic variables in a type:
- * ------------------------------------------------------------------------*/
-
-Type genvarTyvar(vn,vs) /* calculate list of generic vars */
-Int vn; /* thru variable vn, prepended to */
-List vs; { /* list vs */
- Tyvar *tyv = tyvar(vn);
-
- if (isBound(tyv))
- return genvarType(tyv->bound,tyv->offs,vs);
- else if (tyv->offs == UNUSED_GENERIC) {
- tyv->offs += GENERIC + nextGeneric++;
- return cons(mkInt(vn),vs);
- }
- else if (tyv->offs>=GENERIC && !intIsMember(vn,vs))
- return cons(mkInt(vn),vs);
- else
- return vs;
-}
-
-List genvarType(t,o,vs) /* calculate list of generic vars */
-Type t; /* in type expression (t,o) */
-Int o; /* results are prepended to vs */
-List vs; {
- switch (whatIs(t)) {
- case AP : return genvarType(snd(t),o,genvarType(fst(t),o,vs));
- case OFFSET : return genvarTyvar(o+offsetOf(t),vs);
- case INTCELL : return genvarTyvar(intOf(t),vs);
- case VARIDCELL :
- case VAROPCELL : return genvarTyvar(findBtyvsInt(textOf(t)),vs);
- }
- return vs;
-}
-
-/* --------------------------------------------------------------------------
- * Occurs check:
- * ------------------------------------------------------------------------*/
-
-Bool doesntOccurIn(lookFor,t,o) /* Return TRUE if var lookFor */
-Tyvar *lookFor; /* isn't referenced in (t,o) */
-Type t;
-Int o; {
- Tyvar *tyv;
-
- STACK_CHECK
- for (;;) {
- deRef(tyv,t,o);
- if (tyv) /* type variable */
- return tyv!=lookFor;
- else if (isAp(t)) { /* application */
- if (doesntOccurIn(lookFor,snd(t),o))
- t = fst(t);
- else
- return FALSE;
- }
- else /* no variable found */
- break;
- }
- return TRUE;
-}
-
-/* --------------------------------------------------------------------------
- * Unification algorithm:
- * ------------------------------------------------------------------------*/
-
-char *unifyFails = 0; /* Unification error message */
-static Int bindAbove = 0; /* Used to restrict var binding */
-
-#define bindOnlyAbove(beta) bindAbove=beta
-#define noBind() bindAbove=MAXPOSINT
-#define unrestrictBind() bindAbove=0
-
-static Bool local varToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2 */
-Tyvar *tyv1, *tyv2; {
- if (tyv1!=tyv2) { /* If vars are same, nothing to do!*/
-
- /* Check that either tyv1 or tyv2 is in allowed range for binding */
- /* and is not a Skolem constant, and swap vars if nec. so we can */
- /* bind to tyv1. */
-
- if (tyvNum(tyv1)<bindAbove || tyv1->bound==SKOLEM) {
- if (tyvNum(tyv2)<bindAbove || tyv2->bound==SKOLEM) {
- unifyFails = "types do not match";
- return FALSE;
- }
- else {
- Tyvar *tyv = tyv1;
- tyv1 = tyv2;
- tyv2 = tyv;
- }
- }
- if (!eqKind(tyv1->kind,tyv2->kind)) {
- unifyFails = "constructor variable kinds do not match";
- return FALSE;
- }
- tyv1->bound = aVar;
- tyv1->offs = tyvNum(tyv2);
-#ifdef DEBUG_TYPES
- Printf("vv binding tyvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
-#endif
- }
- return TRUE;
-}
-
-static Bool local varToTypeBind(tyv,t,o)/* Make binding tyv := (t,o) */
-Tyvar *tyv;
-Type t; /* guaranteed not to be a v'ble or */
-Int o; { /* have synonym as outermost constr*/
- if (tyvNum(tyv)<bindAbove) { /* Check that tyv is in range */
- unifyFails = "types do not match";
- return FALSE;
- }
- else if (tyv->bound == SKOLEM) { /* Check that it is not Skolemized */
- unifyFails = "cannot instantiate Skolem constant";
- return FALSE;
- }
- else if (!doesntOccurIn(tyv,t,o)) /* Carry out occurs check */
- unifyFails = "unification would give infinite type";
- else if (!eqKind(tyv->kind,getKind(t,o)))
- unifyFails = "kinds do not match";
- else {
- tyv->bound = t;
- tyv->offs = o;
-#ifdef DEBUG_TYPES
- Printf("vt binding type variable: _%d to ",tyvNum(tyv));
- printType(stdout,debugType(t,o));
- Putchar('\n');
-#endif
- return TRUE;
- }
- return FALSE;
-}
-
-Bool unify(t1,o1,t2,o2) /* Main unification routine */
-Type t1,t2; /* unify (t1,o1) with (t2,o2) */
-Int o1,o2; {
- Tyvar *tyv1, *tyv2;
-
- STACK_CHECK
- deRef(tyv1,t1,o1);
- deRef(tyv2,t2,o2);
-
-un: if (tyv1) {
- if (tyv2)
- return varToVarBind(tyv1,tyv2); /* t1, t2 variables */
- else {
- Cell h2 = getDerefHead(t2,o2); /* t1 variable, t2 not */
- if (isSynonym(h2) && argCount>=tycon(h2).arity) {
- expandSyn(h2,argCount,&t2,&o2);
- deRef(tyv2,t2,o2);
- goto un;
- }
- return varToTypeBind(tyv1,t2,o2);
- }
- }
- else
- if (tyv2) {
- Cell h1 = getDerefHead(t1,o1); /* t2 variable, t1 not */
- if (isSynonym(h1) && argCount>=tycon(h1).arity) {
- expandSyn(h1,argCount,&t1,&o1);
- deRef(tyv1,t1,o1);
- goto un;
- }
- return varToTypeBind(tyv2,t1,o1);
- }
- else { /* t1, t2 not vars */
- Type h1 = getDerefHead(t1,o1);
- Int a1 = argCount;
- Type h2 = getDerefHead(t2,o2);
- Int a2 = argCount;
-
-#ifdef DEBUG_TYPES
- Printf("tt unifying types: ");
- printType(stdout,debugType(t1,o1));
- Printf(" with ");
- printType(stdout,debugType(t2,o2));
- Putchar('\n');
-#endif
- if (isOffset(h1) || isInt(h1)) h1=NIL; /* represent var by NIL*/
- if (isOffset(h2) || isInt(h2)) h2=NIL;
-
-#if TREX
- if (isExt(h1) || isExt(h2)) {
- if (a1==2 && isExt(h1) && a2==2 && isExt(h2)) {
- if (extText(h1)==extText(h2)) {
- return unify(arg(fun(t1)),o1,arg(fun(t2)),o2) &&
- unify(arg(t1),o1,arg(t2),o2);
- } else {
- return inserter(t1,o1,t2,o2) &&
- unify(arg(t1),o1,aVar,
- remover(extText(h1),t2,o2));
- }
- } else {
- unifyFails = "rows are not compatible";
- return FALSE;
- }
- }
-#endif
- if (nonNull(h1) && h1==h2) {/* Assuming well-formed types, both*/
- if (a1!=a2) { /* t1, t2 must have same no of args*/
- unifyFails = "incompatible constructors";
- return FALSE;
- }
- while (isAp(t1)) {
- if (!unify(arg(t1),o1,arg(t2),o2))
- return FALSE;
- t1 = fun(t1);
- deRef(tyv1,t1,o1);
- t2 = fun(t2);
- deRef(tyv2,t2,o2);
- }
- unifyFails = 0;
- return TRUE;
- }
-
- /* Types do not match -- look for type synonyms to expand */
-
- if (isSynonym(h1) && a1>=tycon(h1).arity) {
- expandSyn(h1,a1,&t1,&o1);
- deRef(tyv1,t1,o1);
- goto un;
- }
- if (isSynonym(h2) && a2>=tycon(h2).arity) {
- expandSyn(h2,a2,&t2,&o2);
- deRef(tyv2,t2,o2);
- goto un;
- }
-
- if ((isNull(h1) && a1<=a2) || /* last attempt -- maybe */
- (isNull(h2) && a2<=a1)) { /* one head is a variable? */
- for (;;) {
- deRef(tyv1,t1,o1);
- deRef(tyv2,t2,o2);
-
- if (tyv1) { /* unify heads! */
- if (tyv2)
- return varToVarBind(tyv1,tyv2);
- else
- return varToTypeBind(tyv1,t2,o2);
- }
- else if (tyv2)
- return varToTypeBind(tyv2,t1,o1);
-
- /* at this point, neither t1 nor t2 is a variable. In */
- /* addition, they must both be APs unless one of the */
- /* head variables has been bound during unification of */
- /* the arguments. */
-
- if (!isAp(t1) || !isAp(t2)) { /* might not be APs*/
- unifyFails = 0;
- return t1==t2;
- }
- if (!unify(arg(t1),o1,arg(t2),o2)) /* o/w must be APs */
- return FALSE;
- t1 = fun(t1);
- t2 = fun(t2);
- }
- }
- }
- unifyFails = 0;
- return FALSE;
-}
-
-#if TREX
-static Bool local inserter(r1,o1,r,o) /* Insert first field in (r1,o1) */
-Type r1; /* into row (r,o), both of which */
-Int o1; /* are known to begin with an EXT */
-Type r;
-Int o; {
- Text labt = extText(fun(fun(r1))); /* Find the text of the label */
-#ifdef DEBUG_TYPES
- Printf("inserting ");
- printType(stdout,debugType(r1,o1));
- Printf(" into ");
- printType(stdout,debugType(r,o));
- Putchar('\n');
-#endif
- for (;;) {
- Tyvar *tyv;
- deRef(tyv,r,o);
- if (tyv) {
- Int beta; /* Test for common tail */
- if (tailVar(arg(r1),o1)==tyvNum(tyv)) {
- unifyFails = "distinct rows have common tail";
- return FALSE;
- }
- beta = newTyvars(1); /* Extend row with new field */
- tyvar(beta)->kind = ROW;
- return varToTypeBind(tyv,ap(fun(r1),mkInt(beta)),o1);
- }
- else if (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r)))) {
- if (labt==extText(fun(fun(r))))/* Compare existing fields */
- return unify(arg(fun(r1)),o1,extField(r),o);
- r = extRow(r); /* Or skip to next field */
- }
- else { /* Nothing else will match */
- unifyFails = "field mismatch";
- return FALSE;
- }
- }
-}
-
-static Int local remover(l,r,o) /* Make a new row by copying (r,o) */
-Text l; /* but removing the l field (which */
-Type r; /* MUST exist) */
-Int o; {
- Tyvar *tyv;
- Int beta = newTyvars(1);
- tyvar(beta)->kind = ROW;
-#ifdef DEBUG_TYPES
- Printf("removing %s from",textToStr(l));
- printType(stdout,debugType(r,o));
- Putchar('\n');
-#endif
- deRef(tyv,r,o);
- if (tyv || !isAp(r) || !isAp(fun(r)) || !isExt(fun(fun(r))))
- internal("remover");
- if (l==extText(fun(fun(r))))
- r = extRow(r);
- else
- r = ap(fun(r),mkInt(remover(l,extRow(r),o)));
- bindTv(beta,r,o);
- return beta;
-}
-
-
-static Int local tailVar(r,o) /* Find var at tail end of a row */
-Type r;
-Int o; {
- for (;;) {
- Tyvar *tyv;
- deRef(tyv,r,o);
- if (tyv) {
- return tyvNum(tyv);
- }
- else if (isAp(r) && isAp(fun(r)) && isExt(fun(fun(r)))) {
- r = extRow(r);
- }
- else {
- return (-1);
- }
- }
-}
-#endif
-
-
-Bool typeMatches(type,mt) /* test if type matches monotype mt*/
- Type type, mt; { /* imported from STG Hugs */
- Bool result;
- if (isPolyOrQualType(type))
- return FALSE;
- emptySubstitution();
- noBind();
- result = unify(mt,0,type,0);
- unrestrictBind();
- emptySubstitution();
- return result;
-}
-
-Bool isProgType(ks,type) /* Test if type is of the form */
-List ks; /* IO t for some t. */
-Type type; {
- Bool result;
- Int alpha;
- Int beta;
- emptySubstitution();
- alpha = newKindedVars(ks);
- beta = newTyvars(1);
- bindOnlyAbove(beta);
- result = unify(type,alpha,typeProgIO,beta);
- unrestrictBind();
- emptySubstitution();
- return result;
-}
-
-/* --------------------------------------------------------------------------
- * Matching predicates:
- *
- * There are (at least) four situations where we need to match up pairs
- * of predicates:
- *
- * 1) Testing to see if two predicates are the same (ignoring differences
- * caused by the use of type synonyms, for example).
- *
- * 2) Matching a predicate with the head of its class so that we can
- * find the corresponding superclass predicates. If the predicates
- * have already been kind-checked, and the classes are known to be
- * the same, then this should never fail.
- *
- * 3) Matching a predicate against the head of an instance to see if
- * that instance is applicable.
- *
- * 4) Matching two instance heads to see if there is an overlap.
- *
- * For (1), we need a matching process that does not bind any variables.
- * For (2) and (3), we need to use one-way matching, only allowing
- * variables in the class or instance head to be instantiated. For
- * (4), we need two-way unification.
- *
- * Another situation in which both one-way and two-way unification might
- * be used is in an implementation of improvement. Here, a one-way match
- * would be used to determine applicability of a rule for improvement
- * that would then be followed by unification with another predicate.
- * One possible syntax for this might be:
- *
- * instance P => pi [improves pi'] where ...
- *
- * The intention here is that any predicate matching pi' can be unified
- * with pi to get more accurate types. A simple example of this is:
- *
- * instance Collection [a] a improves Collection [a] b where ...
- *
- * As soon as we know what the collection type is (in this case, a list),
- * we will also know what the element type is. To ensure that the rule
- * for improvement is valid, the compilation system will also need to use
- * a one-way matching process to ensure that pi is a (substitution) instance
- * of pi'. Another extension would be to allow more than one predicate pi'
- * in an improving rule. Read the paper on simplification and improvement
- * for technical background. Watch this space for implementation news!
- * ------------------------------------------------------------------------*/
-
-Bool samePred(pi1,o1,pi,o) /* Test to see if predicates are */
-Cell pi1; /* the same, with no binding of */
-Int o1; /* the variables in either one. */
-Cell pi; /* Assumes preds are kind correct */
-Int o; { /* with the same class. */
- Bool result;
- noBind();
- result = unifyPred(pi1,o1,pi,o);
- unrestrictBind();
- return result;
-}
-
-Bool matchPred(pi1,o1,pi,o) /* One way match predicate (pi1,o1)*/
-Cell pi1; /* against (pi,o), allowing only */
-Int o1; /* vars in 2nd pred to be bound. */
-Cell pi; /* Assumes preds are kind correct */
-Int o; { /* with the same class and that no */
- Bool result; /* vars have been alloc'd since o. */
- bindOnlyAbove(o);
- result = unifyPred(pi1,o1,pi,o);
- unrestrictBind();
- return result;
-}
-
-Bool unifyPred(pi1,o1,pi,o) /* Unify two predicates */
-Cell pi1; /* Assumes preds are kind correct */
-Int o1; /* with the same class. */
-Cell pi;
-Int o; {
- for (; isAp(pi1); pi1=fun(pi1), pi=fun(pi)) {
- if (!isAp(pi) || !unify(arg(pi1),o1,arg(pi),o))
- return FALSE;
- }
- /* pi1 has exhausted its argument chain, we also need to check that
- pi has no remaining arguments. However, under this condition,
- the pi1 == pi will always return FALSE, giving the desired
- result. */
-
-#if IPARAM
- if (isIP(pi1) && isIP(pi))
- return textOf(pi1)==textOf(pi);
- else
-#endif
- return pi1==pi;
-}
-
-#if TREX
-static Cell trexShow = NIL; /* Used to test for show on records*/
-static Cell trexEq = NIL; /* Used to test for eq on records */
-#endif
-
-Inst findInstFor(pi,o) /* Find matching instance for pred */
-Cell pi; /* (pi,o), or otherwise NIL. If a */
-Int o; { /* match is found, then tyvars from*/
- Class c = getHead(pi); /* typeOff have been initialized to*/
- List ins; /* allow direct use of specifics. */
- Cell kspi = NIL;
-
- if (!isClass(c))
- return NIL;
-
- for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins)) {
- Inst in = hd(ins);
- Int beta = newKindedVars(inst(in).kinds);
- if (matchPred(pi,o,inst(in).head,beta)) {
- typeOff = beta;
- return in;
- }
- else {
- numTyvars = beta;
- if (allowOverlap) {
- Int alpha = newKindedVars(inst(in).kinds);
- if (isNull(kspi)) {
- kspi = copyNoMark(pi,o);
- }
- beta = newKindedVars(fst(kspi));
- if (matchPred(inst(in).head,alpha,snd(kspi),beta)) {
- numTyvars = alpha;
- return NIL;
- }
- numTyvars = alpha;
- }
- }
- }
- unrestrictBind();
-
-#if TREX
- { Bool wantShow = (c==findQualClass(trexShow));
- Bool wantEither = wantShow || (c==findQualClass(trexEq));
-
- if (wantEither) { /* Generate instances of */
- Type t = arg(pi); /* ShowRecRow and EqRecRow */
- Tyvar *tyv; /* on the fly */
- Cell e;
- deRef(tyv,t,o);
- e = getHead(t);
- if (isExt(e)) {
- Inst in = NIL;
- for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins))
- if (getHead(arg(inst(hd(ins)).head))==e) {
- in = hd(ins);
- break;
- }
- if (isNull(in))
- in = (wantShow ? addRecShowInst(c,e) : addRecEqInst(c,e));
- typeOff = newKindedVars(extKind);
- bindTv(typeOff,arg(fun(t)),o);
- bindTv(typeOff+1,arg(t),o);
- return in;
- }
- }
- }
-#endif
-
- return NIL;
-}
-
-#if MULTI_INST
-List findInstsFor(pi,o) /* Find matching instance for pred */
-Cell pi; /* (pi,o), or otherwise NIL. If a */
-Int o; { /* match is found, then tyvars from*/
- Class c = getHead(pi); /* typeOff have been initialized to*/
- List ins; /* allow direct use of specifics. */
- List res = NIL;
-
- if (!isClass(c))
- return NIL;
-
- for (ins=cclass(c).instances; nonNull(ins); ins=tl(ins)) {
- Inst in = hd(ins);
- Int beta = newKindedVars(inst(in).kinds);
- if (matchPred(pi,o,inst(in).head,beta)) {
- res = cons (pair (beta, in), res);
- continue;
- }
- else
- numTyvars = beta;
- }
- if (res == NIL) {
- unrestrictBind();
- }
-
- return rev(res);
-}
-#endif
-
-/* --------------------------------------------------------------------------
- * Improvement:
- * ------------------------------------------------------------------------*/
-
-Void improve(line,sps,ps) /* Improve a list of predicates */
-Int line;
-List sps;
-List ps; {
- Bool improved;
- List ps1;
- do {
- improved = FALSE;
- for (ps1=ps; nonNull(ps1); ps1=tl(ps1)) {
- Cell pi = fst3(hd(ps1));
- Int o = intOf(snd3(hd(ps1)));
- Cell c = getHead(pi);
- if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
- improved |= improveAgainst(line,sps,pi,o);
- if (!isIP(c))
- improved |= instImprove(line,c,pi,o);
- improved |= improveAgainst(line,tl(ps1),pi,o);
- }
- }
- } while (improved);
-}
-
-Void improve1(line,sps,pi,o) /* Improve a single predicate */
-Int line;
-List sps;
-Cell pi;
-Int o; {
- Bool improved;
- Cell c = getHead(pi);
- do {
- improved = FALSE;
- if ((isClass(c) && nonNull(cclass(c).xfds)) || isIP(c)) {
- improved |= improveAgainst(line,sps,pi,o);
- if (!isIP(c))
- improved |= instImprove(line,c,pi,o);
- }
- } while (improved);
-}
-
-Bool improveAgainst(line,ps,pi,o)
-Int line;
-List ps;
-Cell pi;
-Int o; {
- Bool improved = FALSE;
- Cell h = getHead(pi);
- for (; nonNull(ps); ps=tl(ps)) {
- Cell pr = hd(ps);
- Cell pi1 = fst3(pr);
- Int o1 = intOf(snd3(pr));
- Cell h1 = getHead(pi1);
- /* it would be nice to optimize for the common case
- where h == h1 */
- if (isClass(h) && isClass(h1)) {
- improved |= pairImprove(line,h,pi,o,pi1,o1,numTyvars);
- if (h != h1)
- improved |= pairImprove(line,h1,pi1,o1,pi,o,numTyvars);
- }
-#if IPARAM
- else if (isIP(h1) && textOf(h1) == textOf(h))
- improved |= ipImprove(line,pi,o,pi1,o1);
-#endif
- }
- return improved;
-}
-/* should emulate findInsts behavior of shorting out if the
- predicate would match a more general signature... */
-
-Bool instImprove(line,c,pi,o)
-Int line;
-Class c;
-Cell pi;
-Int o; {
- Bool improved = FALSE;
- List ins = cclass(c).instances;
- for (; nonNull(ins); ins=tl(ins)) {
- Cell in = hd(ins);
- Int alpha = newKindedVars(inst(in).kinds);
- improved |= pairImprove(line,c,pi,o,inst(in).head,alpha,alpha);
- }
- return improved;
-}
-
-#if IPARAM
-Bool ipImprove(line,pi,o,pi1,o1)
-Int line;
-Cell pi;
-Int o;
-Cell pi1;
-Int o1; {
- Type t = arg(pi);
- Type t1 = arg(pi1);
- if (!sameType(t,o,t1,o1)) {
- if (!unify(t,o,t1,o1)) {
- ERRMSG(line) "Mismatching uses of implicit parameter\n"
- ETHEN
- ERRTEXT "\n*** "
- ETHEN ERRPRED(copyPred(pi1,o1));
- ERRTEXT "\n*** "
- ETHEN ERRPRED(copyPred(pi,o));
- ERRTEXT "\n"
- EEND;
- }
- return TRUE;
- }
- return FALSE;
-}
-#endif
-
-Bool pairImprove(line,c,pi1,o1,pi2,o2,above) /* Look for improvement of (pi1,o1)*/
-Int line; /* against (pi2,o2) */
-Class c;
-Cell pi1;
-Int o1;
-Cell pi2;
-Int o2;
-Int above; {
- Bool improved = FALSE;
- List xfds = cclass(c).xfds;
- for (; nonNull(xfds); xfds=tl(xfds)) {
- Cell xfd = hd(xfds);
- Cell hs = fst(xfd);
- Int alpha;
- for (; nonNull(hs); hs=tl(hs)) {
- Cell h = hd(hs);
- Class d = getHead(h);
- alpha = newKindedVars(cclass(d).kinds);
- if (matchPred(pi2,o2,h,alpha))
- break;
- numTyvars = alpha;
- }
- if (nonNull(hs)) {
- List fds = snd(xfd);
- for (; nonNull(fds); fds=tl(fds)) {
- List as = fst(hd(fds));
- Bool same = TRUE;
- for (; same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- same &= matchTypeAbove(nthArg(n,pi1),o1,
- mkOffset(n),alpha,above);
- }
- if (isNull(as) && same) {
- for (as=snd(hd(fds)); same && nonNull(as); as=tl(as)) {
- Int n = offsetOf(hd(as));
- Type t1 = nthArg(n,pi1);
- Type t2 = mkOffset(n);
- if (!matchTypeAbove(t1,o1,t2,alpha,above)) {
- same &= unify(t1,o1,t2,alpha);
- improved = TRUE;
- }
- }
- if (!same) {
- ERRMSG(line)
- "Constraints are not consistent with functional dependency"
- ETHEN
- ERRTEXT "\n*** Constraint : "
- ETHEN ERRPRED(copyPred(pi1,o1));
- ERRTEXT "\n*** And constraint : "
- ETHEN ERRPRED(copyPred(pi2,o2));
- ERRTEXT "\n*** For class : "
- ETHEN ERRPRED(cclass(c).head);
- ERRTEXT "\n*** Break dependency : "
- ETHEN ERRFD(hd(fds));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- numTyvars = alpha;
- }
- }
- return improved;
-}
-
-/* --------------------------------------------------------------------------
- * Compare type schemes:
- * ------------------------------------------------------------------------*/
-
-Bool sameSchemes(s,s1) /* Test to see whether two type */
-Type s; /* schemes are the same */
-Type s1; {
- Int o = 0;
- Int m = 0;
- Int nr2 = 0;
- Bool b = isPolyType(s); /* Check quantifiers are the same */
- Bool b1 = isPolyType(s1);
- if (b || b1) {
- if (b && b1 && eqKind(polySigOf(s),polySigOf(s1))) {
- Kind k = polySigOf(s);
- s = monotypeOf(s);
- s1 = monotypeOf(s1);
- o = newKindedVars(k);
- for (; isAp(k); k=arg(k))
- m++;
- }
- else
- return FALSE;
- }
-
- b = (whatIs(s)==QUAL); /* Check that contexts are the same*/
- b1 = (whatIs(s1)==QUAL);
- if (b || b1) {
- if (b && b1) {
- List ps = fst(snd(s));
- List ps1 = fst(snd(s1));
- noBind();
- while (nonNull(ps) && nonNull(ps1)) {
- Cell pi = hd(ps);
- Cell pi1 = hd(ps1);
- if (getHead(pi)!=getHead(pi1)
- || !unifyPred(pi,o,pi1,o))
- break;
- ps = tl(ps);
- ps1 = tl(ps1);
- }
- unrestrictBind();
- if (nonNull(ps) || nonNull(ps1))
- return FALSE;
- s = snd(snd(s));
- s1 = snd(snd(s1));
- }
- else
- return FALSE;
- }
-
- b = (whatIs(s)==RANK2); /* Check any rank 2 annotations */
- b1 = (whatIs(s1)==RANK2);
- if (b || b1) {
- if (b && b1 && intOf(fst(snd(s)))==intOf(fst(snd(s1)))) {
- nr2 = intOf(fst(snd(s)));
- s = snd(snd(s));
- s1 = snd(snd(s1));
- }
- else
- return FALSE;
- }
-
- for (; nr2>0; nr2--) { /* Deal with rank 2 arguments */
- Type t = arg(fun(s));
- Type t1 = arg(fun(s1));
- b = isPolyOrQualType(t);
- b1 = isPolyOrQualType(t1);
- if (b || b1) {
- if (b && b1) {
- t = dropRank1(t,o,m);
- t1 = dropRank1(t1,o,m);
- if (!sameSchemes(t,t1))
- return FALSE;
- }
- else
- return FALSE;
- }
- else {
- if (!sameType(t,o,t1,o)) {
- return FALSE;
- }
- }
-
- s = arg(s);
- s1 = arg(s1);
- }
-
- return sameType(s,o,s1,o); /* Ensure body types are the same */
-}
-
-Bool sameType(t1,o1,t,o) /* Test to see if types are */
-Type t1; /* the same, with no binding of */
-Int o1; /* the variables in either one. */
-Cell t; /* Assumes types are kind correct */
-Int o; { /* with the same kind. */
- Bool result;
- noBind();
- result = unify(t1,o1,t,o);
- unrestrictBind();
- return result;
-}
-
-Bool matchType(t1,o1,t,o) /* One way match type (t1,o1) */
-Type t1; /* against (t,o), allowing only */
-Int o1; /* vars in 2nd type to be bound. */
-Type t; /* Assumes types are kind correct */
-Int o; { /* and that no vars have been */
- Bool result; /* alloc'd since o. */
- bindOnlyAbove(o);
- result = unify(t1,o1,t,o);
- unrestrictBind();
- return result;
-}
-
-static Bool local matchTypeAbove(t1,o1,t,o,a) /* match, allowing only vars */
-Type t1; /* allocated since `a' to be bound */
-Int o1; /* this is deeply hacky, since it */
-Type t; /* relies on careful use of the */
-Int o; /* substitution stack */
-Int a; {
- Bool result;
- bindOnlyAbove(a);
- result = unify(t1,o1,t,o);
- unrestrictBind();
- return result;
-}
-
-/* --------------------------------------------------------------------------
- * Unify kind expressions:
- * ------------------------------------------------------------------------*/
-
-static Bool local kvarToVarBind(tyv1,tyv2)/* Make binding tyv1 := tyv2 */
-Tyvar *tyv1, *tyv2; { /* for kind variable bindings */
- if (tyv1!=tyv2) {
- tyv1->bound = aVar;
- tyv1->offs = tyvNum(tyv2);
-#ifdef DEBUG_KINDS
- Printf("vv binding kvar: _%d to _%d\n",tyvNum(tyv1),tyvNum(tyv2));
-#endif
- }
- return TRUE;
-}
-
-static Bool local kvarToTypeBind(tyv,t,o)/* Make binding tyv := (t,o) */
-Tyvar *tyv; /* for kind variable bindings */
-Type t; /* guaranteed not to be a v'ble or */
-Int o; { /* have synonym as outermost constr*/
- if (doesntOccurIn(tyv,t,o)) {
- tyv->bound = t;
- tyv->offs = o;
-#ifdef DEBUG_KINDS
- Printf("vt binding kind variable: _%d to ",tyvNum(tyv));
- printType(stdout,debugType(t,o));
- Putchar('\n');
-#endif
- return TRUE;
- }
- unifyFails = "unification would give infinite kind";
- return FALSE;
-}
-
-Bool kunify(k1,o1,k2,o2) /* Unify kind expr (k1,o1) with */
-Kind k1,k2; /* (k2,o2) */
-Int o1,o2; {
- Tyvar *kyv1, *kyv2;
-
- deRef(kyv1,k1,o1);
- deRef(kyv2,k2,o2);
-
- if (kyv1) {
- if (kyv2)
- return kvarToVarBind(kyv1,kyv2); /* k1, k2 variables */
- else
- return kvarToTypeBind(kyv1,k2,o2); /* k1 variable, k2 not */
- }
- else
- if (kyv2)
- return kvarToTypeBind(kyv2,k1,o1); /* k2 variable, k1 not */
- else {
-#ifdef DEBUG_KINDS
- Printf("unifying kinds: ");
- printType(stdout,debugType(k1,o1));
- Printf(" with ");
- printType(stdout,debugType(k2,o2));
- Putchar('\n');
-#endif
- if (k1==STAR && k2==STAR) /* k1, k2 not vars */
- return TRUE;
-#if TREX
- else if (k1==ROW && k2==ROW)
- return TRUE;
-#endif
- else if (isAp(k1) && isAp(k2))
- return kunify(fst(k1),o1,fst(k2),o2) &&
- kunify(snd(k1),o1,snd(k2),o2);
- }
- unifyFails = 0;
- return FALSE;
-}
-
-/* --------------------------------------------------------------------------
- * Tuple type constructors: are generated as necessary. The most common
- * n-tuple constructors (n<MAXTUPCON) are held in a cache to avoid
- * repeated generation of the constructor types.
- * ------------------------------------------------------------------------*/
-
-#define MAXTUPCON 10
-static Type tupleConTypes[MAXTUPCON];
-
-Void typeTuple(e) /* find type for tuple constr, using*/
-Cell e; { /* tupleConTypes to cache previously*/
- Int n = tupleOf(e); /* calculated tuple constr. types. */
- typeOff = newTyvars(n);
- if (n>=MAXTUPCON)
- typeIs = makeTupleType(n);
- else if (tupleConTypes[n])
- typeIs = tupleConTypes[n];
- else
- typeIs = tupleConTypes[n] = makeTupleType(n);
-}
-
-static Type local makeTupleType(n) /* construct type for tuple constr. */
-Int n; { /* t1 -> ... -> tn -> (t1,...,tn) */
- Type h = mkTuple(n);
- Int i;
-
- for (i=0; i<n; ++i)
- h = ap(h,mkOffset(i));
- while (0<n--)
- h = fn(mkOffset(n),h);
- return h;
-}
-
-/* --------------------------------------------------------------------------
- * Two forms of kind expression are used quite frequently:
- * * -> * -> ... -> * -> * for kinds of ->, [], ->, (,) etc...
- * v1 -> v2 -> ... -> vn -> vn+1 skeletons for constructor kinds
- * Expressions of these forms are produced by the following functions which
- * use a cache to avoid repeated construction of commonly used values.
- * A similar approach is used to store the types of tuple constructors in the
- * main type checker.
- * ------------------------------------------------------------------------*/
-
-#define MAXKINDFUN 10
-static Kind simpleKindCache[MAXKINDFUN];
-static Kind varKindCache[MAXKINDFUN];
-
-static Kind local makeSimpleKind(n) /* construct * -> ... -> * (n args)*/
-Int n; {
- Kind k = STAR;
- while (n-- > 0)
- k = ap(STAR,k);
- return k;
-}
-
-Kind simpleKind(n) /* return (possibly cached) simple */
-Int n; { /* function kind */
- if (n>=MAXKINDFUN)
- return makeSimpleKind(n);
- else if (nonNull(simpleKindCache[n]))
- return simpleKindCache[n];
- else if (n==0)
- return simpleKindCache[0] = STAR;
- else
- return simpleKindCache[n] = ap(STAR,simpleKind(n-1));
-}
-
-static Kind local makeVarKind(n) /* construct v0 -> .. -> vn */
-Int n; {
- Kind k = mkOffset(n);
- while (n-- > 0)
- k = ap(mkOffset(n),k);
- return k;
-}
-
-Void varKind(n) /* return (possibly cached) var */
-Int n; { /* function kind */
- typeOff = newKindvars(n+1);
- if (n>=MAXKINDFUN)
- typeIs = makeVarKind(n);
- else if (nonNull(varKindCache[n]))
- typeIs = varKindCache[n];
- else
- typeIs = varKindCache[n] = makeVarKind(n);
-}
-
-/* --------------------------------------------------------------------------
- * Substitutution control:
- * ------------------------------------------------------------------------*/
-
-Void substitution(what)
-Int what; {
- Int i;
-
- switch (what) {
- case RESET : emptySubstitution();
- unrestrictBind();
- btyvars = NIL;
- break;
-
- case MARK : for (i=0; i<MAXTUPCON; ++i)
- mark(tupleConTypes[i]);
- for (i=0; i<MAXKINDFUN; ++i) {
- mark(simpleKindCache[i]);
- mark(varKindCache[i]);
- }
- for (i=0; i<numTyvars; ++i)
- mark(tyvars[i].bound);
- mark(btyvars);
- mark(typeIs);
- mark(predsAre);
- mark(genericVars);
-#if TREX
- mark(trexShow);
- mark(trexEq);
-#endif
- break;
-
- case POSTPREL: break;
-
- case PREPREL : substitution(RESET);
- for (i=0; i<MAXTUPCON; ++i)
- tupleConTypes[i] = NIL;
- for (i=0; i<MAXKINDFUN; ++i) {
- simpleKindCache[i] = NIL;
- varKindCache[i] = NIL;
- }
-#if TREX
- trexShow = mkQCon(findText("Trex"),
- findText("ShowRecRow"));
- trexEq = mkQCon(findText("Trex"),
- findText("EqRecRow"));
-#endif
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-#!/usr/bin/perl
-
-die "Usage: before <regexp>" unless $ARGV[0];
-
-$start = $ARGV[0];
-
-# Filter that trims lines before regexp
-
-# skip the initial part
-while (<STDIN>) {
- last if /$start/;
-}
-# print the good bit
-while (<STDIN>) {
- print;
-}
-
-exit 0;
+++ /dev/null
-#!/usr/bin/perl
-
-die "Usage: before <regexp>" unless $ARGV[0];
-
-$pat = $ARGV[0];
-
-# Filter that trims lines after regexp
-
-# print the initial part
-while (<STDIN>) {
- last if /$pat/;
- print;
-}
-
-exit 0;
+++ /dev/null
-look env "f"
-look env "g"
-look env2 "f"
-look env2 "g"
-main
-main2
\ No newline at end of file
+++ /dev/null
---!!! Testing IOExts.fixIO
-
-> module FixIOTest where
-> import Monad
-> import Maybe
-> import IOExts( fixIO )
-
-First a recursively-defined environment in the normal way:
-
-> env = foldl (\env' (s,v) -> enter env' s v)
-> empty
-> [ ("f", (1, fst (fromJust (look env "g")))) ,
-> ("g", (2, fst (fromJust (look env "f")))) ]
-
-> env2 = let vF = (1, fst (fromJust (look env2 "g")))
-> vG = (2, fst (fromJust (look env2 "f")))
-> in enter (enter empty "f" vF) "g" vG
-
-Which yields these correct evaluations:
- look env' "f" ==> (1,2)
- look env' "g" ==> (2,1)
-
-Now let's add some IO to each "store action" and use foldM/fixIO to
-tie it all together:
-
-> main =
-> do env <- fixIO (\env -> do
-> foldM (\env' (s,vM) -> do v <- vM
-> return (enter env' s v))
-> empty
-> [ ("f", do putStrLn "storing f"
-> return (1, fst (fromJust (look env "g")))) ,
-> ("g", do putStrLn "storing g"
-> return (2, fst (fromJust (look env "f")))) ] )
-> print (look env "f")
-> print (look env "g")
-> return ()
-
-> main2 =
-> do env <- fixIO (\env -> do
-> let vF = (1,fst (fromJust (look env "g")))
-> vG = (2,fst (fromJust (look env "f")))
-> putStrLn "storing f and g"
-> return $ enter (enter empty "f" vF) "g" vG
-> )
-> putStrLn "Constructed environment"
-> print env
-> print (look env "f")
-> print (look env "g")
-> return ()
-
-But this unfortunately dies a horrible death:
-
-FixIOTest> main
-storing f
-storing g
-Just (1,
-Program error: {_Gc Black Hole}
-
-If I comment out the "print" statements I get:
-
-FixIOTest> main
-storing f
-storing g
-
-and it terminates properly.
-
-----------------------------------------------------------------
--- Environments
-----------------------------------------------------------------
-
-> empty :: Table a
-> enter :: Table a -> String -> a -> Table a
-> look :: Table a -> String -> Maybe a
-
-----------------------------------------------------------------
--- A very simple environment implemented as functions:
-----------------------------------------------------------------
-
-> {-
-> type Table a = String -> Maybe a
-> empty s = Nothing
-> enter t s1 x s2 | s1==s2 = Just x
-> | otherwise = look t s2
-> look t s = t s
-> -}
-
-----------------------------------------------------------------
--- A very simple environment implemented using association lists:
-----------------------------------------------------------------
-
-> type Table a = [(String,a)]
-> empty = []
-> enter t s x = (s,x):t
-> look t s = lookup s t
-
-
+++ /dev/null
-Reading file "Monad.hs":
-Reading file "Maybe.hs":
-Reading file "IOExts.lhs":
-Reading file "ST.lhs":
-Reading file "IOExts.lhs":
-Reading file "test/exts/FixIO.lhs":
-Type :? for help
-Hugs:Just (1,2)
-Hugs:Just (2,1)
-Hugs:Just (1,2)
-Hugs:Just (2,1)
-Hugs:storing f
-storing g
-Just (1,2)
-Just (2,1)
-
-Hugs:storing f and g
-Constructed environment
-[("g",(2,1)), ("f",(1,2))]
-Just (1,2)
-Just (2,1)
-
+++ /dev/null
---!!! Testing Int and Word
-module T where
-import Int
-import Word
-import Bits
-import Ix
-
-test = do
- testIntlike "Int8" (0::Int8)
- testIntlike "Int16" (0::Int16)
- testIntlike "Int32" (0::Int32)
- testIntlike "Word8" (0::Word8)
- testIntlike "Word16" (0::Word16)
- testIntlike "Word32" (0::Word32)
-
-testIntlike :: (Bounded a, Integral a, Ix a, Read a, Bits a) => String -> a -> IO ()
-testIntlike name zero = do
- putStrLn $ "--------------------------------"
- putStrLn $ "--Testing " ++ name
- putStrLn $ "--------------------------------"
- testBounded zero
- testEnum zero
- testReadShow zero
- testEq zero
- testOrd zero
- testNum zero
- testReal zero
- testIntegral zero
- testBits zero
- putStrLn $ "--------------------------------"
-
--- In all these tests, zero is a dummy element used to get
--- the overloading to work
-
-testBounded zero = do
- putStrLn "testBounded"
- print $ (minBound-1, minBound, minBound+1) `asTypeOf` (zero,zero,zero)
- print $ (maxBound-1, maxBound, maxBound+1) `asTypeOf` (zero,zero,zero)
-
-testEnum zero = do
- putStrLn "testEnum"
- print $ take 10 [zero .. ] -- enumFrom
- print $ take 10 [zero, toEnum 2 .. ] -- enumFromThen
- print [zero .. toEnum 20] -- enumFromTo
- print [zero, toEnum 2 .. toEnum 20] -- enumFromThenTo
-
-samples :: (Num a, Enum a) => a -> ([a], [a])
-samples zero = ([-3 .. -1]++[0 .. 3], [-3 .. -1]++[1 .. 3])
-
-table1 :: (Show a, Show b) => String -> (a -> b) -> [a] -> IO ()
-table1 nm f xs = do
- sequence [ f' x | x <- xs ]
- putStrLn "#"
- where
- f' x = putStrLn (nm ++ " " ++ show x ++ " = " ++ show (f x))
-
-table2 :: (Show a, Show b, Show c) => String -> (a -> b -> c) -> [a] -> [b] -> IO ()
-table2 nm op xs ys = do
- sequence [ sequence [ op' x y | y <- ys ] >> putStrLn " "
- | x <- xs
- ]
- putStrLn "#"
- where
- op' x y = putStrLn (show x ++ " " ++ nm ++ " " ++ show y
- ++ " = " ++ show (op x y))
-
-testReadShow zero = do
- putStrLn "testReadShow"
- print xs
- print (map read_show xs)
- where
- (xs,zs) = samples zero
- read_show x = (read (show x) `asTypeOf` zero)
-
-testEq zero = do
- putStrLn "testEq"
- table2 "==" (==) xs xs
- table2 "/=" (/=) xs xs
- where
- (xs,ys) = samples zero
-
-testOrd zero = do
- putStrLn "testOrd"
- table2 "<=" (<=) xs xs
- table2 "< " (<) xs xs
- table2 "> " (>) xs xs
- table2 ">=" (>=) xs xs
- table2 "`compare`" compare xs xs
- where
- (xs,ys) = samples zero
-
-testNum zero = do
- putStrLn "testNum"
- table2 "+" (+) xs xs
- table2 "-" (-) xs xs
- table2 "*" (*) xs xs
- table1 "negate" negate xs
- where
- (xs,ys) = samples zero
-
-testReal zero = do
- putStrLn "testReal"
- table1 "toRational" toRational xs
- where
- (xs,ys) = samples zero
-
-testIntegral zero = do
- putStrLn "testIntegral"
- table2 "`divMod` " divMod xs ys
- table2 "`div` " div xs ys
- table2 "`mod` " mod xs ys
- table2 "`quotRem`" quotRem xs ys
- table2 "`quot` " quot xs ys
- table2 "`rem` " rem xs ys
- where
- (xs,ys) = samples zero
-
-testBits zero = do
- putStrLn "testBits"
- table2 ".&. " (.&.) xs ys
- table2 ".|. " (.|.) xs ys
- table2 "`xor`" xor xs ys
- table1 "complement" complement xs
- table2 "`shift`" shift xs [0..3]
--- table2 "`rotate`" rotate xs [0..3]
--- table1 "bit" bit xs
- table2 "`setBit`" setBit xs [0..3]
- table2 "`clearBit`" clearBit xs [0..3]
- table2 "`complementBit`" complementBit xs [0..3]
- table2 "`testBit`" testBit xs [0..3]
- table1 "bitSize" bitSize xs
- table1 "isSigned" isSigned xs
- where
- (xs,ys) = samples zero
+++ /dev/null
-Reading file "Int.hs":
-Reading file "Bits.lhs":
-Reading file "Int.hs":
-Reading file "Word.hs":
-Reading file "test/exts/intTest.hs":
-Type :? for help
-Hugs:--------------------------------
---Testing Int8
---------------------------------
-testBounded
-(127,-128,-127)
-(126,127,-128)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[-3,-2,-1,0,1,2,3]
-[-3,-2,-1,0,1,2,3]
-testEq
--3 == -3 = True
--3 == -2 = False
--3 == -1 = False
--3 == 0 = False
--3 == 1 = False
--3 == 2 = False
--3 == 3 = False
-
--2 == -3 = False
--2 == -2 = True
--2 == -1 = False
--2 == 0 = False
--2 == 1 = False
--2 == 2 = False
--2 == 3 = False
-
--1 == -3 = False
--1 == -2 = False
--1 == -1 = True
--1 == 0 = False
--1 == 1 = False
--1 == 2 = False
--1 == 3 = False
-
-0 == -3 = False
-0 == -2 = False
-0 == -1 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == -3 = False
-1 == -2 = False
-1 == -1 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == -3 = False
-2 == -2 = False
-2 == -1 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == -3 = False
-3 == -2 = False
-3 == -1 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
--3 /= -3 = False
--3 /= -2 = True
--3 /= -1 = True
--3 /= 0 = True
--3 /= 1 = True
--3 /= 2 = True
--3 /= 3 = True
-
--2 /= -3 = True
--2 /= -2 = False
--2 /= -1 = True
--2 /= 0 = True
--2 /= 1 = True
--2 /= 2 = True
--2 /= 3 = True
-
--1 /= -3 = True
--1 /= -2 = True
--1 /= -1 = False
--1 /= 0 = True
--1 /= 1 = True
--1 /= 2 = True
--1 /= 3 = True
-
-0 /= -3 = True
-0 /= -2 = True
-0 /= -1 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= -3 = True
-1 /= -2 = True
-1 /= -1 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= -3 = True
-2 /= -2 = True
-2 /= -1 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= -3 = True
-3 /= -2 = True
-3 /= -1 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
--3 <= -3 = True
--3 <= -2 = True
--3 <= -1 = True
--3 <= 0 = True
--3 <= 1 = True
--3 <= 2 = True
--3 <= 3 = True
-
--2 <= -3 = False
--2 <= -2 = True
--2 <= -1 = True
--2 <= 0 = True
--2 <= 1 = True
--2 <= 2 = True
--2 <= 3 = True
-
--1 <= -3 = False
--1 <= -2 = False
--1 <= -1 = True
--1 <= 0 = True
--1 <= 1 = True
--1 <= 2 = True
--1 <= 3 = True
-
-0 <= -3 = False
-0 <= -2 = False
-0 <= -1 = False
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= -3 = False
-1 <= -2 = False
-1 <= -1 = False
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= -3 = False
-2 <= -2 = False
-2 <= -1 = False
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= -3 = False
-3 <= -2 = False
-3 <= -1 = False
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
--3 < -3 = False
--3 < -2 = True
--3 < -1 = True
--3 < 0 = True
--3 < 1 = True
--3 < 2 = True
--3 < 3 = True
-
--2 < -3 = False
--2 < -2 = False
--2 < -1 = True
--2 < 0 = True
--2 < 1 = True
--2 < 2 = True
--2 < 3 = True
-
--1 < -3 = False
--1 < -2 = False
--1 < -1 = False
--1 < 0 = True
--1 < 1 = True
--1 < 2 = True
--1 < 3 = True
-
-0 < -3 = False
-0 < -2 = False
-0 < -1 = False
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < -3 = False
-1 < -2 = False
-1 < -1 = False
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < -3 = False
-2 < -2 = False
-2 < -1 = False
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < -3 = False
-3 < -2 = False
-3 < -1 = False
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
--3 > -3 = False
--3 > -2 = False
--3 > -1 = False
--3 > 0 = False
--3 > 1 = False
--3 > 2 = False
--3 > 3 = False
-
--2 > -3 = True
--2 > -2 = False
--2 > -1 = False
--2 > 0 = False
--2 > 1 = False
--2 > 2 = False
--2 > 3 = False
-
--1 > -3 = True
--1 > -2 = True
--1 > -1 = False
--1 > 0 = False
--1 > 1 = False
--1 > 2 = False
--1 > 3 = False
-
-0 > -3 = True
-0 > -2 = True
-0 > -1 = True
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > -3 = True
-1 > -2 = True
-1 > -1 = True
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > -3 = True
-2 > -2 = True
-2 > -1 = True
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > -3 = True
-3 > -2 = True
-3 > -1 = True
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
--3 >= -3 = True
--3 >= -2 = False
--3 >= -1 = False
--3 >= 0 = False
--3 >= 1 = False
--3 >= 2 = False
--3 >= 3 = False
-
--2 >= -3 = True
--2 >= -2 = True
--2 >= -1 = False
--2 >= 0 = False
--2 >= 1 = False
--2 >= 2 = False
--2 >= 3 = False
-
--1 >= -3 = True
--1 >= -2 = True
--1 >= -1 = True
--1 >= 0 = False
--1 >= 1 = False
--1 >= 2 = False
--1 >= 3 = False
-
-0 >= -3 = True
-0 >= -2 = True
-0 >= -1 = True
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= -3 = True
-1 >= -2 = True
-1 >= -1 = True
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= -3 = True
-2 >= -2 = True
-2 >= -1 = True
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= -3 = True
-3 >= -2 = True
-3 >= -1 = True
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
--3 `compare` -3 = EQ
--3 `compare` -2 = LT
--3 `compare` -1 = LT
--3 `compare` 0 = LT
--3 `compare` 1 = LT
--3 `compare` 2 = LT
--3 `compare` 3 = LT
-
--2 `compare` -3 = GT
--2 `compare` -2 = EQ
--2 `compare` -1 = LT
--2 `compare` 0 = LT
--2 `compare` 1 = LT
--2 `compare` 2 = LT
--2 `compare` 3 = LT
-
--1 `compare` -3 = GT
--1 `compare` -2 = GT
--1 `compare` -1 = EQ
--1 `compare` 0 = LT
--1 `compare` 1 = LT
--1 `compare` 2 = LT
--1 `compare` 3 = LT
-
-0 `compare` -3 = GT
-0 `compare` -2 = GT
-0 `compare` -1 = GT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` -3 = GT
-1 `compare` -2 = GT
-1 `compare` -1 = GT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` -3 = GT
-2 `compare` -2 = GT
-2 `compare` -1 = GT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` -3 = GT
-3 `compare` -2 = GT
-3 `compare` -1 = GT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
--3 + -3 = -6
--3 + -2 = -5
--3 + -1 = -4
--3 + 0 = -3
--3 + 1 = -2
--3 + 2 = -1
--3 + 3 = 0
-
--2 + -3 = -5
--2 + -2 = -4
--2 + -1 = -3
--2 + 0 = -2
--2 + 1 = -1
--2 + 2 = 0
--2 + 3 = 1
-
--1 + -3 = -4
--1 + -2 = -3
--1 + -1 = -2
--1 + 0 = -1
--1 + 1 = 0
--1 + 2 = 1
--1 + 3 = 2
-
-0 + -3 = -3
-0 + -2 = -2
-0 + -1 = -1
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + -3 = -2
-1 + -2 = -1
-1 + -1 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + -3 = -1
-2 + -2 = 0
-2 + -1 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + -3 = 0
-3 + -2 = 1
-3 + -1 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
--3 - -3 = 0
--3 - -2 = -1
--3 - -1 = -2
--3 - 0 = -3
--3 - 1 = -4
--3 - 2 = -5
--3 - 3 = -6
-
--2 - -3 = 1
--2 - -2 = 0
--2 - -1 = -1
--2 - 0 = -2
--2 - 1 = -3
--2 - 2 = -4
--2 - 3 = -5
-
--1 - -3 = 2
--1 - -2 = 1
--1 - -1 = 0
--1 - 0 = -1
--1 - 1 = -2
--1 - 2 = -3
--1 - 3 = -4
-
-0 - -3 = 3
-0 - -2 = 2
-0 - -1 = 1
-0 - 0 = 0
-0 - 1 = -1
-0 - 2 = -2
-0 - 3 = -3
-
-1 - -3 = 4
-1 - -2 = 3
-1 - -1 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = -1
-1 - 3 = -2
-
-2 - -3 = 5
-2 - -2 = 4
-2 - -1 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = -1
-
-3 - -3 = 6
-3 - -2 = 5
-3 - -1 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
--3 * -3 = 9
--3 * -2 = 6
--3 * -1 = 3
--3 * 0 = 0
--3 * 1 = -3
--3 * 2 = -6
--3 * 3 = -9
-
--2 * -3 = 6
--2 * -2 = 4
--2 * -1 = 2
--2 * 0 = 0
--2 * 1 = -2
--2 * 2 = -4
--2 * 3 = -6
-
--1 * -3 = 3
--1 * -2 = 2
--1 * -1 = 1
--1 * 0 = 0
--1 * 1 = -1
--1 * 2 = -2
--1 * 3 = -3
-
-0 * -3 = 0
-0 * -2 = 0
-0 * -1 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * -3 = -3
-1 * -2 = -2
-1 * -1 = -1
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * -3 = -6
-2 * -2 = -4
-2 * -1 = -2
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * -3 = -9
-3 * -2 = -6
-3 * -1 = -3
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate -3 = 3
-negate -2 = 2
-negate -1 = 1
-negate 0 = 0
-negate 1 = -1
-negate 2 = -2
-negate 3 = -3
-#
-testReal
-toRational -3 = -3 % 1
-toRational -2 = -2 % 1
-toRational -1 = -1 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
--3 `divMod` -3 = (1,0)
--3 `divMod` -2 = (1,-1)
--3 `divMod` -1 = (3,0)
--3 `divMod` 1 = (-3,0)
--3 `divMod` 2 = (-2,1)
--3 `divMod` 3 = (-1,0)
-
--2 `divMod` -3 = (0,-2)
--2 `divMod` -2 = (1,0)
--2 `divMod` -1 = (2,0)
--2 `divMod` 1 = (-2,0)
--2 `divMod` 2 = (-1,0)
--2 `divMod` 3 = (-1,1)
-
--1 `divMod` -3 = (0,-1)
--1 `divMod` -2 = (0,-1)
--1 `divMod` -1 = (1,0)
--1 `divMod` 1 = (-1,0)
--1 `divMod` 2 = (-1,1)
--1 `divMod` 3 = (-1,2)
-
-0 `divMod` -3 = (0,0)
-0 `divMod` -2 = (0,0)
-0 `divMod` -1 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` -3 = (-1,-2)
-1 `divMod` -2 = (-1,-1)
-1 `divMod` -1 = (-1,0)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` -3 = (-1,-1)
-2 `divMod` -2 = (-1,0)
-2 `divMod` -1 = (-2,0)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` -3 = (-1,0)
-3 `divMod` -2 = (-2,-1)
-3 `divMod` -1 = (-3,0)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
--3 `div` -3 = 1
--3 `div` -2 = 1
--3 `div` -1 = 3
--3 `div` 1 = -3
--3 `div` 2 = -2
--3 `div` 3 = -1
-
--2 `div` -3 = 0
--2 `div` -2 = 1
--2 `div` -1 = 2
--2 `div` 1 = -2
--2 `div` 2 = -1
--2 `div` 3 = -1
-
--1 `div` -3 = 0
--1 `div` -2 = 0
--1 `div` -1 = 1
--1 `div` 1 = -1
--1 `div` 2 = -1
--1 `div` 3 = -1
-
-0 `div` -3 = 0
-0 `div` -2 = 0
-0 `div` -1 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` -3 = -1
-1 `div` -2 = -1
-1 `div` -1 = -1
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` -3 = -1
-2 `div` -2 = -1
-2 `div` -1 = -2
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` -3 = -1
-3 `div` -2 = -2
-3 `div` -1 = -3
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
--3 `mod` -3 = 0
--3 `mod` -2 = -1
--3 `mod` -1 = 0
--3 `mod` 1 = 0
--3 `mod` 2 = 1
--3 `mod` 3 = 0
-
--2 `mod` -3 = -2
--2 `mod` -2 = 0
--2 `mod` -1 = 0
--2 `mod` 1 = 0
--2 `mod` 2 = 0
--2 `mod` 3 = 1
-
--1 `mod` -3 = -1
--1 `mod` -2 = -1
--1 `mod` -1 = 0
--1 `mod` 1 = 0
--1 `mod` 2 = 1
--1 `mod` 3 = 2
-
-0 `mod` -3 = 0
-0 `mod` -2 = 0
-0 `mod` -1 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` -3 = -2
-1 `mod` -2 = -1
-1 `mod` -1 = 0
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` -3 = -1
-2 `mod` -2 = 0
-2 `mod` -1 = 0
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` -3 = 0
-3 `mod` -2 = -1
-3 `mod` -1 = 0
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
--3 `quotRem` -3 = (1,0)
--3 `quotRem` -2 = (1,-1)
--3 `quotRem` -1 = (3,0)
--3 `quotRem` 1 = (-3,0)
--3 `quotRem` 2 = (-1,-1)
--3 `quotRem` 3 = (-1,0)
-
--2 `quotRem` -3 = (0,-2)
--2 `quotRem` -2 = (1,0)
--2 `quotRem` -1 = (2,0)
--2 `quotRem` 1 = (-2,0)
--2 `quotRem` 2 = (-1,0)
--2 `quotRem` 3 = (0,-2)
-
--1 `quotRem` -3 = (0,-1)
--1 `quotRem` -2 = (0,-1)
--1 `quotRem` -1 = (1,0)
--1 `quotRem` 1 = (-1,0)
--1 `quotRem` 2 = (0,-1)
--1 `quotRem` 3 = (0,-1)
-
-0 `quotRem` -3 = (0,0)
-0 `quotRem` -2 = (0,0)
-0 `quotRem` -1 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` -3 = (0,1)
-1 `quotRem` -2 = (0,1)
-1 `quotRem` -1 = (-1,0)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` -3 = (0,2)
-2 `quotRem` -2 = (-1,0)
-2 `quotRem` -1 = (-2,0)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` -3 = (-1,0)
-3 `quotRem` -2 = (-1,1)
-3 `quotRem` -1 = (-3,0)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
--3 `quot` -3 = 1
--3 `quot` -2 = 1
--3 `quot` -1 = 3
--3 `quot` 1 = -3
--3 `quot` 2 = -1
--3 `quot` 3 = -1
-
--2 `quot` -3 = 0
--2 `quot` -2 = 1
--2 `quot` -1 = 2
--2 `quot` 1 = -2
--2 `quot` 2 = -1
--2 `quot` 3 = 0
-
--1 `quot` -3 = 0
--1 `quot` -2 = 0
--1 `quot` -1 = 1
--1 `quot` 1 = -1
--1 `quot` 2 = 0
--1 `quot` 3 = 0
-
-0 `quot` -3 = 0
-0 `quot` -2 = 0
-0 `quot` -1 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` -3 = 0
-1 `quot` -2 = 0
-1 `quot` -1 = -1
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` -3 = 0
-2 `quot` -2 = -1
-2 `quot` -1 = -2
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` -3 = -1
-3 `quot` -2 = -1
-3 `quot` -1 = -3
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
--3 `rem` -3 = 0
--3 `rem` -2 = -1
--3 `rem` -1 = 0
--3 `rem` 1 = 0
--3 `rem` 2 = -1
--3 `rem` 3 = 0
-
--2 `rem` -3 = -2
--2 `rem` -2 = 0
--2 `rem` -1 = 0
--2 `rem` 1 = 0
--2 `rem` 2 = 0
--2 `rem` 3 = -2
-
--1 `rem` -3 = -1
--1 `rem` -2 = -1
--1 `rem` -1 = 0
--1 `rem` 1 = 0
--1 `rem` 2 = -1
--1 `rem` 3 = -1
-
-0 `rem` -3 = 0
-0 `rem` -2 = 0
-0 `rem` -1 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` -3 = 1
-1 `rem` -2 = 1
-1 `rem` -1 = 0
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` -3 = 2
-2 `rem` -2 = 0
-2 `rem` -1 = 0
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` -3 = 0
-3 `rem` -2 = 1
-3 `rem` -1 = 0
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
--3 .&. -3 = -3
--3 .&. -2 = -4
--3 .&. -1 = -3
--3 .&. 1 = 1
--3 .&. 2 = 0
--3 .&. 3 = 1
-
--2 .&. -3 = -4
--2 .&. -2 = -2
--2 .&. -1 = -2
--2 .&. 1 = 0
--2 .&. 2 = 2
--2 .&. 3 = 2
-
--1 .&. -3 = -3
--1 .&. -2 = -2
--1 .&. -1 = -1
--1 .&. 1 = 1
--1 .&. 2 = 2
--1 .&. 3 = 3
-
-0 .&. -3 = 0
-0 .&. -2 = 0
-0 .&. -1 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. -3 = 1
-1 .&. -2 = 0
-1 .&. -1 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. -3 = 0
-2 .&. -2 = 2
-2 .&. -1 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. -3 = 1
-3 .&. -2 = 2
-3 .&. -1 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
--3 .|. -3 = -3
--3 .|. -2 = -1
--3 .|. -1 = -1
--3 .|. 1 = -3
--3 .|. 2 = -1
--3 .|. 3 = -1
-
--2 .|. -3 = -1
--2 .|. -2 = -2
--2 .|. -1 = -1
--2 .|. 1 = -1
--2 .|. 2 = -2
--2 .|. 3 = -1
-
--1 .|. -3 = -1
--1 .|. -2 = -1
--1 .|. -1 = -1
--1 .|. 1 = -1
--1 .|. 2 = -1
--1 .|. 3 = -1
-
-0 .|. -3 = -3
-0 .|. -2 = -2
-0 .|. -1 = -1
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. -3 = -3
-1 .|. -2 = -1
-1 .|. -1 = -1
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. -3 = -1
-2 .|. -2 = -2
-2 .|. -1 = -1
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. -3 = -1
-3 .|. -2 = -1
-3 .|. -1 = -1
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
--3 `xor` -3 = 0
--3 `xor` -2 = 3
--3 `xor` -1 = 2
--3 `xor` 1 = -4
--3 `xor` 2 = -1
--3 `xor` 3 = -2
-
--2 `xor` -3 = 3
--2 `xor` -2 = 0
--2 `xor` -1 = 1
--2 `xor` 1 = -1
--2 `xor` 2 = -4
--2 `xor` 3 = -3
-
--1 `xor` -3 = 2
--1 `xor` -2 = 1
--1 `xor` -1 = 0
--1 `xor` 1 = -2
--1 `xor` 2 = -3
--1 `xor` 3 = -4
-
-0 `xor` -3 = -3
-0 `xor` -2 = -2
-0 `xor` -1 = -1
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` -3 = -4
-1 `xor` -2 = -1
-1 `xor` -1 = -2
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` -3 = -1
-2 `xor` -2 = -4
-2 `xor` -1 = -3
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` -3 = -2
-3 `xor` -2 = -3
-3 `xor` -1 = -4
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement -3 = 2
-complement -2 = 1
-complement -1 = 0
-complement 0 = -1
-complement 1 = -2
-complement 2 = -3
-complement 3 = -4
-#
--3 `shift` 0 = -3
--3 `shift` 1 = -6
--3 `shift` 2 = -12
--3 `shift` 3 = -24
-
--2 `shift` 0 = -2
--2 `shift` 1 = -4
--2 `shift` 2 = -8
--2 `shift` 3 = -16
-
--1 `shift` 0 = -1
--1 `shift` 1 = -2
--1 `shift` 2 = -4
--1 `shift` 3 = -8
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
--3 `setBit` 0 = -3
--3 `setBit` 1 = -1
--3 `setBit` 2 = -3
--3 `setBit` 3 = -3
-
--2 `setBit` 0 = -1
--2 `setBit` 1 = -2
--2 `setBit` 2 = -2
--2 `setBit` 3 = -2
-
--1 `setBit` 0 = -1
--1 `setBit` 1 = -1
--1 `setBit` 2 = -1
--1 `setBit` 3 = -1
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
--3 `clearBit` 0 = -4
--3 `clearBit` 1 = -3
--3 `clearBit` 2 = -7
--3 `clearBit` 3 = -11
-
--2 `clearBit` 0 = -2
--2 `clearBit` 1 = -4
--2 `clearBit` 2 = -6
--2 `clearBit` 3 = -10
-
--1 `clearBit` 0 = -2
--1 `clearBit` 1 = -3
--1 `clearBit` 2 = -5
--1 `clearBit` 3 = -9
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
--3 `complementBit` 0 = -4
--3 `complementBit` 1 = -1
--3 `complementBit` 2 = -7
--3 `complementBit` 3 = -11
-
--2 `complementBit` 0 = -1
--2 `complementBit` 1 = -4
--2 `complementBit` 2 = -6
--2 `complementBit` 3 = -10
-
--1 `complementBit` 0 = -2
--1 `complementBit` 1 = -3
--1 `complementBit` 2 = -5
--1 `complementBit` 3 = -9
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
--3 `testBit` 0 = True
--3 `testBit` 1 = False
--3 `testBit` 2 = True
--3 `testBit` 3 = True
-
--2 `testBit` 0 = False
--2 `testBit` 1 = True
--2 `testBit` 2 = True
--2 `testBit` 3 = True
-
--1 `testBit` 0 = True
--1 `testBit` 1 = True
--1 `testBit` 2 = True
--1 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize -3 = 8
-bitSize -2 = 8
-bitSize -1 = 8
-bitSize 0 = 8
-bitSize 1 = 8
-bitSize 2 = 8
-bitSize 3 = 8
-#
-isSigned -3 = True
-isSigned -2 = True
-isSigned -1 = True
-isSigned 0 = True
-isSigned 1 = True
-isSigned 2 = True
-isSigned 3 = True
-#
---------------------------------
---------------------------------
---Testing Int16
---------------------------------
-testBounded
-(32767,-32768,-32767)
-(32766,32767,-32768)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[-3,-2,-1,0,1,2,3]
-[-3,-2,-1,0,1,2,3]
-testEq
--3 == -3 = True
--3 == -2 = False
--3 == -1 = False
--3 == 0 = False
--3 == 1 = False
--3 == 2 = False
--3 == 3 = False
-
--2 == -3 = False
--2 == -2 = True
--2 == -1 = False
--2 == 0 = False
--2 == 1 = False
--2 == 2 = False
--2 == 3 = False
-
--1 == -3 = False
--1 == -2 = False
--1 == -1 = True
--1 == 0 = False
--1 == 1 = False
--1 == 2 = False
--1 == 3 = False
-
-0 == -3 = False
-0 == -2 = False
-0 == -1 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == -3 = False
-1 == -2 = False
-1 == -1 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == -3 = False
-2 == -2 = False
-2 == -1 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == -3 = False
-3 == -2 = False
-3 == -1 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
--3 /= -3 = False
--3 /= -2 = True
--3 /= -1 = True
--3 /= 0 = True
--3 /= 1 = True
--3 /= 2 = True
--3 /= 3 = True
-
--2 /= -3 = True
--2 /= -2 = False
--2 /= -1 = True
--2 /= 0 = True
--2 /= 1 = True
--2 /= 2 = True
--2 /= 3 = True
-
--1 /= -3 = True
--1 /= -2 = True
--1 /= -1 = False
--1 /= 0 = True
--1 /= 1 = True
--1 /= 2 = True
--1 /= 3 = True
-
-0 /= -3 = True
-0 /= -2 = True
-0 /= -1 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= -3 = True
-1 /= -2 = True
-1 /= -1 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= -3 = True
-2 /= -2 = True
-2 /= -1 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= -3 = True
-3 /= -2 = True
-3 /= -1 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
--3 <= -3 = True
--3 <= -2 = True
--3 <= -1 = True
--3 <= 0 = True
--3 <= 1 = True
--3 <= 2 = True
--3 <= 3 = True
-
--2 <= -3 = False
--2 <= -2 = True
--2 <= -1 = True
--2 <= 0 = True
--2 <= 1 = True
--2 <= 2 = True
--2 <= 3 = True
-
--1 <= -3 = False
--1 <= -2 = False
--1 <= -1 = True
--1 <= 0 = True
--1 <= 1 = True
--1 <= 2 = True
--1 <= 3 = True
-
-0 <= -3 = False
-0 <= -2 = False
-0 <= -1 = False
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= -3 = False
-1 <= -2 = False
-1 <= -1 = False
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= -3 = False
-2 <= -2 = False
-2 <= -1 = False
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= -3 = False
-3 <= -2 = False
-3 <= -1 = False
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
--3 < -3 = False
--3 < -2 = True
--3 < -1 = True
--3 < 0 = True
--3 < 1 = True
--3 < 2 = True
--3 < 3 = True
-
--2 < -3 = False
--2 < -2 = False
--2 < -1 = True
--2 < 0 = True
--2 < 1 = True
--2 < 2 = True
--2 < 3 = True
-
--1 < -3 = False
--1 < -2 = False
--1 < -1 = False
--1 < 0 = True
--1 < 1 = True
--1 < 2 = True
--1 < 3 = True
-
-0 < -3 = False
-0 < -2 = False
-0 < -1 = False
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < -3 = False
-1 < -2 = False
-1 < -1 = False
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < -3 = False
-2 < -2 = False
-2 < -1 = False
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < -3 = False
-3 < -2 = False
-3 < -1 = False
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
--3 > -3 = False
--3 > -2 = False
--3 > -1 = False
--3 > 0 = False
--3 > 1 = False
--3 > 2 = False
--3 > 3 = False
-
--2 > -3 = True
--2 > -2 = False
--2 > -1 = False
--2 > 0 = False
--2 > 1 = False
--2 > 2 = False
--2 > 3 = False
-
--1 > -3 = True
--1 > -2 = True
--1 > -1 = False
--1 > 0 = False
--1 > 1 = False
--1 > 2 = False
--1 > 3 = False
-
-0 > -3 = True
-0 > -2 = True
-0 > -1 = True
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > -3 = True
-1 > -2 = True
-1 > -1 = True
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > -3 = True
-2 > -2 = True
-2 > -1 = True
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > -3 = True
-3 > -2 = True
-3 > -1 = True
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
--3 >= -3 = True
--3 >= -2 = False
--3 >= -1 = False
--3 >= 0 = False
--3 >= 1 = False
--3 >= 2 = False
--3 >= 3 = False
-
--2 >= -3 = True
--2 >= -2 = True
--2 >= -1 = False
--2 >= 0 = False
--2 >= 1 = False
--2 >= 2 = False
--2 >= 3 = False
-
--1 >= -3 = True
--1 >= -2 = True
--1 >= -1 = True
--1 >= 0 = False
--1 >= 1 = False
--1 >= 2 = False
--1 >= 3 = False
-
-0 >= -3 = True
-0 >= -2 = True
-0 >= -1 = True
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= -3 = True
-1 >= -2 = True
-1 >= -1 = True
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= -3 = True
-2 >= -2 = True
-2 >= -1 = True
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= -3 = True
-3 >= -2 = True
-3 >= -1 = True
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
--3 `compare` -3 = EQ
--3 `compare` -2 = LT
--3 `compare` -1 = LT
--3 `compare` 0 = LT
--3 `compare` 1 = LT
--3 `compare` 2 = LT
--3 `compare` 3 = LT
-
--2 `compare` -3 = GT
--2 `compare` -2 = EQ
--2 `compare` -1 = LT
--2 `compare` 0 = LT
--2 `compare` 1 = LT
--2 `compare` 2 = LT
--2 `compare` 3 = LT
-
--1 `compare` -3 = GT
--1 `compare` -2 = GT
--1 `compare` -1 = EQ
--1 `compare` 0 = LT
--1 `compare` 1 = LT
--1 `compare` 2 = LT
--1 `compare` 3 = LT
-
-0 `compare` -3 = GT
-0 `compare` -2 = GT
-0 `compare` -1 = GT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` -3 = GT
-1 `compare` -2 = GT
-1 `compare` -1 = GT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` -3 = GT
-2 `compare` -2 = GT
-2 `compare` -1 = GT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` -3 = GT
-3 `compare` -2 = GT
-3 `compare` -1 = GT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
--3 + -3 = -6
--3 + -2 = -5
--3 + -1 = -4
--3 + 0 = -3
--3 + 1 = -2
--3 + 2 = -1
--3 + 3 = 0
-
--2 + -3 = -5
--2 + -2 = -4
--2 + -1 = -3
--2 + 0 = -2
--2 + 1 = -1
--2 + 2 = 0
--2 + 3 = 1
-
--1 + -3 = -4
--1 + -2 = -3
--1 + -1 = -2
--1 + 0 = -1
--1 + 1 = 0
--1 + 2 = 1
--1 + 3 = 2
-
-0 + -3 = -3
-0 + -2 = -2
-0 + -1 = -1
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + -3 = -2
-1 + -2 = -1
-1 + -1 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + -3 = -1
-2 + -2 = 0
-2 + -1 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + -3 = 0
-3 + -2 = 1
-3 + -1 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
--3 - -3 = 0
--3 - -2 = -1
--3 - -1 = -2
--3 - 0 = -3
--3 - 1 = -4
--3 - 2 = -5
--3 - 3 = -6
-
--2 - -3 = 1
--2 - -2 = 0
--2 - -1 = -1
--2 - 0 = -2
--2 - 1 = -3
--2 - 2 = -4
--2 - 3 = -5
-
--1 - -3 = 2
--1 - -2 = 1
--1 - -1 = 0
--1 - 0 = -1
--1 - 1 = -2
--1 - 2 = -3
--1 - 3 = -4
-
-0 - -3 = 3
-0 - -2 = 2
-0 - -1 = 1
-0 - 0 = 0
-0 - 1 = -1
-0 - 2 = -2
-0 - 3 = -3
-
-1 - -3 = 4
-1 - -2 = 3
-1 - -1 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = -1
-1 - 3 = -2
-
-2 - -3 = 5
-2 - -2 = 4
-2 - -1 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = -1
-
-3 - -3 = 6
-3 - -2 = 5
-3 - -1 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
--3 * -3 = 9
--3 * -2 = 6
--3 * -1 = 3
--3 * 0 = 0
--3 * 1 = -3
--3 * 2 = -6
--3 * 3 = -9
-
--2 * -3 = 6
--2 * -2 = 4
--2 * -1 = 2
--2 * 0 = 0
--2 * 1 = -2
--2 * 2 = -4
--2 * 3 = -6
-
--1 * -3 = 3
--1 * -2 = 2
--1 * -1 = 1
--1 * 0 = 0
--1 * 1 = -1
--1 * 2 = -2
--1 * 3 = -3
-
-0 * -3 = 0
-0 * -2 = 0
-0 * -1 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * -3 = -3
-1 * -2 = -2
-1 * -1 = -1
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * -3 = -6
-2 * -2 = -4
-2 * -1 = -2
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * -3 = -9
-3 * -2 = -6
-3 * -1 = -3
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate -3 = 3
-negate -2 = 2
-negate -1 = 1
-negate 0 = 0
-negate 1 = -1
-negate 2 = -2
-negate 3 = -3
-#
-testReal
-toRational -3 = -3 % 1
-toRational -2 = -2 % 1
-toRational -1 = -1 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
--3 `divMod` -3 = (1,0)
--3 `divMod` -2 = (1,-1)
--3 `divMod` -1 = (3,0)
--3 `divMod` 1 = (-3,0)
--3 `divMod` 2 = (-2,1)
--3 `divMod` 3 = (-1,0)
-
--2 `divMod` -3 = (0,-2)
--2 `divMod` -2 = (1,0)
--2 `divMod` -1 = (2,0)
--2 `divMod` 1 = (-2,0)
--2 `divMod` 2 = (-1,0)
--2 `divMod` 3 = (-1,1)
-
--1 `divMod` -3 = (0,-1)
--1 `divMod` -2 = (0,-1)
--1 `divMod` -1 = (1,0)
--1 `divMod` 1 = (-1,0)
--1 `divMod` 2 = (-1,1)
--1 `divMod` 3 = (-1,2)
-
-0 `divMod` -3 = (0,0)
-0 `divMod` -2 = (0,0)
-0 `divMod` -1 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` -3 = (-1,-2)
-1 `divMod` -2 = (-1,-1)
-1 `divMod` -1 = (-1,0)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` -3 = (-1,-1)
-2 `divMod` -2 = (-1,0)
-2 `divMod` -1 = (-2,0)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` -3 = (-1,0)
-3 `divMod` -2 = (-2,-1)
-3 `divMod` -1 = (-3,0)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
--3 `div` -3 = 1
--3 `div` -2 = 1
--3 `div` -1 = 3
--3 `div` 1 = -3
--3 `div` 2 = -2
--3 `div` 3 = -1
-
--2 `div` -3 = 0
--2 `div` -2 = 1
--2 `div` -1 = 2
--2 `div` 1 = -2
--2 `div` 2 = -1
--2 `div` 3 = -1
-
--1 `div` -3 = 0
--1 `div` -2 = 0
--1 `div` -1 = 1
--1 `div` 1 = -1
--1 `div` 2 = -1
--1 `div` 3 = -1
-
-0 `div` -3 = 0
-0 `div` -2 = 0
-0 `div` -1 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` -3 = -1
-1 `div` -2 = -1
-1 `div` -1 = -1
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` -3 = -1
-2 `div` -2 = -1
-2 `div` -1 = -2
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` -3 = -1
-3 `div` -2 = -2
-3 `div` -1 = -3
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
--3 `mod` -3 = 0
--3 `mod` -2 = -1
--3 `mod` -1 = 0
--3 `mod` 1 = 0
--3 `mod` 2 = 1
--3 `mod` 3 = 0
-
--2 `mod` -3 = -2
--2 `mod` -2 = 0
--2 `mod` -1 = 0
--2 `mod` 1 = 0
--2 `mod` 2 = 0
--2 `mod` 3 = 1
-
--1 `mod` -3 = -1
--1 `mod` -2 = -1
--1 `mod` -1 = 0
--1 `mod` 1 = 0
--1 `mod` 2 = 1
--1 `mod` 3 = 2
-
-0 `mod` -3 = 0
-0 `mod` -2 = 0
-0 `mod` -1 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` -3 = -2
-1 `mod` -2 = -1
-1 `mod` -1 = 0
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` -3 = -1
-2 `mod` -2 = 0
-2 `mod` -1 = 0
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` -3 = 0
-3 `mod` -2 = -1
-3 `mod` -1 = 0
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
--3 `quotRem` -3 = (1,0)
--3 `quotRem` -2 = (1,-1)
--3 `quotRem` -1 = (3,0)
--3 `quotRem` 1 = (-3,0)
--3 `quotRem` 2 = (-1,-1)
--3 `quotRem` 3 = (-1,0)
-
--2 `quotRem` -3 = (0,-2)
--2 `quotRem` -2 = (1,0)
--2 `quotRem` -1 = (2,0)
--2 `quotRem` 1 = (-2,0)
--2 `quotRem` 2 = (-1,0)
--2 `quotRem` 3 = (0,-2)
-
--1 `quotRem` -3 = (0,-1)
--1 `quotRem` -2 = (0,-1)
--1 `quotRem` -1 = (1,0)
--1 `quotRem` 1 = (-1,0)
--1 `quotRem` 2 = (0,-1)
--1 `quotRem` 3 = (0,-1)
-
-0 `quotRem` -3 = (0,0)
-0 `quotRem` -2 = (0,0)
-0 `quotRem` -1 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` -3 = (0,1)
-1 `quotRem` -2 = (0,1)
-1 `quotRem` -1 = (-1,0)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` -3 = (0,2)
-2 `quotRem` -2 = (-1,0)
-2 `quotRem` -1 = (-2,0)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` -3 = (-1,0)
-3 `quotRem` -2 = (-1,1)
-3 `quotRem` -1 = (-3,0)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
--3 `quot` -3 = 1
--3 `quot` -2 = 1
--3 `quot` -1 = 3
--3 `quot` 1 = -3
--3 `quot` 2 = -1
--3 `quot` 3 = -1
-
--2 `quot` -3 = 0
--2 `quot` -2 = 1
--2 `quot` -1 = 2
--2 `quot` 1 = -2
--2 `quot` 2 = -1
--2 `quot` 3 = 0
-
--1 `quot` -3 = 0
--1 `quot` -2 = 0
--1 `quot` -1 = 1
--1 `quot` 1 = -1
--1 `quot` 2 = 0
--1 `quot` 3 = 0
-
-0 `quot` -3 = 0
-0 `quot` -2 = 0
-0 `quot` -1 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` -3 = 0
-1 `quot` -2 = 0
-1 `quot` -1 = -1
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` -3 = 0
-2 `quot` -2 = -1
-2 `quot` -1 = -2
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` -3 = -1
-3 `quot` -2 = -1
-3 `quot` -1 = -3
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
--3 `rem` -3 = 0
--3 `rem` -2 = -1
--3 `rem` -1 = 0
--3 `rem` 1 = 0
--3 `rem` 2 = -1
--3 `rem` 3 = 0
-
--2 `rem` -3 = -2
--2 `rem` -2 = 0
--2 `rem` -1 = 0
--2 `rem` 1 = 0
--2 `rem` 2 = 0
--2 `rem` 3 = -2
-
--1 `rem` -3 = -1
--1 `rem` -2 = -1
--1 `rem` -1 = 0
--1 `rem` 1 = 0
--1 `rem` 2 = -1
--1 `rem` 3 = -1
-
-0 `rem` -3 = 0
-0 `rem` -2 = 0
-0 `rem` -1 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` -3 = 1
-1 `rem` -2 = 1
-1 `rem` -1 = 0
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` -3 = 2
-2 `rem` -2 = 0
-2 `rem` -1 = 0
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` -3 = 0
-3 `rem` -2 = 1
-3 `rem` -1 = 0
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
--3 .&. -3 = -3
--3 .&. -2 = -4
--3 .&. -1 = -3
--3 .&. 1 = 1
--3 .&. 2 = 0
--3 .&. 3 = 1
-
--2 .&. -3 = -4
--2 .&. -2 = -2
--2 .&. -1 = -2
--2 .&. 1 = 0
--2 .&. 2 = 2
--2 .&. 3 = 2
-
--1 .&. -3 = -3
--1 .&. -2 = -2
--1 .&. -1 = -1
--1 .&. 1 = 1
--1 .&. 2 = 2
--1 .&. 3 = 3
-
-0 .&. -3 = 0
-0 .&. -2 = 0
-0 .&. -1 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. -3 = 1
-1 .&. -2 = 0
-1 .&. -1 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. -3 = 0
-2 .&. -2 = 2
-2 .&. -1 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. -3 = 1
-3 .&. -2 = 2
-3 .&. -1 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
--3 .|. -3 = -3
--3 .|. -2 = -1
--3 .|. -1 = -1
--3 .|. 1 = -3
--3 .|. 2 = -1
--3 .|. 3 = -1
-
--2 .|. -3 = -1
--2 .|. -2 = -2
--2 .|. -1 = -1
--2 .|. 1 = -1
--2 .|. 2 = -2
--2 .|. 3 = -1
-
--1 .|. -3 = -1
--1 .|. -2 = -1
--1 .|. -1 = -1
--1 .|. 1 = -1
--1 .|. 2 = -1
--1 .|. 3 = -1
-
-0 .|. -3 = -3
-0 .|. -2 = -2
-0 .|. -1 = -1
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. -3 = -3
-1 .|. -2 = -1
-1 .|. -1 = -1
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. -3 = -1
-2 .|. -2 = -2
-2 .|. -1 = -1
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. -3 = -1
-3 .|. -2 = -1
-3 .|. -1 = -1
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
--3 `xor` -3 = 0
--3 `xor` -2 = 3
--3 `xor` -1 = 2
--3 `xor` 1 = -4
--3 `xor` 2 = -1
--3 `xor` 3 = -2
-
--2 `xor` -3 = 3
--2 `xor` -2 = 0
--2 `xor` -1 = 1
--2 `xor` 1 = -1
--2 `xor` 2 = -4
--2 `xor` 3 = -3
-
--1 `xor` -3 = 2
--1 `xor` -2 = 1
--1 `xor` -1 = 0
--1 `xor` 1 = -2
--1 `xor` 2 = -3
--1 `xor` 3 = -4
-
-0 `xor` -3 = -3
-0 `xor` -2 = -2
-0 `xor` -1 = -1
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` -3 = -4
-1 `xor` -2 = -1
-1 `xor` -1 = -2
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` -3 = -1
-2 `xor` -2 = -4
-2 `xor` -1 = -3
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` -3 = -2
-3 `xor` -2 = -3
-3 `xor` -1 = -4
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement -3 = 2
-complement -2 = 1
-complement -1 = 0
-complement 0 = -1
-complement 1 = -2
-complement 2 = -3
-complement 3 = -4
-#
--3 `shift` 0 = -3
--3 `shift` 1 = -6
--3 `shift` 2 = -12
--3 `shift` 3 = -24
-
--2 `shift` 0 = -2
--2 `shift` 1 = -4
--2 `shift` 2 = -8
--2 `shift` 3 = -16
-
--1 `shift` 0 = -1
--1 `shift` 1 = -2
--1 `shift` 2 = -4
--1 `shift` 3 = -8
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
--3 `setBit` 0 = -3
--3 `setBit` 1 = -1
--3 `setBit` 2 = -3
--3 `setBit` 3 = -3
-
--2 `setBit` 0 = -1
--2 `setBit` 1 = -2
--2 `setBit` 2 = -2
--2 `setBit` 3 = -2
-
--1 `setBit` 0 = -1
--1 `setBit` 1 = -1
--1 `setBit` 2 = -1
--1 `setBit` 3 = -1
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
--3 `clearBit` 0 = -4
--3 `clearBit` 1 = -3
--3 `clearBit` 2 = -7
--3 `clearBit` 3 = -11
-
--2 `clearBit` 0 = -2
--2 `clearBit` 1 = -4
--2 `clearBit` 2 = -6
--2 `clearBit` 3 = -10
-
--1 `clearBit` 0 = -2
--1 `clearBit` 1 = -3
--1 `clearBit` 2 = -5
--1 `clearBit` 3 = -9
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
--3 `complementBit` 0 = -4
--3 `complementBit` 1 = -1
--3 `complementBit` 2 = -7
--3 `complementBit` 3 = -11
-
--2 `complementBit` 0 = -1
--2 `complementBit` 1 = -4
--2 `complementBit` 2 = -6
--2 `complementBit` 3 = -10
-
--1 `complementBit` 0 = -2
--1 `complementBit` 1 = -3
--1 `complementBit` 2 = -5
--1 `complementBit` 3 = -9
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
--3 `testBit` 0 = True
--3 `testBit` 1 = False
--3 `testBit` 2 = True
--3 `testBit` 3 = True
-
--2 `testBit` 0 = False
--2 `testBit` 1 = True
--2 `testBit` 2 = True
--2 `testBit` 3 = True
-
--1 `testBit` 0 = True
--1 `testBit` 1 = True
--1 `testBit` 2 = True
--1 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize -3 = 16
-bitSize -2 = 16
-bitSize -1 = 16
-bitSize 0 = 16
-bitSize 1 = 16
-bitSize 2 = 16
-bitSize 3 = 16
-#
-isSigned -3 = True
-isSigned -2 = True
-isSigned -1 = True
-isSigned 0 = True
-isSigned 1 = True
-isSigned 2 = True
-isSigned 3 = True
-#
---------------------------------
---------------------------------
---Testing Int32
---------------------------------
-testBounded
-(2147483647,-2147483648,-2147483647)
-(2147483646,2147483647,-2147483648)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[-3,-2,-1,0,1,2,3]
-[-3,-2,-1,0,1,2,3]
-testEq
--3 == -3 = True
--3 == -2 = False
--3 == -1 = False
--3 == 0 = False
--3 == 1 = False
--3 == 2 = False
--3 == 3 = False
-
--2 == -3 = False
--2 == -2 = True
--2 == -1 = False
--2 == 0 = False
--2 == 1 = False
--2 == 2 = False
--2 == 3 = False
-
--1 == -3 = False
--1 == -2 = False
--1 == -1 = True
--1 == 0 = False
--1 == 1 = False
--1 == 2 = False
--1 == 3 = False
-
-0 == -3 = False
-0 == -2 = False
-0 == -1 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == -3 = False
-1 == -2 = False
-1 == -1 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == -3 = False
-2 == -2 = False
-2 == -1 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == -3 = False
-3 == -2 = False
-3 == -1 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
--3 /= -3 = False
--3 /= -2 = True
--3 /= -1 = True
--3 /= 0 = True
--3 /= 1 = True
--3 /= 2 = True
--3 /= 3 = True
-
--2 /= -3 = True
--2 /= -2 = False
--2 /= -1 = True
--2 /= 0 = True
--2 /= 1 = True
--2 /= 2 = True
--2 /= 3 = True
-
--1 /= -3 = True
--1 /= -2 = True
--1 /= -1 = False
--1 /= 0 = True
--1 /= 1 = True
--1 /= 2 = True
--1 /= 3 = True
-
-0 /= -3 = True
-0 /= -2 = True
-0 /= -1 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= -3 = True
-1 /= -2 = True
-1 /= -1 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= -3 = True
-2 /= -2 = True
-2 /= -1 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= -3 = True
-3 /= -2 = True
-3 /= -1 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
--3 <= -3 = True
--3 <= -2 = True
--3 <= -1 = True
--3 <= 0 = True
--3 <= 1 = True
--3 <= 2 = True
--3 <= 3 = True
-
--2 <= -3 = False
--2 <= -2 = True
--2 <= -1 = True
--2 <= 0 = True
--2 <= 1 = True
--2 <= 2 = True
--2 <= 3 = True
-
--1 <= -3 = False
--1 <= -2 = False
--1 <= -1 = True
--1 <= 0 = True
--1 <= 1 = True
--1 <= 2 = True
--1 <= 3 = True
-
-0 <= -3 = False
-0 <= -2 = False
-0 <= -1 = False
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= -3 = False
-1 <= -2 = False
-1 <= -1 = False
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= -3 = False
-2 <= -2 = False
-2 <= -1 = False
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= -3 = False
-3 <= -2 = False
-3 <= -1 = False
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
--3 < -3 = False
--3 < -2 = True
--3 < -1 = True
--3 < 0 = True
--3 < 1 = True
--3 < 2 = True
--3 < 3 = True
-
--2 < -3 = False
--2 < -2 = False
--2 < -1 = True
--2 < 0 = True
--2 < 1 = True
--2 < 2 = True
--2 < 3 = True
-
--1 < -3 = False
--1 < -2 = False
--1 < -1 = False
--1 < 0 = True
--1 < 1 = True
--1 < 2 = True
--1 < 3 = True
-
-0 < -3 = False
-0 < -2 = False
-0 < -1 = False
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < -3 = False
-1 < -2 = False
-1 < -1 = False
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < -3 = False
-2 < -2 = False
-2 < -1 = False
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < -3 = False
-3 < -2 = False
-3 < -1 = False
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
--3 > -3 = False
--3 > -2 = False
--3 > -1 = False
--3 > 0 = False
--3 > 1 = False
--3 > 2 = False
--3 > 3 = False
-
--2 > -3 = True
--2 > -2 = False
--2 > -1 = False
--2 > 0 = False
--2 > 1 = False
--2 > 2 = False
--2 > 3 = False
-
--1 > -3 = True
--1 > -2 = True
--1 > -1 = False
--1 > 0 = False
--1 > 1 = False
--1 > 2 = False
--1 > 3 = False
-
-0 > -3 = True
-0 > -2 = True
-0 > -1 = True
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > -3 = True
-1 > -2 = True
-1 > -1 = True
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > -3 = True
-2 > -2 = True
-2 > -1 = True
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > -3 = True
-3 > -2 = True
-3 > -1 = True
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
--3 >= -3 = True
--3 >= -2 = False
--3 >= -1 = False
--3 >= 0 = False
--3 >= 1 = False
--3 >= 2 = False
--3 >= 3 = False
-
--2 >= -3 = True
--2 >= -2 = True
--2 >= -1 = False
--2 >= 0 = False
--2 >= 1 = False
--2 >= 2 = False
--2 >= 3 = False
-
--1 >= -3 = True
--1 >= -2 = True
--1 >= -1 = True
--1 >= 0 = False
--1 >= 1 = False
--1 >= 2 = False
--1 >= 3 = False
-
-0 >= -3 = True
-0 >= -2 = True
-0 >= -1 = True
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= -3 = True
-1 >= -2 = True
-1 >= -1 = True
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= -3 = True
-2 >= -2 = True
-2 >= -1 = True
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= -3 = True
-3 >= -2 = True
-3 >= -1 = True
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
--3 `compare` -3 = EQ
--3 `compare` -2 = LT
--3 `compare` -1 = LT
--3 `compare` 0 = LT
--3 `compare` 1 = LT
--3 `compare` 2 = LT
--3 `compare` 3 = LT
-
--2 `compare` -3 = GT
--2 `compare` -2 = EQ
--2 `compare` -1 = LT
--2 `compare` 0 = LT
--2 `compare` 1 = LT
--2 `compare` 2 = LT
--2 `compare` 3 = LT
-
--1 `compare` -3 = GT
--1 `compare` -2 = GT
--1 `compare` -1 = EQ
--1 `compare` 0 = LT
--1 `compare` 1 = LT
--1 `compare` 2 = LT
--1 `compare` 3 = LT
-
-0 `compare` -3 = GT
-0 `compare` -2 = GT
-0 `compare` -1 = GT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` -3 = GT
-1 `compare` -2 = GT
-1 `compare` -1 = GT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` -3 = GT
-2 `compare` -2 = GT
-2 `compare` -1 = GT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` -3 = GT
-3 `compare` -2 = GT
-3 `compare` -1 = GT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
--3 + -3 = -6
--3 + -2 = -5
--3 + -1 = -4
--3 + 0 = -3
--3 + 1 = -2
--3 + 2 = -1
--3 + 3 = 0
-
--2 + -3 = -5
--2 + -2 = -4
--2 + -1 = -3
--2 + 0 = -2
--2 + 1 = -1
--2 + 2 = 0
--2 + 3 = 1
-
--1 + -3 = -4
--1 + -2 = -3
--1 + -1 = -2
--1 + 0 = -1
--1 + 1 = 0
--1 + 2 = 1
--1 + 3 = 2
-
-0 + -3 = -3
-0 + -2 = -2
-0 + -1 = -1
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + -3 = -2
-1 + -2 = -1
-1 + -1 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + -3 = -1
-2 + -2 = 0
-2 + -1 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + -3 = 0
-3 + -2 = 1
-3 + -1 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
--3 - -3 = 0
--3 - -2 = -1
--3 - -1 = -2
--3 - 0 = -3
--3 - 1 = -4
--3 - 2 = -5
--3 - 3 = -6
-
--2 - -3 = 1
--2 - -2 = 0
--2 - -1 = -1
--2 - 0 = -2
--2 - 1 = -3
--2 - 2 = -4
--2 - 3 = -5
-
--1 - -3 = 2
--1 - -2 = 1
--1 - -1 = 0
--1 - 0 = -1
--1 - 1 = -2
--1 - 2 = -3
--1 - 3 = -4
-
-0 - -3 = 3
-0 - -2 = 2
-0 - -1 = 1
-0 - 0 = 0
-0 - 1 = -1
-0 - 2 = -2
-0 - 3 = -3
-
-1 - -3 = 4
-1 - -2 = 3
-1 - -1 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = -1
-1 - 3 = -2
-
-2 - -3 = 5
-2 - -2 = 4
-2 - -1 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = -1
-
-3 - -3 = 6
-3 - -2 = 5
-3 - -1 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
--3 * -3 = 9
--3 * -2 = 6
--3 * -1 = 3
--3 * 0 = 0
--3 * 1 = -3
--3 * 2 = -6
--3 * 3 = -9
-
--2 * -3 = 6
--2 * -2 = 4
--2 * -1 = 2
--2 * 0 = 0
--2 * 1 = -2
--2 * 2 = -4
--2 * 3 = -6
-
--1 * -3 = 3
--1 * -2 = 2
--1 * -1 = 1
--1 * 0 = 0
--1 * 1 = -1
--1 * 2 = -2
--1 * 3 = -3
-
-0 * -3 = 0
-0 * -2 = 0
-0 * -1 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * -3 = -3
-1 * -2 = -2
-1 * -1 = -1
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * -3 = -6
-2 * -2 = -4
-2 * -1 = -2
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * -3 = -9
-3 * -2 = -6
-3 * -1 = -3
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate -3 = 3
-negate -2 = 2
-negate -1 = 1
-negate 0 = 0
-negate 1 = -1
-negate 2 = -2
-negate 3 = -3
-#
-testReal
-toRational -3 = -3 % 1
-toRational -2 = -2 % 1
-toRational -1 = -1 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
--3 `divMod` -3 = (1,0)
--3 `divMod` -2 = (1,-1)
--3 `divMod` -1 = (3,0)
--3 `divMod` 1 = (-3,0)
--3 `divMod` 2 = (-2,1)
--3 `divMod` 3 = (-1,0)
-
--2 `divMod` -3 = (0,-2)
--2 `divMod` -2 = (1,0)
--2 `divMod` -1 = (2,0)
--2 `divMod` 1 = (-2,0)
--2 `divMod` 2 = (-1,0)
--2 `divMod` 3 = (-1,1)
-
--1 `divMod` -3 = (0,-1)
--1 `divMod` -2 = (0,-1)
--1 `divMod` -1 = (1,0)
--1 `divMod` 1 = (-1,0)
--1 `divMod` 2 = (-1,1)
--1 `divMod` 3 = (-1,2)
-
-0 `divMod` -3 = (0,0)
-0 `divMod` -2 = (0,0)
-0 `divMod` -1 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` -3 = (-1,-2)
-1 `divMod` -2 = (-1,-1)
-1 `divMod` -1 = (-1,0)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` -3 = (-1,-1)
-2 `divMod` -2 = (-1,0)
-2 `divMod` -1 = (-2,0)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` -3 = (-1,0)
-3 `divMod` -2 = (-2,-1)
-3 `divMod` -1 = (-3,0)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
--3 `div` -3 = 1
--3 `div` -2 = 1
--3 `div` -1 = 3
--3 `div` 1 = -3
--3 `div` 2 = -2
--3 `div` 3 = -1
-
--2 `div` -3 = 0
--2 `div` -2 = 1
--2 `div` -1 = 2
--2 `div` 1 = -2
--2 `div` 2 = -1
--2 `div` 3 = -1
-
--1 `div` -3 = 0
--1 `div` -2 = 0
--1 `div` -1 = 1
--1 `div` 1 = -1
--1 `div` 2 = -1
--1 `div` 3 = -1
-
-0 `div` -3 = 0
-0 `div` -2 = 0
-0 `div` -1 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` -3 = -1
-1 `div` -2 = -1
-1 `div` -1 = -1
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` -3 = -1
-2 `div` -2 = -1
-2 `div` -1 = -2
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` -3 = -1
-3 `div` -2 = -2
-3 `div` -1 = -3
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
--3 `mod` -3 = 0
--3 `mod` -2 = -1
--3 `mod` -1 = 0
--3 `mod` 1 = 0
--3 `mod` 2 = 1
--3 `mod` 3 = 0
-
--2 `mod` -3 = -2
--2 `mod` -2 = 0
--2 `mod` -1 = 0
--2 `mod` 1 = 0
--2 `mod` 2 = 0
--2 `mod` 3 = 1
-
--1 `mod` -3 = -1
--1 `mod` -2 = -1
--1 `mod` -1 = 0
--1 `mod` 1 = 0
--1 `mod` 2 = 1
--1 `mod` 3 = 2
-
-0 `mod` -3 = 0
-0 `mod` -2 = 0
-0 `mod` -1 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` -3 = -2
-1 `mod` -2 = -1
-1 `mod` -1 = 0
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` -3 = -1
-2 `mod` -2 = 0
-2 `mod` -1 = 0
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` -3 = 0
-3 `mod` -2 = -1
-3 `mod` -1 = 0
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
--3 `quotRem` -3 = (1,0)
--3 `quotRem` -2 = (1,-1)
--3 `quotRem` -1 = (3,0)
--3 `quotRem` 1 = (-3,0)
--3 `quotRem` 2 = (-1,-1)
--3 `quotRem` 3 = (-1,0)
-
--2 `quotRem` -3 = (0,-2)
--2 `quotRem` -2 = (1,0)
--2 `quotRem` -1 = (2,0)
--2 `quotRem` 1 = (-2,0)
--2 `quotRem` 2 = (-1,0)
--2 `quotRem` 3 = (0,-2)
-
--1 `quotRem` -3 = (0,-1)
--1 `quotRem` -2 = (0,-1)
--1 `quotRem` -1 = (1,0)
--1 `quotRem` 1 = (-1,0)
--1 `quotRem` 2 = (0,-1)
--1 `quotRem` 3 = (0,-1)
-
-0 `quotRem` -3 = (0,0)
-0 `quotRem` -2 = (0,0)
-0 `quotRem` -1 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` -3 = (0,1)
-1 `quotRem` -2 = (0,1)
-1 `quotRem` -1 = (-1,0)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` -3 = (0,2)
-2 `quotRem` -2 = (-1,0)
-2 `quotRem` -1 = (-2,0)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` -3 = (-1,0)
-3 `quotRem` -2 = (-1,1)
-3 `quotRem` -1 = (-3,0)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
--3 `quot` -3 = 1
--3 `quot` -2 = 1
--3 `quot` -1 = 3
--3 `quot` 1 = -3
--3 `quot` 2 = -1
--3 `quot` 3 = -1
-
--2 `quot` -3 = 0
--2 `quot` -2 = 1
--2 `quot` -1 = 2
--2 `quot` 1 = -2
--2 `quot` 2 = -1
--2 `quot` 3 = 0
-
--1 `quot` -3 = 0
--1 `quot` -2 = 0
--1 `quot` -1 = 1
--1 `quot` 1 = -1
--1 `quot` 2 = 0
--1 `quot` 3 = 0
-
-0 `quot` -3 = 0
-0 `quot` -2 = 0
-0 `quot` -1 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` -3 = 0
-1 `quot` -2 = 0
-1 `quot` -1 = -1
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` -3 = 0
-2 `quot` -2 = -1
-2 `quot` -1 = -2
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` -3 = -1
-3 `quot` -2 = -1
-3 `quot` -1 = -3
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
--3 `rem` -3 = 0
--3 `rem` -2 = -1
--3 `rem` -1 = 0
--3 `rem` 1 = 0
--3 `rem` 2 = -1
--3 `rem` 3 = 0
-
--2 `rem` -3 = -2
--2 `rem` -2 = 0
--2 `rem` -1 = 0
--2 `rem` 1 = 0
--2 `rem` 2 = 0
--2 `rem` 3 = -2
-
--1 `rem` -3 = -1
--1 `rem` -2 = -1
--1 `rem` -1 = 0
--1 `rem` 1 = 0
--1 `rem` 2 = -1
--1 `rem` 3 = -1
-
-0 `rem` -3 = 0
-0 `rem` -2 = 0
-0 `rem` -1 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` -3 = 1
-1 `rem` -2 = 1
-1 `rem` -1 = 0
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` -3 = 2
-2 `rem` -2 = 0
-2 `rem` -1 = 0
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` -3 = 0
-3 `rem` -2 = 1
-3 `rem` -1 = 0
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
--3 .&. -3 = -3
--3 .&. -2 = -4
--3 .&. -1 = -3
--3 .&. 1 = 1
--3 .&. 2 = 0
--3 .&. 3 = 1
-
--2 .&. -3 = -4
--2 .&. -2 = -2
--2 .&. -1 = -2
--2 .&. 1 = 0
--2 .&. 2 = 2
--2 .&. 3 = 2
-
--1 .&. -3 = -3
--1 .&. -2 = -2
--1 .&. -1 = -1
--1 .&. 1 = 1
--1 .&. 2 = 2
--1 .&. 3 = 3
-
-0 .&. -3 = 0
-0 .&. -2 = 0
-0 .&. -1 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. -3 = 1
-1 .&. -2 = 0
-1 .&. -1 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. -3 = 0
-2 .&. -2 = 2
-2 .&. -1 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. -3 = 1
-3 .&. -2 = 2
-3 .&. -1 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
--3 .|. -3 = -3
--3 .|. -2 = -1
--3 .|. -1 = -1
--3 .|. 1 = -3
--3 .|. 2 = -1
--3 .|. 3 = -1
-
--2 .|. -3 = -1
--2 .|. -2 = -2
--2 .|. -1 = -1
--2 .|. 1 = -1
--2 .|. 2 = -2
--2 .|. 3 = -1
-
--1 .|. -3 = -1
--1 .|. -2 = -1
--1 .|. -1 = -1
--1 .|. 1 = -1
--1 .|. 2 = -1
--1 .|. 3 = -1
-
-0 .|. -3 = -3
-0 .|. -2 = -2
-0 .|. -1 = -1
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. -3 = -3
-1 .|. -2 = -1
-1 .|. -1 = -1
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. -3 = -1
-2 .|. -2 = -2
-2 .|. -1 = -1
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. -3 = -1
-3 .|. -2 = -1
-3 .|. -1 = -1
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
--3 `xor` -3 = 0
--3 `xor` -2 = 3
--3 `xor` -1 = 2
--3 `xor` 1 = -4
--3 `xor` 2 = -1
--3 `xor` 3 = -2
-
--2 `xor` -3 = 3
--2 `xor` -2 = 0
--2 `xor` -1 = 1
--2 `xor` 1 = -1
--2 `xor` 2 = -4
--2 `xor` 3 = -3
-
--1 `xor` -3 = 2
--1 `xor` -2 = 1
--1 `xor` -1 = 0
--1 `xor` 1 = -2
--1 `xor` 2 = -3
--1 `xor` 3 = -4
-
-0 `xor` -3 = -3
-0 `xor` -2 = -2
-0 `xor` -1 = -1
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` -3 = -4
-1 `xor` -2 = -1
-1 `xor` -1 = -2
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` -3 = -1
-2 `xor` -2 = -4
-2 `xor` -1 = -3
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` -3 = -2
-3 `xor` -2 = -3
-3 `xor` -1 = -4
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement -3 = 2
-complement -2 = 1
-complement -1 = 0
-complement 0 = -1
-complement 1 = -2
-complement 2 = -3
-complement 3 = -4
-#
--3 `shift` 0 = -3
--3 `shift` 1 = -6
--3 `shift` 2 = -12
--3 `shift` 3 = -24
-
--2 `shift` 0 = -2
--2 `shift` 1 = -4
--2 `shift` 2 = -8
--2 `shift` 3 = -16
-
--1 `shift` 0 = -1
--1 `shift` 1 = -2
--1 `shift` 2 = -4
--1 `shift` 3 = -8
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
--3 `setBit` 0 = -3
--3 `setBit` 1 = -1
--3 `setBit` 2 = -3
--3 `setBit` 3 = -3
-
--2 `setBit` 0 = -1
--2 `setBit` 1 = -2
--2 `setBit` 2 = -2
--2 `setBit` 3 = -2
-
--1 `setBit` 0 = -1
--1 `setBit` 1 = -1
--1 `setBit` 2 = -1
--1 `setBit` 3 = -1
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
--3 `clearBit` 0 = -4
--3 `clearBit` 1 = -3
--3 `clearBit` 2 = -7
--3 `clearBit` 3 = -11
-
--2 `clearBit` 0 = -2
--2 `clearBit` 1 = -4
--2 `clearBit` 2 = -6
--2 `clearBit` 3 = -10
-
--1 `clearBit` 0 = -2
--1 `clearBit` 1 = -3
--1 `clearBit` 2 = -5
--1 `clearBit` 3 = -9
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
--3 `complementBit` 0 = -4
--3 `complementBit` 1 = -1
--3 `complementBit` 2 = -7
--3 `complementBit` 3 = -11
-
--2 `complementBit` 0 = -1
--2 `complementBit` 1 = -4
--2 `complementBit` 2 = -6
--2 `complementBit` 3 = -10
-
--1 `complementBit` 0 = -2
--1 `complementBit` 1 = -3
--1 `complementBit` 2 = -5
--1 `complementBit` 3 = -9
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
--3 `testBit` 0 = True
--3 `testBit` 1 = False
--3 `testBit` 2 = True
--3 `testBit` 3 = True
-
--2 `testBit` 0 = False
--2 `testBit` 1 = True
--2 `testBit` 2 = True
--2 `testBit` 3 = True
-
--1 `testBit` 0 = True
--1 `testBit` 1 = True
--1 `testBit` 2 = True
--1 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize -3 = 32
-bitSize -2 = 32
-bitSize -1 = 32
-bitSize 0 = 32
-bitSize 1 = 32
-bitSize 2 = 32
-bitSize 3 = 32
-#
-isSigned -3 = True
-isSigned -2 = True
-isSigned -1 = True
-isSigned 0 = True
-isSigned 1 = True
-isSigned 2 = True
-isSigned 3 = True
-#
---------------------------------
---------------------------------
---Testing Word8
---------------------------------
-testBounded
-(255,0,1)
-(254,255,0)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[253,254,255,0,1,2,3]
-[253,254,255,0,1,2,3]
-testEq
-253 == 253 = True
-253 == 254 = False
-253 == 255 = False
-253 == 0 = False
-253 == 1 = False
-253 == 2 = False
-253 == 3 = False
-
-254 == 253 = False
-254 == 254 = True
-254 == 255 = False
-254 == 0 = False
-254 == 1 = False
-254 == 2 = False
-254 == 3 = False
-
-255 == 253 = False
-255 == 254 = False
-255 == 255 = True
-255 == 0 = False
-255 == 1 = False
-255 == 2 = False
-255 == 3 = False
-
-0 == 253 = False
-0 == 254 = False
-0 == 255 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == 253 = False
-1 == 254 = False
-1 == 255 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == 253 = False
-2 == 254 = False
-2 == 255 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == 253 = False
-3 == 254 = False
-3 == 255 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
-253 /= 253 = False
-253 /= 254 = True
-253 /= 255 = True
-253 /= 0 = True
-253 /= 1 = True
-253 /= 2 = True
-253 /= 3 = True
-
-254 /= 253 = True
-254 /= 254 = False
-254 /= 255 = True
-254 /= 0 = True
-254 /= 1 = True
-254 /= 2 = True
-254 /= 3 = True
-
-255 /= 253 = True
-255 /= 254 = True
-255 /= 255 = False
-255 /= 0 = True
-255 /= 1 = True
-255 /= 2 = True
-255 /= 3 = True
-
-0 /= 253 = True
-0 /= 254 = True
-0 /= 255 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= 253 = True
-1 /= 254 = True
-1 /= 255 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= 253 = True
-2 /= 254 = True
-2 /= 255 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= 253 = True
-3 /= 254 = True
-3 /= 255 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
-253 <= 253 = True
-253 <= 254 = True
-253 <= 255 = True
-253 <= 0 = False
-253 <= 1 = False
-253 <= 2 = False
-253 <= 3 = False
-
-254 <= 253 = False
-254 <= 254 = True
-254 <= 255 = True
-254 <= 0 = False
-254 <= 1 = False
-254 <= 2 = False
-254 <= 3 = False
-
-255 <= 253 = False
-255 <= 254 = False
-255 <= 255 = True
-255 <= 0 = False
-255 <= 1 = False
-255 <= 2 = False
-255 <= 3 = False
-
-0 <= 253 = True
-0 <= 254 = True
-0 <= 255 = True
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= 253 = True
-1 <= 254 = True
-1 <= 255 = True
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= 253 = True
-2 <= 254 = True
-2 <= 255 = True
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= 253 = True
-3 <= 254 = True
-3 <= 255 = True
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
-253 < 253 = False
-253 < 254 = True
-253 < 255 = True
-253 < 0 = False
-253 < 1 = False
-253 < 2 = False
-253 < 3 = False
-
-254 < 253 = False
-254 < 254 = False
-254 < 255 = True
-254 < 0 = False
-254 < 1 = False
-254 < 2 = False
-254 < 3 = False
-
-255 < 253 = False
-255 < 254 = False
-255 < 255 = False
-255 < 0 = False
-255 < 1 = False
-255 < 2 = False
-255 < 3 = False
-
-0 < 253 = True
-0 < 254 = True
-0 < 255 = True
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < 253 = True
-1 < 254 = True
-1 < 255 = True
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < 253 = True
-2 < 254 = True
-2 < 255 = True
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < 253 = True
-3 < 254 = True
-3 < 255 = True
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
-253 > 253 = False
-253 > 254 = False
-253 > 255 = False
-253 > 0 = True
-253 > 1 = True
-253 > 2 = True
-253 > 3 = True
-
-254 > 253 = True
-254 > 254 = False
-254 > 255 = False
-254 > 0 = True
-254 > 1 = True
-254 > 2 = True
-254 > 3 = True
-
-255 > 253 = True
-255 > 254 = True
-255 > 255 = False
-255 > 0 = True
-255 > 1 = True
-255 > 2 = True
-255 > 3 = True
-
-0 > 253 = False
-0 > 254 = False
-0 > 255 = False
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > 253 = False
-1 > 254 = False
-1 > 255 = False
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > 253 = False
-2 > 254 = False
-2 > 255 = False
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > 253 = False
-3 > 254 = False
-3 > 255 = False
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
-253 >= 253 = True
-253 >= 254 = False
-253 >= 255 = False
-253 >= 0 = True
-253 >= 1 = True
-253 >= 2 = True
-253 >= 3 = True
-
-254 >= 253 = True
-254 >= 254 = True
-254 >= 255 = False
-254 >= 0 = True
-254 >= 1 = True
-254 >= 2 = True
-254 >= 3 = True
-
-255 >= 253 = True
-255 >= 254 = True
-255 >= 255 = True
-255 >= 0 = True
-255 >= 1 = True
-255 >= 2 = True
-255 >= 3 = True
-
-0 >= 253 = False
-0 >= 254 = False
-0 >= 255 = False
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= 253 = False
-1 >= 254 = False
-1 >= 255 = False
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= 253 = False
-2 >= 254 = False
-2 >= 255 = False
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= 253 = False
-3 >= 254 = False
-3 >= 255 = False
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
-253 `compare` 253 = EQ
-253 `compare` 254 = LT
-253 `compare` 255 = LT
-253 `compare` 0 = GT
-253 `compare` 1 = GT
-253 `compare` 2 = GT
-253 `compare` 3 = GT
-
-254 `compare` 253 = GT
-254 `compare` 254 = EQ
-254 `compare` 255 = LT
-254 `compare` 0 = GT
-254 `compare` 1 = GT
-254 `compare` 2 = GT
-254 `compare` 3 = GT
-
-255 `compare` 253 = GT
-255 `compare` 254 = GT
-255 `compare` 255 = EQ
-255 `compare` 0 = GT
-255 `compare` 1 = GT
-255 `compare` 2 = GT
-255 `compare` 3 = GT
-
-0 `compare` 253 = LT
-0 `compare` 254 = LT
-0 `compare` 255 = LT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` 253 = LT
-1 `compare` 254 = LT
-1 `compare` 255 = LT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` 253 = LT
-2 `compare` 254 = LT
-2 `compare` 255 = LT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` 253 = LT
-3 `compare` 254 = LT
-3 `compare` 255 = LT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
-253 + 253 = 250
-253 + 254 = 251
-253 + 255 = 252
-253 + 0 = 253
-253 + 1 = 254
-253 + 2 = 255
-253 + 3 = 0
-
-254 + 253 = 251
-254 + 254 = 252
-254 + 255 = 253
-254 + 0 = 254
-254 + 1 = 255
-254 + 2 = 0
-254 + 3 = 1
-
-255 + 253 = 252
-255 + 254 = 253
-255 + 255 = 254
-255 + 0 = 255
-255 + 1 = 0
-255 + 2 = 1
-255 + 3 = 2
-
-0 + 253 = 253
-0 + 254 = 254
-0 + 255 = 255
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + 253 = 254
-1 + 254 = 255
-1 + 255 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + 253 = 255
-2 + 254 = 0
-2 + 255 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + 253 = 0
-3 + 254 = 1
-3 + 255 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
-253 - 253 = 0
-253 - 254 = 255
-253 - 255 = 254
-253 - 0 = 253
-253 - 1 = 252
-253 - 2 = 251
-253 - 3 = 250
-
-254 - 253 = 1
-254 - 254 = 0
-254 - 255 = 255
-254 - 0 = 254
-254 - 1 = 253
-254 - 2 = 252
-254 - 3 = 251
-
-255 - 253 = 2
-255 - 254 = 1
-255 - 255 = 0
-255 - 0 = 255
-255 - 1 = 254
-255 - 2 = 253
-255 - 3 = 252
-
-0 - 253 = 3
-0 - 254 = 2
-0 - 255 = 1
-0 - 0 = 0
-0 - 1 = 255
-0 - 2 = 254
-0 - 3 = 253
-
-1 - 253 = 4
-1 - 254 = 3
-1 - 255 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = 255
-1 - 3 = 254
-
-2 - 253 = 5
-2 - 254 = 4
-2 - 255 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = 255
-
-3 - 253 = 6
-3 - 254 = 5
-3 - 255 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
-253 * 253 = 9
-253 * 254 = 6
-253 * 255 = 3
-253 * 0 = 0
-253 * 1 = 253
-253 * 2 = 250
-253 * 3 = 247
-
-254 * 253 = 6
-254 * 254 = 4
-254 * 255 = 2
-254 * 0 = 0
-254 * 1 = 254
-254 * 2 = 252
-254 * 3 = 250
-
-255 * 253 = 3
-255 * 254 = 2
-255 * 255 = 1
-255 * 0 = 0
-255 * 1 = 255
-255 * 2 = 254
-255 * 3 = 253
-
-0 * 253 = 0
-0 * 254 = 0
-0 * 255 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * 253 = 253
-1 * 254 = 254
-1 * 255 = 255
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * 253 = 250
-2 * 254 = 252
-2 * 255 = 254
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * 253 = 247
-3 * 254 = 250
-3 * 255 = 253
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate 253 = 3
-negate 254 = 2
-negate 255 = 1
-negate 0 = 0
-negate 1 = 255
-negate 2 = 254
-negate 3 = 253
-#
-testReal
-toRational 253 = 253 % 1
-toRational 254 = 254 % 1
-toRational 255 = 255 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
-253 `divMod` 253 = (1,0)
-253 `divMod` 254 = (0,253)
-253 `divMod` 255 = (0,253)
-253 `divMod` 1 = (253,0)
-253 `divMod` 2 = (126,1)
-253 `divMod` 3 = (84,1)
-
-254 `divMod` 253 = (1,1)
-254 `divMod` 254 = (1,0)
-254 `divMod` 255 = (0,254)
-254 `divMod` 1 = (254,0)
-254 `divMod` 2 = (127,0)
-254 `divMod` 3 = (84,2)
-
-255 `divMod` 253 = (1,2)
-255 `divMod` 254 = (1,1)
-255 `divMod` 255 = (1,0)
-255 `divMod` 1 = (255,0)
-255 `divMod` 2 = (127,1)
-255 `divMod` 3 = (85,0)
-
-0 `divMod` 253 = (0,0)
-0 `divMod` 254 = (0,0)
-0 `divMod` 255 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` 253 = (0,1)
-1 `divMod` 254 = (0,1)
-1 `divMod` 255 = (0,1)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` 253 = (0,2)
-2 `divMod` 254 = (0,2)
-2 `divMod` 255 = (0,2)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` 253 = (0,3)
-3 `divMod` 254 = (0,3)
-3 `divMod` 255 = (0,3)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
-253 `div` 253 = 1
-253 `div` 254 = 0
-253 `div` 255 = 0
-253 `div` 1 = 253
-253 `div` 2 = 126
-253 `div` 3 = 84
-
-254 `div` 253 = 1
-254 `div` 254 = 1
-254 `div` 255 = 0
-254 `div` 1 = 254
-254 `div` 2 = 127
-254 `div` 3 = 84
-
-255 `div` 253 = 1
-255 `div` 254 = 1
-255 `div` 255 = 1
-255 `div` 1 = 255
-255 `div` 2 = 127
-255 `div` 3 = 85
-
-0 `div` 253 = 0
-0 `div` 254 = 0
-0 `div` 255 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` 253 = 0
-1 `div` 254 = 0
-1 `div` 255 = 0
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` 253 = 0
-2 `div` 254 = 0
-2 `div` 255 = 0
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` 253 = 0
-3 `div` 254 = 0
-3 `div` 255 = 0
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
-253 `mod` 253 = 0
-253 `mod` 254 = 253
-253 `mod` 255 = 253
-253 `mod` 1 = 0
-253 `mod` 2 = 1
-253 `mod` 3 = 1
-
-254 `mod` 253 = 1
-254 `mod` 254 = 0
-254 `mod` 255 = 254
-254 `mod` 1 = 0
-254 `mod` 2 = 0
-254 `mod` 3 = 2
-
-255 `mod` 253 = 2
-255 `mod` 254 = 1
-255 `mod` 255 = 0
-255 `mod` 1 = 0
-255 `mod` 2 = 1
-255 `mod` 3 = 0
-
-0 `mod` 253 = 0
-0 `mod` 254 = 0
-0 `mod` 255 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` 253 = 1
-1 `mod` 254 = 1
-1 `mod` 255 = 1
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` 253 = 2
-2 `mod` 254 = 2
-2 `mod` 255 = 2
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` 253 = 3
-3 `mod` 254 = 3
-3 `mod` 255 = 3
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
-253 `quotRem` 253 = (1,0)
-253 `quotRem` 254 = (0,253)
-253 `quotRem` 255 = (0,253)
-253 `quotRem` 1 = (253,0)
-253 `quotRem` 2 = (126,1)
-253 `quotRem` 3 = (84,1)
-
-254 `quotRem` 253 = (1,1)
-254 `quotRem` 254 = (1,0)
-254 `quotRem` 255 = (0,254)
-254 `quotRem` 1 = (254,0)
-254 `quotRem` 2 = (127,0)
-254 `quotRem` 3 = (84,2)
-
-255 `quotRem` 253 = (1,2)
-255 `quotRem` 254 = (1,1)
-255 `quotRem` 255 = (1,0)
-255 `quotRem` 1 = (255,0)
-255 `quotRem` 2 = (127,1)
-255 `quotRem` 3 = (85,0)
-
-0 `quotRem` 253 = (0,0)
-0 `quotRem` 254 = (0,0)
-0 `quotRem` 255 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` 253 = (0,1)
-1 `quotRem` 254 = (0,1)
-1 `quotRem` 255 = (0,1)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` 253 = (0,2)
-2 `quotRem` 254 = (0,2)
-2 `quotRem` 255 = (0,2)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` 253 = (0,3)
-3 `quotRem` 254 = (0,3)
-3 `quotRem` 255 = (0,3)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
-253 `quot` 253 = 1
-253 `quot` 254 = 0
-253 `quot` 255 = 0
-253 `quot` 1 = 253
-253 `quot` 2 = 126
-253 `quot` 3 = 84
-
-254 `quot` 253 = 1
-254 `quot` 254 = 1
-254 `quot` 255 = 0
-254 `quot` 1 = 254
-254 `quot` 2 = 127
-254 `quot` 3 = 84
-
-255 `quot` 253 = 1
-255 `quot` 254 = 1
-255 `quot` 255 = 1
-255 `quot` 1 = 255
-255 `quot` 2 = 127
-255 `quot` 3 = 85
-
-0 `quot` 253 = 0
-0 `quot` 254 = 0
-0 `quot` 255 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` 253 = 0
-1 `quot` 254 = 0
-1 `quot` 255 = 0
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` 253 = 0
-2 `quot` 254 = 0
-2 `quot` 255 = 0
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` 253 = 0
-3 `quot` 254 = 0
-3 `quot` 255 = 0
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
-253 `rem` 253 = 0
-253 `rem` 254 = 253
-253 `rem` 255 = 253
-253 `rem` 1 = 0
-253 `rem` 2 = 1
-253 `rem` 3 = 1
-
-254 `rem` 253 = 1
-254 `rem` 254 = 0
-254 `rem` 255 = 254
-254 `rem` 1 = 0
-254 `rem` 2 = 0
-254 `rem` 3 = 2
-
-255 `rem` 253 = 2
-255 `rem` 254 = 1
-255 `rem` 255 = 0
-255 `rem` 1 = 0
-255 `rem` 2 = 1
-255 `rem` 3 = 0
-
-0 `rem` 253 = 0
-0 `rem` 254 = 0
-0 `rem` 255 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` 253 = 1
-1 `rem` 254 = 1
-1 `rem` 255 = 1
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` 253 = 2
-2 `rem` 254 = 2
-2 `rem` 255 = 2
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` 253 = 3
-3 `rem` 254 = 3
-3 `rem` 255 = 3
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
-253 .&. 253 = 253
-253 .&. 254 = 252
-253 .&. 255 = 253
-253 .&. 1 = 1
-253 .&. 2 = 0
-253 .&. 3 = 1
-
-254 .&. 253 = 252
-254 .&. 254 = 254
-254 .&. 255 = 254
-254 .&. 1 = 0
-254 .&. 2 = 2
-254 .&. 3 = 2
-
-255 .&. 253 = 253
-255 .&. 254 = 254
-255 .&. 255 = 255
-255 .&. 1 = 1
-255 .&. 2 = 2
-255 .&. 3 = 3
-
-0 .&. 253 = 0
-0 .&. 254 = 0
-0 .&. 255 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. 253 = 1
-1 .&. 254 = 0
-1 .&. 255 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. 253 = 0
-2 .&. 254 = 2
-2 .&. 255 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. 253 = 1
-3 .&. 254 = 2
-3 .&. 255 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
-253 .|. 253 = 253
-253 .|. 254 = 255
-253 .|. 255 = 255
-253 .|. 1 = 253
-253 .|. 2 = 255
-253 .|. 3 = 255
-
-254 .|. 253 = 255
-254 .|. 254 = 254
-254 .|. 255 = 255
-254 .|. 1 = 255
-254 .|. 2 = 254
-254 .|. 3 = 255
-
-255 .|. 253 = 255
-255 .|. 254 = 255
-255 .|. 255 = 255
-255 .|. 1 = 255
-255 .|. 2 = 255
-255 .|. 3 = 255
-
-0 .|. 253 = 253
-0 .|. 254 = 254
-0 .|. 255 = 255
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. 253 = 253
-1 .|. 254 = 255
-1 .|. 255 = 255
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. 253 = 255
-2 .|. 254 = 254
-2 .|. 255 = 255
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. 253 = 255
-3 .|. 254 = 255
-3 .|. 255 = 255
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
-253 `xor` 253 = 0
-253 `xor` 254 = 3
-253 `xor` 255 = 2
-253 `xor` 1 = 252
-253 `xor` 2 = 255
-253 `xor` 3 = 254
-
-254 `xor` 253 = 3
-254 `xor` 254 = 0
-254 `xor` 255 = 1
-254 `xor` 1 = 255
-254 `xor` 2 = 252
-254 `xor` 3 = 253
-
-255 `xor` 253 = 2
-255 `xor` 254 = 1
-255 `xor` 255 = 0
-255 `xor` 1 = 254
-255 `xor` 2 = 253
-255 `xor` 3 = 252
-
-0 `xor` 253 = 253
-0 `xor` 254 = 254
-0 `xor` 255 = 255
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` 253 = 252
-1 `xor` 254 = 255
-1 `xor` 255 = 254
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` 253 = 255
-2 `xor` 254 = 252
-2 `xor` 255 = 253
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` 253 = 254
-3 `xor` 254 = 253
-3 `xor` 255 = 252
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement 253 = 2
-complement 254 = 1
-complement 255 = 0
-complement 0 = 255
-complement 1 = 254
-complement 2 = 253
-complement 3 = 252
-#
-253 `shift` 0 = 253
-253 `shift` 1 = 250
-253 `shift` 2 = 244
-253 `shift` 3 = 232
-
-254 `shift` 0 = 254
-254 `shift` 1 = 252
-254 `shift` 2 = 248
-254 `shift` 3 = 240
-
-255 `shift` 0 = 255
-255 `shift` 1 = 254
-255 `shift` 2 = 252
-255 `shift` 3 = 248
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
-253 `setBit` 0 = 253
-253 `setBit` 1 = 255
-253 `setBit` 2 = 253
-253 `setBit` 3 = 253
-
-254 `setBit` 0 = 255
-254 `setBit` 1 = 254
-254 `setBit` 2 = 254
-254 `setBit` 3 = 254
-
-255 `setBit` 0 = 255
-255 `setBit` 1 = 255
-255 `setBit` 2 = 255
-255 `setBit` 3 = 255
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
-253 `clearBit` 0 = 252
-253 `clearBit` 1 = 253
-253 `clearBit` 2 = 249
-253 `clearBit` 3 = 245
-
-254 `clearBit` 0 = 254
-254 `clearBit` 1 = 252
-254 `clearBit` 2 = 250
-254 `clearBit` 3 = 246
-
-255 `clearBit` 0 = 254
-255 `clearBit` 1 = 253
-255 `clearBit` 2 = 251
-255 `clearBit` 3 = 247
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
-253 `complementBit` 0 = 252
-253 `complementBit` 1 = 255
-253 `complementBit` 2 = 249
-253 `complementBit` 3 = 245
-
-254 `complementBit` 0 = 255
-254 `complementBit` 1 = 252
-254 `complementBit` 2 = 250
-254 `complementBit` 3 = 246
-
-255 `complementBit` 0 = 254
-255 `complementBit` 1 = 253
-255 `complementBit` 2 = 251
-255 `complementBit` 3 = 247
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
-253 `testBit` 0 = True
-253 `testBit` 1 = False
-253 `testBit` 2 = True
-253 `testBit` 3 = True
-
-254 `testBit` 0 = False
-254 `testBit` 1 = True
-254 `testBit` 2 = True
-254 `testBit` 3 = True
-
-255 `testBit` 0 = True
-255 `testBit` 1 = True
-255 `testBit` 2 = True
-255 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize 253 = 8
-bitSize 254 = 8
-bitSize 255 = 8
-bitSize 0 = 8
-bitSize 1 = 8
-bitSize 2 = 8
-bitSize 3 = 8
-#
-isSigned 253 = False
-isSigned 254 = False
-isSigned 255 = False
-isSigned 0 = False
-isSigned 1 = False
-isSigned 2 = False
-isSigned 3 = False
-#
---------------------------------
---------------------------------
---Testing Word16
---------------------------------
-testBounded
-(65535,0,1)
-(65534,65535,0)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[65533,65534,65535,0,1,2,3]
-[65533,65534,65535,0,1,2,3]
-testEq
-65533 == 65533 = True
-65533 == 65534 = False
-65533 == 65535 = False
-65533 == 0 = False
-65533 == 1 = False
-65533 == 2 = False
-65533 == 3 = False
-
-65534 == 65533 = False
-65534 == 65534 = True
-65534 == 65535 = False
-65534 == 0 = False
-65534 == 1 = False
-65534 == 2 = False
-65534 == 3 = False
-
-65535 == 65533 = False
-65535 == 65534 = False
-65535 == 65535 = True
-65535 == 0 = False
-65535 == 1 = False
-65535 == 2 = False
-65535 == 3 = False
-
-0 == 65533 = False
-0 == 65534 = False
-0 == 65535 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == 65533 = False
-1 == 65534 = False
-1 == 65535 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == 65533 = False
-2 == 65534 = False
-2 == 65535 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == 65533 = False
-3 == 65534 = False
-3 == 65535 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
-65533 /= 65533 = False
-65533 /= 65534 = True
-65533 /= 65535 = True
-65533 /= 0 = True
-65533 /= 1 = True
-65533 /= 2 = True
-65533 /= 3 = True
-
-65534 /= 65533 = True
-65534 /= 65534 = False
-65534 /= 65535 = True
-65534 /= 0 = True
-65534 /= 1 = True
-65534 /= 2 = True
-65534 /= 3 = True
-
-65535 /= 65533 = True
-65535 /= 65534 = True
-65535 /= 65535 = False
-65535 /= 0 = True
-65535 /= 1 = True
-65535 /= 2 = True
-65535 /= 3 = True
-
-0 /= 65533 = True
-0 /= 65534 = True
-0 /= 65535 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= 65533 = True
-1 /= 65534 = True
-1 /= 65535 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= 65533 = True
-2 /= 65534 = True
-2 /= 65535 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= 65533 = True
-3 /= 65534 = True
-3 /= 65535 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
-65533 <= 65533 = True
-65533 <= 65534 = True
-65533 <= 65535 = True
-65533 <= 0 = False
-65533 <= 1 = False
-65533 <= 2 = False
-65533 <= 3 = False
-
-65534 <= 65533 = False
-65534 <= 65534 = True
-65534 <= 65535 = True
-65534 <= 0 = False
-65534 <= 1 = False
-65534 <= 2 = False
-65534 <= 3 = False
-
-65535 <= 65533 = False
-65535 <= 65534 = False
-65535 <= 65535 = True
-65535 <= 0 = False
-65535 <= 1 = False
-65535 <= 2 = False
-65535 <= 3 = False
-
-0 <= 65533 = True
-0 <= 65534 = True
-0 <= 65535 = True
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= 65533 = True
-1 <= 65534 = True
-1 <= 65535 = True
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= 65533 = True
-2 <= 65534 = True
-2 <= 65535 = True
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= 65533 = True
-3 <= 65534 = True
-3 <= 65535 = True
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
-65533 < 65533 = False
-65533 < 65534 = True
-65533 < 65535 = True
-65533 < 0 = False
-65533 < 1 = False
-65533 < 2 = False
-65533 < 3 = False
-
-65534 < 65533 = False
-65534 < 65534 = False
-65534 < 65535 = True
-65534 < 0 = False
-65534 < 1 = False
-65534 < 2 = False
-65534 < 3 = False
-
-65535 < 65533 = False
-65535 < 65534 = False
-65535 < 65535 = False
-65535 < 0 = False
-65535 < 1 = False
-65535 < 2 = False
-65535 < 3 = False
-
-0 < 65533 = True
-0 < 65534 = True
-0 < 65535 = True
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < 65533 = True
-1 < 65534 = True
-1 < 65535 = True
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < 65533 = True
-2 < 65534 = True
-2 < 65535 = True
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < 65533 = True
-3 < 65534 = True
-3 < 65535 = True
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
-65533 > 65533 = False
-65533 > 65534 = False
-65533 > 65535 = False
-65533 > 0 = True
-65533 > 1 = True
-65533 > 2 = True
-65533 > 3 = True
-
-65534 > 65533 = True
-65534 > 65534 = False
-65534 > 65535 = False
-65534 > 0 = True
-65534 > 1 = True
-65534 > 2 = True
-65534 > 3 = True
-
-65535 > 65533 = True
-65535 > 65534 = True
-65535 > 65535 = False
-65535 > 0 = True
-65535 > 1 = True
-65535 > 2 = True
-65535 > 3 = True
-
-0 > 65533 = False
-0 > 65534 = False
-0 > 65535 = False
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > 65533 = False
-1 > 65534 = False
-1 > 65535 = False
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > 65533 = False
-2 > 65534 = False
-2 > 65535 = False
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > 65533 = False
-3 > 65534 = False
-3 > 65535 = False
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
-65533 >= 65533 = True
-65533 >= 65534 = False
-65533 >= 65535 = False
-65533 >= 0 = True
-65533 >= 1 = True
-65533 >= 2 = True
-65533 >= 3 = True
-
-65534 >= 65533 = True
-65534 >= 65534 = True
-65534 >= 65535 = False
-65534 >= 0 = True
-65534 >= 1 = True
-65534 >= 2 = True
-65534 >= 3 = True
-
-65535 >= 65533 = True
-65535 >= 65534 = True
-65535 >= 65535 = True
-65535 >= 0 = True
-65535 >= 1 = True
-65535 >= 2 = True
-65535 >= 3 = True
-
-0 >= 65533 = False
-0 >= 65534 = False
-0 >= 65535 = False
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= 65533 = False
-1 >= 65534 = False
-1 >= 65535 = False
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= 65533 = False
-2 >= 65534 = False
-2 >= 65535 = False
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= 65533 = False
-3 >= 65534 = False
-3 >= 65535 = False
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
-65533 `compare` 65533 = EQ
-65533 `compare` 65534 = LT
-65533 `compare` 65535 = LT
-65533 `compare` 0 = GT
-65533 `compare` 1 = GT
-65533 `compare` 2 = GT
-65533 `compare` 3 = GT
-
-65534 `compare` 65533 = GT
-65534 `compare` 65534 = EQ
-65534 `compare` 65535 = LT
-65534 `compare` 0 = GT
-65534 `compare` 1 = GT
-65534 `compare` 2 = GT
-65534 `compare` 3 = GT
-
-65535 `compare` 65533 = GT
-65535 `compare` 65534 = GT
-65535 `compare` 65535 = EQ
-65535 `compare` 0 = GT
-65535 `compare` 1 = GT
-65535 `compare` 2 = GT
-65535 `compare` 3 = GT
-
-0 `compare` 65533 = LT
-0 `compare` 65534 = LT
-0 `compare` 65535 = LT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` 65533 = LT
-1 `compare` 65534 = LT
-1 `compare` 65535 = LT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` 65533 = LT
-2 `compare` 65534 = LT
-2 `compare` 65535 = LT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` 65533 = LT
-3 `compare` 65534 = LT
-3 `compare` 65535 = LT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
-65533 + 65533 = 65530
-65533 + 65534 = 65531
-65533 + 65535 = 65532
-65533 + 0 = 65533
-65533 + 1 = 65534
-65533 + 2 = 65535
-65533 + 3 = 0
-
-65534 + 65533 = 65531
-65534 + 65534 = 65532
-65534 + 65535 = 65533
-65534 + 0 = 65534
-65534 + 1 = 65535
-65534 + 2 = 0
-65534 + 3 = 1
-
-65535 + 65533 = 65532
-65535 + 65534 = 65533
-65535 + 65535 = 65534
-65535 + 0 = 65535
-65535 + 1 = 0
-65535 + 2 = 1
-65535 + 3 = 2
-
-0 + 65533 = 65533
-0 + 65534 = 65534
-0 + 65535 = 65535
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + 65533 = 65534
-1 + 65534 = 65535
-1 + 65535 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + 65533 = 65535
-2 + 65534 = 0
-2 + 65535 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + 65533 = 0
-3 + 65534 = 1
-3 + 65535 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
-65533 - 65533 = 0
-65533 - 65534 = 65535
-65533 - 65535 = 65534
-65533 - 0 = 65533
-65533 - 1 = 65532
-65533 - 2 = 65531
-65533 - 3 = 65530
-
-65534 - 65533 = 1
-65534 - 65534 = 0
-65534 - 65535 = 65535
-65534 - 0 = 65534
-65534 - 1 = 65533
-65534 - 2 = 65532
-65534 - 3 = 65531
-
-65535 - 65533 = 2
-65535 - 65534 = 1
-65535 - 65535 = 0
-65535 - 0 = 65535
-65535 - 1 = 65534
-65535 - 2 = 65533
-65535 - 3 = 65532
-
-0 - 65533 = 3
-0 - 65534 = 2
-0 - 65535 = 1
-0 - 0 = 0
-0 - 1 = 65535
-0 - 2 = 65534
-0 - 3 = 65533
-
-1 - 65533 = 4
-1 - 65534 = 3
-1 - 65535 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = 65535
-1 - 3 = 65534
-
-2 - 65533 = 5
-2 - 65534 = 4
-2 - 65535 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = 65535
-
-3 - 65533 = 6
-3 - 65534 = 5
-3 - 65535 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
-65533 * 65533 = 9
-65533 * 65534 = 6
-65533 * 65535 = 3
-65533 * 0 = 0
-65533 * 1 = 65533
-65533 * 2 = 65530
-65533 * 3 = 65527
-
-65534 * 65533 = 6
-65534 * 65534 = 4
-65534 * 65535 = 2
-65534 * 0 = 0
-65534 * 1 = 65534
-65534 * 2 = 65532
-65534 * 3 = 65530
-
-65535 * 65533 = 3
-65535 * 65534 = 2
-65535 * 65535 = 1
-65535 * 0 = 0
-65535 * 1 = 65535
-65535 * 2 = 65534
-65535 * 3 = 65533
-
-0 * 65533 = 0
-0 * 65534 = 0
-0 * 65535 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * 65533 = 65533
-1 * 65534 = 65534
-1 * 65535 = 65535
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * 65533 = 65530
-2 * 65534 = 65532
-2 * 65535 = 65534
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * 65533 = 65527
-3 * 65534 = 65530
-3 * 65535 = 65533
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate 65533 = 3
-negate 65534 = 2
-negate 65535 = 1
-negate 0 = 0
-negate 1 = 65535
-negate 2 = 65534
-negate 3 = 65533
-#
-testReal
-toRational 65533 = 65533 % 1
-toRational 65534 = 65534 % 1
-toRational 65535 = 65535 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
-65533 `divMod` 65533 = (1,0)
-65533 `divMod` 65534 = (0,65533)
-65533 `divMod` 65535 = (0,65533)
-65533 `divMod` 1 = (65533,0)
-65533 `divMod` 2 = (32766,1)
-65533 `divMod` 3 = (21844,1)
-
-65534 `divMod` 65533 = (1,1)
-65534 `divMod` 65534 = (1,0)
-65534 `divMod` 65535 = (0,65534)
-65534 `divMod` 1 = (65534,0)
-65534 `divMod` 2 = (32767,0)
-65534 `divMod` 3 = (21844,2)
-
-65535 `divMod` 65533 = (1,2)
-65535 `divMod` 65534 = (1,1)
-65535 `divMod` 65535 = (1,0)
-65535 `divMod` 1 = (65535,0)
-65535 `divMod` 2 = (32767,1)
-65535 `divMod` 3 = (21845,0)
-
-0 `divMod` 65533 = (0,0)
-0 `divMod` 65534 = (0,0)
-0 `divMod` 65535 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` 65533 = (0,1)
-1 `divMod` 65534 = (0,1)
-1 `divMod` 65535 = (0,1)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` 65533 = (0,2)
-2 `divMod` 65534 = (0,2)
-2 `divMod` 65535 = (0,2)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` 65533 = (0,3)
-3 `divMod` 65534 = (0,3)
-3 `divMod` 65535 = (0,3)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
-65533 `div` 65533 = 1
-65533 `div` 65534 = 0
-65533 `div` 65535 = 0
-65533 `div` 1 = 65533
-65533 `div` 2 = 32766
-65533 `div` 3 = 21844
-
-65534 `div` 65533 = 1
-65534 `div` 65534 = 1
-65534 `div` 65535 = 0
-65534 `div` 1 = 65534
-65534 `div` 2 = 32767
-65534 `div` 3 = 21844
-
-65535 `div` 65533 = 1
-65535 `div` 65534 = 1
-65535 `div` 65535 = 1
-65535 `div` 1 = 65535
-65535 `div` 2 = 32767
-65535 `div` 3 = 21845
-
-0 `div` 65533 = 0
-0 `div` 65534 = 0
-0 `div` 65535 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` 65533 = 0
-1 `div` 65534 = 0
-1 `div` 65535 = 0
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` 65533 = 0
-2 `div` 65534 = 0
-2 `div` 65535 = 0
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` 65533 = 0
-3 `div` 65534 = 0
-3 `div` 65535 = 0
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
-65533 `mod` 65533 = 0
-65533 `mod` 65534 = 65533
-65533 `mod` 65535 = 65533
-65533 `mod` 1 = 0
-65533 `mod` 2 = 1
-65533 `mod` 3 = 1
-
-65534 `mod` 65533 = 1
-65534 `mod` 65534 = 0
-65534 `mod` 65535 = 65534
-65534 `mod` 1 = 0
-65534 `mod` 2 = 0
-65534 `mod` 3 = 2
-
-65535 `mod` 65533 = 2
-65535 `mod` 65534 = 1
-65535 `mod` 65535 = 0
-65535 `mod` 1 = 0
-65535 `mod` 2 = 1
-65535 `mod` 3 = 0
-
-0 `mod` 65533 = 0
-0 `mod` 65534 = 0
-0 `mod` 65535 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` 65533 = 1
-1 `mod` 65534 = 1
-1 `mod` 65535 = 1
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` 65533 = 2
-2 `mod` 65534 = 2
-2 `mod` 65535 = 2
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` 65533 = 3
-3 `mod` 65534 = 3
-3 `mod` 65535 = 3
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
-65533 `quotRem` 65533 = (1,0)
-65533 `quotRem` 65534 = (0,65533)
-65533 `quotRem` 65535 = (0,65533)
-65533 `quotRem` 1 = (65533,0)
-65533 `quotRem` 2 = (32766,1)
-65533 `quotRem` 3 = (21844,1)
-
-65534 `quotRem` 65533 = (1,1)
-65534 `quotRem` 65534 = (1,0)
-65534 `quotRem` 65535 = (0,65534)
-65534 `quotRem` 1 = (65534,0)
-65534 `quotRem` 2 = (32767,0)
-65534 `quotRem` 3 = (21844,2)
-
-65535 `quotRem` 65533 = (1,2)
-65535 `quotRem` 65534 = (1,1)
-65535 `quotRem` 65535 = (1,0)
-65535 `quotRem` 1 = (65535,0)
-65535 `quotRem` 2 = (32767,1)
-65535 `quotRem` 3 = (21845,0)
-
-0 `quotRem` 65533 = (0,0)
-0 `quotRem` 65534 = (0,0)
-0 `quotRem` 65535 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` 65533 = (0,1)
-1 `quotRem` 65534 = (0,1)
-1 `quotRem` 65535 = (0,1)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` 65533 = (0,2)
-2 `quotRem` 65534 = (0,2)
-2 `quotRem` 65535 = (0,2)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` 65533 = (0,3)
-3 `quotRem` 65534 = (0,3)
-3 `quotRem` 65535 = (0,3)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
-65533 `quot` 65533 = 1
-65533 `quot` 65534 = 0
-65533 `quot` 65535 = 0
-65533 `quot` 1 = 65533
-65533 `quot` 2 = 32766
-65533 `quot` 3 = 21844
-
-65534 `quot` 65533 = 1
-65534 `quot` 65534 = 1
-65534 `quot` 65535 = 0
-65534 `quot` 1 = 65534
-65534 `quot` 2 = 32767
-65534 `quot` 3 = 21844
-
-65535 `quot` 65533 = 1
-65535 `quot` 65534 = 1
-65535 `quot` 65535 = 1
-65535 `quot` 1 = 65535
-65535 `quot` 2 = 32767
-65535 `quot` 3 = 21845
-
-0 `quot` 65533 = 0
-0 `quot` 65534 = 0
-0 `quot` 65535 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` 65533 = 0
-1 `quot` 65534 = 0
-1 `quot` 65535 = 0
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` 65533 = 0
-2 `quot` 65534 = 0
-2 `quot` 65535 = 0
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` 65533 = 0
-3 `quot` 65534 = 0
-3 `quot` 65535 = 0
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
-65533 `rem` 65533 = 0
-65533 `rem` 65534 = 65533
-65533 `rem` 65535 = 65533
-65533 `rem` 1 = 0
-65533 `rem` 2 = 1
-65533 `rem` 3 = 1
-
-65534 `rem` 65533 = 1
-65534 `rem` 65534 = 0
-65534 `rem` 65535 = 65534
-65534 `rem` 1 = 0
-65534 `rem` 2 = 0
-65534 `rem` 3 = 2
-
-65535 `rem` 65533 = 2
-65535 `rem` 65534 = 1
-65535 `rem` 65535 = 0
-65535 `rem` 1 = 0
-65535 `rem` 2 = 1
-65535 `rem` 3 = 0
-
-0 `rem` 65533 = 0
-0 `rem` 65534 = 0
-0 `rem` 65535 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` 65533 = 1
-1 `rem` 65534 = 1
-1 `rem` 65535 = 1
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` 65533 = 2
-2 `rem` 65534 = 2
-2 `rem` 65535 = 2
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` 65533 = 3
-3 `rem` 65534 = 3
-3 `rem` 65535 = 3
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
-65533 .&. 65533 = 65533
-65533 .&. 65534 = 65532
-65533 .&. 65535 = 65533
-65533 .&. 1 = 1
-65533 .&. 2 = 0
-65533 .&. 3 = 1
-
-65534 .&. 65533 = 65532
-65534 .&. 65534 = 65534
-65534 .&. 65535 = 65534
-65534 .&. 1 = 0
-65534 .&. 2 = 2
-65534 .&. 3 = 2
-
-65535 .&. 65533 = 65533
-65535 .&. 65534 = 65534
-65535 .&. 65535 = 65535
-65535 .&. 1 = 1
-65535 .&. 2 = 2
-65535 .&. 3 = 3
-
-0 .&. 65533 = 0
-0 .&. 65534 = 0
-0 .&. 65535 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. 65533 = 1
-1 .&. 65534 = 0
-1 .&. 65535 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. 65533 = 0
-2 .&. 65534 = 2
-2 .&. 65535 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. 65533 = 1
-3 .&. 65534 = 2
-3 .&. 65535 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
-65533 .|. 65533 = 65533
-65533 .|. 65534 = 65535
-65533 .|. 65535 = 65535
-65533 .|. 1 = 65533
-65533 .|. 2 = 65535
-65533 .|. 3 = 65535
-
-65534 .|. 65533 = 65535
-65534 .|. 65534 = 65534
-65534 .|. 65535 = 65535
-65534 .|. 1 = 65535
-65534 .|. 2 = 65534
-65534 .|. 3 = 65535
-
-65535 .|. 65533 = 65535
-65535 .|. 65534 = 65535
-65535 .|. 65535 = 65535
-65535 .|. 1 = 65535
-65535 .|. 2 = 65535
-65535 .|. 3 = 65535
-
-0 .|. 65533 = 65533
-0 .|. 65534 = 65534
-0 .|. 65535 = 65535
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. 65533 = 65533
-1 .|. 65534 = 65535
-1 .|. 65535 = 65535
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. 65533 = 65535
-2 .|. 65534 = 65534
-2 .|. 65535 = 65535
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. 65533 = 65535
-3 .|. 65534 = 65535
-3 .|. 65535 = 65535
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
-65533 `xor` 65533 = 0
-65533 `xor` 65534 = 3
-65533 `xor` 65535 = 2
-65533 `xor` 1 = 65532
-65533 `xor` 2 = 65535
-65533 `xor` 3 = 65534
-
-65534 `xor` 65533 = 3
-65534 `xor` 65534 = 0
-65534 `xor` 65535 = 1
-65534 `xor` 1 = 65535
-65534 `xor` 2 = 65532
-65534 `xor` 3 = 65533
-
-65535 `xor` 65533 = 2
-65535 `xor` 65534 = 1
-65535 `xor` 65535 = 0
-65535 `xor` 1 = 65534
-65535 `xor` 2 = 65533
-65535 `xor` 3 = 65532
-
-0 `xor` 65533 = 65533
-0 `xor` 65534 = 65534
-0 `xor` 65535 = 65535
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` 65533 = 65532
-1 `xor` 65534 = 65535
-1 `xor` 65535 = 65534
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` 65533 = 65535
-2 `xor` 65534 = 65532
-2 `xor` 65535 = 65533
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` 65533 = 65534
-3 `xor` 65534 = 65533
-3 `xor` 65535 = 65532
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement 65533 = 2
-complement 65534 = 1
-complement 65535 = 0
-complement 0 = 65535
-complement 1 = 65534
-complement 2 = 65533
-complement 3 = 65532
-#
-65533 `shift` 0 = 65533
-65533 `shift` 1 = 65530
-65533 `shift` 2 = 65524
-65533 `shift` 3 = 65512
-
-65534 `shift` 0 = 65534
-65534 `shift` 1 = 65532
-65534 `shift` 2 = 65528
-65534 `shift` 3 = 65520
-
-65535 `shift` 0 = 65535
-65535 `shift` 1 = 65534
-65535 `shift` 2 = 65532
-65535 `shift` 3 = 65528
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
-65533 `setBit` 0 = 65533
-65533 `setBit` 1 = 65535
-65533 `setBit` 2 = 65533
-65533 `setBit` 3 = 65533
-
-65534 `setBit` 0 = 65535
-65534 `setBit` 1 = 65534
-65534 `setBit` 2 = 65534
-65534 `setBit` 3 = 65534
-
-65535 `setBit` 0 = 65535
-65535 `setBit` 1 = 65535
-65535 `setBit` 2 = 65535
-65535 `setBit` 3 = 65535
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
-65533 `clearBit` 0 = 65532
-65533 `clearBit` 1 = 65533
-65533 `clearBit` 2 = 65529
-65533 `clearBit` 3 = 65525
-
-65534 `clearBit` 0 = 65534
-65534 `clearBit` 1 = 65532
-65534 `clearBit` 2 = 65530
-65534 `clearBit` 3 = 65526
-
-65535 `clearBit` 0 = 65534
-65535 `clearBit` 1 = 65533
-65535 `clearBit` 2 = 65531
-65535 `clearBit` 3 = 65527
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
-65533 `complementBit` 0 = 65532
-65533 `complementBit` 1 = 65535
-65533 `complementBit` 2 = 65529
-65533 `complementBit` 3 = 65525
-
-65534 `complementBit` 0 = 65535
-65534 `complementBit` 1 = 65532
-65534 `complementBit` 2 = 65530
-65534 `complementBit` 3 = 65526
-
-65535 `complementBit` 0 = 65534
-65535 `complementBit` 1 = 65533
-65535 `complementBit` 2 = 65531
-65535 `complementBit` 3 = 65527
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
-65533 `testBit` 0 = True
-65533 `testBit` 1 = False
-65533 `testBit` 2 = True
-65533 `testBit` 3 = True
-
-65534 `testBit` 0 = False
-65534 `testBit` 1 = True
-65534 `testBit` 2 = True
-65534 `testBit` 3 = True
-
-65535 `testBit` 0 = True
-65535 `testBit` 1 = True
-65535 `testBit` 2 = True
-65535 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize 65533 = 16
-bitSize 65534 = 16
-bitSize 65535 = 16
-bitSize 0 = 16
-bitSize 1 = 16
-bitSize 2 = 16
-bitSize 3 = 16
-#
-isSigned 65533 = False
-isSigned 65534 = False
-isSigned 65535 = False
-isSigned 0 = False
-isSigned 1 = False
-isSigned 2 = False
-isSigned 3 = False
-#
---------------------------------
---------------------------------
---Testing Word32
---------------------------------
-testBounded
-(4294967295,0,1)
-(4294967294,4294967295,0)
-testEnum
-[0,1,2,3,4,5,6,7,8,9]
-[0,2,4,6,8,10,12,14,16,18]
-[0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20]
-[0,2,4,6,8,10,12,14,16,18,20]
-testReadShow
-[4294967293,4294967294,4294967295,0,1,2,3]
-[4294967293,4294967294,4294967295,0,1,2,3]
-testEq
-4294967293 == 4294967293 = True
-4294967293 == 4294967294 = False
-4294967293 == 4294967295 = False
-4294967293 == 0 = False
-4294967293 == 1 = False
-4294967293 == 2 = False
-4294967293 == 3 = False
-
-4294967294 == 4294967293 = False
-4294967294 == 4294967294 = True
-4294967294 == 4294967295 = False
-4294967294 == 0 = False
-4294967294 == 1 = False
-4294967294 == 2 = False
-4294967294 == 3 = False
-
-4294967295 == 4294967293 = False
-4294967295 == 4294967294 = False
-4294967295 == 4294967295 = True
-4294967295 == 0 = False
-4294967295 == 1 = False
-4294967295 == 2 = False
-4294967295 == 3 = False
-
-0 == 4294967293 = False
-0 == 4294967294 = False
-0 == 4294967295 = False
-0 == 0 = True
-0 == 1 = False
-0 == 2 = False
-0 == 3 = False
-
-1 == 4294967293 = False
-1 == 4294967294 = False
-1 == 4294967295 = False
-1 == 0 = False
-1 == 1 = True
-1 == 2 = False
-1 == 3 = False
-
-2 == 4294967293 = False
-2 == 4294967294 = False
-2 == 4294967295 = False
-2 == 0 = False
-2 == 1 = False
-2 == 2 = True
-2 == 3 = False
-
-3 == 4294967293 = False
-3 == 4294967294 = False
-3 == 4294967295 = False
-3 == 0 = False
-3 == 1 = False
-3 == 2 = False
-3 == 3 = True
-
-#
-4294967293 /= 4294967293 = False
-4294967293 /= 4294967294 = True
-4294967293 /= 4294967295 = True
-4294967293 /= 0 = True
-4294967293 /= 1 = True
-4294967293 /= 2 = True
-4294967293 /= 3 = True
-
-4294967294 /= 4294967293 = True
-4294967294 /= 4294967294 = False
-4294967294 /= 4294967295 = True
-4294967294 /= 0 = True
-4294967294 /= 1 = True
-4294967294 /= 2 = True
-4294967294 /= 3 = True
-
-4294967295 /= 4294967293 = True
-4294967295 /= 4294967294 = True
-4294967295 /= 4294967295 = False
-4294967295 /= 0 = True
-4294967295 /= 1 = True
-4294967295 /= 2 = True
-4294967295 /= 3 = True
-
-0 /= 4294967293 = True
-0 /= 4294967294 = True
-0 /= 4294967295 = True
-0 /= 0 = False
-0 /= 1 = True
-0 /= 2 = True
-0 /= 3 = True
-
-1 /= 4294967293 = True
-1 /= 4294967294 = True
-1 /= 4294967295 = True
-1 /= 0 = True
-1 /= 1 = False
-1 /= 2 = True
-1 /= 3 = True
-
-2 /= 4294967293 = True
-2 /= 4294967294 = True
-2 /= 4294967295 = True
-2 /= 0 = True
-2 /= 1 = True
-2 /= 2 = False
-2 /= 3 = True
-
-3 /= 4294967293 = True
-3 /= 4294967294 = True
-3 /= 4294967295 = True
-3 /= 0 = True
-3 /= 1 = True
-3 /= 2 = True
-3 /= 3 = False
-
-#
-testOrd
-4294967293 <= 4294967293 = True
-4294967293 <= 4294967294 = True
-4294967293 <= 4294967295 = True
-4294967293 <= 0 = False
-4294967293 <= 1 = False
-4294967293 <= 2 = False
-4294967293 <= 3 = False
-
-4294967294 <= 4294967293 = False
-4294967294 <= 4294967294 = True
-4294967294 <= 4294967295 = True
-4294967294 <= 0 = False
-4294967294 <= 1 = False
-4294967294 <= 2 = False
-4294967294 <= 3 = False
-
-4294967295 <= 4294967293 = False
-4294967295 <= 4294967294 = False
-4294967295 <= 4294967295 = True
-4294967295 <= 0 = False
-4294967295 <= 1 = False
-4294967295 <= 2 = False
-4294967295 <= 3 = False
-
-0 <= 4294967293 = True
-0 <= 4294967294 = True
-0 <= 4294967295 = True
-0 <= 0 = True
-0 <= 1 = True
-0 <= 2 = True
-0 <= 3 = True
-
-1 <= 4294967293 = True
-1 <= 4294967294 = True
-1 <= 4294967295 = True
-1 <= 0 = False
-1 <= 1 = True
-1 <= 2 = True
-1 <= 3 = True
-
-2 <= 4294967293 = True
-2 <= 4294967294 = True
-2 <= 4294967295 = True
-2 <= 0 = False
-2 <= 1 = False
-2 <= 2 = True
-2 <= 3 = True
-
-3 <= 4294967293 = True
-3 <= 4294967294 = True
-3 <= 4294967295 = True
-3 <= 0 = False
-3 <= 1 = False
-3 <= 2 = False
-3 <= 3 = True
-
-#
-4294967293 < 4294967293 = False
-4294967293 < 4294967294 = True
-4294967293 < 4294967295 = True
-4294967293 < 0 = False
-4294967293 < 1 = False
-4294967293 < 2 = False
-4294967293 < 3 = False
-
-4294967294 < 4294967293 = False
-4294967294 < 4294967294 = False
-4294967294 < 4294967295 = True
-4294967294 < 0 = False
-4294967294 < 1 = False
-4294967294 < 2 = False
-4294967294 < 3 = False
-
-4294967295 < 4294967293 = False
-4294967295 < 4294967294 = False
-4294967295 < 4294967295 = False
-4294967295 < 0 = False
-4294967295 < 1 = False
-4294967295 < 2 = False
-4294967295 < 3 = False
-
-0 < 4294967293 = True
-0 < 4294967294 = True
-0 < 4294967295 = True
-0 < 0 = False
-0 < 1 = True
-0 < 2 = True
-0 < 3 = True
-
-1 < 4294967293 = True
-1 < 4294967294 = True
-1 < 4294967295 = True
-1 < 0 = False
-1 < 1 = False
-1 < 2 = True
-1 < 3 = True
-
-2 < 4294967293 = True
-2 < 4294967294 = True
-2 < 4294967295 = True
-2 < 0 = False
-2 < 1 = False
-2 < 2 = False
-2 < 3 = True
-
-3 < 4294967293 = True
-3 < 4294967294 = True
-3 < 4294967295 = True
-3 < 0 = False
-3 < 1 = False
-3 < 2 = False
-3 < 3 = False
-
-#
-4294967293 > 4294967293 = False
-4294967293 > 4294967294 = False
-4294967293 > 4294967295 = False
-4294967293 > 0 = True
-4294967293 > 1 = True
-4294967293 > 2 = True
-4294967293 > 3 = True
-
-4294967294 > 4294967293 = True
-4294967294 > 4294967294 = False
-4294967294 > 4294967295 = False
-4294967294 > 0 = True
-4294967294 > 1 = True
-4294967294 > 2 = True
-4294967294 > 3 = True
-
-4294967295 > 4294967293 = True
-4294967295 > 4294967294 = True
-4294967295 > 4294967295 = False
-4294967295 > 0 = True
-4294967295 > 1 = True
-4294967295 > 2 = True
-4294967295 > 3 = True
-
-0 > 4294967293 = False
-0 > 4294967294 = False
-0 > 4294967295 = False
-0 > 0 = False
-0 > 1 = False
-0 > 2 = False
-0 > 3 = False
-
-1 > 4294967293 = False
-1 > 4294967294 = False
-1 > 4294967295 = False
-1 > 0 = True
-1 > 1 = False
-1 > 2 = False
-1 > 3 = False
-
-2 > 4294967293 = False
-2 > 4294967294 = False
-2 > 4294967295 = False
-2 > 0 = True
-2 > 1 = True
-2 > 2 = False
-2 > 3 = False
-
-3 > 4294967293 = False
-3 > 4294967294 = False
-3 > 4294967295 = False
-3 > 0 = True
-3 > 1 = True
-3 > 2 = True
-3 > 3 = False
-
-#
-4294967293 >= 4294967293 = True
-4294967293 >= 4294967294 = False
-4294967293 >= 4294967295 = False
-4294967293 >= 0 = True
-4294967293 >= 1 = True
-4294967293 >= 2 = True
-4294967293 >= 3 = True
-
-4294967294 >= 4294967293 = True
-4294967294 >= 4294967294 = True
-4294967294 >= 4294967295 = False
-4294967294 >= 0 = True
-4294967294 >= 1 = True
-4294967294 >= 2 = True
-4294967294 >= 3 = True
-
-4294967295 >= 4294967293 = True
-4294967295 >= 4294967294 = True
-4294967295 >= 4294967295 = True
-4294967295 >= 0 = True
-4294967295 >= 1 = True
-4294967295 >= 2 = True
-4294967295 >= 3 = True
-
-0 >= 4294967293 = False
-0 >= 4294967294 = False
-0 >= 4294967295 = False
-0 >= 0 = True
-0 >= 1 = False
-0 >= 2 = False
-0 >= 3 = False
-
-1 >= 4294967293 = False
-1 >= 4294967294 = False
-1 >= 4294967295 = False
-1 >= 0 = True
-1 >= 1 = True
-1 >= 2 = False
-1 >= 3 = False
-
-2 >= 4294967293 = False
-2 >= 4294967294 = False
-2 >= 4294967295 = False
-2 >= 0 = True
-2 >= 1 = True
-2 >= 2 = True
-2 >= 3 = False
-
-3 >= 4294967293 = False
-3 >= 4294967294 = False
-3 >= 4294967295 = False
-3 >= 0 = True
-3 >= 1 = True
-3 >= 2 = True
-3 >= 3 = True
-
-#
-4294967293 `compare` 4294967293 = EQ
-4294967293 `compare` 4294967294 = LT
-4294967293 `compare` 4294967295 = LT
-4294967293 `compare` 0 = GT
-4294967293 `compare` 1 = GT
-4294967293 `compare` 2 = GT
-4294967293 `compare` 3 = GT
-
-4294967294 `compare` 4294967293 = GT
-4294967294 `compare` 4294967294 = EQ
-4294967294 `compare` 4294967295 = LT
-4294967294 `compare` 0 = GT
-4294967294 `compare` 1 = GT
-4294967294 `compare` 2 = GT
-4294967294 `compare` 3 = GT
-
-4294967295 `compare` 4294967293 = GT
-4294967295 `compare` 4294967294 = GT
-4294967295 `compare` 4294967295 = EQ
-4294967295 `compare` 0 = GT
-4294967295 `compare` 1 = GT
-4294967295 `compare` 2 = GT
-4294967295 `compare` 3 = GT
-
-0 `compare` 4294967293 = LT
-0 `compare` 4294967294 = LT
-0 `compare` 4294967295 = LT
-0 `compare` 0 = EQ
-0 `compare` 1 = LT
-0 `compare` 2 = LT
-0 `compare` 3 = LT
-
-1 `compare` 4294967293 = LT
-1 `compare` 4294967294 = LT
-1 `compare` 4294967295 = LT
-1 `compare` 0 = GT
-1 `compare` 1 = EQ
-1 `compare` 2 = LT
-1 `compare` 3 = LT
-
-2 `compare` 4294967293 = LT
-2 `compare` 4294967294 = LT
-2 `compare` 4294967295 = LT
-2 `compare` 0 = GT
-2 `compare` 1 = GT
-2 `compare` 2 = EQ
-2 `compare` 3 = LT
-
-3 `compare` 4294967293 = LT
-3 `compare` 4294967294 = LT
-3 `compare` 4294967295 = LT
-3 `compare` 0 = GT
-3 `compare` 1 = GT
-3 `compare` 2 = GT
-3 `compare` 3 = EQ
-
-#
-testNum
-4294967293 + 4294967293 = 4294967290
-4294967293 + 4294967294 = 4294967291
-4294967293 + 4294967295 = 4294967292
-4294967293 + 0 = 4294967293
-4294967293 + 1 = 4294967294
-4294967293 + 2 = 4294967295
-4294967293 + 3 = 0
-
-4294967294 + 4294967293 = 4294967291
-4294967294 + 4294967294 = 4294967292
-4294967294 + 4294967295 = 4294967293
-4294967294 + 0 = 4294967294
-4294967294 + 1 = 4294967295
-4294967294 + 2 = 0
-4294967294 + 3 = 1
-
-4294967295 + 4294967293 = 4294967292
-4294967295 + 4294967294 = 4294967293
-4294967295 + 4294967295 = 4294967294
-4294967295 + 0 = 4294967295
-4294967295 + 1 = 0
-4294967295 + 2 = 1
-4294967295 + 3 = 2
-
-0 + 4294967293 = 4294967293
-0 + 4294967294 = 4294967294
-0 + 4294967295 = 4294967295
-0 + 0 = 0
-0 + 1 = 1
-0 + 2 = 2
-0 + 3 = 3
-
-1 + 4294967293 = 4294967294
-1 + 4294967294 = 4294967295
-1 + 4294967295 = 0
-1 + 0 = 1
-1 + 1 = 2
-1 + 2 = 3
-1 + 3 = 4
-
-2 + 4294967293 = 4294967295
-2 + 4294967294 = 0
-2 + 4294967295 = 1
-2 + 0 = 2
-2 + 1 = 3
-2 + 2 = 4
-2 + 3 = 5
-
-3 + 4294967293 = 0
-3 + 4294967294 = 1
-3 + 4294967295 = 2
-3 + 0 = 3
-3 + 1 = 4
-3 + 2 = 5
-3 + 3 = 6
-
-#
-4294967293 - 4294967293 = 0
-4294967293 - 4294967294 = 4294967295
-4294967293 - 4294967295 = 4294967294
-4294967293 - 0 = 4294967293
-4294967293 - 1 = 4294967292
-4294967293 - 2 = 4294967291
-4294967293 - 3 = 4294967290
-
-4294967294 - 4294967293 = 1
-4294967294 - 4294967294 = 0
-4294967294 - 4294967295 = 4294967295
-4294967294 - 0 = 4294967294
-4294967294 - 1 = 4294967293
-4294967294 - 2 = 4294967292
-4294967294 - 3 = 4294967291
-
-4294967295 - 4294967293 = 2
-4294967295 - 4294967294 = 1
-4294967295 - 4294967295 = 0
-4294967295 - 0 = 4294967295
-4294967295 - 1 = 4294967294
-4294967295 - 2 = 4294967293
-4294967295 - 3 = 4294967292
-
-0 - 4294967293 = 3
-0 - 4294967294 = 2
-0 - 4294967295 = 1
-0 - 0 = 0
-0 - 1 = 4294967295
-0 - 2 = 4294967294
-0 - 3 = 4294967293
-
-1 - 4294967293 = 4
-1 - 4294967294 = 3
-1 - 4294967295 = 2
-1 - 0 = 1
-1 - 1 = 0
-1 - 2 = 4294967295
-1 - 3 = 4294967294
-
-2 - 4294967293 = 5
-2 - 4294967294 = 4
-2 - 4294967295 = 3
-2 - 0 = 2
-2 - 1 = 1
-2 - 2 = 0
-2 - 3 = 4294967295
-
-3 - 4294967293 = 6
-3 - 4294967294 = 5
-3 - 4294967295 = 4
-3 - 0 = 3
-3 - 1 = 2
-3 - 2 = 1
-3 - 3 = 0
-
-#
-4294967293 * 4294967293 = 9
-4294967293 * 4294967294 = 6
-4294967293 * 4294967295 = 3
-4294967293 * 0 = 0
-4294967293 * 1 = 4294967293
-4294967293 * 2 = 4294967290
-4294967293 * 3 = 4294967287
-
-4294967294 * 4294967293 = 6
-4294967294 * 4294967294 = 4
-4294967294 * 4294967295 = 2
-4294967294 * 0 = 0
-4294967294 * 1 = 4294967294
-4294967294 * 2 = 4294967292
-4294967294 * 3 = 4294967290
-
-4294967295 * 4294967293 = 3
-4294967295 * 4294967294 = 2
-4294967295 * 4294967295 = 1
-4294967295 * 0 = 0
-4294967295 * 1 = 4294967295
-4294967295 * 2 = 4294967294
-4294967295 * 3 = 4294967293
-
-0 * 4294967293 = 0
-0 * 4294967294 = 0
-0 * 4294967295 = 0
-0 * 0 = 0
-0 * 1 = 0
-0 * 2 = 0
-0 * 3 = 0
-
-1 * 4294967293 = 4294967293
-1 * 4294967294 = 4294967294
-1 * 4294967295 = 4294967295
-1 * 0 = 0
-1 * 1 = 1
-1 * 2 = 2
-1 * 3 = 3
-
-2 * 4294967293 = 4294967290
-2 * 4294967294 = 4294967292
-2 * 4294967295 = 4294967294
-2 * 0 = 0
-2 * 1 = 2
-2 * 2 = 4
-2 * 3 = 6
-
-3 * 4294967293 = 4294967287
-3 * 4294967294 = 4294967290
-3 * 4294967295 = 4294967293
-3 * 0 = 0
-3 * 1 = 3
-3 * 2 = 6
-3 * 3 = 9
-
-#
-negate 4294967293 = 3
-negate 4294967294 = 2
-negate 4294967295 = 1
-negate 0 = 0
-negate 1 = 4294967295
-negate 2 = 4294967294
-negate 3 = 4294967293
-#
-testReal
-toRational 4294967293 = 4294967293 % 1
-toRational 4294967294 = 4294967294 % 1
-toRational 4294967295 = 4294967295 % 1
-toRational 0 = 0 % 1
-toRational 1 = 1 % 1
-toRational 2 = 2 % 1
-toRational 3 = 3 % 1
-#
-testIntegral
-4294967293 `divMod` 4294967293 = (1,0)
-4294967293 `divMod` 4294967294 = (0,4294967293)
-4294967293 `divMod` 4294967295 = (0,4294967293)
-4294967293 `divMod` 1 = (4294967293,0)
-4294967293 `divMod` 2 = (2147483646,1)
-4294967293 `divMod` 3 = (1431655764,1)
-
-4294967294 `divMod` 4294967293 = (1,1)
-4294967294 `divMod` 4294967294 = (1,0)
-4294967294 `divMod` 4294967295 = (0,4294967294)
-4294967294 `divMod` 1 = (4294967294,0)
-4294967294 `divMod` 2 = (2147483647,0)
-4294967294 `divMod` 3 = (1431655764,2)
-
-4294967295 `divMod` 4294967293 = (1,2)
-4294967295 `divMod` 4294967294 = (1,1)
-4294967295 `divMod` 4294967295 = (1,0)
-4294967295 `divMod` 1 = (4294967295,0)
-4294967295 `divMod` 2 = (2147483647,1)
-4294967295 `divMod` 3 = (1431655765,0)
-
-0 `divMod` 4294967293 = (0,0)
-0 `divMod` 4294967294 = (0,0)
-0 `divMod` 4294967295 = (0,0)
-0 `divMod` 1 = (0,0)
-0 `divMod` 2 = (0,0)
-0 `divMod` 3 = (0,0)
-
-1 `divMod` 4294967293 = (0,1)
-1 `divMod` 4294967294 = (0,1)
-1 `divMod` 4294967295 = (0,1)
-1 `divMod` 1 = (1,0)
-1 `divMod` 2 = (0,1)
-1 `divMod` 3 = (0,1)
-
-2 `divMod` 4294967293 = (0,2)
-2 `divMod` 4294967294 = (0,2)
-2 `divMod` 4294967295 = (0,2)
-2 `divMod` 1 = (2,0)
-2 `divMod` 2 = (1,0)
-2 `divMod` 3 = (0,2)
-
-3 `divMod` 4294967293 = (0,3)
-3 `divMod` 4294967294 = (0,3)
-3 `divMod` 4294967295 = (0,3)
-3 `divMod` 1 = (3,0)
-3 `divMod` 2 = (1,1)
-3 `divMod` 3 = (1,0)
-
-#
-4294967293 `div` 4294967293 = 1
-4294967293 `div` 4294967294 = 0
-4294967293 `div` 4294967295 = 0
-4294967293 `div` 1 = 4294967293
-4294967293 `div` 2 = 2147483646
-4294967293 `div` 3 = 1431655764
-
-4294967294 `div` 4294967293 = 1
-4294967294 `div` 4294967294 = 1
-4294967294 `div` 4294967295 = 0
-4294967294 `div` 1 = 4294967294
-4294967294 `div` 2 = 2147483647
-4294967294 `div` 3 = 1431655764
-
-4294967295 `div` 4294967293 = 1
-4294967295 `div` 4294967294 = 1
-4294967295 `div` 4294967295 = 1
-4294967295 `div` 1 = 4294967295
-4294967295 `div` 2 = 2147483647
-4294967295 `div` 3 = 1431655765
-
-0 `div` 4294967293 = 0
-0 `div` 4294967294 = 0
-0 `div` 4294967295 = 0
-0 `div` 1 = 0
-0 `div` 2 = 0
-0 `div` 3 = 0
-
-1 `div` 4294967293 = 0
-1 `div` 4294967294 = 0
-1 `div` 4294967295 = 0
-1 `div` 1 = 1
-1 `div` 2 = 0
-1 `div` 3 = 0
-
-2 `div` 4294967293 = 0
-2 `div` 4294967294 = 0
-2 `div` 4294967295 = 0
-2 `div` 1 = 2
-2 `div` 2 = 1
-2 `div` 3 = 0
-
-3 `div` 4294967293 = 0
-3 `div` 4294967294 = 0
-3 `div` 4294967295 = 0
-3 `div` 1 = 3
-3 `div` 2 = 1
-3 `div` 3 = 1
-
-#
-4294967293 `mod` 4294967293 = 0
-4294967293 `mod` 4294967294 = 4294967293
-4294967293 `mod` 4294967295 = 4294967293
-4294967293 `mod` 1 = 0
-4294967293 `mod` 2 = 1
-4294967293 `mod` 3 = 1
-
-4294967294 `mod` 4294967293 = 1
-4294967294 `mod` 4294967294 = 0
-4294967294 `mod` 4294967295 = 4294967294
-4294967294 `mod` 1 = 0
-4294967294 `mod` 2 = 0
-4294967294 `mod` 3 = 2
-
-4294967295 `mod` 4294967293 = 2
-4294967295 `mod` 4294967294 = 1
-4294967295 `mod` 4294967295 = 0
-4294967295 `mod` 1 = 0
-4294967295 `mod` 2 = 1
-4294967295 `mod` 3 = 0
-
-0 `mod` 4294967293 = 0
-0 `mod` 4294967294 = 0
-0 `mod` 4294967295 = 0
-0 `mod` 1 = 0
-0 `mod` 2 = 0
-0 `mod` 3 = 0
-
-1 `mod` 4294967293 = 1
-1 `mod` 4294967294 = 1
-1 `mod` 4294967295 = 1
-1 `mod` 1 = 0
-1 `mod` 2 = 1
-1 `mod` 3 = 1
-
-2 `mod` 4294967293 = 2
-2 `mod` 4294967294 = 2
-2 `mod` 4294967295 = 2
-2 `mod` 1 = 0
-2 `mod` 2 = 0
-2 `mod` 3 = 2
-
-3 `mod` 4294967293 = 3
-3 `mod` 4294967294 = 3
-3 `mod` 4294967295 = 3
-3 `mod` 1 = 0
-3 `mod` 2 = 1
-3 `mod` 3 = 0
-
-#
-4294967293 `quotRem` 4294967293 = (1,0)
-4294967293 `quotRem` 4294967294 = (0,4294967293)
-4294967293 `quotRem` 4294967295 = (0,4294967293)
-4294967293 `quotRem` 1 = (4294967293,0)
-4294967293 `quotRem` 2 = (2147483646,1)
-4294967293 `quotRem` 3 = (1431655764,1)
-
-4294967294 `quotRem` 4294967293 = (1,1)
-4294967294 `quotRem` 4294967294 = (1,0)
-4294967294 `quotRem` 4294967295 = (0,4294967294)
-4294967294 `quotRem` 1 = (4294967294,0)
-4294967294 `quotRem` 2 = (2147483647,0)
-4294967294 `quotRem` 3 = (1431655764,2)
-
-4294967295 `quotRem` 4294967293 = (1,2)
-4294967295 `quotRem` 4294967294 = (1,1)
-4294967295 `quotRem` 4294967295 = (1,0)
-4294967295 `quotRem` 1 = (4294967295,0)
-4294967295 `quotRem` 2 = (2147483647,1)
-4294967295 `quotRem` 3 = (1431655765,0)
-
-0 `quotRem` 4294967293 = (0,0)
-0 `quotRem` 4294967294 = (0,0)
-0 `quotRem` 4294967295 = (0,0)
-0 `quotRem` 1 = (0,0)
-0 `quotRem` 2 = (0,0)
-0 `quotRem` 3 = (0,0)
-
-1 `quotRem` 4294967293 = (0,1)
-1 `quotRem` 4294967294 = (0,1)
-1 `quotRem` 4294967295 = (0,1)
-1 `quotRem` 1 = (1,0)
-1 `quotRem` 2 = (0,1)
-1 `quotRem` 3 = (0,1)
-
-2 `quotRem` 4294967293 = (0,2)
-2 `quotRem` 4294967294 = (0,2)
-2 `quotRem` 4294967295 = (0,2)
-2 `quotRem` 1 = (2,0)
-2 `quotRem` 2 = (1,0)
-2 `quotRem` 3 = (0,2)
-
-3 `quotRem` 4294967293 = (0,3)
-3 `quotRem` 4294967294 = (0,3)
-3 `quotRem` 4294967295 = (0,3)
-3 `quotRem` 1 = (3,0)
-3 `quotRem` 2 = (1,1)
-3 `quotRem` 3 = (1,0)
-
-#
-4294967293 `quot` 4294967293 = 1
-4294967293 `quot` 4294967294 = 0
-4294967293 `quot` 4294967295 = 0
-4294967293 `quot` 1 = 4294967293
-4294967293 `quot` 2 = 2147483646
-4294967293 `quot` 3 = 1431655764
-
-4294967294 `quot` 4294967293 = 1
-4294967294 `quot` 4294967294 = 1
-4294967294 `quot` 4294967295 = 0
-4294967294 `quot` 1 = 4294967294
-4294967294 `quot` 2 = 2147483647
-4294967294 `quot` 3 = 1431655764
-
-4294967295 `quot` 4294967293 = 1
-4294967295 `quot` 4294967294 = 1
-4294967295 `quot` 4294967295 = 1
-4294967295 `quot` 1 = 4294967295
-4294967295 `quot` 2 = 2147483647
-4294967295 `quot` 3 = 1431655765
-
-0 `quot` 4294967293 = 0
-0 `quot` 4294967294 = 0
-0 `quot` 4294967295 = 0
-0 `quot` 1 = 0
-0 `quot` 2 = 0
-0 `quot` 3 = 0
-
-1 `quot` 4294967293 = 0
-1 `quot` 4294967294 = 0
-1 `quot` 4294967295 = 0
-1 `quot` 1 = 1
-1 `quot` 2 = 0
-1 `quot` 3 = 0
-
-2 `quot` 4294967293 = 0
-2 `quot` 4294967294 = 0
-2 `quot` 4294967295 = 0
-2 `quot` 1 = 2
-2 `quot` 2 = 1
-2 `quot` 3 = 0
-
-3 `quot` 4294967293 = 0
-3 `quot` 4294967294 = 0
-3 `quot` 4294967295 = 0
-3 `quot` 1 = 3
-3 `quot` 2 = 1
-3 `quot` 3 = 1
-
-#
-4294967293 `rem` 4294967293 = 0
-4294967293 `rem` 4294967294 = 4294967293
-4294967293 `rem` 4294967295 = 4294967293
-4294967293 `rem` 1 = 0
-4294967293 `rem` 2 = 1
-4294967293 `rem` 3 = 1
-
-4294967294 `rem` 4294967293 = 1
-4294967294 `rem` 4294967294 = 0
-4294967294 `rem` 4294967295 = 4294967294
-4294967294 `rem` 1 = 0
-4294967294 `rem` 2 = 0
-4294967294 `rem` 3 = 2
-
-4294967295 `rem` 4294967293 = 2
-4294967295 `rem` 4294967294 = 1
-4294967295 `rem` 4294967295 = 0
-4294967295 `rem` 1 = 0
-4294967295 `rem` 2 = 1
-4294967295 `rem` 3 = 0
-
-0 `rem` 4294967293 = 0
-0 `rem` 4294967294 = 0
-0 `rem` 4294967295 = 0
-0 `rem` 1 = 0
-0 `rem` 2 = 0
-0 `rem` 3 = 0
-
-1 `rem` 4294967293 = 1
-1 `rem` 4294967294 = 1
-1 `rem` 4294967295 = 1
-1 `rem` 1 = 0
-1 `rem` 2 = 1
-1 `rem` 3 = 1
-
-2 `rem` 4294967293 = 2
-2 `rem` 4294967294 = 2
-2 `rem` 4294967295 = 2
-2 `rem` 1 = 0
-2 `rem` 2 = 0
-2 `rem` 3 = 2
-
-3 `rem` 4294967293 = 3
-3 `rem` 4294967294 = 3
-3 `rem` 4294967295 = 3
-3 `rem` 1 = 0
-3 `rem` 2 = 1
-3 `rem` 3 = 0
-
-#
-testBits
-4294967293 .&. 4294967293 = 4294967293
-4294967293 .&. 4294967294 = 4294967292
-4294967293 .&. 4294967295 = 4294967293
-4294967293 .&. 1 = 1
-4294967293 .&. 2 = 0
-4294967293 .&. 3 = 1
-
-4294967294 .&. 4294967293 = 4294967292
-4294967294 .&. 4294967294 = 4294967294
-4294967294 .&. 4294967295 = 4294967294
-4294967294 .&. 1 = 0
-4294967294 .&. 2 = 2
-4294967294 .&. 3 = 2
-
-4294967295 .&. 4294967293 = 4294967293
-4294967295 .&. 4294967294 = 4294967294
-4294967295 .&. 4294967295 = 4294967295
-4294967295 .&. 1 = 1
-4294967295 .&. 2 = 2
-4294967295 .&. 3 = 3
-
-0 .&. 4294967293 = 0
-0 .&. 4294967294 = 0
-0 .&. 4294967295 = 0
-0 .&. 1 = 0
-0 .&. 2 = 0
-0 .&. 3 = 0
-
-1 .&. 4294967293 = 1
-1 .&. 4294967294 = 0
-1 .&. 4294967295 = 1
-1 .&. 1 = 1
-1 .&. 2 = 0
-1 .&. 3 = 1
-
-2 .&. 4294967293 = 0
-2 .&. 4294967294 = 2
-2 .&. 4294967295 = 2
-2 .&. 1 = 0
-2 .&. 2 = 2
-2 .&. 3 = 2
-
-3 .&. 4294967293 = 1
-3 .&. 4294967294 = 2
-3 .&. 4294967295 = 3
-3 .&. 1 = 1
-3 .&. 2 = 2
-3 .&. 3 = 3
-
-#
-4294967293 .|. 4294967293 = 4294967293
-4294967293 .|. 4294967294 = 4294967295
-4294967293 .|. 4294967295 = 4294967295
-4294967293 .|. 1 = 4294967293
-4294967293 .|. 2 = 4294967295
-4294967293 .|. 3 = 4294967295
-
-4294967294 .|. 4294967293 = 4294967295
-4294967294 .|. 4294967294 = 4294967294
-4294967294 .|. 4294967295 = 4294967295
-4294967294 .|. 1 = 4294967295
-4294967294 .|. 2 = 4294967294
-4294967294 .|. 3 = 4294967295
-
-4294967295 .|. 4294967293 = 4294967295
-4294967295 .|. 4294967294 = 4294967295
-4294967295 .|. 4294967295 = 4294967295
-4294967295 .|. 1 = 4294967295
-4294967295 .|. 2 = 4294967295
-4294967295 .|. 3 = 4294967295
-
-0 .|. 4294967293 = 4294967293
-0 .|. 4294967294 = 4294967294
-0 .|. 4294967295 = 4294967295
-0 .|. 1 = 1
-0 .|. 2 = 2
-0 .|. 3 = 3
-
-1 .|. 4294967293 = 4294967293
-1 .|. 4294967294 = 4294967295
-1 .|. 4294967295 = 4294967295
-1 .|. 1 = 1
-1 .|. 2 = 3
-1 .|. 3 = 3
-
-2 .|. 4294967293 = 4294967295
-2 .|. 4294967294 = 4294967294
-2 .|. 4294967295 = 4294967295
-2 .|. 1 = 3
-2 .|. 2 = 2
-2 .|. 3 = 3
-
-3 .|. 4294967293 = 4294967295
-3 .|. 4294967294 = 4294967295
-3 .|. 4294967295 = 4294967295
-3 .|. 1 = 3
-3 .|. 2 = 3
-3 .|. 3 = 3
-
-#
-4294967293 `xor` 4294967293 = 0
-4294967293 `xor` 4294967294 = 3
-4294967293 `xor` 4294967295 = 2
-4294967293 `xor` 1 = 4294967292
-4294967293 `xor` 2 = 4294967295
-4294967293 `xor` 3 = 4294967294
-
-4294967294 `xor` 4294967293 = 3
-4294967294 `xor` 4294967294 = 0
-4294967294 `xor` 4294967295 = 1
-4294967294 `xor` 1 = 4294967295
-4294967294 `xor` 2 = 4294967292
-4294967294 `xor` 3 = 4294967293
-
-4294967295 `xor` 4294967293 = 2
-4294967295 `xor` 4294967294 = 1
-4294967295 `xor` 4294967295 = 0
-4294967295 `xor` 1 = 4294967294
-4294967295 `xor` 2 = 4294967293
-4294967295 `xor` 3 = 4294967292
-
-0 `xor` 4294967293 = 4294967293
-0 `xor` 4294967294 = 4294967294
-0 `xor` 4294967295 = 4294967295
-0 `xor` 1 = 1
-0 `xor` 2 = 2
-0 `xor` 3 = 3
-
-1 `xor` 4294967293 = 4294967292
-1 `xor` 4294967294 = 4294967295
-1 `xor` 4294967295 = 4294967294
-1 `xor` 1 = 0
-1 `xor` 2 = 3
-1 `xor` 3 = 2
-
-2 `xor` 4294967293 = 4294967295
-2 `xor` 4294967294 = 4294967292
-2 `xor` 4294967295 = 4294967293
-2 `xor` 1 = 3
-2 `xor` 2 = 0
-2 `xor` 3 = 1
-
-3 `xor` 4294967293 = 4294967294
-3 `xor` 4294967294 = 4294967293
-3 `xor` 4294967295 = 4294967292
-3 `xor` 1 = 2
-3 `xor` 2 = 1
-3 `xor` 3 = 0
-
-#
-complement 4294967293 = 2
-complement 4294967294 = 1
-complement 4294967295 = 0
-complement 0 = 4294967295
-complement 1 = 4294967294
-complement 2 = 4294967293
-complement 3 = 4294967292
-#
-4294967293 `shift` 0 = 4294967293
-4294967293 `shift` 1 = 4294967290
-4294967293 `shift` 2 = 4294967284
-4294967293 `shift` 3 = 4294967272
-
-4294967294 `shift` 0 = 4294967294
-4294967294 `shift` 1 = 4294967292
-4294967294 `shift` 2 = 4294967288
-4294967294 `shift` 3 = 4294967280
-
-4294967295 `shift` 0 = 4294967295
-4294967295 `shift` 1 = 4294967294
-4294967295 `shift` 2 = 4294967292
-4294967295 `shift` 3 = 4294967288
-
-0 `shift` 0 = 0
-0 `shift` 1 = 0
-0 `shift` 2 = 0
-0 `shift` 3 = 0
-
-1 `shift` 0 = 1
-1 `shift` 1 = 2
-1 `shift` 2 = 4
-1 `shift` 3 = 8
-
-2 `shift` 0 = 2
-2 `shift` 1 = 4
-2 `shift` 2 = 8
-2 `shift` 3 = 16
-
-3 `shift` 0 = 3
-3 `shift` 1 = 6
-3 `shift` 2 = 12
-3 `shift` 3 = 24
-
-#
-4294967293 `setBit` 0 = 4294967293
-4294967293 `setBit` 1 = 4294967295
-4294967293 `setBit` 2 = 4294967293
-4294967293 `setBit` 3 = 4294967293
-
-4294967294 `setBit` 0 = 4294967295
-4294967294 `setBit` 1 = 4294967294
-4294967294 `setBit` 2 = 4294967294
-4294967294 `setBit` 3 = 4294967294
-
-4294967295 `setBit` 0 = 4294967295
-4294967295 `setBit` 1 = 4294967295
-4294967295 `setBit` 2 = 4294967295
-4294967295 `setBit` 3 = 4294967295
-
-0 `setBit` 0 = 1
-0 `setBit` 1 = 2
-0 `setBit` 2 = 4
-0 `setBit` 3 = 8
-
-1 `setBit` 0 = 1
-1 `setBit` 1 = 3
-1 `setBit` 2 = 5
-1 `setBit` 3 = 9
-
-2 `setBit` 0 = 3
-2 `setBit` 1 = 2
-2 `setBit` 2 = 6
-2 `setBit` 3 = 10
-
-3 `setBit` 0 = 3
-3 `setBit` 1 = 3
-3 `setBit` 2 = 7
-3 `setBit` 3 = 11
-
-#
-4294967293 `clearBit` 0 = 4294967292
-4294967293 `clearBit` 1 = 4294967293
-4294967293 `clearBit` 2 = 4294967289
-4294967293 `clearBit` 3 = 4294967285
-
-4294967294 `clearBit` 0 = 4294967294
-4294967294 `clearBit` 1 = 4294967292
-4294967294 `clearBit` 2 = 4294967290
-4294967294 `clearBit` 3 = 4294967286
-
-4294967295 `clearBit` 0 = 4294967294
-4294967295 `clearBit` 1 = 4294967293
-4294967295 `clearBit` 2 = 4294967291
-4294967295 `clearBit` 3 = 4294967287
-
-0 `clearBit` 0 = 0
-0 `clearBit` 1 = 0
-0 `clearBit` 2 = 0
-0 `clearBit` 3 = 0
-
-1 `clearBit` 0 = 0
-1 `clearBit` 1 = 1
-1 `clearBit` 2 = 1
-1 `clearBit` 3 = 1
-
-2 `clearBit` 0 = 2
-2 `clearBit` 1 = 0
-2 `clearBit` 2 = 2
-2 `clearBit` 3 = 2
-
-3 `clearBit` 0 = 2
-3 `clearBit` 1 = 1
-3 `clearBit` 2 = 3
-3 `clearBit` 3 = 3
-
-#
-4294967293 `complementBit` 0 = 4294967292
-4294967293 `complementBit` 1 = 4294967295
-4294967293 `complementBit` 2 = 4294967289
-4294967293 `complementBit` 3 = 4294967285
-
-4294967294 `complementBit` 0 = 4294967295
-4294967294 `complementBit` 1 = 4294967292
-4294967294 `complementBit` 2 = 4294967290
-4294967294 `complementBit` 3 = 4294967286
-
-4294967295 `complementBit` 0 = 4294967294
-4294967295 `complementBit` 1 = 4294967293
-4294967295 `complementBit` 2 = 4294967291
-4294967295 `complementBit` 3 = 4294967287
-
-0 `complementBit` 0 = 1
-0 `complementBit` 1 = 2
-0 `complementBit` 2 = 4
-0 `complementBit` 3 = 8
-
-1 `complementBit` 0 = 0
-1 `complementBit` 1 = 3
-1 `complementBit` 2 = 5
-1 `complementBit` 3 = 9
-
-2 `complementBit` 0 = 3
-2 `complementBit` 1 = 0
-2 `complementBit` 2 = 6
-2 `complementBit` 3 = 10
-
-3 `complementBit` 0 = 2
-3 `complementBit` 1 = 1
-3 `complementBit` 2 = 7
-3 `complementBit` 3 = 11
-
-#
-4294967293 `testBit` 0 = True
-4294967293 `testBit` 1 = False
-4294967293 `testBit` 2 = True
-4294967293 `testBit` 3 = True
-
-4294967294 `testBit` 0 = False
-4294967294 `testBit` 1 = True
-4294967294 `testBit` 2 = True
-4294967294 `testBit` 3 = True
-
-4294967295 `testBit` 0 = True
-4294967295 `testBit` 1 = True
-4294967295 `testBit` 2 = True
-4294967295 `testBit` 3 = True
-
-0 `testBit` 0 = False
-0 `testBit` 1 = False
-0 `testBit` 2 = False
-0 `testBit` 3 = False
-
-1 `testBit` 0 = True
-1 `testBit` 1 = False
-1 `testBit` 2 = False
-1 `testBit` 3 = False
-
-2 `testBit` 0 = False
-2 `testBit` 1 = True
-2 `testBit` 2 = False
-2 `testBit` 3 = False
-
-3 `testBit` 0 = True
-3 `testBit` 1 = True
-3 `testBit` 2 = False
-3 `testBit` 3 = False
-
-#
-bitSize 4294967293 = 32
-bitSize 4294967294 = 32
-bitSize 4294967295 = 32
-bitSize 0 = 32
-bitSize 1 = 32
-bitSize 2 = 32
-bitSize 3 = 32
-#
-isSigned 4294967293 = False
-isSigned 4294967294 = False
-isSigned 4294967295 = False
-isSigned 0 = False
-isSigned 1 = False
-isSigned 2 = False
-isSigned 3 = False
-#
---------------------------------
-
+++ /dev/null
---!!! Testing the MVar primitives
-
--- I quickly converted some of this code to work in the new system.
--- Many of the rest haven't been updated or tested much and you'll
--- find that the claims about what they "should print" are wrong
--- being based on the old Hugs behaviour instead of assuming an
--- arbitrary interleaving.
---
--- ADR - 5th nov 1998
-
-module TestMVar(test1,test2,test3,test4,test5,test6,test7,test8) where
-
-import Concurrent
-
--- should print "a" then deadlock
-test1 = do
- { v <- newEmptyMVar
- ; putMVar v 'a'
- ; get v
- ; get v
- }
-
--- Nondeterministic
-test2 = do
- { v <- newEmptyMVar
- ; forkIO (p1 v)
- ; p2 v
- }
- where
- p1 v = do { put v 'a'; get v }
- p2 v = do { get v ; put v 'b' }
-
--- should print "a"
-test3 =
- newEmptyMVar >>= \ v ->
- forkIO (put v 'a') >>
- get v
-
--- should print "ab"
--- NB: it's important that p1 is called from the main thread to make sure
--- that the final get is executed
-test4 = do
- { v1 <- newEmptyMVar
- ; v2 <- newEmptyMVar
- ; forkIO (p2 v1 v2)
- ; p1 v1 v2
- }
- where
- p1 v1 v2 = do { put v1 'a'; get v2 }
- p2 v1 v2 = do { get v1 ; put v2 'b' }
-
--- should abort: primPutMVar: full MVar
-test5 =
- newEmptyMVar >>= \ v ->
- put v 'a' >>
- put v 'b'
-
--- test blocking of two processes on the same variable.
--- should print "aa"
-test6 = do
- { x <- newEmptyMVar
- ; ack <- newEmptyMVar
- ; forkIO (get x >> put ack 'X')
- ; forkIO (get x >> put ack 'X')
- ; put x 'a' >> get ack -- use up one reader
- ; put x 'b' >> get ack -- use up the other
- ; put x 'c' >> get ack -- deadlock
- }
-
-----------------------------------------------------------------
--- Non-deterministic tests below this point
--- Must be tested interactively and probably don't work using
--- "logical concurrency".
-
-
--- should print interleaving of a's and b's
--- (degree of interleaving depends on granularity of concurrency)
-test7 =
- forkIO a >> b
- where
- a = putStr "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
- b = putStr "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
-
--- should give infinite interleaving of a's and b's
--- (degree of interleaving depends on granularity of concurrency)
--- Ming's example. The Hugs read-eval-print loop gets confused if
--- there's no type signature
-test8 :: IO ()
-test8 =
- forkIO a >> b
- where
- -- symbols carefully chosen to make them look very different on screen
- a = putChar 'a' >> a
- b = putChar 'B' >> b
-
--- test blocking of two processes on the same variable.
--- may print "aXbY{Deadlock}" or "aYbX{Deadlock}"
-test9 = do
- { x <- newEmptyMVar
- ; ack <- newEmptyMVar
- ; forkIO (get x >> put ack 'X')
- ; forkIO (get x >> put ack 'Y')
- ; put x 'a' >> get ack -- use up one reader
- ; put x 'b' >> get ack -- use up the other
- ; put x 'c' >> get ack -- deadlock
- }
-
-put v x =
- putMVar v x
-
-get v =
- takeMVar v >>= \ x ->
- putChar x
+++ /dev/null
-test1
-test3
-test4
-test5
+++ /dev/null
-Reading file "Concurrent.lhs":
-Reading file "ChannelVar.lhs":
-Reading file "PrelConc.hs":
-Reading file "ChannelVar.lhs":
-Reading file "Channel.lhs":
-Reading file "Semaphore.lhs":
-Reading file "Merge.lhs":
-Reading file "SampleVar.lhs":
-Reading file "Concurrent.lhs":
-Reading file "test/exts/mvar.hs":
-Type :? for help
-Hugs:a{Deadlock}
-Hugs:a
-Hugs:ab
-Hugs:Program error: putMVar {full MVar}
-
+++ /dev/null
---!!! Testing Refs
-import IOExts
-
-a1 =
- newIORef 'a' >>= \ v ->
- readIORef v >>= \ x ->
- print x
-
-a2 =
- newIORef 'a' >>= \ v ->
- writeIORef v 'b' >>
- readIORef v >>= \ x ->
- print x
-
-a3 =
- newIORef 'a' >>= \ v1 ->
- newIORef 'a' >>= \ v2 ->
- print (v1 == v1, v1 == v2, v2 == v2)
-
-
+++ /dev/null
-a1
-a2
-a3
+++ /dev/null
-Reading file "IOExts.lhs":
-Reading file "ST.lhs":
-Reading file "Monad.hs":
-Reading file "ST.lhs":
-Reading file "IOExts.lhs":
-Reading file "test/exts/refs1.hs":
-Type :? for help
-Hugs:'a'
-
-Hugs:'b'
-
-Hugs:(True,False,True)
-
+++ /dev/null
---!!! Testing Mutvars
-
-import ST
-
--- Note: equivalent code of the form: show (runST (newSTRef 'a' ...))
--- won't typecheck under Hugs 1.01.
-
-a1 = show (runST prog)
- where
- prog :: ST s Char
- prog =
- newSTRef 'a' >>= \ v ->
- readSTRef v
-
-a2 = show (runST prog)
- where
- prog :: ST s Char
- prog =
- newSTRef 'a' >>= \ v ->
- writeSTRef v 'b' >>
- readSTRef v
-
-a3 = show (runST prog)
- where
- prog :: ST s (Bool,Bool,Bool)
- prog =
- newSTRef 'a' >>= \ v1 ->
- newSTRef 'a' >>= \ v2 ->
- return (v1 == v1, v1 == v2, v2 == v2)
-
+++ /dev/null
-a1
-a2
-a3
+++ /dev/null
-Reading file "ST.lhs":
-Reading file "Monad.hs":
-Reading file "ST.lhs":
-Reading file "test/exts/refs2.hs":
-Type :? for help
-Hugs:"'a'"
-Hugs:"'b'"
-Hugs:"(True,False,True)"
+++ /dev/null
---!!! Testing typechecking of runST
-module RunSTTest where
-
-import ST
-
-t1 = runST (return '1')
-
-t2 = runST (do
- v <- newSTRef '2'
- readSTRef v
- )
-
+++ /dev/null
-Reading file "ST.lhs":
-Reading file "Monad.hs":
-Reading file "ST.lhs":
-Reading file "test/exts/refs3.hs":
-Type :? for help
-Hugs:'1'
-Hugs:'2'
+++ /dev/null
-#!/usr/bin/perl
-#! /usr/local/bin/perl
-#
-# Given:
-# * a program to run (1st arg)
-# * some "command-line opts" ( -O<opt1> -O<opt2> ... )
-# [default: anything on the cmd line this script doesn't recognise ]
-# the first opt not starting w/ "-" is taken to be an input
-# file and (if it exists) is grepped for "what's going on here"
-# comments (^--!!!).
-# * a file to feed to stdin ( -i<file> ) [default: $dev_null ]
-# * a "time" command to use (-t <cmd>).
-# * a "start" line (-s <line>) - all preceeding lines of output
-# * are ignored (from stdout).
-# * a "start" pattern (-f <regexp>) - all preceeding lines of output
-# * are deleted (from stdout).
-# * an "end" pattern (-l <regexp>) - all later lines of output
-# * are deleted (from stdout).
-#
-# * alternatively, a "-script <script>" argument says: run the
-# named Bourne-shell script to do the test. It's passed the
-# pgm-to-run as the one-and-only arg.
-#
-# Run the program with those options and that input, and check:
-# if we get...
-#
-# * an expected exit status ( -x <val> ) [ default 0 ]
-# * expected output on stdout ( -o1 <file> ) [ default $dev_null ]
-# ( we'll accept one of several...)
-# * expected output on stderr ( -o2 <file> ) [ default $dev_null ]
-# ( we'll accept one of several...)
-#
-# (if the expected-output files' names end in .Z, then
-# they are uncompressed before doing the comparison)
-#
-# (This is supposed to be a "prettier" replacement for runstdtest.)
-#
-
-die "$0 requires perl 5.0 or higher" unless $] >= 5.0;
-
-($Pgm = $0) =~ s|.*/||;
-
-$tmpdir = &fromEnv('TMPDIR',"/tmp");
-$shell = "/bin/sh";
-$cmp = "diff -q";
-$diff = &fromEnv('CONTEXT_DIFF',"diff -c1");
-$dev_null = &fromEnv('DEV_NULL',"/dev/null");
-
-$Verbose = 0;
-$Status = 0;
-@PgmArgs = ();
-$PgmExitStatus = 0;
-$PgmStdinFile = $dev_null;
-$DefaultStdoutFile = "${tmpdir}/no_stdout$$"; # can't use $dev_null (e.g. Alphas)
-$DefaultStderrFile = "${tmpdir}/no_stderr$$";
-@PgmStdoutFile = ();
-@PgmStderrFile = ();
-$PgmStartLine = 0;
-$PgmStartPat = '.';
-$PgmEndPat = 'WILLNAEMATCH'; # hack!
-$AltScript = '';
-$TimeCmd = '';
-
-die "$Pgm: program to run not given as first argument\n" if $#ARGV < 0;
-$ToRun = $ARGV[0]; shift(@ARGV);
-# avoid picking up same-named thing from somewhere else on $PATH...
-$ToRun = "./$ToRun" if $ToRun !~ /^\//;
-
-arg: while ($_ = $ARGV[0]) {
- shift(@ARGV);
-
- /^-v$/ && do { $Verbose = 1; next arg; };
- /^-O(.*)/ && do { push(@PgmArgs, &grab_arg_arg('-O',$1)); next arg; };
- /^-i(.*)/ && do { $PgmStdinFile = &grab_arg_arg('-i',$1);
- $Status++,
- print STDERR "$Pgm: bogus -i input file: $PgmStdinFile\n"
- if ! -f $PgmStdinFile;
- next arg; };
- /^-x(.*)/ && do { $PgmExitStatus = &grab_arg_arg('-x',$1);
- $Status++ ,
- print STDERR "$Pgm: bogus -x expected exit status: $PgmExitStatus\n"
- if $PgmExitStatus !~ /^\d+$/;
- next arg; };
- /^-s(.*)/ && do { $PgmStartLine = &grab_arg_arg('-x',$1);
- $Status++ ,
- print STDERR "$Pgm: bogus -s start line: $PgmStartLine\n"
- if $PgmStartLine !~ /^\d+$/;
- next arg; };
- /^-f(.*)/ && do { $PgmStartPat = &grab_arg_arg('-f',$1);
- next arg; };
- /^-l(.*)/ && do { $PgmEndPat = &grab_arg_arg('-l',$1);
- next arg; };
- /^-o1(.*)/ && do { $out_file = &grab_arg_arg('-o1',$1);
- $Status++ ,
- print STDERR "$Pgm: bogus -o1 expected-output file: $out_file\n"
- if ! -f $out_file;
- push(@PgmStdoutFile, $out_file);
- next arg; };
- /^-o2(.*)/ && do { $out_file = &grab_arg_arg('-o2',$1);
- $Status++,
- print STDERR "$Pgm: bogus -o2 expected-stderr file: $out_file\n"
- if ! -f $out_file;
- push(@PgmStderrFile, $out_file);
- next arg; };
- /^-script(.*)/ && do { $AltScript = &grab_arg_arg('-script',$1);
- next arg; };
- /^-t(.*)/ && do { $TimeCmd = &grab_arg_arg('-t', $1); next arg; };
-
- # anything else is taken to be a pgm arg
- push(@PgmArgs, $_);
-}
-exit 1 if $Status;
-
-# add on defaults if none specified
-@PgmStdoutFile = ( $DefaultStdoutFile ) if $#PgmStdoutFile < 0;
-@PgmStderrFile = ( $DefaultStderrFile ) if $#PgmStderrFile < 0;
-
-# tidy up the pgm args:
-# (1) look for the "first input file"
-# and grep it for "interesting" comments (--!!! )
-# (2) quote any args w/ whitespace in them.
-$grep_done = 0;
-foreach $a ( @PgmArgs ) {
- if (! $grep_done && $a !~ /^-/ && -f $a) {
- unless (open(ARG, $a)) {
- print STDERR "Can't open $a: $!\n";
- exit 1;
- }
- while (<ARG>) {
- print if /^--!!!/;
- }
- close(ARG);
- $grep_done = 1;
- }
- if ($a =~ /\s/ || $a =~ /'/) {
- $a =~ s/'/\\'/g; # backslash the quotes;
- $a =~ s/"/\\"/g; # backslash the quotes;
- $a = "\"$a\""; # quote the arg
- }
-}
-
-if ($AltScript ne '') {
- local($to_do);
- $to_do = `cat $AltScript`;
- # glue in pgm to run...
- $* = 1;
- $to_do =~ s/^\$1 /$ToRun /;
- &run_something($to_do);
- exit 0;
-# exec "$AltScript $ToRun";
-# print STDERR "Failed to exec!!! $AltScript $ToRun\n";
-# exit 1;
-}
-
-# OK, so we're gonna do the normal thing...
-
-$Script = <<EOSCRIPT;
-CONTEXT_DIFF='/usr/bin/diff -C 1'
-export CONTEXT_DIFF
-DEV_NULL='/dev/null'
-export DEV_NULL
-myexit=0
-diffsShown=0
-/bin/rm -f $DefaultStdoutFile $DefaultStderrFile
-cat $dev_null > $DefaultStdoutFile
-cat $dev_null > $DefaultStderrFile
-$TimeCmd ${shell} -c \'$ToRun @PgmArgs < $PgmStdinFile 1> ${tmpdir}/runtest$$.1 2> ${tmpdir}/runtest$$.2\'
-progexit=\$?
-if [ \$progexit -ne $PgmExitStatus ]; then
- echo $ToRun @PgmArgs \\< $PgmStdinFile
- echo expected exit status $PgmExitStatus not seen \\; got \$progexit
- myexit=1
-else
- # Pipe that filters out stuff we don't want to check
- tail +$PgmStartLine ${tmpdir}/runtest$$.1 | test/after "$PgmStartPat" | test/before "$PgmEndPat" >${tmpdir}/runtest$$.3
-
- for out_file in @PgmStdoutFile ; do
- $diff \$out_file ${tmpdir}/runtest$$.3 > ${tmpdir}/diffs$$
- if [ \$? -ne 0 ]; then
- echo $ToRun @PgmArgs \\< $PgmStdinFile
- echo expected stdout not matched by reality
- cat ${tmpdir}/diffs$$
- myexit=1
- fi
- /bin/rm -f ${tmpdir}/diffs$$
- done
-fi
-for out_file in @PgmStderrFile ; do
- $diff \$out_file ${tmpdir}/runtest$$.2 > ${tmpdir}/diffs$$
- if [ \$? -ne 0 ]; then
- echo $ToRun @PgmArgs \\< $PgmStdinFile
- echo expected stderr not matched by reality
- cat ${tmpdir}/diffs$$
- myexit=1
- fi
- /bin/rm -f ${tmpdir}/diffs$$
-done
-/bin/rm -f core $DefaultStdoutFile $DefaultStderrFile ${tmpdir}/runtest$$.1 ${tmpdir}/runtest$$.3 ${tmpdir}/runtest$$.2
-exit \$myexit
-EOSCRIPT
-
-&run_something($Script);
-# print $Script if $Verbose;
-# open(SH, "| ${shell}") || die "Can't open shell pipe\n";
-# print SH $Script;
-# close(SH);
-
-exit 0;
-
-sub fromEnv {
- local($varname,$default) = @_;
- local($val) = $ENV{$varname};
- $val = $default if $val eq "";
- return $val;
-}
-
-sub grab_arg_arg {
- local($option, $rest_of_arg) = @_;
-
- if ($rest_of_arg) {
- return($rest_of_arg);
- } elsif ($#ARGV >= 0) {
- local($temp) = $ARGV[0]; shift(@ARGV);
- return($temp);
- } else {
- print STDERR "$Pgm: no argument following $option option\n";
- $Status++;
- }
-}
-
-sub run_something {
- local($str_to_do) = @_;
-
- print STDERR "$str_to_do\n" if $Verbose;
-
- local($return_val) = 0;
-
- # On Windows NT, we have to build a file before we can interpret it.
- local($scriptfile) = "./script$$";
- open(FOO,">$scriptfile") || die "Can't create script $scriptfile";
- print FOO $str_to_do;
- close FOO;
-
- system("sh $scriptfile");
- $return_val = $?;
- system("rm $scriptfile");
-
- if ($return_val != 0) {
-#ToDo: this return-value mangling is wrong
-# local($die_msg) = "$Pgm: execution of the $tidy_name had trouble";
-# $die_msg .= " (program not found)" if $return_val == 255;
-# $die_msg .= " ($!)" if $Verbose && $! != 0;
-# $die_msg .= "\n";
-
- exit (($return_val == 0) ? 0 : 1);
- }
-}
+++ /dev/null
-#! /usr/bin/perl
-
-foreach $file (@ARGV) {
- ($base = $file) =~ s/\.l?hs$//;
-
- $cmd = "perl test/runstdtest hugs +q -w -h300k -pHugs: -f\"$file\" -l\"Leaving Hugs\"";
-
- die "Yoiks, file \"$file\" doesn't exist" unless -f "$file";
- $cmd .= " -O$file";
-
- $cmd .= " -i$base.in1" if (-f "$base.in1");
- $cmd .= " -o1$base.out1" if (-f "$base.out1");
- $cmd .= " -o2$base.out2" if (-f "$base.out2");
-
- # print "$cmd\n";
- system($cmd);
-}
-
-exit 0;
+++ /dev/null
-#! /usr/bin/perl -i.bak
-
-while (<>) {
- # Insert header line
- if ($ARGV ne $oldargv) {
- $ARGV =~ /\d+/;
- $filenum = $&;
- print <<EOTXT;
-Reading file "test/runtime/r$filenum.hs":
-EOTXT
- $oldargv = $ARGV;
- }
-
- # Make this script idempotent
- next if /^Reading file "test\/runtime\/r\d+\.hs":/;
-
- # Fix error messages
- s#test/[A-Za-z]+\d+\.hs#test/runtime/r$filenum.hs#g;
-
- # Delete trailing line
- s/^Hugs:\[Leaving Hugs\]\n//;
-
- print;
-}
+++ /dev/null
-----------------------------------------------------------------
--- Testing runtime system.
--- This group of checks will produce 12-16 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- It may also produce output that looks like this:
---
--- ./hugs +q -pHugs: test/???.hs < test/???.input
--- expected stdout not matched by reality
--- *** test/???.output Fri Jul 11 13:25:27 1997
--- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
--- ***************
--- *** 1,3 ****
--- ...
--- | Hugs:\"[0.0, 0.304693, 0.643501, 1.5708]\"
--- ...
--- --- 1,3 ----
--- ...
--- | Hugs:\"[0.0, 0.30469323452, 0.643503234321, 1.5708234234]\"
--- ...
---
--- This is harmless and reflects variations in the accuracy of floating
--- point representation, calculations and printing.
---
--- You should report a problem if any other output is generated or if
--- the size of the floating point errors seem excessively large.
-----------------------------------------------------------------
+++ /dev/null
---!!! Testing bignums
-
--- Note: anything which prints an Integer automatically tests
--- quotRem.
-
-egs1 = [-5..5] :: [Integer]
-egs2 = filter (/=0) egs1 -- avoid division by zero
-
-t0 = (1::Integer) == (1::Integer)
-
-t1 = shw $ table (+) egs1 egs1
-t2 = shw $ table (-) egs1 egs1
-t3 = shw $ table (*) egs1 egs1
-
-t4 = shw $ table div egs1 egs2
-t5 = shw $ table mod egs1 egs2
-t6 = shw $ table quot egs1 egs2
-t7 = shw $ table rem egs1 egs2
-
-u1 = shw $ table (==) egs1 egs1
-u2 = shw $ table (/=) egs1 egs1
-u3 = shw $ table (<=) egs1 egs1
-u4 = shw $ table (<) egs1 egs1
-u5 = shw $ table (>) egs1 egs1
-u6 = shw $ table (>=) egs1 egs1
-
-
--- The implementation is based on 4 digit chunks - so let's test
--- the results when we use values near those boundaries.
-
-egs3 = [9999,10000,10001,99999999,100000000,100000001] :: [Integer]
-egs4 = filter (/=0) egs3 -- avoid division by zero
-
-v1 = shw $ table (+) egs3 egs3
-v2 = shw $ table (-) egs3 egs3
-v3 = shw $ table (*) egs3 egs3
-
-v4 = shw $ table div egs3 egs4
-v5 = shw $ table mod egs3 egs4
-v6 = shw $ table quot egs3 egs4
-v7 = shw $ table rem egs3 egs4
-
-w1 = shw $ table (==) egs3 egs3
-w2 = shw $ table (/=) egs3 egs3
-w3 = shw $ table (<=) egs3 egs3
-w4 = shw $ table (<) egs3 egs3
-w5 = shw $ table (>) egs3 egs3
-w6 = shw $ table (>=) egs3 egs3
-
--- Some utilities for generating neat tables of test results
-table :: (a -> a -> b) -> [a] -> [a] -> [[b]]
-table f xs ys = [ [ x `f` y | x <- xs ] | y <- ys ]
-
-shw :: Show a => [[a]] -> IO ()
-shw = putStr . unlines . map (unwords . map show)
-
+++ /dev/null
-t0
-t1
-t2
-t3
-t4
-t5
-t6
-t7
-
-u1
-u2
-u3
-u4
-u5
-u6
-
-v1
-v2
-v3
-v4
-v5
-v6
-v7
-
-w1
-w2
-w3
-w4
-w5
-w6
-
+++ /dev/null
-Type :? for help
-Hugs:True
-Hugs:-10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0
--9 -8 -7 -6 -5 -4 -3 -2 -1 0 1
--8 -7 -6 -5 -4 -3 -2 -1 0 1 2
--7 -6 -5 -4 -3 -2 -1 0 1 2 3
--6 -5 -4 -3 -2 -1 0 1 2 3 4
--5 -4 -3 -2 -1 0 1 2 3 4 5
--4 -3 -2 -1 0 1 2 3 4 5 6
--3 -2 -1 0 1 2 3 4 5 6 7
--2 -1 0 1 2 3 4 5 6 7 8
--1 0 1 2 3 4 5 6 7 8 9
-0 1 2 3 4 5 6 7 8 9 10
-
-Hugs:0 1 2 3 4 5 6 7 8 9 10
--1 0 1 2 3 4 5 6 7 8 9
--2 -1 0 1 2 3 4 5 6 7 8
--3 -2 -1 0 1 2 3 4 5 6 7
--4 -3 -2 -1 0 1 2 3 4 5 6
--5 -4 -3 -2 -1 0 1 2 3 4 5
--6 -5 -4 -3 -2 -1 0 1 2 3 4
--7 -6 -5 -4 -3 -2 -1 0 1 2 3
--8 -7 -6 -5 -4 -3 -2 -1 0 1 2
--9 -8 -7 -6 -5 -4 -3 -2 -1 0 1
--10 -9 -8 -7 -6 -5 -4 -3 -2 -1 0
-
-Hugs:25 20 15 10 5 0 -5 -10 -15 -20 -25
-20 16 12 8 4 0 -4 -8 -12 -16 -20
-15 12 9 6 3 0 -3 -6 -9 -12 -15
-10 8 6 4 2 0 -2 -4 -6 -8 -10
-5 4 3 2 1 0 -1 -2 -3 -4 -5
-0 0 0 0 0 0 0 0 0 0 0
--5 -4 -3 -2 -1 0 1 2 3 4 5
--10 -8 -6 -4 -2 0 2 4 6 8 10
--15 -12 -9 -6 -3 0 3 6 9 12 15
--20 -16 -12 -8 -4 0 4 8 12 16 20
--25 -20 -15 -10 -5 0 5 10 15 20 25
-
-Hugs:1 0 0 0 0 0 -1 -1 -1 -1 -1
-1 1 0 0 0 0 -1 -1 -1 -1 -2
-1 1 1 0 0 0 -1 -1 -1 -2 -2
-2 2 1 1 0 0 -1 -1 -2 -2 -3
-5 4 3 2 1 0 -1 -2 -3 -4 -5
--5 -4 -3 -2 -1 0 1 2 3 4 5
--3 -2 -2 -1 -1 0 0 1 1 2 2
--2 -2 -1 -1 -1 0 0 0 1 1 1
--2 -1 -1 -1 -1 0 0 0 0 1 1
--1 -1 -1 -1 -1 0 0 0 0 0 1
-
-Hugs:0 -4 -3 -2 -1 0 -4 -3 -2 -1 0
--1 0 -3 -2 -1 0 -3 -2 -1 0 -3
--2 -1 0 -2 -1 0 -2 -1 0 -2 -1
--1 0 -1 0 -1 0 -1 0 -1 0 -1
-0 0 0 0 0 0 0 0 0 0 0
-0 0 0 0 0 0 0 0 0 0 0
-1 0 1 0 1 0 1 0 1 0 1
-1 2 0 1 2 0 1 2 0 1 2
-3 0 1 2 3 0 1 2 3 0 1
-0 1 2 3 4 0 1 2 3 4 0
-
-Hugs:1 0 0 0 0 0 0 0 0 0 -1
-1 1 0 0 0 0 0 0 0 -1 -1
-1 1 1 0 0 0 0 0 -1 -1 -1
-2 2 1 1 0 0 0 -1 -1 -2 -2
-5 4 3 2 1 0 -1 -2 -3 -4 -5
--5 -4 -3 -2 -1 0 1 2 3 4 5
--2 -2 -1 -1 0 0 0 1 1 2 2
--1 -1 -1 0 0 0 0 0 1 1 1
--1 -1 0 0 0 0 0 0 0 1 1
--1 0 0 0 0 0 0 0 0 0 1
-
-Hugs:0 -4 -3 -2 -1 0 1 2 3 4 0
--1 0 -3 -2 -1 0 1 2 3 0 1
--2 -1 0 -2 -1 0 1 2 0 1 2
--1 0 -1 0 -1 0 1 0 1 0 1
-0 0 0 0 0 0 0 0 0 0 0
-0 0 0 0 0 0 0 0 0 0 0
--1 0 -1 0 -1 0 1 0 1 0 1
--2 -1 0 -2 -1 0 1 2 0 1 2
--1 0 -3 -2 -1 0 1 2 3 0 1
-0 -4 -3 -2 -1 0 1 2 3 4 0
-
-Hugs:Hugs:True False False False False False False False False False False
-False True False False False False False False False False False
-False False True False False False False False False False False
-False False False True False False False False False False False
-False False False False True False False False False False False
-False False False False False True False False False False False
-False False False False False False True False False False False
-False False False False False False False True False False False
-False False False False False False False False True False False
-False False False False False False False False False True False
-False False False False False False False False False False True
-
-Hugs:False True True True True True True True True True True
-True False True True True True True True True True True
-True True False True True True True True True True True
-True True True False True True True True True True True
-True True True True False True True True True True True
-True True True True True False True True True True True
-True True True True True True False True True True True
-True True True True True True True False True True True
-True True True True True True True True False True True
-True True True True True True True True True False True
-True True True True True True True True True True False
-
-Hugs:True False False False False False False False False False False
-True True False False False False False False False False False
-True True True False False False False False False False False
-True True True True False False False False False False False
-True True True True True False False False False False False
-True True True True True True False False False False False
-True True True True True True True False False False False
-True True True True True True True True False False False
-True True True True True True True True True False False
-True True True True True True True True True True False
-True True True True True True True True True True True
-
-Hugs:False False False False False False False False False False False
-True False False False False False False False False False False
-True True False False False False False False False False False
-True True True False False False False False False False False
-True True True True False False False False False False False
-True True True True True False False False False False False
-True True True True True True False False False False False
-True True True True True True True False False False False
-True True True True True True True True False False False
-True True True True True True True True True False False
-True True True True True True True True True True False
-
-Hugs:False True True True True True True True True True True
-False False True True True True True True True True True
-False False False True True True True True True True True
-False False False False True True True True True True True
-False False False False False True True True True True True
-False False False False False False True True True True True
-False False False False False False False True True True True
-False False False False False False False False True True True
-False False False False False False False False False True True
-False False False False False False False False False False True
-False False False False False False False False False False False
-
-Hugs:True True True True True True True True True True True
-False True True True True True True True True True True
-False False True True True True True True True True True
-False False False True True True True True True True True
-False False False False True True True True True True True
-False False False False False True True True True True True
-False False False False False False True True True True True
-False False False False False False False True True True True
-False False False False False False False False True True True
-False False False False False False False False False True True
-False False False False False False False False False False True
-
-Hugs:Hugs:19998 19999 20000 100009998 100009999 100010000
-19999 20000 20001 100009999 100010000 100010001
-20000 20001 20002 100010000 100010001 100010002
-100009998 100009999 100010000 199999998 199999999 200000000
-100009999 100010000 100010001 199999999 200000000 200000001
-100010000 100010001 100010002 200000000 200000001 200000002
-
-Hugs:0 1 2 99990000 99990001 99990002
--1 0 1 99989999 99990000 99990001
--2 -1 0 99989998 99989999 99990000
--99990000 -99989999 -99989998 0 1 2
--99990001 -99990000 -99989999 -1 0 1
--99990002 -99990001 -99990000 -2 -1 0
-
-Hugs:99980001 99990000 99999999 999899990001 999900000000 999900009999
-99990000 100000000 100010000 999999990000 1000000000000 1000000010000
-99999999 100010000 100020001 1000099989999 1000100000000 1000100010001
-999899990001 999999990000 1000099989999 9999999800000001 9999999900000000 9999999999999999
-999900000000 1000000000000 1000100000000 9999999900000000 10000000000000000 10000000100000000
-999900009999 1000000010000 1000100010001 9999999999999999 10000000100000000 10000000200000001
-
-Hugs:1 1 1 10001 10001 10001
-0 1 1 9999 10000 10000
-0 0 1 9999 9999 9999
-0 0 0 1 1 1
-0 0 0 0 1 1
-0 0 0 0 0 1
-
-Hugs:0 1 2 0 1 2
-9999 0 1 9999 0 1
-9999 10000 0 0 1 2
-9999 10000 10001 0 1 2
-9999 10000 10001 99999999 0 1
-9999 10000 10001 99999999 100000000 0
-
-Hugs:1 1 1 10001 10001 10001
-0 1 1 9999 10000 10000
-0 0 1 9999 9999 9999
-0 0 0 1 1 1
-0 0 0 0 1 1
-0 0 0 0 0 1
-
-Hugs:0 1 2 0 1 2
-9999 0 1 9999 0 1
-9999 10000 0 0 1 2
-9999 10000 10001 0 1 2
-9999 10000 10001 99999999 0 1
-9999 10000 10001 99999999 100000000 0
-
-Hugs:Hugs:True False False False False False
-False True False False False False
-False False True False False False
-False False False True False False
-False False False False True False
-False False False False False True
-
-Hugs:False True True True True True
-True False True True True True
-True True False True True True
-True True True False True True
-True True True True False True
-True True True True True False
-
-Hugs:True False False False False False
-True True False False False False
-True True True False False False
-True True True True False False
-True True True True True False
-True True True True True True
-
-Hugs:False False False False False False
-True False False False False False
-True True False False False False
-True True True False False False
-True True True True False False
-True True True True True False
-
-Hugs:False True True True True True
-False False True True True True
-False False False True True True
-False False False False True True
-False False False False False True
-False False False False False False
-
-Hugs:True True True True True True
-False True True True True True
-False False True True True True
-False False False True True True
-False False False False True True
-False False False False False True
-
+++ /dev/null
---!!! Testing Enum
-
-module TestEnum where
-
--- test for derived instances
-
-data T = C1 | C2 | C3 | C4 | C5 | C6 | C7 deriving (Eq, Ord, Enum, Show)
-
-test1 = show $ [C1 .. ]
-test2 = show $ [C1 .. C4]
-test3 = show $ [C1, C3 ..]
-test4 = show $ [C1, C3 .. C6]
-test5 = show $ [C7, C5 .. ]
-test6 = show $ [C7, C5 .. C2]
-test7 = show $ map fromEnum [C1 .. ]
-test8 = show (map toEnum [0..6] :: [T])
-
-test9 = show (toEnum (-1) :: T) -- should fail
-test10 = show (toEnum 7 :: T) -- should fail
-
-test11 = show $ take 7 (iterate succ C1)
-test12 = show $ take 7 (iterate pred C7)
-
-test13 = show $ succ C7 -- should fail
-test14 = show $ pred C1 -- should fail
-
--- test for built in Enum instances
-
-test20 = show $ ['a' ..]
-test21 = show $ ['a' ..'z']
-test22 = show $ ['a', 'd' ..]
-test23 = show $ ['a', 'd' .. 'z']
-test24 = show $ ['z','y'..'a']
-test25 = show $ map fromEnum ['a' ..]
-test26 = show $ map fromEnum ['a', 'd' ..]
-test27 = show $ map fromEnum ['a'..'z']
-test28 = show (map toEnum [fromEnum 'a'..fromEnum 'z'] :: [Char])
-
-test30 = show (take 50 $ [1..]::[Int])
-test31 = show ([1..10]::[Int])
-test32 = show (take 50 $ [1, 3 ..]::[Int])
-test33 = show ([1, 3 .. 10]::[Int])
-test34 = show ([10,9..1]::[Int])
-test35 = show (map fromEnum [1..10]::[Int])
-test36 = show (map toEnum [fromEnum 1..fromEnum 10]::[Int])
-
-
-test40 = show (take 50 $ [1..]::[Integer])
-test41 = show ([1..10]::[Integer])
-test42 = show (take 50 $ [1, 3 ..]::[Integer])
-test43 = show ([1, 3 .. 10]::[Integer])
-test44 = show ([10,9..1]::[Integer])
-test45 = show (map fromEnum [1..10]::[Int])
-test46 = show (map toEnum [fromEnum 1..fromEnum 10]::[Integer])
-
--- All these tests use integers because roundoff errors have
--- such bizarre effects on the printed number.
-test50 = show (take 50 $ [1..]::[Float])
-test51 = show ([1..10]::[Float])
-test52 = show (take 50 $ [1, 2 ..]::[Float])
-test53 = show ([1, 2 .. 20]::[Float])
-test54 = show ([20,19..10]::[Float])
-test55 = show (map fromEnum ([1..10]::[Float]))
-test56 = show (map toEnum [fromEnum 1..fromEnum 10]::[Float])
-
-
-test60 = show (take 50 $ [1..]::[Double])
-test61 = show ([1..10]::[Double])
-test62 = show (take 50 $ [1, 2 ..]::[Double])
-test63 = show ([1, 2 .. 20]::[Double])
-test64 = show ([20,19..10]::[Double])
-test65 = show (map fromEnum ([1..10]::[Double]))
-test66 = show (map toEnum [fromEnum 1..fromEnum 10]::[Double])
-
-
-
+++ /dev/null
-test1
-test2
-test3
-test4
-test5
-test6
-test7
-test8
-test9
-test10
-test11
-test12
-test13
-test14
-
-test20
-test21
-test22
-test23
-test24
-test25
-test26
-test27
-test28
-
-test30
-test31
-test32
-test33
-test34
-test35
-test36
-
-test40
-test41
-test42
-test43
-test44
-test45
-test46
-
-test50
-test51
-test52
-test53
-test54
-test55
-test56
-
-test60
-test61
-test62
-test63
-test64
-test65
-test66
-
+++ /dev/null
-Type :? for help
-Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
-Hugs:"[C1,C2,C3,C4]"
-Hugs:"[C1,C3,C5,C7]"
-Hugs:"[C1,C3,C5]"
-Hugs:"[C7,C5,C3,C1]"
-Hugs:"[C7,C5,C3]"
-Hugs:"[0,1,2,3,4,5,6]"
-Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
-Hugs:"
-Program error: out-of-range arg for `toEnum' in (derived) `instance Enum T'
-
-Hugs:"
-Program error: out-of-range arg for `toEnum' in (derived) `instance Enum T'
-
-Hugs:"[C1,C2,C3,C4,C5,C6,C7]"
-Hugs:"[C7,C6,C5,C4,C3,C2,C1]"
-Hugs:"
-Program error: out-of-range arg for `toEnum' in (derived) `instance Enum T'
-
-Hugs:"
-Program error: out-of-range arg for `toEnum' in (derived) `instance Enum T'
-
-Hugs:Hugs:"\"abcdefghijklmnopqrstuvwxyz{|}~\\DEL\\128\\129\\130\\131\\132\\133\\134\\135\\136\\137\\138\\139\\140\\141\\142\\143\\144\\145\\146\\147\\148\\149\\150\\151\\152\\153\\154\\155\\156\\157\\158\\159\\160\\161\\162\\163\\164\\165\\166\\167\\168\\169\\170\\171\\172\\173\\174\\175\\176\\177\\178\\179\\180\\181\\182\\183\\184\\185\\186\\187\\188\\189\\190\\191\\192\\193\\194\\195\\196\\197\\198\\199\\200\\201\\202\\203\\204\\205\\206\\207\\208\\209\\210\\211\\212\\213\\214\\215\\216\\217\\218\\219\\220\\221\\222\\223\\224\\225\\226\\227\\228\\229\\230\\231\\232\\233\\234\\235\\236\\237\\238\\239\\240\\241\\242\\243\\244\\245\\246\\247\\248\\249\\250\\251\\252\\253\\254\\255\""
-Hugs:"\"abcdefghijklmnopqrstuvwxyz\""
-Hugs:"\"adgjmpsvy|\\DEL\\130\\133\\136\\139\\142\\145\\148\\151\\154\\157\\160\\163\\166\\169\\172\\175\\178\\181\\184\\187\\190\\193\\196\\199\\202\\205\\208\\211\\214\\217\\220\\223\\226\\229\\232\\235\\238\\241\\244\\247\\250\\253\""
-Hugs:"\"adgjmpsvy\""
-Hugs:"\"zyxwvutsrqponmlkjihgfedcba\""
-Hugs:"[97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255]"
-Hugs:"[97,100,103,106,109,112,115,118,121,124,127,130,133,136,139,142,145,148,151,154,157,160,163,166,169,172,175,178,181,184,187,190,193,196,199,202,205,208,211,214,217,220,223,226,229,232,235,238,241,244,247,250,253]"
-Hugs:"[97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122]"
-Hugs:"\"abcdefghijklmnopqrstuvwxyz\""
-Hugs:Hugs:"[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99]"
-Hugs:"[1,3,5,7,9]"
-Hugs:"[10,9,8,7,6,5,4,3,2,1]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:Hugs:"[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1,3,5,7,9,11,13,15,17,19,21,23,25,27,29,31,33,35,37,39,41,43,45,47,49,51,53,55,57,59,61,63,65,67,69,71,73,75,77,79,81,83,85,87,89,91,93,95,97,99]"
-Hugs:"[1,3,5,7,9]"
-Hugs:"[10,9,8,7,6,5,4,3,2,1]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0]"
-Hugs:"[20.0,19.0,18.0,17.0,16.0,15.0,14.0,13.0,12.0,11.0,10.0]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
-Hugs:Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0,21.0,22.0,23.0,24.0,25.0,26.0,27.0,28.0,29.0,30.0,31.0,32.0,33.0,34.0,35.0,36.0,37.0,38.0,39.0,40.0,41.0,42.0,43.0,44.0,45.0,46.0,47.0,48.0,49.0,50.0]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0,11.0,12.0,13.0,14.0,15.0,16.0,17.0,18.0,19.0,20.0]"
-Hugs:"[20.0,19.0,18.0,17.0,16.0,15.0,14.0,13.0,12.0,11.0,10.0]"
-Hugs:"[1,2,3,4,5,6,7,8,9,10]"
-Hugs:"[1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0,10.0]"
+++ /dev/null
---!!! Testing show minInt (interesting if minInt /= -maxInt)
-
-a1 = show (maxBound::Int)
-a2 = show (-maxBound::Int)
-a3 = show (minBound::Int)
+++ /dev/null
-a1
-a2
-a3
+++ /dev/null
-Type :? for help
-Hugs:"2147483647"
-Hugs:"-2147483647"
-Hugs:"-2147483648"
+++ /dev/null
--- test for derived Ord instances
-
-module TestOrd where
-
-data T = C1 | C2 deriving (Eq, Ord)
-
-cmps :: [T -> T -> Bool]
-cmps = [ (<), (<=), (==), (/=), (>=), (>) ]
-
--- kind of a reversed zipWith...
-rzipWith :: [a -> b -> c] -> a -> b -> [c]
-rzipWith fs a b = [ f a b | f <- fs ]
-
---!!! Testing derived Ord and Eq instances for enumeration type
-test1 = rzipWith cmps C1 C1 -- should be [F,T,T,F,T,F]
-test2 = rzipWith cmps C1 C2 -- should be [T,T,F,T,F,F]
-test3 = rzipWith cmps C2 C1 -- should be [F,F,F,T,T,T]
-
+++ /dev/null
-show test1
-show test2
-show test3
+++ /dev/null
-Type :? for help
-Hugs:"[False,True,True,False,True,False]"
-Hugs:"[True,True,False,True,False,False]"
-Hugs:"[False,False,False,True,True,True]"
+++ /dev/null
---!!! Testing Read (assuming that Eq, Show and Enum work!)
-
-module TestRead where
-
-import Ratio(Ratio,(%),Rational)
-import List(zip4,zip5,zip6,zip7)
-
--- test that expected equality holds
-tst :: (Read a, Show a, Eq a) => a -> Bool
-tst x = read (show x) == x
-
--- measure degree of error
-diff :: (Read a, Show a, Num a) => a -> a
-diff x = read (show x) - x
-
-----------------------------------------------------------------
--- test for hand-written instances
-----------------------------------------------------------------
-
-test1 = tst ()
-test2 = all tst [False,True]
-test3 = all tst [minBound::Char ..]
-test4 = all tst [Nothing, Just (Just True)]
-test5 = all tst [Left True, Right (Just True)]
-test6 = all tst [LT .. GT]
-test7 = all tst [[],['a'..'z'],['A'..'Z']]
-test8 = all tst $ [minBound,maxBound]
- ++ [-100..100 :: Int]
-test9 = all tst $ [(fromInt minBound)-1, (fromInt maxBound)+1]
- ++ [-100..100 :: Integer]
-
--- we don't test fractional Floats/Doubles because they don't work
-test10 = all tst $ [-100..100 :: Float]
-test11 = all tst $ [-100..100 :: Double]
-
-test12 = all tst $ [-2%2,-1%2,0%2,1%2,2%2]
- ++ [-10.0,-9.9..10.0 :: Ratio Int]
-test13 = all tst $ [-2%2,-1%2,0%2,1%2,2%2]
- ++ [-10.0,-9.9..10.0 :: Rational]
-
-----------------------------------------------------------------
--- test for derived instances
-----------------------------------------------------------------
-
--- Tuples
-
-test21 = all tst $ [-1..1]
-test22 = all tst $ zip [-1..1] [-1..1]
-test23 = all tst $ zip3 [-1..1] [-1..1] [-1..1]
-test24 = all tst $ zip4 [-1..1] [-1..1] [-1..1] [-1..1]
-test25 = all tst $ zip5 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
-{- Not derived automatically
-test26 = all tst $ zip6 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
-test27 = all tst $ zip7 [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1] [-1..1]
--}
-
--- Enumeration
-
-data T1 = C1 | C2 | C3 | C4 | C5 | C6 | C7
- deriving (Eq, Ord, Enum, Read, Show)
-
-test30 = all tst [C1 .. C7]
-
--- Records
-
-data T2 = A Int | B {x,y::Int, z::Bool} | C Bool
- deriving (Eq, Read, Show)
-
-test31 = all tst [A 1, B 1 2 True, C True]
-
--- newtype
-
-newtype T3 = T3 Int
- deriving (Eq, Read, Show)
-
-test32 = all tst [ T3 i | i <- [-10..10] ]
-
-----------------------------------------------------------------
--- Random tests for things which have failed in the past
-----------------------------------------------------------------
-
-test100 = read "(True)" :: Bool
-
-test101 = tst (pi :: Float)
-test102 = diff (pi :: Float)
-
-test103 = tst (pi :: Double)
-test104 = diff (pi :: Double)
-
-
-
+++ /dev/null
-"hand written instances"
-test1
-test2
-test3
-test4
-test5
-test6
-test7
-test8
-test9
-test10
-test11
-test12
-test13
-"derived instances - tuples"
-test21
-test22
-test23
-test24
-test25
-"derived instances - datatypes"
-test30
-test31
-test32
-"random assortment"
-test100
-test101
-test102
-test103
-test104
+++ /dev/null
-Reading file "List.hs":
-Reading file "test/runtime/r004.hs":
-Type :? for help
-Hugs:"hand written instances"
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:"derived instances - tuples"
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:"derived instances - datatypes"
-Hugs:True
-Hugs:True
-Hugs:True
-Hugs:"random assortment"
-Hugs:True
-Hugs:True
-Hugs:0.0
-Hugs:True
-Hugs:0.0
+++ /dev/null
---!!! Testing arithmetic operators
-
--- Int primitives
-
- -- standard show function will produce garbage for primMinInt
-test1 = show (1 + minBound::Int, minBound::Int)
-test2 = show (maxBound::Int)
-test3 = show $ (1 + 2::Int)
-test4 = show $ (1 - 2::Int)
-test5 = show $ (3 * 5::Int)
-test6 = show $ (-(10::Int))
-test7 = show $ (even (10::Int), even (11::Int))
-test8 = show $ (10 == (10::Int), 10 == (11::Int))
-test9 = show $ [ x `quotRem` (y::Int) | x <- [-5,0,5], y <- [-3,3] ]
-test10 = show $ [ x `divMod` (y::Int) | x <- [-5,0,5], y <- [-3,3] ]
-test11 = show $ 1 `quot` (0::Int)
-test12 = show $ 1 `rem` (0::Int)
-
--- Integer primitives
-
---test21 = show (1 + minBound::Integer, minBound::Integer)
---test22 = show (maxBound::Integer)
-test23 = show $ (1 + 2::Integer)
-test24 = show $ (1 - 2::Integer)
-test25 = show $ (3 * 5::Integer)
-test26 = show $ (-(10::Integer))
-test27 = show $ (even (10::Integer), even (11::Integer))
-test28 = show $ (10 == (10::Integer), 10 == (11::Integer))
-test29 = show $ [ x `quotRem` (y::Integer) | x <- [-5,0,5], y <- [-3,3] ]
-test30 = show $ [ x `divMod` (y::Integer) | x <- [-5,0,5], y <- [-3,3] ]
-test31 = show $ 1 `quot` (0::Integer)
-test32 = show $ 1 `rem` (0::Integer)
-
--- Float primitives
-
---test41 = show (1 + minBound::Float, minBound::Float)
---test42 = show (maxBound::Float)
-test43 = show $ (1 + 2::Float)
-test44 = show $ (1 - 2::Float)
-test45 = show $ (3 * 5::Float)
-test46 = show $ (-(10::Float))
-test47 = show $ (10 == (10::Float), 10 == (11::Float))
-test48 = show $ [ x / (y::Float) | x <- [-5,0,5], y <- [-3,3] ]
-test49 = show $ 1 / (0::Float)
-
-test50 = show $ (pi::Float)
-test51 = show $ map sin [0.0, 0.3, 0.6, 1.0::Float]
-test52 = show $ map cos [0.0, 0.3, 0.6, 1.0::Float]
-test53 = show $ map tan [0.0, 0.3, 0.6, 1.0::Float]
-test54 = show $ map asin [0.0, 0.3, 0.6, 1.0::Float]
-test55 = show $ map acos [0.0, 0.3, 0.6, 1.0::Float]
-test56 = show $ map atan [0.0, 0.3, 0.6, 1.0::Float]
-test57 = show $ map exp [0.0, 0.3, 0.6, 1.0::Float]
-
-test58 = show $ map log [0.3, 0.6, 1.0, 10.0::Float]
-test59 = show $ log 0.0
-
---primitive primLog10Float "primLog10Float" :: Float -> Float
---test60 = show $ map primLog10Float [0.3, 0.6, 1.0, 10.0]
---test61 = show $ primLog10Float 0.0
-
-test62 = show $ map sqrt [0.0, 0.3, 0.6, 1.0::Float]
-test63 = show $ sqrt (-1.0::Float)
-
--- not in Hugs prelude, rounds towards zero
---primitive primFloatToInt "primFloatToInt" :: Float -> Int
---test64 = show $ map primFloatToInt [-2,-1.6,-1.5,-1.4,-1,0,1,2.0,2.4,2.5,2.6,pi,10]
-
-test65 = show $ floatDigits (1.0 :: Float)
-test66 = show $ floatDigits (error "test66" :: Float) -- laziness check
-
-test67 = show $ floatRange (1.0 :: Float)
-test68 = show $ floatRange (error "test68" :: Float) -- laziness check
-
-test69 = show $ floatRadix (1.0 :: Float)
-test70 = show $ floatRadix (error "test70" :: Float) -- laziness check
-
-
-
--- Double primitives
-
---test81 = show (1 + minBound::Double, minBound::Double)
---test82 = show (maxBound::Double)
-test83 = show $ (1 + 2::Double)
-test84 = show $ (1 - 2::Double)
-test85 = show $ (3 * 5::Double)
-test86 = show $ (-(10::Double))
-test87 = show $ (10 == (10::Double), 10 == (11::Double))
-test88 = show $ [ x / (y::Double) | x <- [-5,0,5], y <- [-3,3] ]
-test89 = show $ 1 / (0::Double)
-
-test90 = show $ (pi::Double)
-test91 = show $ map sin [0.0, 0.3, 0.6, 1.0::Double]
-test92 = show $ map cos [0.0, 0.3, 0.6, 1.0::Double]
-test93 = show $ map tan [0.0, 0.3, 0.6, 1.0::Double]
-test94 = show $ map asin [0.0, 0.3, 0.6, 1.0::Double]
-test95 = show $ map acos [0.0, 0.3, 0.6, 1.0::Double]
-test96 = show $ map atan [0.0, 0.3, 0.6, 1.0::Double]
-test97 = show $ map exp [0.0, 0.3, 0.6, 1.0::Double]
-
-test98 = show $ map log [0.3, 0.6, 1.0, 10.0::Double]
-test99 = show $ log 0.0
-
---primitive primLog10Double "primLog10Double" :: Double -> Double
---test100 = show $ map primLog10Double [0.3, 0.6, 1.0, 10.0]
---test101 = show $ primLog10Double 0.0
-
-test102 = show $ map sqrt [0.0, 0.3, 0.6, 1.0::Double]
-test103 = show $ sqrt (-1.0::Double)
-
--- not in Hugs prelude, rounds towards zero
---primitive primDoubleToInt "primDoubleToInt" :: Double -> Int
---test104 = show $ map primDoubleToInt [-2,-1.6,-1.5,-1.4,-1,0,1,2.0,2.4,2.5,2.6,pi,10]
-
-test105 = show $ floatDigits (1.0 :: Double)
-test106 = show $ floatDigits (error "test106" :: Double) -- laziness check
-
-test107 = show $ floatRange (1.0 :: Double)
-test108 = show $ floatRange (error "test108" :: Double) -- laziness check
-
-test109 = show $ floatRadix (1.0 :: Double)
-test110 = show $ floatRadix (error "test110" :: Double) -- laziness check
-
-
--- Char primitives
-
-test120 = show ('a' == 'b', 'b' == 'b', 'b' == 'a')
-test121 = show ('a' <= 'b', 'b' <= 'b', 'b' <= 'a')
-
-
+++ /dev/null
-"Int primitives"
-test1
-test2
-test3
-test4
-test5
-test6
-test7
-test8
-test9
-test10
-test11
-test12
-"Integer primitives"
-test23
-test24
-test25
-test26
-test27
-test28
-test29
-test30
-test31
-test32
-"Float primitives"
-test43
-test44
-test45
-test46
-test47
-test48
-test49
-test50
-test51
-test52
-test53
-test54
-test55
-test56
-test57
-test58
-test59
-test62
-test63
-test65
-test66
-test67
-test68
-test69
-test70
-"Double primitives"
-test83
-test84
-test85
-test86
-test87
-test88
-test89
-test90
-test91
-test92
-test93
-test94
-test95
-test96
-test97
-test98
-test99
-test102
-test103
-test105
-test106
-test107
-test108
-test109
-test110
-"Char primitives"
-test120
-test121
+++ /dev/null
-Type :? for help
-Hugs:"Int primitives"
-Hugs:"(-2147483647,-2147483648)"
-Hugs:"2147483647"
-Hugs:"3"
-Hugs:"-1"
-Hugs:"15"
-Hugs:"-10"
-Hugs:"(True,False)"
-Hugs:"(True,False)"
-Hugs:"[(1,-2),(-1,-2),(0,0),(0,0),(-1,2),(1,2)]"
-Hugs:"[(1,-2),(-2,1),(0,0),(0,0),(-2,-1),(1,2)]"
-Hugs:"
-Program error: {primQuotInt 1 0}
-
-Hugs:"
-Program error: {primRemInt 1 0}
-
-Hugs:"Integer primitives"
-Hugs:"3"
-Hugs:"-1"
-Hugs:"15"
-Hugs:"-10"
-Hugs:"(True,False)"
-Hugs:"(True,False)"
-Hugs:"[(1,-2),(-1,-2),(0,0),(0,0),(-1,2),(1,2)]"
-Hugs:"[(1,-2),(-2,1),(0,0),(0,0),(-2,-1),(1,2)]"
-Hugs:"
-Program error: {primQrmInteger 1 0}
-
-Hugs:"
-Program error: {primQrmInteger 1 0}
-
-Hugs:"Float primitives"
-Hugs:"3.0"
-Hugs:"-1.0"
-Hugs:"15.0"
-Hugs:"-10.0"
-Hugs:"(True,False)"
-Hugs:"[1.6666666,-1.6666666,-0.0,0.0,-1.6666666,1.6666666]"
-Hugs:"Infinity"
-Hugs:"3.1415927"
-Hugs:"[0.0,0.29552022,0.5646425,0.84147096]"
-Hugs:"[1.0,0.9553365,0.8253356,0.5403023]"
-Hugs:"[0.0,0.30933627,0.68413687,1.5574077]"
-Hugs:"[0.0,0.30469266,0.64350116,1.5707964]"
-Hugs:"[1.5707964,1.2661036,0.9272952,0.0]"
-Hugs:"[0.0,0.29145682,0.5404195,0.7853982]"
-Hugs:"[1.0,1.3498589,1.8221189,2.7182817]"
-Hugs:"[-1.2039728,-0.5108256,0.0,2.3025851]"
-Hugs:"-Infinity"
-Hugs:"[0.0,0.5477226,0.7745967,1.0]"
-Hugs:"NaN"
-Hugs:"24"
-Hugs:"24"
-Hugs:"(-125,128)"
-Hugs:"(-125,128)"
-Hugs:"2"
-Hugs:"2"
-Hugs:"Double primitives"
-Hugs:"3.0"
-Hugs:"-1.0"
-Hugs:"15.0"
-Hugs:"-10.0"
-Hugs:"(True,False)"
-Hugs:"[1.6666666666666667,-1.6666666666666667,-0.0,0.0,-1.6666666666666667,1.6666666666666667]"
-Hugs:"Infinity"
-Hugs:"3.141592653589793"
-Hugs:"[0.0,0.29552020666133955,0.5646424733950354,0.8414709848078965]"
-Hugs:"[1.0,0.955336489125606,0.8253356149096783,0.5403023058681398]"
-Hugs:"[0.0,0.30933624960962325,0.6841368083416923,1.5574077246549023]"
-Hugs:"[0.0,0.3046926540153975,0.6435011087932844,1.5707963267948966]"
-Hugs:"[1.5707963267948966,1.2661036727794992,0.9272952180016123,0.0]"
-Hugs:"[0.0,0.2914567944778671,0.5404195002705842,0.7853981633974483]"
-Hugs:"[1.0,1.3498588075760032,1.8221188003905089,2.718281828459045]"
-Hugs:"[-1.2039728043259361,-0.5108256237659907,0.0,2.302585092994046]"
-Hugs:"-Infinity"
-Hugs:"[0.0,0.5477225575051661,0.7745966692414834,1.0]"
-Hugs:"NaN"
-Hugs:"53"
-Hugs:"53"
-Hugs:"(-1021,1024)"
-Hugs:"(-1021,1024)"
-Hugs:"2"
-Hugs:"2"
-Hugs:"Char primitives"
-Hugs:"(False,True,False)"
-Hugs:"(True,True,False)"
+++ /dev/null
---!!! Testing list operations
-
--- Hack: The only purpose of this script is to give us a place to put
--- the above comment...
--- It might be useful to import the List library so that we can test it too.
-
--- padding so that this isn't an empty script
-module TestList where
-import Prelude
+++ /dev/null
-map succ [1..10]
-
-filter odd [1..10]
-
-takeWhile (<5) [1..10]
-dropWhile (<5) [1..10]
-span (<5) [1..10]
-break (<5) [1..10]
-span (>5) [1..10]
-break (>5) [1..10]
-
-length [1..10]
-[1..10] !! 5
-
-take 5 [1..10]
-drop 5 [1..10]
-splitAt 5 [1..10]
+++ /dev/null
-Type :? for help
-Hugs:[2,3,4,5,6,7,8,9,10,11]
-Hugs:Hugs:[1,3,5,7,9]
-Hugs:Hugs:[1,2,3,4]
-Hugs:[5,6,7,8,9,10]
-Hugs:([1,2,3,4],[5,6,7,8,9,10])
-Hugs:([],[1,2,3,4,5,6,7,8,9,10])
-Hugs:([],[1,2,3,4,5,6,7,8,9,10])
-Hugs:([1,2,3,4,5],[6,7,8,9,10])
-Hugs:Hugs:10
-Hugs:6
-Hugs:Hugs:[1,2,3,4,5]
-Hugs:[6,7,8,9,10]
-Hugs:([1,2,3,4,5],[6,7,8,9,10])
+++ /dev/null
---!!! Testing Immutable Arrays (part 1)
-
-import Array
-
-a1 :: Array Int Int
-a1 = array (1,10) [ (i,i*i) | i <- [1..10] ]
-
-
-test1 = bounds a1
-test2 = assocs a1
-test3 = indices a1
-test4 = elems a1
-
-test5 = a1 // [(3,3),(4,4)]
-
--- note duplicate value and absent value
-a1' :: Array Int Char
-a1' = array (1,3) [(1,'a'), (1,'b'), (3,'c')]
-
-test6 = a1' ! 1 -- duplicate array index
-test7 = a1' ! 2 -- undefined array element
-test8 = a1' ! 3 -- 'c'
-
-test10 = a1 ! 0 -- should fail
-test11 = a1 ! 11 -- should fail
-test12 = [ a1 ! i | i <- [1..10] ]
-
+++ /dev/null
-test1
-test2
-test3
-test4
-test5
-test6
-test7
-test8
-test10
-test11
-test12
-
+++ /dev/null
-Type :? for help
-Hugs:(1,10)
-Hugs:[(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]
-Hugs:[1,2,3,4,5,6,7,8,9,10]
-Hugs:[1,4,9,16,25,36,49,64,81,100]
-Hugs:array (1,10) [(1,1),(2,4),(3,3),(4,4),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]
-Hugs:'b'
-Hugs:
-Program error: (Array.!): undefined array element
-
-Hugs:'c'
-Hugs:
-Program error: Ix.index.Int: Index out of range.
-
-Hugs:
-Program error: Ix.index.Int: Index out of range.
-
-Hugs:[1,4,9,16,25,36,49,64,81,100]
+++ /dev/null
---!!! Dictionary bug demo
-import Array
-
-a :: Array Int Int
-a = array (1,10) [ (i,i*i) | i <- [1..10] ]
-
-test1 = show a
-test2 = show a
-
-test3 = let a = array (1,10) [ (i,i*i) | i <- [1..10] ] in show a
-test4 = let a = array (1,10) [ (i,i*i) | i <- [1..10] ] in show a
\ No newline at end of file
+++ /dev/null
-test1
-test2
-test3
-test4
+++ /dev/null
-Type :? for help
-Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
-Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
-Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
-Hugs:"array (1,10) [(1,1),(2,4),(3,9),(4,16),(5,25),(6,36),(7,49),(8,64),(9,81),(10,100)]"
+++ /dev/null
---!!! Some simple examples using arrays.
-
-module ArrayEx where
-import Array
-
--- Some applications, most taken from the Gentle Introduction ... -------------
-
-timesTable :: Array (Int,Int) Int
-timesTable = array ((1,1),(10,10)) [ ((i,j), i*j) | i<-[1..10], j<-[1..10] ]
-
-fibs n = a where a = array (0,n) ([ (0,1), (1,1) ] ++
- [ (i, a!(i-2) + a!(i-1)) | i <- [2..n] ])
-
-wavefront n = a where a = array ((1,1),(n,n))
- ([ ((1,j), 1) | j <- [1..n] ] ++
- [ ((i,1), 1) | i <- [2..n] ] ++
- [ ((i,j), a!(i,j-1) + a!(i-1,j-1) + a!(i-1,j))
- | i <- [2..n], j <- [2..n] ])
-
-listwave n = [ [wf!(i,j) | j <- [1..n]] | i <- [1..n] ]
- where wf = wavefront n
-
-eg1 :: Array Integer Integer
-eg1 = array (1,100) ((1, 1) : [ (i, i * eg1!(i-1)) | i <- [2..100] ])
-
--------------------------------------------------------------------------------
+++ /dev/null
-show timesTable
+++ /dev/null
-Type :? for help
-Hugs:"array ((1,1),(10,10)) [((1,1),1),((1,2),2),((1,3),3),((1,4),4),((1,5),5),((1,6),6),((1,7),7),((1,8),8),((1,9),9),((1,10),10),((2,1),2),((2,2),4),((2,3),6),((2,4),8),((2,5),10),((2,6),12),((2,7),14),((2,8),16),((2,9),18),((2,10),20),((3,1),3),((3,2),6),((3,3),9),((3,4),12),((3,5),15),((3,6),18),((3,7),21),((3,8),24),((3,9),27),((3,10),30),((4,1),4),((4,2),8),((4,3),12),((4,4),16),((4,5),20),((4,6),24),((4,7),28),((4,8),32),((4,9),36),((4,10),40),((5,1),5),((5,2),10),((5,3),15),((5,4),20),((5,5),25),((5,6),30),((5,7),35),((5,8),40),((5,9),45),((5,10),50),((6,1),6),((6,2),12),((6,3),18),((6,4),24),((6,5),30),((6,6),36),((6,7),42),((6,8),48),((6,9),54),((6,10),60),((7,1),7),((7,2),14),((7,3),21),((7,4),28),((7,5),35),((7,6),42),((7,7),49),((7,8),56),((7,9),63),((7,10),70),((8,1),8),((8,2),16),((8,3),24),((8,4),32),((8,5),40),((8,6),48),((8,7),56),((8,8),64),((8,9),72),((8,10),80),((9,1),9),((9,2),18),((9,3),27),((9,4),36),((9,5),45),((9,6),54),((9,7),63),((9,8),72),((9,9),81),((9,10),90),((10,1),10),((10,2),20),((10,3),30),((10,4),40),((10,5),50),((10,6),60),((10,7),70),((10,8),80),((10,9),90),((10,10),100)]"
+++ /dev/null
-#! /usr/bin/perl -i.bak
-
-while (<>) {
- # Insert header line
- if ($ARGV ne $oldargv) {
- $ARGV =~ /\d+/;
- $filenum = $&;
- print <<EOTXT;
-Reading file "test/static/s$filenum.hs":
-EOTXT
- $oldargv = $ARGV;
- }
-
- # Make this script idempotent
- next if /^Reading file "test\/static\/s\d+\.hs":/;
-
- # Fix error messages
- s#test/[A-Za-z]+\d+\.hs#test/static/s$filenum.hs#g;
-
- # Delete trailing line
- s/^Hugs:\[Leaving Hugs\]\n//;
-
- print;
-}
+++ /dev/null
-----------------------------------------------------------------
--- Testing syntax checking, static checking and modules.
--- This group of checks will produce about 100 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------"
+++ /dev/null
---!!! Testing error checking in qualified names (patterns)
-
--- No qualified variables in patterns
-module TestQual1 where
-f (A.x : xs) = xs
-
+++ /dev/null
-ERROR "test/static/s001.hs" (line 5): Illegal use of qualified variable in pattern
+++ /dev/null
---!!! Testing error checking in qualified names (type variables)
-
--- No qualified type variables
-module TestQual2 where
-x :: A.a
-x = x
-
-
+++ /dev/null
-ERROR "test/static/s002.hs" (line 5): Syntax error in type expression (unexpected symbol "A.a")
+++ /dev/null
---!!! Testing error checking in qualified names (local variables)
-
--- No qualified local variables
-module TestQual3 where
-f x = A.y where A.y = x
+++ /dev/null
-ERROR "test/static/s003.hs" (line 5): Binding for qualified variable "A.y" not allowed
+++ /dev/null
---!!! Testing error checking in qualified names (top level variables)
-
--- No qualified top level variables
-module TestQual4 where
-A.f x = x
+++ /dev/null
-ERROR "test/static/s004.hs" (line 5): Binding for qualified variable "A.f" not allowed
+++ /dev/null
---!!! Testing error checking in qualified names (unknown module)
-
--- Qualifying with a module that isn't imported
-module TestQual5 where
-foo = A.foo
+++ /dev/null
-ERROR "test/static/s005.hs" (line 5): Undefined qualified variable "A.foo"
+++ /dev/null
---!!! Testing Haskell 1.3 syntax
-
--- Haskell 1.3 syntax differs from Haskell 1.2 syntax in several ways:
-
--- * Qualified names in export lists
-module TestSyntax where
-
--- * Qualified import/export
-
--- 1) Syntax:
-
-import qualified Prelude as P
-
-import Prelude
-import qualified Prelude
-
-import Prelude ()
-import Prelude (fst,snd)
-import qualified Prelude(fst,snd)
-
--- bizarre syntax allowed in draft of Haskell 1.3
-import Prelude(,)
-import Prelude(fst,snd,)
-import Prelude(Ord(..),Eq((==),(/=)),)
-import Prelude hiding (fst,snd,)
-
-import Prelude hiding (fst,snd)
-import qualified Prelude hiding (fst,snd)
-
-import Prelude as P
-import qualified Prelude as P
-
-import Prelude as P(fst,snd)
-import Prelude as P(,)
-import qualified Prelude as P(fst,snd)
-
-import Prelude as P hiding (fst,snd)
-import qualified Prelude as P hiding (fst,snd)
-
--- 2) Use of qualified type names
--- 3) Use of qualified constructors
--- 4) Use of qualified variables
-
--- * No n+k patterns (yippee!)
--- (No tests yet)
-
--- Some things are unchanged.
-
--- * Unqualified imports and use of hiding/selective import.
---
--- Note: it's not clear how these various imports are supposed to
--- interact with one another.
--- John explains:
--- 1) "hiding" lists etc are just abbreviations for very long
--- lists.
--- 2) Multiple imports are additive.
--- (This makes the meaning order-independent!)
--- Note: Hugs allows imports anywhere a topdecl is allowed.
--- This isn't legal Haskell - but it does no harm.
-
--- import Prelude(lex)
--- import Prelude
--- import Prelude hiding (lex)
--- lex = 1 :: Int -- error unless we've hidden lex.
-
-
-
--- * Qualified names
-
--- Function/operator names
-myfilter x = Prelude.filter x -- argument added to avoid monomorphism restn
-mycompose = (Prelude..)
-
--- Use of module synonyms
-myfilter2 p = P.filter p
-
--- Method names
-myplus :: Num a => a -> a -> a
-myplus = (Prelude.+)
-
--- Tycons
-myminus = (Prelude.-) :: Prelude.Int -> Prelude.Int -> Prelude.Int
-
--- Type synonyms
-foo :: P.ShowS
-foo = foo
-
--- Class names in instances
-instance P.Num P.Bool where
- (+) = (P.||)
- (*) = (P.&&)
- negate = P.not
-
-instance (P.Num a, P.Num b) => P.Num (a,b) where
- x + y = (fst x + fst y, snd x + snd y)
-
--- Constructor names in expressions
-
--- this used to break tidyInfix in parser.y
--- Note that P.[] is _not_ legal!
-testInfixQualifiedCon = 'a' P.: [] :: String
-
--- Constructor names in patterns
-f (P.Just x) = True
-f (P.Nothing) = False
-
-g (x P.: xs) = x
-
-y P.: ys = ['a'..]
-
--- * Support for octal and hexadecimal numbers
--- Note: 0xff and 0xFF are legal but 0Xff and 0XFF are not.
--- ToDo: negative tests to make sure invalid numbers are excluded.
-
-d = ( -1, -0, 0, 1) :: (Int,Int,Int,Int)
-o = (-0o1,-0o0,0o0,0o1) :: (Int,Int,Int,Int)
-x = (-0x1,-0x0,0x0,0x1) :: (Int,Int,Int,Int)
-x' = (0xff,0xFf,0xfF,0xFF) :: (Int,Int,Int,Int)
-
--- * No renaming or interface files
--- We test that "interface", "renaming" and "to" are not reserved.
-
-interface = 1 :: Int
-renaming = 42 :: Int
-to = 2 :: Int
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Importing unknown module
-module M where
-import N
+++ /dev/null
-Reading file "N":
-ERROR "N": Unable to open file "N"
+++ /dev/null
---!!! Qualified import of unknown module
-module M where
-import qualified N
+++ /dev/null
-Reading file "N":
-ERROR "N": Unable to open file "N"
+++ /dev/null
---!!! Exporting "constructor" of a type synonym
-module M(T(K1)) where
-type T = T'
-data T' = K1
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s009.hs": Explicit constructor list given for type synonym "T" in export list of module "M"
+++ /dev/null
---!!! Exporting unknown constructor
-module M(T(K1,K2)) where
-data T = K1
+++ /dev/null
-ERROR "test/static/s010.hs": Entity "K2" is not a constructor of type "T"
+++ /dev/null
---!!! Duplicate export of constructor
-module M(T(K1,K1)) where
-data T = K1
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Omitted constructor from export list
-module M(T(K1)) where
-data T = K1|K2
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Exporting non-existent type/class
-module M(T) where
-x = 'a' -- dummy definition to get round a separate bug
+++ /dev/null
-ERROR "test/static/s013.hs": Unknown entity "T" exported from module "M"
+++ /dev/null
---!!! Exporting non-existent module
-module M(module N) where
-x = 'a' -- dummy definition to get round a separate bug
+++ /dev/null
-ERROR "test/static/s014.hs": Unknown module "N" exported from module "M"
+++ /dev/null
---!!! Exporting non-existent type transparently
-module M(T(..)) where
-x = 'a' -- dummy definition to get round a separate bug
+++ /dev/null
-ERROR "test/static/s015.hs": Explicit export list given for non-class/datatype "T" in export list of module "M"
+++ /dev/null
---!!! Exporting non-existent datatype transparently
-module M(T(K1)) where
-x = 'a' -- dummy definition to get round a separate bug
+++ /dev/null
-ERROR "test/static/s016.hs": Explicit export list given for non-class/datatype "T" in export list of module "M"
+++ /dev/null
---!!! Empty module body
-module M where
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct class export
-module M(C(m1,m2,m3)) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Omitted member from export list
-module M(C(m1,m3)) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Duplicate member in export list
-module M(C(m1,m2,m2,m3)) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct class export
-module M(C(..)) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct abstract class export
-module M(C) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Testing non-member function in explicit class export list
-module M(C(m1,m2,m3,Left)) where
-class C a where
- m1 :: a
- m2, m3 :: a
+++ /dev/null
-ERROR "test/static/s023.hs": Entity "Left" is not a member of class "C"
+++ /dev/null
---!!! Testing duplicate type synonyms
-type T = Int
-type T = Float
+++ /dev/null
-ERROR "test/static/s024.hs" (line 3): Repeated definition of type constructor "T"
+++ /dev/null
---!!! Testing duplicate classes
-class C a where m :: a
-class C a where m :: a
+++ /dev/null
-ERROR "test/static/s025.hs" (line 3): Repeated definition of class "C"
+++ /dev/null
---!!! Testing duplicate members
-class C1 a where m :: a
-class C2 a where m :: a
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s026.hs" (line 2): Repeated definition for member function "m"
+++ /dev/null
---!!! Testing duplicate type constructors
-data T = K1
-data T = K2
+++ /dev/null
-ERROR "test/static/s027.hs" (line 3): Repeated definition of type constructor "T"
+++ /dev/null
---!!! Testing duplicate data constructors
-data T1 = K
-data T2 = K
+++ /dev/null
-ERROR "test/static/s028.hs" (line 2): Repeated definition for constructor function "K"
+++ /dev/null
---!!! Testing duplicate type variables
-type T a a = Either a a
+++ /dev/null
-ERROR "test/static/s029.hs" (line 2): Repeated type variable "a" on left hand side
+++ /dev/null
---!!! Testing duplicate type variables
-data T a a = K a a
+++ /dev/null
-ERROR "test/static/s030.hs" (line 2): Repeated type variable "a" on left hand side
+++ /dev/null
---!!! Testing existential type variables
-data T a = K a b
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Testing bogus (or existential) type variables
-type T a = Either a b
+++ /dev/null
-ERROR "test/static/s032.hs" (line 2): Undefined type variable "b"
+++ /dev/null
---!!! Testing recursive type synonyms
-type T1 = (Int,T2)
-type T2 = (Int,T1)
+++ /dev/null
-ERROR "test/static/s033.hs" (line 2): Type synonyms "T1" and "T2" are mutually recursive
+++ /dev/null
---!!! Trying to export restricted type synonyms
-module M(T(..)) where
-type T = Char in x :: T
-x = 'a'
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s034.hs": Transparent export of restricted type synonym "T" in export list of module "M"
+++ /dev/null
---!!! Imported tycon clashes with local definition
-module M where
-import Prelude(Int)
-type Int = Char
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s035.hs": Tycon "Int" imported from "Prelude" already defined in module "M"
+++ /dev/null
---!!! Imported class clashes with local class definition
-module M where
-import Prelude(Eq,Bool)
-class Eq a where (==) :: a -> a -> Bool
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s036.hs": Class "Eq" imported from "Prelude" already defined in module "M"
+++ /dev/null
---!!! Imported class clashes with local type definition
-module M where
-import Prelude(Eq,Bool)
-type Eq = Bool
+++ /dev/null
-ERROR "test/static/s037.hs": Import of class "Eq" clashes with type constructor in module "Prelude"
+++ /dev/null
---!!! Imported tycon clashes with local class definition
-module M where
-import Prelude(Int,Bool)
-class Int a where (==) :: a -> a -> Bool
+++ /dev/null
-ERROR "test/static/s038.hs": Import of type constructor "Int" clashes with class in module "PreludeBuiltin"
+++ /dev/null
---!!! Imported var clashes with local var definition
-module M where
---import Prelude(id)
-id x = x
+++ /dev/null
-ERROR "test/static/s039.hs" (line 4): Definition of variable "id" clashes with import
+++ /dev/null
---!!! Imported member fun clashes with local var definition
-module M where
-import Ix(Ix(..))
-index x = x
+++ /dev/null
-ERROR "test/static/s040.hs" (line 4): Definition of variable "index" clashes with import
+++ /dev/null
---!!! Imported constructor clashes with local constructor
-module M where
-import Prelude(Bool(True,False))
-data T = True
+++ /dev/null
-ERROR "test/static/s041.hs" (line 4): Definition of constructor function "True" clashes with import
+++ /dev/null
---!!! Hiding lists "intersect" part 1
-module M where
-import Prelude hiding (const,id)
-import Prelude hiding (const)
-x = const
+++ /dev/null
-ERROR "test/static/s042.hs" (line 5): Undefined variable "const"
+++ /dev/null
---!!! Hiding lists "intersect" part 2
-module M where
-import Prelude hiding (const,id)
-import Prelude hiding (const)
-x = id
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Class decl clashes with type decl
-module M where
-type C = Int
-class C a where f :: a
+++ /dev/null
-ERROR "test/static/s044.hs" (line 4): "C" used as both class and type constructor
+++ /dev/null
---!!! Illegal constraints on member funs
-module M where
-class C a where f :: Eq a => a
+++ /dev/null
-ERROR "test/static/s045.hs" (line 3): Illegal constraints on class variable "a" in type of member function "f"
+++ /dev/null
---!!! Cyclic class hierarchy
-module M where
-class C2 a => C1 a where f :: a
-class C1 a => C2 a where g :: a
+++ /dev/null
-ERROR "test/static/s046.hs" (line 4): Class hierarchy for "C2" is not acyclic
+++ /dev/null
---!!! Overlapping instances
-module M where
-instance Eq a => Eq (Either a a)
+++ /dev/null
-ERROR "test/static/s047.hs" (line 3): Overlapping instances for class "Eq"
-*** This instance : Eq (Either a a)
-*** Overlaps with : Eq (Either a b)
-*** Common instance : Eq (Either a a)
-
+++ /dev/null
---!!! Overlapping instances
-module M where
-instance Eq a
+++ /dev/null
-ERROR "test/static/s048.hs" (line 3): Overlapping instances for class "Eq"
-*** This instance : Eq a
-*** Overlaps with : Eq (Ref a b)
-*** Common instance : Eq (Ref a b)
-
+++ /dev/null
---!!! Type synonym in instance
-module M where
-type T = S
-data S = MkS
-instance Eq T
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Repeated instance decl
-module M where
-data T = T Int
-instance Eq T
-instance Eq T
+++ /dev/null
-ERROR "test/static/s050.hs" (line 5): Overlapping instances for class "Eq"
-*** This instance : Eq T
-*** Overlaps with : Eq T
-*** Common instance : Eq T
-
+++ /dev/null
---!!! Type sigs in instance decl
-module M where
-data T = T Int
-instance Eq T where
- (==) :: T -> T -> Bool
- T x == T y = x == y
-
+++ /dev/null
-ERROR "test/static/s051.hs" (line 4): Type signature decls not permitted in instance decl
+++ /dev/null
---!!! Instances of superclasses exist
-module M where
-data T = T Int
-instance Ord T
+++ /dev/null
-ERROR "test/static/s052.hs" (line 4): Cannot build superclass instance
-*** Instance : Ord T
-*** Context supplied : ()
-*** Required superclass : Eq T
-
+++ /dev/null
---!!! Instance context can't satisfy class-hierarchy constraint
-module M where
-class Foo a
-class Foo a => Bar a
-instance Num a => Foo [a]
-instance (Eq a, Enum a) => Bar [a]
-
+++ /dev/null
-ERROR "test/static/s053.hs" (line 6): Cannot build superclass instance
-*** Instance : Bar [a]
-*** Context supplied : (Enum a, Eq a)
-*** Required superclass : Foo [a]
-
+++ /dev/null
---!!! Class decl can't use pattern bindings
-module M where
-class C a where
- x,y :: a
- (x,y) = error "foo"
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s054.hs" (line 5): Pattern binding illegal in class declaration
+++ /dev/null
---!!! Default decl for non-method
-module M where
-class C a where
- x :: a
- y = error "foo"
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s055.hs" (line 5): No member "y" in class "C"
+++ /dev/null
---!!! Default decl for non-method
-module M where
-data T = C deriving (Foo)
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s056.hs" (line 3): Unknown class "Foo" in derived instance
+++ /dev/null
---!!! Duplicate derived instance
-module M where
-data T = C deriving (Eq,Eq)
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s057.hs" (line 3): Overlapping instances for class "Eq"
-*** This instance : Eq T
-*** Overlaps with : Eq T
-*** Common instance : Eq T
-
+++ /dev/null
---!!! Duplicate derived instance
-module M where
-data T = C deriving (Eq)
-instance Eq T
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s058.hs" (line 3): Overlapping instances for class "Eq"
-*** This instance : Eq T
-*** Overlaps with : Eq T
-*** Common instance : Eq T
-
+++ /dev/null
---!!! Duplicate derived instance
-module M where
-class C a
-data T = K deriving (C)
+++ /dev/null
-ERROR "test/static/s059.hs" (line 4): Cannot derive instances of class "C"
+++ /dev/null
---!!! Duplicate derived instance
-module M where
-data T = K deriving (Ord)
+++ /dev/null
-ERROR "test/static/s060.hs" (line 3): Cannot build superclass instance
-*** Instance : Ord T
-*** Context supplied : ()
-*** Required superclass : Eq T
-
+++ /dev/null
---!!! Illegal deriving Enum
-module M where
-data T = K Int deriving (Enum)
+++ /dev/null
-ERROR "test/static/s061.hs" (line 3): Can only derive instances of Enum for enumeration types
+++ /dev/null
---!!! Illegal deriving Ix
-module M where
-import Ix(Ix(..))
-data T = K1 Int | K2 deriving (Eq,Ord,Ix)
+++ /dev/null
-ERROR "test/static/s062.hs" (line 4): Can only derive instances of Ix for enumeration or product types
+++ /dev/null
---!!! Multiple (identical) default decls
-module M where
-default (Int,Integer)
-default (Int,Integer)
+++ /dev/null
-ERROR "test/static/s064.hs" (line 4): Multiple default declarations are not permitted ina single script file.
-
+++ /dev/null
---!!! Malformed pattern (unknown constructor)
-module M where
-f K = error "foo"
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s065.hs" (line 3): Undefined constructor function "K"
+++ /dev/null
---!!! Malformed pattern (arity)
-module M where
-f (Left) = error "foo"
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s066.hs" (line 3): Constructor function "Left" needs 1 args in pattern
+++ /dev/null
---!!! Malformed infix expression
-module M where
-f a b c = a==b==c
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s067.hs" (line 3): Ambiguous use of operator "==" with "=="
+++ /dev/null
---!!! Malformed binding (qualified)
-module M where
-x = let M.y = 'a' in M.y
+++ /dev/null
-ERROR "test/static/s068.hs" (line 3): Binding for qualified variable "M.y" not allowed
+++ /dev/null
---!!! Bindings of different arities
-module M where
-f 0 = id
-f x y = x+y
+++ /dev/null
-ERROR "test/static/s069.hs" (line 3): Equations give different arities for "f"
+++ /dev/null
---!!! Pattern binding must bind (not an error in standard Haskell)
-module M where
-x = let ['a'] = "a" in 'a'
+++ /dev/null
-ERROR "test/static/s070.hs" (line 3): No variables defined in lhs pattern
+++ /dev/null
---!!! Malformed lhs (pointless but legal in Haskell 1.3, rejected by Hugs)
-module M where
-x = let [] = "a" in 'a'
+++ /dev/null
-ERROR "test/static/s071.hs" (line 3): No variables defined in lhs pattern
+++ /dev/null
---!!! Multiple value bindings
-module M where
-f x = 'a'
-g x = 'b'
-f x = 'c'
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s072.hs" (line 3): "f" multiply defined
+++ /dev/null
---!!! Type decl but no body
-module M where
-f :: Int -> Bool
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s073.hs" (line 3): Type declaration for variable "f" with no body
+++ /dev/null
---!!! Multiple type decls
-module M where
-f :: Int -> Bool
-f :: Int -> Bool
-f = even
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s074.hs" (line 4): Repeated type declaration for "f"
+++ /dev/null
---!!! Illegal @ in expression
-module M where
-f x = x@1
+++ /dev/null
-ERROR "test/static/s075.hs" (line 3): Illegal `@' in expression
+++ /dev/null
---!!! Illegal ~ in expression
-module M where
-f x = x~1
+++ /dev/null
-ERROR "test/static/s076.hs" (line 3): Illegal `~' in expression
+++ /dev/null
---!!! Illegal _ in expression
-module M where
-f x = x _ 1
+++ /dev/null
-ERROR "test/static/s077.hs" (line 3): Illegal `_' in expression
+++ /dev/null
---!!! Undefined variable in expression
-module M where
-f x = g x
+++ /dev/null
-ERROR "test/static/s078.hs" (line 3): Undefined variable "g"
+++ /dev/null
---!!! Undefined qualified variable in expression
-module M where
-f x = Prelude.g x
+++ /dev/null
-ERROR "test/static/s079.hs" (line 3): Undefined qualified variable "Prelude.g"
+++ /dev/null
---!!! Undefined qualifier in expression
-module M where
-f x = N.g x
+++ /dev/null
-ERROR "test/static/s080.hs" (line 3): Undefined qualified variable "N.g"
+++ /dev/null
---!!! Qualifying with local module name
-module M where
-f x = M.f x
+++ /dev/null
-ERROR "test/static/s081.hs" (line 3): Undefined qualified variable "M.f"
+++ /dev/null
---!!! Multiple modules per file
-module M where
-foo = 'a'
-
-module N where
-bar = 'b'
-
+++ /dev/null
-ERROR "test/static/s082.hs" (line 5): Syntax error in input (unexpected keyword "module")
+++ /dev/null
---!!! Naked fixity declaration
-module M where
-infix $$$
-x = 'a'
+++ /dev/null
-ERROR "test/static/s083.hs": No top level definition for operator symbol "$$$"
+++ /dev/null
---!!! Undefined var in restricted synonym
-module M where
-type T = Int in x
-
+++ /dev/null
-ERROR "test/static/s084.hs" (line 3): No top level binding of "x" for restricted synonym "T"
+++ /dev/null
---!!! Importing unknown class/tycon
-module M where
-import Prelude(C)
-
+++ /dev/null
-ERROR "test/static/s085.hs": Unknown entity "C" imported from module "Prelude"
+++ /dev/null
---!!! Importing unknown name
-module M where
-import Prelude(f)
-
+++ /dev/null
-ERROR "test/static/s086.hs": Unknown entity "f" imported from module "Prelude"
+++ /dev/null
---!!! Importing Tycon with bogus constructor
-module M where
-import Prelude(Either(Left,Right,Foo))
-
+++ /dev/null
-ERROR "test/static/s087.hs": Entity "Foo" is not a constructor of type "Either"
+++ /dev/null
---!!! Importing Tycon with missing constructor
-module M where
-import Prelude(Either(Left))
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Importing Tycon with duplicate constructor
-module M where
-import Prelude(Either(Left,Right,Right))
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct tycon import (explicit constructor list)
-module M where
-import Prelude(Either(Left,Right))
-x = (Left 'a', Right 'a')
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct tycon import (implicit constructor list)
-module M where
-import Prelude(Either(..))
-x = (Left 'a', Right 'a')
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct abstract tycon import
-module M where
-import Prelude(Either)
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Trying to use constructors of abstractly imported type.
-module M where
-import Prelude(Either)
-x = Left 'a'
+++ /dev/null
-ERROR "test/static/s093.hs" (line 4): Undefined constructor function "Left"
+++ /dev/null
---!!! Known bug: Qualified import ignores import list
-module M where
-import qualified Prelude (map)
-x = Prelude.Left 'a'
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Sublist for non-class/tycon
-module M where
-import Prelude(map(..))
-
+++ /dev/null
-ERROR "test/static/s095.hs" (line 3): Syntax error in import declaration (unexpected `(')
+++ /dev/null
---!!! Sublist for non-class/tycon
-module M where
-import Prelude(Left(..))
-
+++ /dev/null
-ERROR "test/static/s096.hs": Unknown entity "Left" imported from module "Prelude"
+++ /dev/null
---!!! Importing Class with bogus member
-module M where
-import Prelude(Eq((==),(/=),eq))
-
+++ /dev/null
-ERROR "test/static/s097.hs": Entity "eq" is not a member of class "Eq"
+++ /dev/null
---!!! Importing Class with missing member
-module M where
-import Prelude(Eq((==)))
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Importing Class with duplicate member
-module M where
-import Prelude(Eq((==),(/=),(==)))
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct Class import (explicit member list)
-module M where
-import Prelude(Eq((==),(/=)))
-x = 'a' == 'b'
-y = 'a' /= 'b'
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct Class import (explicit member list)
-module M where
-import Prelude(Eq(..))
-x = 'a' == 'b'
-y = 'a' /= 'b'
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Correct abstract class import
-module M where
-import Prelude(Eq)
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Trying to use members of abstractly imported class
-module M where
-import Prelude(Eq)
-x = 'a' == 'b'
+++ /dev/null
-ERROR "test/static/s103.hs" (line 4): Undefined variable "=="
+++ /dev/null
---!!! Type signature for qualified name
-module M where
-M.x :: Char
-x = 'a'
+++ /dev/null
-ERROR "test/static/s104.hs" (line 3): Type signature for qualified variable "M.x" is not allowed
+++ /dev/null
---!!! Opaque import/export of tycons
-module T2 where
-import T1
+++ /dev/null
-Reading file "test/static/T1.hs":
-Reading file "test/static/s105.hs":
-Type :? for help
+++ /dev/null
---!!! Transparent import of type synonyms
-module T3 where
-import Prelude(ReadS(..))
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Testing export of class members
-
-module T7 where
-
-import T6
-
-p :: (W a,X a, Y a, Z a) => [a]
-p = [y,z]
+++ /dev/null
-Reading file "test/static/T6.hs":
-Reading file "test/static/s107.hs":
-Type :? for help
+++ /dev/null
---!!! Testing export of unknown name
-module Bar(bar) where
-foo = foo
\ No newline at end of file
+++ /dev/null
-ERROR "test/static/s108.hs": Unknown entity "bar" exported from module "Bar"
+++ /dev/null
---!!! Repeated type variable "a" in instance predicate
-module M where
-data T a b = MkT a b
-instance Eq a => Eq (T a a)
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Empty field list in update
-data T = T { x,y :: Int }
-f t = t {}
+++ /dev/null
-ERROR "test/static/s110.hs" (line 3): Empty field list in update
+++ /dev/null
---!!! No constructor has all of the fields specified
-data T = T {x,y::Int}
-data U = U {z::Int}
-
-f a b c = T{x=a,y=b,z=c}
-
+++ /dev/null
-ERROR "test/static/s111.hs" (line 5): No constructor has all of the fields specified in T{x = a, y = b, z = c}
-
+++ /dev/null
---!!! Constructor ... does not have selected fields in ...
-data T = T1 {x,y :: Int}
- | T2 { y,z :: Int}
-
-f a b c = T1{y=b,z=c}
-
+++ /dev/null
-ERROR "test/static/s112.hs" (line 5): Constructor "T1" does not have selected fields in T1{y = b, z = c}
-
+++ /dev/null
---!!! Repeated field name ... in field list
-data T = T {x,y :: Int}
-
-f a b = T{x=a,x=b}
-
+++ /dev/null
-ERROR "test/static/s113.hs" (line 4): Repeated field name "x" in field list
+++ /dev/null
---!!! Repeated field name ... for constructor ...
-
-data T = T {x,x :: Int}
-
+++ /dev/null
-ERROR "test/static/s114.hs" (line 3): Repeated field name "x" for constructor "T"
+++ /dev/null
---!!! Known bug: can't have strict fieldnames (I think this is trivial to fix)
-
-data T = T {x :: Int, y :: !Int} deriving Show
-
-
-
+++ /dev/null
---!!! Construction does not define strict field
-
-data T = T {x :: Int, y :: !Int}
-
-f a = T{x=a}
-
+++ /dev/null
---!!! Attempt to redefine variable ...
-
-data T = T {x::Int}
-
-x = 'c'
+++ /dev/null
-ERROR "test/static/s117.hs" (line 5): Attempt to redefine variable "x"
+++ /dev/null
---!!! Redeclaration of foreign ...
-
-foreign import "libc.so.6" "putchar" primPutChar :: Char -> IO ()
-foreign import "libc.so.6" "putchar" primPutChar :: Char -> IO ()
+++ /dev/null
-ERROR "test/static/s118.hs" (line 4): Redeclaration of foreign "primPutChar"
+++ /dev/null
---!!! Testing error catching
-
-test1, test2 :: Either HugsObject Int
-
-test1 = primCatchError (error "foo")
-test2 = primCatchError 1
-
-
-test3, test4, test5 :: Int
-
-test3 = myCatch (1+error "foo") 2
-test4 = myCatch 1 (error "bar")
-test5 = myCatch (error "foo") (error "bar")
-
-
-test6, test7, test8, test9 :: IO ()
-
-test6 = printString "abcdefg"
-test7 = printString (error "a" : "bcdefg")
-test8 = printString ("abc" ++ error "defg")
-test9 = printString (error "a" : "bc" ++ error "defg")
-
--- if an error occurs, replace it with a default (hopefully error-free) value
-myCatch :: a -> a -> a
-myCatch x deflt = case primCatchError x of
- Right x' -> x'
- Left _ -> deflt
-
--- lazily print a string - catching any errors as necessary
-printString :: String -> IO ()
-printString str =
- case primCatchError str of
- Left _ -> putStr "<error>"
- Right [] -> return ()
- Right (c:cs) -> case primCatchError c of
- Left _ -> putStr "<error>" >> printString cs
- Right c' -> putChar c' >> printString cs
-
+++ /dev/null
-test1
-test2
-test3
-test4
-test5
-
-test6
-test7
-test8
-test9
+++ /dev/null
-Left {HugsObject ...}
-Right 1
-2
-1
-{error "bar"}
-abcdefg
-<error>bcdefg
-abc<error>
-<error>bc<error>
+++ /dev/null
---!!! Testing error catching
-
---module TestCatch where
-
-test1, test2 :: String
-
-test1 = show $ primCatchError (error "foo"::Int)
-test2 = show $ primCatchError 1
-
-
-test3, test4, test5 :: String
-
-test3 = show $ catch (1+error "foo") 2
-test4 = show $ catch 1 (error "bar")
-test5 = show $ catch (error "foo") (error "bar" :: Int)
-
-
-test6, test7, test8, test9 :: IO ()
-
-test6 = printString "abcdefg"
-test7 = printString (error "a" : "bcdefg")
-test8 = printString ("abc" ++ error "defg")
-test9 = printString (error "a" : "bc" ++ error "defg")
-
--- if an error occurs, replace it with a default (hopefully error-free) value
-catch :: a -> a -> a
-catch x deflt = case primCatchError x of
- Just x' -> x'
- Nothing -> deflt
-
--- lazily print a string - catching any errors as necessary
-printString :: String -> IO ()
-printString str =
- case primCatchError str of
- Nothing -> putStr "<error>"
- Just [] -> return ()
- Just (c:cs) -> case primCatchError c of
- Nothing -> putStr "<error>" >> printString cs
- Just c' -> putChar c' >> printString cs
-
+++ /dev/null
-Nothing
-Just 1
-2
-1
-
-Program Error
-
-abcdefg
-<error>bcdefg
-abc<error>
-<error>bc<error>
+++ /dev/null
-polar (0:+0)
+++ /dev/null
-Type :? for help
-Hugs:(0.0, 0.0)
-Hugs:[Leaving Hugs]
+++ /dev/null
---!!! Testing IOError
-
-import IO
-
--- printing IOError values
-a1 = userError "foo"
-
--- testing IOError values
-a2 = isUserError (userError "foo")
-
--- catching IOErrors
-a3 = catch (fail (userError "foo")) (\err -> putStr "Caught error\n")
-
--- continuing after catching errors
-a4 = catch (fail (userError "foo")) (\err -> putStr "Caught error\n") >>
- putStr "Continuing\n"
-
--- raising uncaught errors
-a5 :: IO () -- signature required to override "IO a"
-a5 = fail (userError "foo")
+++ /dev/null
-a1
-a2
-a3
-a4
-a5
+++ /dev/null
-userError "foo"
-Just "foo"
-Caught error
-
-Caught error
-Continuing
-
-
-foo
+++ /dev/null
---!!! Testing IOError
-
--- These should both raise the same error - not IOErrors!
-a1 = ["a" !! 1]
-a2 = writeFile "foo" (["a"] !! 1)
+++ /dev/null
-Type :? for help
-Hugs:"
-Program error: PreludeList.!!: index too large
-
-Hugs:
-Program error: PreludeList.!!: index too large
-
-
+++ /dev/null
---!!! Testing File I/O operations and errors
-
-import IO
-
-testFile = "test/iohandle.tst"
-unreadable = "test/unreadable.tst"
-unwritable = "test/unwritable.tst"
-nonexistent = "test/nonexistent.tst"
-
--- Handle free ops
-a1 = writeFile testFile (show [1..10])
-a2 = readFile testFile >>= \ s -> putStr s
-a3 = appendFile testFile (show [11..20])
-a4 = readFile testFile >>= \ s -> putStr s
-
--- Same stuff - but using handle-based operations
-b1 = openFile testFile WriteMode >>= \ h ->
- hPutStr h (show [1..10])
-b2 = openFile testFile ReadMode >>= \ h ->
- hGetContents h >>= \ s ->
- putStr s
-b3 = openFile testFile AppendMode >>= \ h ->
- hPutStr h (show [11..20])
-b4 = openFile testFile ReadMode >>= \ h ->
- hGetContents h >>= \ s ->
- putStr s
-
--- Miscellaneous little functions
-c1 = openFile testFile WriteMode >>= \ h ->
- mapM_ (hPutChar h) (show [1..10]) >>
- hClose h
-c2 = openFile testFile ReadMode >>= \ h ->
- let loop =
- hGetChar h >>= \ c ->
- putChar c >>
- loop
- in
- loop :: IO ()
-c3 = openFile testFile AppendMode >>= \ h ->
- hPutStr h (show [11..20]) >>
- hClose h
-c4 = openFile testFile ReadMode >>= \ h ->
- let loop =
- hGetChar h >>= \ c ->
- putChar c >>
- loop
- in
- loop `catch` (\err -> if isEOFError err then return () else fail err)
--- If this function raises an uncaught EOF error, then hIsEOF probably
--- implements ANSI C feof semantics which is quite different from
--- Haskell 1.3 semantics (but much easier to implement).
-c5 = openFile testFile ReadMode >>= \ h ->
- let loop =
- hIsEOF h >>= \ eof ->
- if eof then return () else
- hGetChar h >>= \ c ->
- putChar c >>
- loop
- in
- loop :: IO ()
-
-c6 = openFile testFile ReadMode >>= \ h ->
- hFlush h >>
- hGetContents h >>= \ s ->
- putStr s
-
--- should print first 10 characters of file twice
-c7 = openFile testFile ReadMode >>= \ h ->
- hGetContents h >>= \ s ->
- putStr (take 10 s) >>
- hClose h >>
- putStr s
-
-
--- Deliberately trying to trigger IOErrors:
-
--- Note: Linux allows a file to be opened twice
-d1 = openFile testFile WriteMode >>= \ h1 ->
- openFile testFile WriteMode >>= \ h2 ->
- let x = [h1,h2] in -- try to make sure both pointers remain live
- return ()
-
-d2 = openFile testFile WriteMode >>= \ h ->
- hGetContents h >>= \ s ->
- putStr s
-
-d3 = openFile testFile ReadMode >>= \ h ->
- hPutStr h (show [5..10])
-
--- This should succeed
-d4 = openFile unreadable WriteMode >>= \ h ->
- return ()
-
--- This should fail
-d5 = openFile unreadable ReadMode >>= \ h ->
- return ()
-
--- This should succeed
-d6 = openFile unwritable ReadMode >>= \ h ->
- return ()
-
--- This should fail
-d7 = openFile unwritable WriteMode >>= \ h ->
- return ()
-
-d8 = openFile testFile ReadMode >>= \ h ->
- hClose h >>
- hGetContents h >>= \ s ->
- putStr s
-
-d9 = openFile testFile ReadMode >>= \ h ->
- hClose h >>
- hClose h
-
--- should fail
-d10 = openFile testFile ReadMode >>= \ h ->
- hGetContents h >>= \ s1 ->
- hGetContents h >>= \ s2 ->
- putStr s1 >>
- putStr s2
-
-
-
+++ /dev/null
-a1
-a2
-a3
-a4
-
-b1
-b2
-b3
-b4
-
-c1
-c2
-c3
-c4
-c5
-c6
-c7
-
-d1
-d2
-d3
-d4
-d5
-d6
-d7
-d8
-d9
-d10
+++ /dev/null
-
-[1,2,3,4,5,6,7,8,9,10]
-
-[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
-
-[1,2,3,4,5,6,7,8,9,10]
-
-[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
-
-[1,2,3,4,5,6,7,8,9,10]
-End of file
-
-[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
-[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
-[1,2,3,4,5,6,7,8,9,10][11,12,13,14,15,16,17,18,19,20]
-[1,2,3,4,5[1,2,3,4,5
-
-
-Illegal operation
-
-Illegal operation
-
-
-Illegal operation
-
-
-Illegal operation
-
-Illegal operation
-
-Illegal operation
-
-Illegal operation
+++ /dev/null
---!!! Testing (List.\\) and related functions
-module T where
-
-import List( deleteBy, delete, (\\) )
-
-test1 :: [Int]
-test1 = deleteBy (==) 1 [0,1,1,2,3,4]
-
-test2 :: [Int]
-test2 = delete 1 [0,1,1,2,3,4]
-
-test3 :: [Int]
-test3 = [0,1,1,2,3,4] \\ [3,2,1]
-
+++ /dev/null
-test1
-test2
-test3
+++ /dev/null
-Reading file "List.hs":
-Reading file "test/std/list1.hs":
-Type :? for help
-Hugs:[0,1,2,3,4]
-Hugs:[0,1,2,3,4]
-Hugs:[0,1,4]
+++ /dev/null
---!!! Testing System
-module T where
-
-import System(getArgs,getProgName,getEnv,system)
-
--- like print but no annoying "\n"
-pr :: Show a => a -> IO ()
-pr = putStr . show
-
-test1 = system "exit 0" >>= pr
-test2 = system "exit 1" >>= pr
-test3 = system "exit 2" >>= pr
-
-test4 = getArgs >>= pr
-test5 = getProgName >>= pr
-
--- We want to test getEnv - but there's too much variety in possible
--- environments so we pick an env var that doesn't vary too much
--- and list every variation we've ever come across.
-test6 = do
- shell <- getEnv "SHELL"
- let sh = last $ chop '/' shell
- if (sh `elem` shells)
- then
- putStr "getEnv \"SHELL\" returns known shell"
- else
- putStr "getEnv \"SHELL\" returns unknown shell"
- return ()
- where
- shells = ["sh"
- ,"csh"
- ,"tcsh"
- ,"bash"
- ,"zsh"
- ]
-
-chop :: Eq a => a -> [a] -> [[a]]
-chop seq [] = []
-chop sep xs = ys : case zs of
- [] -> []
- _:zs' -> chop sep zs'
- where
- (ys,zs) = break (sep ==) xs
+++ /dev/null
-test1
-test2
-test3
-test4
-test5
-test6
+++ /dev/null
-Reading file "System.lhs":
-Reading file "test/std/system1.hs":
-Type :? for help
-Hugs:ExitSuccess
-Hugs:ExitFailure 1
-Hugs:ExitFailure 2
-Hugs:[]
-Hugs:"Hugs"
-Hugs:getEnv "SHELL" returns known shell
+++ /dev/null
-#! /usr/bin/perl -i.bak
-
-while (<>) {
- # Insert header line
- if ($ARGV ne $oldargv) {
- $ARGV =~ /\d+/;
- $filenum = $&;
- print <<EOTXT;
-Reading file "test/typechecker/t$filenum.hs":
-EOTXT
- $oldargv = $ARGV;
- }
-
- # Make this script idempotent
- next if /^Reading file "test\/typechecker\/t\d+\.hs":/;
-
- # Fix error messages
- s#test/T[A-Za-z0-9]*\.hs#test/typechecker/t$filenum.hs#g;
-
- # Delete trailing line
- s/^Hugs:\[Leaving Hugs\]\n//;
-
- print;
-}
+++ /dev/null
-----------------------------------------------------------------
--- Testing type checking.
--- This group of checks will produce about 7 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- It may also produce output that looks like this:
---
--- ./hugs +q -pHugs: test/dicts.hs < test/dicts.input
--- expected stdout not matched by reality
--- *** test/dicts.output Fri Jul 11 13:25:27 1997
--- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
--- ***************
--- *** 1,3 ****
--- Hugs:\"(14,14,14)\"
--- ! Hugs:Garbage collection recovered 93815 cells
--- Hugs:\"(14,14,14)\"
--- --- 1,3 ----
--- Hugs:\"(14,14,14)\"
--- ! Hugs:Garbage collection recovered 93781 cells
--- Hugs:\"(14,14,14)\"
---
--- This is harmless and might be caused by minor variations between different
--- machines, or slightly out of date sample output.
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------
+++ /dev/null
---!!! Testing typechecker (fixed in Hugs 1.01)
-
-{-
-Hi again,
-
-While I am at bug reporting I should as well inform you of another
-problem that I encountered.
-
-While testing different variations of the gc-bug test program I
-found a difference between what would compile in the original hugs.1.01
-and the hacked.hugs that I downloaded from the ftp directory.
-
-In the hacked.hugs I have only changed: SUNOS 0, LINUX 1, and finally
-I had to remove the external definition of strchr because it conflicted
-with some include file definition. (Of course this will turn out
-to be the reason, right?)
-
-I also had to add the Ordering type in hugs.prelude that came with
-hacked.hugs.tar.gz, because it was required to be loaded.
-
-Have fun,
-
-Sverker
-
-PS:
-
-The error message was:
-
-ERROR "/home/nilsson/ngof/simpleprims/src/tbugx.gs" (line 15): Insufficient class constraints in instance member binding
-*** Context : (T a, T b, T c)
-*** Required : T d
-
-The test program, tbugx.gs, is:
-
--}
-module TestTypes where
-
-class T a where
- t :: Int -> a
-
-instance T Int where
- t = id
-
-instance (T a, T b) => T (a, b) where
- t p =
- (t p, t p)
-
-
-instance (T a, T b, T c) => T (a, b, c) where
--- The following compiles in hugs1.01, but not in hacked.hugs!
--- It induces the GC bug as well.
- t p = (a, b, c) where
- tp = t p
- a = fst tp
- bc = snd tp
- b = fst bc
- c = snd bc
--- The following does not induce the GC bug.
--- But as the previous one, it compiles only in hugs1.01, not in hacked.hugs.
--- t p = (a, b, c) where
--- a = t p
--- bc = t p
--- b = fst bc
--- c = snd bc
-
-t2:: Int -> (Int,Int)
-t2 = t -- t2 has no problems
-
-t3:: Int -> (Int,Int,Int)
-t3 = t -- t3 has problems
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Testing error-line numbers II (fixed from Hugs 1.01)
-f :: (Show a, Read a) => a -> String
-(f,g) = (show,read)
+++ /dev/null
-ERROR "test/typechecker/t001.hs" (line 3): Explicit overloaded type for "f" not permitted in restricted binding
+++ /dev/null
---!!! Testing error-line numbers I (fixed from Hugs 1.01)
-(x,y)=('a','b')
-x :: a
-
+++ /dev/null
-ERROR "test/typechecker/t002.hs" (line 2): Inferred type is not general enough
-*** Expression : x
-*** Expected type : a
-*** Inferred type : Char
-
+++ /dev/null
---!!! Testing monad comprehensions
-module MonadTest where
-
--- Old uses of list comprehensions
-as :: [Bool]
-as = [ odd x | x <- [1..10] ]
-
--- The next 4 tests used to check that list comprehension syntax
--- could be used for monad comprehensions.
--- Anticipating Standard Haskell's removal of this feature, we don't
--- test (or implement!) that anymore.
-
--- Use in monad comprehensions
-mmap :: (a -> b) -> ([] a -> [] b)
-mmap f xs = [ f x | x <- xs ]
-
--- use ","
-bind1 :: [] a -> (a -> [] b) -> [] b
-bind1 m k = [ b | a <- m, b <- k a ]
-
-bind2 :: [] Int -> (Int -> [] b) -> [] b
-bind2 m k = [ b | a <- m, odd a, b <- k a ]
-
--- use local binding
-bind3 :: [] a -> (a -> b) -> (b -> [] c) -> [] c
-bind3 m f k = [ c | a <- m, let b = f a, c <- k b ]
-
-
--- The next 4 tests check the use of "do-syntax" for monad comprehensions
-
--- Use in monad comprehensions
-mmap2 :: Monad m => (a -> b) -> (m a -> m b)
-mmap2 f xs = do { x <- xs; return (f x) }
-
--- use ","
-bind12 :: Monad m => m a -> (a -> m b) -> m b
-bind12 m k = do { a <- m; b <- k a; return b }
-
-bind22 :: MonadZero m => m Int -> (Int -> m b) -> m b
-bind22 m k = do { a <- m; guard (odd a); b <- k a; return b }
-
--- use local binding
-bind32 :: Monad m => m a -> (a -> b) -> (b -> m c) -> m c
-bind32 m f k = do { a <- m; let { b = f a }; c <- k b; return c }
-
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Testing (one aspect of) the dictionary bug
-{-
-Hello,
-
-Thanks for your reply and advice about the GC debugging. Before I got
-it, (our mail server is slow and undeterministic for incoming mail,
-and I have to call it up manually) I had boiled down my program to a
-quite simple test example, and prepared a mail to send to you.
-
-I don't know if the two problems are related. With my test program,
-the bug occurs only after a (manual) GC. Each time. I have to
-reload the script to get it going again.
-
-The following is the mail I intended to send, with enclosed test
-program:
-
-Hi Alastair,
-
-I have verified that there is a garbage collection related bug in
-Hugs 1.01, both in the unpatched and the patched version, compiled
-for Linux. The unpatched one had no changes to the source expect
-SUNOS 0 and LINUX 1 in prelude.h
-
-I have boiled it down to a simple test program. The program won't
-compile in either Gofer or Hugs 1.0! This seems suspicious to me,
-but maybe the program can be simplified further.
-
-I still suspect it has something to do with the dictionaries not
-being marked correctly.
-
-Maybe this will be of some relevance for your new GC as well.
-
-I don't know what / if there is a Hugs bug mailing list, maybe
-you will forward this there or to Mark directly?
-
-I'll tell you if I find out anything more specific.
-
-It seems pretty certain the problem has nothing to do with that the
-suspicious thing begins on Line 13, though...
-
-Sverker
-
-PS: Boiled down bug-provoking program enclosed, tbug.gs:
-
--}
-module TestDicts where
-
-class T a where -- Line 1
- t :: Int -> a
-
-instance T Int where
- t = id
-
-instance (T a, T b) => T (a, b) where
- t p =
- (t p, t p)
-
-
-instance (T a, T b, T c) => T (a, b, c) where
- t p = -- Line 13
- (a, b, c) where
- (a, (b, c)) = t p
--- The following seems to give the same effect:
--- t p =
--- case t (p + 3) of
--- (a, (b, c)) -> (a, b, c)
--- But the following seems to work:
--- t p = (t p, t p, t p)
-
-
-t2:: Int -> (Int,Int)
-t2 = t -- t2 has no problems
-
-t3:: Int -> (Int,Int,Int)
-t3 = t -- t3 has problems, see session transcript
-
-
-{-
-
--- Gofer or Hugs 1.0 would not allow this program. Extract from Hugs 1.0:
-
-? :l /home/nilsson/ngof/simpleprims/src/tbug.gs
-Reading script file "/home/nilsson/ngof/simpleprims/src/tbug.gs":
-Type checking
-ERROR "/home/nilsson/ngof/simpleprims/src/tbug.gs" (line 13): Insufficient class constraints in instance member binding
-*** Context : (T a, T b, T c)
-*** Required : T d
-
--- Hugs 1.01 allows it, as well as hacked.hugs. But in both the GC bug occurs.
--- Extract from Hugs 1.01:
-
-Hugs session for:
-/usr/local/lib/Hugs/hugs.prelude
-tbug.gs
-? t3 14
-(14,14,14)
-? :gc
-Garbage collection recovered 94995 cells
-? t3 14
-(
-
-INTERNAL ERROR: Error in graph
-? t3 17
-(
-INTERNAL ERROR: Error in graph
-?
-
--- Rewriting the tbug.gs file and reloading restores conditions.
-
-Hugs session for:
-/usr/local/lib/Hugs/hugs.prelude
-tbug.gs
-? t3 14
-(14,14,14)
-? :gc
-Garbage collection recovered 94995 cells
-? t3 14
-(
-INTERNAL ERROR: Error in graph
-
--}
-
+++ /dev/null
-show $ t3 14
-:gc
-show $ t3 14
+++ /dev/null
-Type :? for help
-Hugs:"(14,14,14)"
-Hugs:Garbage collection recovered 93637 cells
-Hugs:"(14,14,14)"
+++ /dev/null
---!!! Test for error in type error message (fixed in Hugs 1.4)
-module TyErr where
-
-newtype StateMonad m s a = MkStateMonad (s -> (m (s, a)))
-
-instance Monad m => Monad (StateMonad m s) where
- (>>=) (MkStateMonad fn1) f
- = MkStateMonad (\st -> (do res <- fn1 st
- case res of
- (st', res') -> extrStateMonad (f res') st'))
- return val = MkStateMonad (\st -> (return (st, val)))
-
-extrStateMonad (MkStateMonad f) = f
-
-getState :: Monad m => StateMonad m s s
-getState = MkStateMonad (\st -> return (st, st))
-
--- popIndentList :: StateMonad IO Int ()
-popIndentList =
- (do getState
- return ())
+++ /dev/null
-ERROR "test/typechecker/t005.hs" (line 19): Unresolved top-level overloading
-*** Binding : popIndentList
-*** Outstanding context : Monad b
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Another example from the 1.3c documentation
-
-data Monad2 m = MkMonad2 (forall a. a -> m a)
- (forall a, b. m a -> (a -> m b) -> m b)
-
-halfListMonad :: (forall a,b. [a] -> (a -> [b]) -> [b]) -> Monad2 []
-halfListMonad b = MkMonad2 (\x -> [x]) b
-
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Using distinct scoped type variables for same type
-
-invalid1 = (\(x::a) (y::b) -> [x,y])
-
+++ /dev/null
-ERROR "test/typechecker/t008.hs" (line 3): Type annotation uses distinct variables a and b where a single variable was inferred
+++ /dev/null
---!!! No scoped type variables in pattern bindings (sorry)
-
-((x::a):xs) = [1..] -- invalid
-
+++ /dev/null
-ERROR "test/typechecker/t009.hs" (line 3): Sorry, no type variables are allowed in pattern binding type annotations
+++ /dev/null
---!!! Escaping existential variable I
-
-data Appl = MkAppl (a -> Int) a (a -> a)
-
-bad1 (MkAppl f x i) = x
+++ /dev/null
-ERROR "test/typechecker/t010.hs" (line 5): Existentially quantified variable in result type
-variable : _4
-from pattern : MkAppl f x i
-result type : Appl -> _4
-
+++ /dev/null
---!!! Escaping existential variable II
-
-data Appl = MkAppl (a -> Int) a (a -> a)
-
-bad3 y = let g (MkAppl f x i) = length [x,y] + 1
- in True
+++ /dev/null
-ERROR "test/typechecker/t011.hs" (line 5): Existentially quantified variable from pattern MkAppl f x i appears in enclosing assumptions
+++ /dev/null
---!!! runST (the classic rank 2 type example)
-
-newtype ST s a = MkST (s -> (a,s))
-
-unST :: ST s a -> (s -> (a,s))
-unST (MkST f) = f
-
-runST :: (forall s. ST s a) -> a
-runST m = case unST m () of { (a,_) ->
- a
- }
-
-returnST :: a -> ST s a
-returnST a = MkST (\s -> (a,s))
-
-thenST :: ST s a -> (a -> ST s b) -> ST s b
-thenST m k = MkST (\ s0 -> case unST m s0 of { (a,s1) -> unST (k a) s1 })
-
-instance Monad (ST s) where
- return = returnST
- (>>=) = thenST
-
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Expr a (the classic existential types + polymorphic recursion example)
-
-data Expr a = App (Expr (b -> a)) (Expr b)
- | K a
-
-eval :: Expr a -> a
-eval (App f x) = (eval f) (eval x)
-eval (K x) = x
+++ /dev/null
-Type :? for help
+++ /dev/null
---!!! Leaving out signature in polymorphic recursion
-
-data Expr a = App (Expr (b -> a)) (Expr b)
- | K a
-
---eval :: Expr a -> a
-eval (App f x) = (eval f) (eval x)
-eval (K x) = x
+++ /dev/null
-ERROR "test/typechecker/t014.hs" (line 7): Type error in application
-*** Expression : eval f (eval x)
-*** Term : eval x
-*** Type : a -> b
-*** Does not match : a
-*** Because : unification would give infinite type
-
+++ /dev/null
---!!! Can't derive instances if you use existentials
-
-data Expr a = App (Expr (b -> a)) (Expr b)
- | K a
- deriving (Show)
+++ /dev/null
-ERROR "test/typechecker/t015.hs" (line 3): Cannot derive instances for types with existentially typed components
+++ /dev/null
-!cp test/DictHW1.hs DictHW.hs
-:l DictHW.hs
-!cp test/DictHW2.hs DictHW.hs
-:r
-f 1
\ No newline at end of file
+++ /dev/null
-Hugs:Hugs:Reading file "DictHW.hs":
-ERROR "DictHW.hs" (line 4): Int is not an instance of class "Fractional"
-Hugs:Hugs:Reading file "DictHW.hs":
-Hugs:"(1, 1, 1)"
-Hugs:[Leaving Hugs]
+++ /dev/null
-f :: Int -> String
-f x = show (x,x,x)
-
-g = 1.0 :: Int
+++ /dev/null
-f :: Int -> String
-f x = show (x,x,x)
-
---g = 1.0 :: Int
+++ /dev/null
-Type :? for help
-Hugs:[Leaving Hugs]
+++ /dev/null
-Type :? for help
-Hugs:[Leaving Hugs]
+++ /dev/null
---!!! Error detection in class declarations.
-
--- From the GHC bugs mailing list - this isn't legal Haskell.
--- (reported by Einar Wolfgang Karlsen <ewk@informatik.uni-bremen.de>)
-
-class Silly x where
- dump :: Silly x => x -> String -- context is illegal
+++ /dev/null
---!!! Testing the garbage collector
-module TestGC where
-
--- All these tests should be run in a freshly started system
--- and with the specified heap size/ heap configuration.
---
--- (Of course, they should run successfully in a non-fresh system,
--- with different heap sizes, etc. - but they've been known to fail
--- with the specified size.)
-
-
--- build Hugs with all gc tests turned on and run with a small heap.
-
--- 27/11/95: This test works fine - but fails when entered on the
--- command line. The difference must be that the top level
--- thunk isn't being treated as a root by the GC system.
--- 3/6/96: Requires 210kbyte heap to run - which is double the size of
--- the string it generates. This has to get stored since
--- test1 is a CAF and the 2-space GC doubles the requirement.
--- If evaluated on the command line, it runs in 16kbytes
--- which is about the smallest possible heap given the
--- setting of minRecovery (1000), the size of a cell (8 bytes)
--- and the GC's need for two equally size semispaces.
-test1 = show [1..1500]
-
--- 27/11/95: This test produces different results on command line
--- and when executed as given. Again, I think I'm failing to make
--- the top-level object a root.
--- 20/5/96: This test runs out of space - I think black holing would fix it.
--- 3/6/96: Now works fine. Nothing to do with blackholing! All I had to do
--- was restore Mark's definitions of sum and product. These used
--- foldl' which is a strict version of foldl.
-test2 = show (sum [1..100000])
-
+++ /dev/null
-:module TestGC
-test1
+++ /dev/null
-[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255,256,257,258,259,260,261,262,263,264,265,266,267,268,269,270,271,272,273,274,275,276,277,278,279,280,281,282,283,284,285,286,287,288,289,290,291,292,293,294,295,296,297,298,299,300,301,302,303,304,305,306,307,308,309,310,311,312,313,314,315,316,317,318,319,320,321,322,323,324,325,326,327,328,329,330,331,332,333,334,335,336,337,338,339,340,341,342,343,344,345,346,347,348,349,350,351,352,353,354,355,356,357,358,359,360,361,362,363,364,365,366,367,368,369,370,371,372,373,374,375,376,377,378,379,380,381,382,383,384,385,386,387,388,389,390,391,392,393,394,395,396,397,398,399,400,401,402,403,404,405,406,407,408,409,410,411,412,413,414,415,416,417,418,419,420,421,422,423,424,425,426,427,428,429,430,431,432,433,434,435,436,437,438,439,440,441,442,443,444,445,446,447,448,449,450,451,452,453,454,455,456,457,458,459,460,461,462,463,464,465,466,467,468,469,470,471,472,473,474,475,476,477,478,479,480,481,482,483,484,485,486,487,488,489,490,491,492,493,494,495,496,497,498,499,500,501,502,503,504,505,506,507,508,509,510,511,512,513,514,515,516,517,518,519,520,521,522,523,524,525,526,527,528,529,530,531,532,533,534,535,536,537,538,539,540,541,542,543,544,545,546,547,548,549,550,551,552,553,554,555,556,557,558,559,560,561,562,563,564,565,566,567,568,569,570,571,572,573,574,575,576,577,578,579,580,581,582,583,584,585,586,587,588,589,590,591,592,593,594,595,596,597,598,599,600,601,602,603,604,605,606,607,608,609,610,611,612,613,614,615,616,617,618,619,620,621,622,623,624,625,626,627,628,629,630,631,632,633,634,635,636,637,638,639,640,641,642,643,644,645,646,647,648,649,650,651,652,653,654,655,656,657,658,659,660,661,662,663,664,665,666,667,668,669,670,671,672,673,674,675,676,677,678,679,680,681,682,683,684,685,686,687,688,689,690,691,692,693,694,695,696,697,698,699,700,701,702,703,704,705,706,707,708,709,710,711,712,713,714,715,716,717,718,719,720,721,722,723,724,725,726,727,728,729,730,731,732,733,734,735,736,737,738,739,740,741,742,743,744,745,746,747,748,749,750,751,752,753,754,755,756,757,758,759,760,761,762,763,764,765,766,767,768,769,770,771,772,773,774,775,776,777,778,779,780,781,782,783,784,785,786,787,788,789,790,791,792,793,794,795,796,797,798,799,800,801,802,803,804,805,806,807,808,809,810,811,812,813,814,815,816,817,818,819,820,821,822,823,824,825,826,827,828,829,830,831,832,833,834,835,836,837,838,839,840,841,842,843,844,845,846,847,848,849,850,851,852,853,854,855,856,857,858,859,860,861,862,863,864,865,866,867,868,869,870,871,872,873,874,875,876,877,878,879,880,881,882,883,884,885,886,887,888,889,890,891,892,893,894,895,896,897,898,899,900,901,902,903,904,905,906,907,908,909,910,911,912,913,914,915,916,917,918,919,920,921,922,923,924,925,926,927,928,929,930,931,932,933,934,935,936,937,938,939,940,941,942,943,944,945,946,947,948,949,950,951,952,953,954,955,956,957,958,959,960,961,962,963,964,965,966,967,968,969,970,971,972,973,974,975,976,977,978,979,980,981,982,983,984,985,986,987,988,989,990,991,992,993,994,995,996,997,998,999,1000,1001,1002,1003,1004,1005,1006,1007,1008,1009,1010,1011,1012,1013,1014,1015,1016,1017,1018,1019,1020,1021,1022,1023,1024,1025,1026,1027,1028,1029,1030,1031,1032,1033,1034,1035,1036,1037,1038,1039,1040,1041,1042,1043,1044,1045,1046,1047,1048,1049,1050,1051,1052,1053,1054,1055,1056,1057,1058,1059,1060,1061,1062,1063,1064,1065,1066,1067,1068,1069,1070,1071,1072,1073,1074,1075,1076,1077,1078,1079,1080,1081,1082,1083,1084,1085,1086,1087,1088,1089,1090,1091,1092,1093,1094,1095,1096,1097,1098,1099,1100,1101,1102,1103,1104,1105,1106,1107,1108,1109,1110,1111,1112,1113,1114,1115,1116,1117,1118,1119,1120,1121,1122,1123,1124,1125,1126,1127,1128,1129,1130,1131,1132,1133,1134,1135,1136,1137,1138,1139,1140,1141,1142,1143,1144,1145,1146,1147,1148,1149,1150,1151,1152,1153,1154,1155,1156,1157,1158,1159,1160,1161,1162,1163,1164,1165,1166,1167,1168,1169,1170,1171,1172,1173,1174,1175,1176,1177,1178,1179,1180,1181,1182,1183,1184,1185,1186,1187,1188,1189,1190,1191,1192,1193,1194,1195,1196,1197,1198,1199,1200,1201,1202,1203,1204,1205,1206,1207,1208,1209,1210,1211,1212,1213,1214,1215,1216,1217,1218,1219,1220,1221,1222,1223,1224,1225,1226,1227,1228,1229,1230,1231,1232,1233,1234,1235,1236,1237,1238,1239,1240,1241,1242,1243,1244,1245,1246,1247,1248,1249,1250,1251,1252,1253,1254,1255,1256,1257,1258,1259,1260,1261,1262,1263,1264,1265,1266,1267,1268,1269,1270,1271,1272,1273,1274,1275,1276,1277,1278,1279,1280,1281,1282,1283,1284,1285,1286,1287,1288,1289,1290,1291,1292,1293,1294,1295,1296,1297,1298,1299,1300,1301,1302,1303,1304,1305,1306,1307,1308,1309,1310,1311,1312,1313,1314,1315,1316,1317,1318,1319,1320,1321,1322,1323,1324,1325,1326,1327,1328,1329,1330,1331,1332,1333,1334,1335,1336,1337,1338,1339,1340,1341,1342,1343,1344,1345,1346,1347,1348,1349,1350,1351,1352,1353,1354,1355,1356,1357,1358,1359,1360,1361,1362,1363,1364,1365,1366,1367,1368,1369,1370,1371,1372,1373,1374,1375,1376,1377,1378,1379,1380,1381,1382,1383,1384,1385,1386,1387,1388,1389,1390,1391,1392,1393,1394,1395,1396,1397,1398,1399,1400,1401,1402,1403,1404,1405,1406,1407,1408,1409,1410,1411,1412,1413,1414,1415,1416,1417,1418,1419,1420,1421,1422,1423,1424,1425,1426,1427,1428,1429,1430,1431,1432,1433,1434,1435,1436,1437,1438,1439,1440,1441,1442,1443,1444,1445,1446,1447,1448,1449,1450,1451,1452,1453,1454,1455,1456,1457,1458,1459,1460,1461,1462,1463,1464,1465,1466,1467,1468,1469,1470,1471,1472,1473,1474,1475,1476,1477,1478,1479,1480,1481,1482,1483,1484,1485,1486,1487,1488,1489,1490,1491,1492,1493,1494,1495,1496,1497,1498,1499,1500]
+++ /dev/null
---!!! Testing the printing of infix constructors
-data Music = Note
- | Music :+: Music
- | Scale Music
- deriving Show
-
-m = Scale (Note :+: Note)
+++ /dev/null
-Hugs:Scale (Note :+: Note)
-Hugs:"Scale (Note :+: Note)"
-Hugs:[Leaving Hugs]
+++ /dev/null
---!!! Testing top level printer (note that this doesn't necessarily test show)
-
--- Test things of type String
-
-test1, test2, test3 :: String
-
-test1 = "abcd"
-test2 = ""
-test3 = "abcd\0efgh\0"
-test4 = "abc" ++ error "def" ++ "hij"
-test5 = "abc" ++ [error "def"] ++ "hij"
-test6 = 'a' : 'b' : 'c' : error "foo"
-test7 = 'a' : 'b' : 'c' : error "foo" : []
-test8 = show (error "foo"::String)
-
-test11, test12 :: String
-test11 = case (error "foo") of _ -> "abcd"
-test12 = case (error "foo") of [] -> "abcd"
-
-test13, test14 :: String
-test13 = error (error "foo")
-test14 = error test14
-
-
-
--- Test things of type IO ()
-
-{- can't include this in backwards compatability tests
-
--- Normal
-
-test101, test102, test103 :: IO ()
-test101 = putStr "abcd"
-test102 = return ()
-test103 = putChar 'a'
-
--- Errors
-
-test111, test112, test113, test114 :: IO ()
-test111 = error "foo"
-test112 = putStr (error "foo")
-test113 = putStr "abcd" >> putStr (error "foo") >> putStr "efgh"
-test114 = putStr "abcd" >> error "foo" >> putStr "efgh"
-
-test123, test124, test125 :: IO ()
-test123 = error (error "foo")
-test124 = error x where x = error x
-test125 = error x where x = 'a' : error x
-
--}
-
--- Test things of type a
-
--- Unit
-
-test241, test242 :: ()
-test241 = ()
-test242 = error "foo"
-
--- Ints
-
-test251, test252 :: Int
-test251 = 10
-test252 = -10
-
-test253, test254 :: Int
-test253 = 42 + error "foo"
-test254 = error "foo" + 42
-
--- Integers
-
-test261, test262 :: Integer
-test261 = 10
-test262 = 10
-
--- Floats
-
-test271, test272 :: Float
-test271 = 10
-test272 = -10
-
--- Doubles
-
-test281, test282 :: Double
-test281 = 10
-test282 = -10
-
--- Char
-
-test291, test292, test293 :: Char
-test291 = 'a'
-test292 = '\0'
-test293 = '\DEL'
-
--- Lists
-
-test301, test302 :: [Int]
-test301 = []
-test302 = [1]
-
--- Bool
-
-test311 = True
-test312 = False
-
--- Tuples
-
-test321 = ('a','b')
-test322 = ('a','b','c')
-
-test323 :: (Int,Int, Int)
-test323 = (1, error "foo", 3)
-
--- Datatypes
-
-data E a b = L a | R b
-test331 = R (1::Int)
-test332 = L 'a'
-
-data M a = N | J a
-test333 = J True
-test334 = N
-
--- No dialogue tests in this file
+++ /dev/null
-test1
-test2
-test3
-test4
-test5
-test6
-test7
-test8
-test11
-test12
-test13
-1--test14 -- omitted - infinite loop
-1--test101 -- IO tests omitted (not supported by original system)
-1--test102
-1--test103
-1--test111
-1--test112
-1--test113
-1--test114
-1--test123
-1--test124
-1--test125
-test241
-test242
-test251
-test252
-test253
-test254
-test261
-test262
-test271
-test272
-test281
-test282
-test291
-test292
-test293
-test301
-test302
-test311
-test312
-test321
-test322
-test323
-test331
-test332
-test333
-test334
+++ /dev/null
-Hugs:"abcd"
-Hugs:[]
-Hugs:"abcd\NULefgh\NUL"
-Hugs:"abc
-Program error: def
-
-Hugs:"abc
-Program error: def
-
-Hugs:"abc
-Program error: foo
-
-Hugs:"abc
-Program error: foo
-
-Hugs:"\"
-Program error: foo
-
-Hugs:"abcd"
-Hugs:
-Program error: foo
-
-Hugs:
-Program error:
-Program error: foo
-
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:()
-Hugs:
-Program error: foo
-
-Hugs:10
-Hugs:-10
-Hugs:
-Program error: foo
-
-Hugs:
-Program error: foo
-
-Hugs:10
-Hugs:10
-Hugs:10.0
-Hugs:-10.0
-Hugs:10.0
-Hugs:-10.0
-Hugs:'a'
-Hugs:'\NUL'
-Hugs:'\DEL'
-Hugs:[]
-Hugs:[1]
-Hugs:True
-Hugs:False
-Hugs:('a','b')
-Hugs:('a','b','c')
-Hugs:(1,
-Program error: foo
-
-Hugs:R 1
-Hugs:L 'a'
-Hugs:J True
-Hugs:N
-Hugs:[Leaving Hugs]
+++ /dev/null
-Hugs:"abcd"
-Hugs:[]
-Hugs:"abcd\NULefgh\NUL"
-Hugs:"abc" ++ {error "def"}
-Hugs:"abc" ++ [{error "def"}, 'h', 'i', 'j']
-Hugs:"abc" ++ {error "foo"}
-Hugs:"abc" ++ [{error "foo"}]
-Hugs:"\"" ++ {error "foo"}
-Hugs:"abcd"
-Hugs:{error "foo"}
-Hugs:{error (error "foo")}
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:1
-Hugs:()
-Hugs:{error "foo"}
-Hugs:10
-Hugs:-10
-Hugs:{error "foo"}
-Hugs:{error "foo"}
-Hugs:10
-Hugs:10
-Hugs:10.0
-Hugs:-10.0
-Hugs:10.0
-Hugs:-10.0
-Hugs:'a'
-Hugs:'\NUL'
-Hugs:'\DEL'
-Hugs:[]
-Hugs:[1]
-Hugs:True
-Hugs:False
-Hugs:('a','b')
-Hugs:('a','b','c')
-Hugs:(1,{error "foo"},3)
-Hugs:R 1
-Hugs:L 'a'
-Hugs:J True
-Hugs:N
-Hugs:[Leaving Hugs]
+++ /dev/null
-foo :: Float -> Float
-foo = cache sin
-
--- A lazy cache.
--- Uses pointer equality (which is not referentially transparent)
--- in a referentially transparent way to allow the test to be:
--- 1) Fully polymorphic (no Eq context)
--- 2) Safe (no assumption that Eq is correct)
--- 3) Lazy -- no need to evaluate the entire argument.
--- Unlike John Hughes' lazy memo functions, there's no assistance
--- from the garbage collector to delete entries which can never be
--- used in the future.
-
-cache :: (a -> b) -> (a -> b)
-cache f = \x -> unsafePerformIO (f' x)
- where
- ref = unsafePerformIO (newRef (error "cache", error "cache"))
- f' x = derefRef ref >>= \ (x',a) ->
- if x `primPtrEq` x' then
- hit >>
- return a
- else
- miss >>
- let a = f x in
- assignRef ref (x, a) >>
- return a
-
-primitive primPtrEq "primPtrEq" :: a -> a -> Bool
-
-
--- Hooks for recording cache hits and misses
-{-
-hit = return ()
-miss = return ()
--}
-
-hit = putStrLn "hit"
-miss = putStrLn "miss"
-
-{-
-hitRef, missRef :: Ref Int
-hitRef = unsafePerformIO (newRef 0)
-missRef = unsafePerformIO (newRef 0)
-hit = derefRef hitRef >>= \ x -> assignRef hitRef (x+1)
-miss = derefRef missRef >>= \ x -> assignRef missRef (x+1)
-
-report =
- derefRef hitRef >>= \ hits ->
- derefRef missRef >>= \ misses ->
- putStrLn ("Cache hits: " ++ show hits ++ "; cache misses: " ++ show misses)
--}
-
-
+++ /dev/null
-let x = 1.0 in print (foo x + foo x + foo 2 + foo x)
+++ /dev/null
-miss
-hit
-miss
-miss
-3.43371
-
+++ /dev/null
---!!! Testing Haskell 1.3 syntax
-
--- Haskell 1.3 syntax differs from Haskell 1.2 syntax in several ways:
-
--- * Qualified names in export lists
-module TestSyntax where
-
--- * Qualified import/export
-
--- 1) Syntax:
-
-import qualified Prelude as P
-
-import Prelude
-import qualified Prelude
-
-import Prelude ()
-import Prelude (fst,snd)
-import qualified Prelude(fst,snd)
-
--- bizarre syntax allowed in draft of Haskell 1.3
-import Prelude(,)
-import Prelude(fst,snd,)
-import Prelude(Ord(..),Eq((==),(/=)),)
-import Prelude hiding (fst,snd,)
-
-import Prelude hiding (fst,snd)
-import qualified Prelude hiding (fst,snd)
-
-import Prelude as P
-import qualified Prelude as P
-
-import Prelude as P(fst,snd)
-import Prelude as P(,)
-import qualified Prelude as P(fst,snd)
-
-import Prelude as P hiding (fst,snd)
-import qualified Prelude as P hiding (fst,snd)
-
--- 2) Use of qualified type names
--- 3) Use of qualified constructors
--- 4) Use of qualified variables
-
--- * No n+k patterns (yippee!)
--- (No tests yet)
-
--- Some things are unchanged.
-
--- * Unqualified imports and use of hiding/selective import.
---
--- Note: it's not clear how these various imports are supposed to
--- interact with one another.
--- John explains:
--- 1) "hiding" lists etc are just abbreviations for very long
--- lists.
--- 2) Multiple imports are additive.
--- (This makes the meaning order-independent!)
--- Note: Hugs allows imports anywhere a topdecl is allowed.
--- This isn't legal Haskell - but it does no harm.
-
--- import Prelude(lex)
--- import Prelude
--- import Prelude hiding (lex)
--- lex = 1 :: Int -- error unless we've hidden lex.
-
-
-
--- * Qualified names
-
--- Function/operator names
-myfilter x = Prelude.filter x -- argument added to avoid monomorphism restn
-mycompose = (Prelude..)
-
--- Use of module synonyms
-myfilter2 p = P.filter p
-
--- Method names
-myplus :: Num a => a -> a -> a
-myplus = (Prelude.+)
-
--- Tycons
-myminus = (Prelude.-) :: Prelude.Int -> Prelude.Int -> Prelude.Int
-
--- Type synonyms
-foo :: P.ShowS
-foo = foo
-
--- Class names in instances
-instance P.Num P.Bool where
- (+) = (P.||)
- (*) = (P.&&)
- negate = P.not
-
-instance (P.Num a, P.Num b) => P.Num (a,b) where
- x + y = (fst x + fst y, snd x + snd y)
-
--- Constructor names in expressions
-
--- this used to break tidyInfix in parser.y
--- Note that P.[] is _not_ legal!
-testInfixQualifiedCon = 'a' P.: [] :: String
-
--- Constructor names in patterns
-f (P.Just x) = True
-f (P.Nothing) = False
-
-g (x P.: xs) = x
-
-y P.: ys = ['a'..]
-
--- * Support for octal and hexadecimal numbers
--- Note: 0xff and 0xFF are legal but 0Xff and 0XFF are not.
--- ToDo: negative tests to make sure invalid numbers are excluded.
-
-d = ( -1, -0, 0, 1) :: (Int,Int,Int,Int)
-o = (-0o1,-0o0,0o0,0o1) :: (Int,Int,Int,Int)
-x = (-0x1,-0x0,0x0,0x1) :: (Int,Int,Int,Int)
-x' = (0xff,0xFf,0xfF,0xFF) :: (Int,Int,Int,Int)
-
--- * No renaming or interface files
--- We test that "interface", "renaming" and "to" are not reserved.
-
-interface = 1 :: Int
-renaming = 42 :: Int
-to = 2 :: Int
-
+++ /dev/null
-Type :? for help
-Hugs:[Leaving Hugs]
+++ /dev/null
-
-simpleLazyPrint :: a -> IO ()
-simpleLazyPrint x = print (primGetHugsObject x)
- where
- -- Extra level of indirection introduced to overcome lack of
- -- polymorphic recursion!
- print :: HugsObject -> IO ()
- print x =
- primClassifyObject False x >>= \ kind ->
- case kind of
- HugsApply fun args ->
- putChar '(' >>
- print fun >>
- for_ args (\arg ->
- putChar ' ' >>
- print arg
- ) >>
- putChar ')'
-
- HugsFun nm ->
- putStr (primNameString nm)
-
- HugsCon nm ->
- putStr (primNameString nm)
-
- HugsTuple arity ->
- putStr ('(' : replicate arity ',' ++ ")")
-
- HugsInt x ->
- putStr (show x)
-
- HugsInteger x ->
- putStr (show x)
-
- HugsFloat x ->
- putStr (show x)
-
- HugsChar x ->
- putStr ('\'' : showLitChar x "\'")
-
- HugsPrim prim ->
- putStr prim
-
- HugsError err ->
- print err
-
-simpleStrictPrint :: a -> IO ()
-simpleStrictPrint x = print (primGetHugsObject x)
- where
- -- Extra level of indirection introduced to overcome lack of
- -- polymorphic recursion!
- print :: HugsObject -> IO ()
- print x =
- primClassifyObject True x >>= \ kind ->
- case kind of
- HugsApply fun args ->
- putChar '(' >>
- print fun >>
- for_ args (\arg ->
- putChar ' ' >>
- print arg
- ) >>
- putChar ')'
-
- HugsFun nm ->
- putStr (primNameString nm)
-
- HugsCon nm ->
- putStr (primNameString nm)
-
- HugsTuple arity ->
- putStr ('(' : replicate arity ',' ++ ")")
-
- HugsInt x ->
- putStr (show x)
-
- HugsInteger x ->
- putStr (show x)
-
- HugsFloat x ->
- putStr (show x)
-
- HugsChar x ->
- putStr ('\'' : showLitChar x "\'")
-
- HugsPrim prim ->
- putStr prim
-
- HugsError err ->
- -- could call lazy print (if object printer was exposed)
- putStr "{error}"
-
-s1 = simpleStrictPrint (error "foo")
-s2 = simpleStrictPrint (1 + error "foo")
-
-
--- test
-
-lazyPrint x = hugsPrinter False (primGetHugsObject x)
-strictPrint x = hugsPrinter True (primGetHugsObject x)
-
-t1 = lazyPrint (True &&)
-t2 = lazyPrint (1:)
-t3 = lazyPrint ('a':)
-t4 = lazyPrint (1 `elem`)
-t5 = lazyPrint "abcd"
-t6 = strict lazyPrint (1 `elem`)
-
-t11 = strictPrint (True &&)
-t12 = strictPrint (1:)
-t13 = strictPrint ('a':)
-t14 = strictPrint (1 `elem`)
-t15 = strictPrint "abcd"
-t16 = strictPrint (take 10 [1..])
-t17 = strictPrint [1..]
-t18 = strictPrint (pi::Float) -- used to fail because pi is a CAF.
-t19 = strictPrint '\DEL'
-
-{-
-Known Bugs:
-
-* Prints "(||) True False" (in lazy mode) instead of "True || False".
-
- This is a deliberate change from the original Hugs version (in builtin.c)
- which would print: '{dict} !! "abcd"' for ("abcd" !!) instead of
- '(!!) {dict} "abcd"' or '("abcd" `(||) {dict}`)'.
-
- (This is a feature not a bug!)
-
-* Should print errors to stderr.
-
--}
\ No newline at end of file
+++ /dev/null
-#! /bin/sh
-
-CONTEXT_DIFF='@CONTEXT_DIFF@'
-export CONTEXT_DIFF
-DEV_NULL='@DEV_NULL@'
-export DEV_NULL
-
-test_static() {
- echo "\
-----------------------------------------------------------------
--- Testing syntax checking, static checking and modules.
--- This group of checks will produce about 100 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------"
-
- # Test syntax/static checks on use of qualified names
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual1.hs" "-o1test/qual1.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual2.hs" "-o1test/qual2.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual3.hs" "-o1test/qual3.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual4.hs" "-o1test/qual4.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/qual5.hs" "-o1test/qual5.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/syntax.hs" "-o1test/syntax.output"
-
- # ToDo: test for duplicate modules
- perl runstdtest hugs -O-i +q -pHugs: -s13 "-Otest/mod1.hs" "-o1test/mod1.output"
- perl runstdtest hugs -O-i +q -pHugs: -s13 "-Otest/mod2.hs" "-o1test/mod2.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod3.hs" "-o1test/mod3.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod4.hs" "-o1test/mod4.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod5.hs" "-o1test/mod5.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod6.hs" "-o1test/mod6.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod7.hs" "-o1test/mod7.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod8.hs" "-o1test/mod8.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod9.hs" "-o1test/mod9.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod10.hs" "-o1test/mod10.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod11.hs" "-o1test/mod11.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod12.hs" "-o1test/mod12.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod13.hs" "-o1test/mod13.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod14.hs" "-o1test/mod14.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod15.hs" "-o1test/mod15.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod16.hs" "-o1test/mod16.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod17.hs" "-o1test/mod17.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod18.hs" "-o1test/mod18.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod19.hs" "-o1test/mod19.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod20.hs" "-o1test/mod20.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod21.hs" "-o1test/mod21.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod22.hs" "-o1test/mod22.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod23.hs" "-o1test/mod23.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod24.hs" "-o1test/mod24.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod25.hs" "-o1test/mod25.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod26.hs" "-o1test/mod26.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod27.hs" "-o1test/mod27.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod28.hs" "-o1test/mod28.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod29.hs" "-o1test/mod29.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod30.hs" "-o1test/mod30.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod31.hs" "-o1test/mod31.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod32.hs" "-o1test/mod32.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod33.hs" "-o1test/mod33.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod34.hs" "-o1test/mod34.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod35.hs" "-o1test/mod35.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod36.hs" "-o1test/mod36.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod37.hs" "-o1test/mod37.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod38.hs" "-o1test/mod38.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod39.hs" "-o1test/mod39.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod40.hs" "-o1test/mod40.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod41.hs" "-o1test/mod41.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod42.hs" "-o1test/mod42.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod43.hs" "-o1test/mod43.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod44.hs" "-o1test/mod44.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod45.hs" "-o1test/mod45.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod46.hs" "-o1test/mod46.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod47.hs" "-o1test/mod47.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod48.hs" "-o1test/mod48.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod49.hs" "-o1test/mod49.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod50.hs" "-o1test/mod50.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod51.hs" "-o1test/mod51.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod52.hs" "-o1test/mod52.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod53.hs" "-o1test/mod53.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod54.hs" "-o1test/mod54.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod55.hs" "-o1test/mod55.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod56.hs" "-o1test/mod56.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod57.hs" "-o1test/mod57.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod58.hs" "-o1test/mod58.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod59.hs" "-o1test/mod59.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod60.hs" "-o1test/mod60.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod61.hs" "-o1test/mod61.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod62.hs" "-o1test/mod62.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod63.hs" "-o1test/mod63.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod64.hs" "-o1test/mod64.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod65.hs" "-o1test/mod65.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod66.hs" "-o1test/mod66.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod67.hs" "-o1test/mod67.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod68.hs" "-o1test/mod68.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod69.hs" "-o1test/mod69.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod70.hs" "-o1test/mod70.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod71.hs" "-o1test/mod71.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod72.hs" "-o1test/mod72.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod73.hs" "-o1test/mod73.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod74.hs" "-o1test/mod74.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod75.hs" "-o1test/mod75.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod76.hs" "-o1test/mod76.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod77.hs" "-o1test/mod77.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod78.hs" "-o1test/mod78.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod79.hs" "-o1test/mod79.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod80.hs" "-o1test/mod80.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod81.hs" "-o1test/mod81.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod82.hs" "-o1test/mod82.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod83.hs" "-o1test/mod83.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod84.hs" "-o1test/mod84.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod85.hs" "-o1test/mod85.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod86.hs" "-o1test/mod86.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod87.hs" "-o1test/mod87.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod88.hs" "-o1test/mod88.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod89.hs" "-o1test/mod89.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod90.hs" "-o1test/mod90.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod91.hs" "-o1test/mod91.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod92.hs" "-o1test/mod92.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/mod93.hs" "-o1test/mod93.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod94.hs" "-o1test/mod94.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod95.hs" "-o1test/mod95.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/mod96.hs" "-o1test/mod96.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod97.hs" "-o1test/mod97.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/mod98.hs" "-o1test/mod98.output"
-
- # Check opaque import/export of tycons
- perl runstdtest hugs +q -pHugs: -s21 "-Otest/T2.hs" "-o1test/T2.output"
- # Check transparent import of type synonyms
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/T3.hs" "-o1test/T3.output"
-
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/export1.hs" "-o1test/export1.output"
-
- # Check opaque import/export of member functions
- perl runstdtest hugs +q -pHugs: -s20 "-Otest/T7.hs" "-o1test/Loaded.output"
-
-} # End of static tests
-
-test_tcheck() {
-
- echo "\
-----------------------------------------------------------------
--- Testing type checking.
--- This group of checks will produce about 7 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- It may also produce output that looks like this:
---
--- ./hugs +q -pHugs: test/dicts.hs < test/dicts.input
--- expected stdout not matched by reality
--- *** test/dicts.output Fri Jul 11 13:25:27 1997
--- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
--- ***************
--- *** 1,3 ****
--- Hugs:\"(14,14,14)\"
--- ! Hugs:Garbage collection recovered 93815 cells
--- Hugs:\"(14,14,14)\"
--- --- 1,3 ----
--- Hugs:\"(14,14,14)\"
--- ! Hugs:Garbage collection recovered 93781 cells
--- Hugs:\"(14,14,14)\"
---
--- This is harmless and might be caused by minor variations between different
--- machines, or slightly out of date sample output.
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------"
-
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/types.hs" "-o1test/types.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/dicts.hs" "-itest/dicts.input" "-o1test/dicts.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/ty1.hs" "-o1test/ty1.output"
- perl runstdtest hugs +q -pHugs: -s13 "-Otest/ty2.hs" "-o1test/ty2.output"
- perl runstdtest hugs +q -pHugs: -s17 "-Otest/monad.hs" "-o1test/monad.output"
- # Very tricky test - the input script uses /bin/cp to mimic the
- # effect of editing a file and reloading
- perl runstdtest hugs -w +q -pHugs: -s13 "-itest/DictHW.input" "-o1test/DictHW.output"
- perl runstdtest hugs -w +q -pHugs: test/TyErr.hs -s12 "-o1test/TyErr.output"
-}
-
-test_rts() {
-
- echo "\
-----------------------------------------------------------------
--- Testing runtime system.
--- This group of checks will produce 12-16 lines of output of the form
---
--- --!!! <description of feature being tested>
---
--- It may also produce output that looks like this:
---
--- ./hugs +q -pHugs: test/???.hs < test/???.input
--- expected stdout not matched by reality
--- *** test/???.output Fri Jul 11 13:25:27 1997
--- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
--- ***************
--- *** 1,3 ****
--- ...
--- | Hugs:\"[0.0, 0.304693, 0.643501, 1.5708]\"
--- ...
--- --- 1,3 ----
--- ...
--- | Hugs:\"[0.0, 0.30469323452, 0.643503234321, 1.5708234234]\"
--- ...
---
--- This is harmless and reflects variations in the accuracy of floating
--- point representation, calculations and printing.
---
--- You should report a problem if any other output is generated or if
--- the size of the floating point errors seem excessively large.
-----------------------------------------------------------------"
-
- # Test bignums early since printing depends on bignums
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/bignums.hs" "-itest/bignums.input" "-o1test/bignums.output"
-
- # Using generic printer
- perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/print.hs" "-itest/print.input" "-o1test/print1.output"
- perl runstdtest hugs +q -pHugs: -u -f -s18 "-Otest/print.hs" "-itest/print.input" "-o1test/print2.output"
- #perl runstdtest hugs +q -pHugs: -u -f -s18 "-Otest/catch.hs" "-itest/catch.input" "-o1test/catch.output"
- perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/enum.hs" "-itest/enum.input" "-o1test/enum.output1"
- perl runstdtest hugs +q -pHugs: -u -s18 "-Otest/infix.hs" "-itest/infix.input" "-o1test/infix.output"
-
- # Using derived show instance
- #perl runstdtest hugs +q -pHugs: +u -f -s18 "-Otest/catch2.hs" "-itest/catch.input" "-o1test/catch2.output"
-
- # Using derived instances
- perl runstdtest hugs +q -pHugs: +u -s18 "-Otest/enum.hs" "-itest/enum.input" "-o1test/enum.output2"
- perl runstdtest hugs +q -pHugs: +u -s18 "-Otest/maxint.hs" "-itest/maxint.input" "-o1test/maxint.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/ord.hs" "-itest/ord.input" "-o1test/ord.output"
- perl runstdtest hugs +q -pHugs: -s25 "-Otest/read.hs" "-itest/read.input" "-o1test/read.output"
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/arith.hs" "-itest/arith.input" "-o1test/arith.output"
-
- perl runstdtest hugs +q -pHugs: -s18 "-Otest/testlist.hs" "-itest/testlist.input" "-o1test/testlist.output"
-
- perl runstdtest hugs +q -pHugs: -s29 "-Otest/arrayt.hs" "-itest/array1.input" "-o1test/array1.output"
- perl runstdtest hugs +q -pHugs: -s29 "-Otest/array2.hs" "-itest/array2.input" "-o1test/array2.output"
- perl runstdtest hugs +q -pHugs: -s29 "-Otest/arrayEx.hs" "-itest/arrayEx.input" "-o1test/arrayEx.output"
-
-
- # Old test code from hugs +q -pHugs:0 - it will probably get resurrected at some stage
- #
- # if TESTREFS
- # if IO_REFS
- # perl runstdtest hugs +q -pHugs: "-Otest/refs.hs" "-itest/refs.input" "-o1test/refs.output"
- # fi
- # else
- # echo "Not testing Refs"
- # fi
- #
- # if TESTPTREQ
- # if IO_REFS
- # perl runstdtest hugs +q -pHugs: "-Otest/ptrEq.hs" "-itest/ptrEq.input" "-o1test/ptrEq.output"
- # fi
- # else
- # echo "Not testing Pointer equality"
- # fi
- #
- # if TESTMUTVARS
- # if ST_MUTVARS
- # perl runstdtest hugs +q -pHugs: "-Otest/mutvars.hs" "-itest/mutvars.input" "-o1test/mutvars.output"
- # fi
- # else
- # echo "Not testing MutVars"
- # fi
- #
- # if TESTIOERROR
- # if !OLD_IOMONAD
- # perl runstdtest hugs +q -pHugs: "-Otest/ioerror1.hs" "-itest/ioerror1.input" "-o1test/ioerror1.output"
- # perl runstdtest hugs +q -pHugs: "-Otest/ioerror2.hs" "-itest/ioerror2.input" "-o1test/ioerror2.output"
- # if IO_HANDLES
- # /* Create an unreadable file (its impossible to supply one in a tar file!) */
- # cat >test/unreadable.tst <<EOF
- # This file should be read+q -protected.
- # perl runstdtests/iohandle.hs attempts to write it.
- # EOF
- # CHMOD 200 "test/unreadable.tst"
- # perl runstdtest hugs +q -pHugs: "-Otest/iohandle.hs" "-itest/iohandle.input" "-o1test/iohandle.output"
- # RM "test/unreadable.tst"
- # fi
- # fi /* !OLD_IOMONAD */
- # else
- # echo "Not testing IOError"
- # fi /* TESTIOERROR */
- #
- # if TESTCONCURRENCY
- # if CONCURRENCY
- # perl runstdtest hugs +q -pHugs: "-Otest/mvar.hs" "-itest/mvar.input" "-o1test/mvar.output"
- # fi
- # else
- # echo "Not testing concurrency"
- # fi
- #
- # if TESTGC
- # perl runstdtest hugs +q -pHugs: "-Otest/gc.hs" "-itest/gc1.input" "-o1test/gc1.output"
- # perl runstdtest hugs +q -pHugs: -H200000" "-Otest/gc.hs" "-itest/gc1.input" "-o1test/gc1.output"
- # perl runstdtest hugs +q -pHugs: -H100000" "-Otest/gc.hs" "-itest/gc2.input" "-o1test/gc2.output"
- # else
- # echo "Not testing GC"
- # fi
- #
- # else
- # echo "Not testing runtime system"
- # fi
-
-} # End of test_rts
-
-test_libs() {
- echo "\
-----------------------------------------------------------------
--- Testing standard libraries for static errors and some old bugs.
---
--- This group of checks tests that each of the standard libraries
--- loads correctly. This generates no output if it works.
--- It also tests the results generated by a few of the standard
--- libraries. This produces the following output.
---
--- --!!! Performing static tests on standard libraries - please wait
--- --!!! Performing static tests on GHC-compatible libraries
--- --!!! Performing static tests on Hugs libraries
--- --!!! Performing static tests on Haskore libraries
--- --!!! Performing dynamic tests on libraries
--- --!!! Testing (List.\\) and related functions
--- --!!! Testing System
--- --!!! Testing Int and Word
---
--- On Windows, it may also produce output that looks like this:
---
--- ./hugs +q -pHugs: test/system1.hs < test/system1.input
--- expected stdout not matched by reality
--- *** test/system1.output Fri Jul 11 13:25:27 1997
--- --- /tmp/runtest3584.3 Fri Jul 11 15:55:13 1997
--- ***************
--- *** 1,3 ****
--- ...
--- | Hugs:ExitFailure 1
--- | Hugs:ExitFailure 2
--- ...
--- --- 1,3 ----
--- ...
--- | Hugs:ExitSuccess
--- | Hugs:ExitSuccess
--- ...
---
--- This reflects the sad fact that System.system always returns
--- ExitSuccess on DOS machines. This is a known bug in DOS.
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------"
-
- echo "--!!! Performing static tests on standard libraries - please wait"
- perl runstdtest hugs +q -pHugs: Array -s27
- perl runstdtest hugs +q -pHugs: Char -s19
- perl runstdtest hugs +q -pHugs: Complex -s19
- perl runstdtest hugs +q -pHugs: IO -s24
- perl runstdtest hugs +q -pHugs: Ix -s19
- perl runstdtest hugs +q -pHugs: List -s22
- perl runstdtest hugs +q -pHugs: Maybe -s19
- perl runstdtest hugs +q -pHugs: Monad -s19
- perl runstdtest hugs +q -pHugs: Ratio -s19
- perl runstdtest hugs +q -pHugs: System -s19
-
- echo "--!!! Performing static tests on GHC-compatible libraries"
- perl runstdtest hugs +q -pHugs: IOExts -s27 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: ST -s33 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: LazyST -s33 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: Concurrent -s42 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: Addr -s17 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: Word -s22 "-o1test/Loaded.output"
- perl runstdtest hugs +q -pHugs: Int -s20 "-o1test/Loaded.output"
-
- echo "--!!! Performing static tests on Hugs libraries"
- perl runstdtest hugs +q -pHugs: HugsLibs -s68 "-o1test/HugsLibs.output"
-
- echo "--!!! Performing static tests on Haskore libraries"
- perl runstdtest hugs +q -pHugs: Haskore -s60 "-o1test/Loaded.output"
-
- echo "--!!! Performing dynamic tests on libraries"
- # Specific tests - checking that old bugs have been fixed
- perl runstdtest hugs +q -pHugs: List -s22 "-Otest/list1.hs" "-itest/list1.input" "-o1test/list1.output"
- perl runstdtest hugs +q -pHugs: System -s19 "-Otest/system1.hs" "-itest/system1.input" "-o1test/system1.output"
- perl runstdtest hugs +q -pHugs: Complex -s17 "-itest/complex1.input" "-o1test/complex1.output"
- perl runstdtest hugs +q -pHugs: Int -s25 "-Otest/intTest.hs" "-itest/intTest.input" "-o1test/intTest.output"
- perl runstdtest hugs +q -pHugs: test/FixIO.lhs -s33 "-itest/FixIO.input" "-o1test/FixIO.output"
-
-} # End of test_libs
-
-test_demos() {
- echo "\
-----------------------------------------------------------------
--- Testing demos for static errors.
---
--- This group of checks tests that each of the demos loads correctly.
--- It should generate this output:
---
--- --!!! Performing static checks on demos
--- --!!! Performing static checks on Haskore demos
---
--- You should report a problem if any other output is generated.
-----------------------------------------------------------------"
-
- echo "--!!! Performing static checks on demos"
- perl runstdtest hugs -w +q -pHugs: ../demos/Demos -s58 "-o1test/Loaded.output"
- perl runstdtest hugs -w +q -pHugs: ../demos/prolog/Main -s23 "-o1test/Loaded.output"
- perl runstdtest hugs -w +q -pHugs: ../demos/cgi/Counter -s30 "-o1test/Loaded.output"
-
- # Test that Haskore demos load successfully
- echo "--!!! Performing static checks on Haskore demos"
- perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/HaskoreExamples -s42 "-o1test/Loaded.output"
- perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/SelfSim -s40 "-o1test/Loaded.output"
- perl runstdtest hugs -w +q -pHugs: ../lib/Haskore/demos/ChildSong6 -s40 "-o1test/Loaded.output"
-
-} # End of test demos
-
-test_temp() {
- echo "\
-----------------------------------------------------------------
--- Testing temporary tests
--- These aren't invoked by the usual "make check" - they serve
--- as a marshalling area when adding new tests
-----------------------------------------------------------------"
-
-} # End of test temp
-
-case "$1" in
-static) test_static;;
-tcheck) test_tcheck;;
-rts) test_rts;;
-libs) test_libs;;
-demos) test_demos;;
-temp) test_temp;;
-*) echo Unknown test $1;;
-esac
-
-echo "----------------------------------------------------------------"
-
+++ /dev/null
--- test:
--- A split-screen program:
--- User input is displayed in top half of screen;
--- Program output in the bottom half of the screen.
-
-module TestCVar(talk) where
-import Concurrent(
- forkIO, CVar, newCVar, readCVar, writeCVar
- )
-
--- from ansi.hs (modified for Xterm settings)
-goto :: Int -> Int -> String
-goto x y = "\ESC[" ++ show (y+1) ++ ";" ++ show (x+1) ++ "H"
-
-cls :: String
-cls = "\ESC[H\ESC[2J" -- for Xterm
-
--- Raw terminal handler:
--- Atomically writes characters to screen at specific coordinates.
-
-type Terminal = CVar (Int,Int,Char)
-
-terminal :: IO Terminal
-terminal
- = newCVar >>= \ buf ->
- forkIO (server_loop buf) >>
- return buf
- where
- -- possible optimisation:
- -- remember current screen location to let us omit goto sometimes
- server_loop buf
- = readCVar buf >>= \ (x,y,c) ->
- putStr (goto x y) >>
- putChar c >>
- server_loop buf
-
--- Window handler:
--- Keeps track of cursor position so that user program doesn't have to.
--- Doesn't do redraw, scrolling, clipping, etc
-
-type DemoWindow = CVar Char
-
-window :: Terminal -> Int -> Int -> IO DemoWindow
-window t left top
- = newCVar >>= \ buf ->
- forkIO (server_loop buf left top) >>
- return buf
- where
- server_loop buf x y
- = readCVar buf >>= \ c ->
- if c == '\n' then
- server_loop buf left (y+1)
- else
- writeCVar t (x,y,c) >>
- server_loop buf (x+1) y
-
-put :: DemoWindow -> Char -> IO ()
-put w c = writeCVar w c
-
--- copy input to top of screen, output to bottom of screen
-talk :: (Char -> Char) -> IO ()
-talk f =
- putStr cls >>
- terminal >>= \ t ->
- window t 0 0 >>= \ w1 ->
- window t 0 12 >>= \ w2 ->
- loop w1 w2
- where
- loop w1 w2
- = getCh >>= \ c ->
- put w1 c >>
- put w2 (f c) >>
- loop w1 w2
-
--- Non-blocking getchar
--- ToDo: find a way to replace the busy wait.
--- (Not easy in Unix!)
-getCh :: IO Char
-getCh
- = primIOAvailable >>= \ avail ->
- if avail then
- getChar
- else
- primWait >>
- getCh
+++ /dev/null
-<<<<<<<<<<<<<< variant A
-
->>>>>>>>>>>>>> variant B
-======= end of combination
-/* --------------------------------------------------------------------------
- * This file provides a simple mechanism for measuring elapsed time on Unix
- * machines (more precisely, on any machine with an rusage() function).
- * A somewhat limited version for other systems is also included, believed
- * to be ANSI compatible, but not guaranteed ...
- *
- * It is included in the Hugs distribution for the purpose of benchmarking
- * the Hugs interpreter, comparing its performance across a variety of
- * different machines, and with other systems for similar languages.
- *
- * To make use of these functions, use the --enable-timer when configuring
- * Hugs or change the setting of "WANT_TIMER" in config.h and recompile
- * Hugs.
- *
- * It would be somewhat foolish to try to use the timings produced in this
- * way for anything other than the purpose described above. In particular,
- * using timings to compare the performance of different versions of an
- * algorithm is likely to give very misleading results. The current
- * implementation of Hugs as an interpreter, without any significant
- * optimizations, means that there are much more significant overheads than
- * can be accounted for by small variations in Hugs code.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: timer.c,v $
- * $Revision: 1.4 $
- * $Date: 1999/10/15 21:41:00 $
- * ------------------------------------------------------------------------*/
-
-
-#if defined(HAVE_SYS_TIME_H) && defined(HAVE_SYS_RESOURCE_H)
-#include <sys/time.h>
-#include <sys/resource.h>
-
-void updateTimers Args((void));
-long millisecs Args((long));
-long userElapsed, systElapsed;
-
-void updateTimers() {
- static long lastUser = 0;
- static long lastSyst = 0;
- long curr;
- struct rusage ruse;
- getrusage(RUSAGE_SELF,&ruse);
-
- curr = ruse.ru_utime.tv_sec*1000000L + ruse.ru_utime.tv_usec;
- userElapsed = curr - lastUser;
- lastUser = curr;
-
- curr = ruse.ru_stime.tv_sec*1000000L + ruse.ru_stime.tv_usec;
- systElapsed = curr - lastSyst;
- lastSyst = curr;
-}
-
-long millisecs(t)
-long t; {
- return (t+500)/1000;
-}
-#else
-#include <time.h>
-
-void updateTimers Args((void));
-long millisecs Args((clock_t));
-clock_t userElapsed=0, systElapsed=0;
-
-void updateTimers() {
- static clock_t lastUser = 0;
- clock_t curr;
- curr = clock();
- userElapsed = curr - lastUser;
- lastUser = curr;
-}
-
-long millisecs(t)
-clock_t t; {
- return (long)((t * 1000)/CLK_TCK);
-}
-#endif
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * Translator: generates stg code from output of pattern matching
- * compiler.
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: translate.c,v $
- * $Revision: 1.35 $
- * $Date: 2000/05/12 11:59:39 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h"
-
-
-/* ---------------------------------------------------------------- */
-
-static StgVar local stgOffset ( Offset,List );
-static StgVar local stgText ( Text,List );
-static StgRhs local stgRhs ( Cell,Int,List,StgExpr );
-static StgCaseAlt local stgCaseAlt ( Cell,Int,List,StgExpr );
-static StgExpr local stgExpr ( Cell,Int,List,StgExpr );
-
-/* ---------------------------------------------------------------- */
-
-static Cell local stgOffset(Offset o, List sc)
-{
- Cell r = cellAssoc(o,sc);
- assert(nonNull(r));
- return snd(r);
-}
-
-static Cell local stgText(Text t,List sc)
-{
- List xs = sc;
- for (; nonNull(xs); xs=tl(xs)) {
- Cell x = hd(xs);
- Cell v = fst(x);
- if (!isOffset(v) && t == textOf(v)) {
- return snd(x);
- }
- }
- internal("stgText");
-}
-
-/* ---------------------------------------------------------------- */
-
-static StgRhs local stgRhs(e,co,sc,failExpr)
-Cell e;
-Int co;
-List sc;
-StgExpr failExpr; {
- switch (whatIs(e)) {
-
- /* Identifiers */
- case OFFSET:
- return stgOffset(e,sc);
- case VARIDCELL:
- case VAROPCELL:
- return stgText(textOf(e),sc);
- case TUPLE:
- return e;
- case NAME:
- return e;
- /* Literals */
- case CHARCELL:
- return mkStgCon(nameMkC,singleton(e));
- case INTCELL:
- return mkStgCon(nameMkI,singleton(e));
- case BIGCELL:
- return mkStgCon(nameMkInteger,singleton(e));
- case FLOATCELL:
- return mkStgCon(nameMkD,singleton(e));
- case STRCELL:
-#if USE_ADDR_FOR_STRINGS
- {
- StgVar v = mkStgVar(mkStgCon(nameMkA,singleton(e)),NIL);
- return mkStgLet(singleton(v),
- makeStgApp(nameUnpackString,singleton(v)));
- }
-#else
- return mkStgApp(nameUnpackString,singleton(e));
-#endif
- case AP:
- return stgExpr(e,co,sc,namePMFail);
- case NIL:
- internal("stgRhs2");
- default:
- return stgExpr(e,co,sc,failExpr/*namePMFail*/);
- }
-}
-
-static StgCaseAlt local stgCaseAlt(alt,co,sc,failExpr)
-Cell alt;
-Int co;
-List sc;
-StgExpr failExpr;
-{
- StgDiscr d = fst(alt);
- Int da = discrArity(d);
- Cell vs = NIL;
- Int i;
- for(i=1; i<=da; ++i) {
- StgVar nv = mkStgVar(NIL,NIL);
- vs = cons(nv,vs);
- sc = cons(pair(mkOffset(co+i),nv),sc);
- }
- return mkStgCaseAlt(d,vs,stgExpr(snd(alt),co+da,sc,failExpr));
-}
-
-static StgExpr local stgExpr(e,co,sc,failExpr)
-Cell e;
-Int co;
-List sc;
-StgExpr failExpr;
-{
- switch (whatIs(e)) {
- case COND:
- {
- return makeStgIf(stgExpr(fst3(snd(e)),co,sc,namePMFail),
- stgExpr(snd3(snd(e)),co,sc,failExpr),
- stgExpr(thd3(snd(e)),co,sc,failExpr));
- }
- case GUARDED:
- {
- List guards = reverse(snd(e));
- e = failExpr;
- for(; nonNull(guards); guards=tl(guards)) {
- Cell g = hd(guards);
- Cell c = stgExpr(fst(g),co,sc,namePMFail);
- Cell rhs = stgExpr(snd(g),co,sc,failExpr);
- e = makeStgIf(c,rhs,e);
- }
- return e;
- }
- case FATBAR:
- {
- StgExpr e2 = stgExpr(snd(snd(e)),co,sc,failExpr);
- StgVar alt = mkStgVar(e2,NIL);
- return mkStgLet(singleton(alt),stgExpr(fst(snd(e)),co,sc,alt));
- }
- case CASE:
- {
- List alts = snd(snd(e));
- Cell scrut = stgExpr(fst(snd(e)),co,sc,namePMFail);
- if (isNull(alts)) {
- return failExpr;
- } else if (isChar(fst(hd(alts)))) {
- Cell alt = hd(alts);
- StgDiscr d = fst(alt);
- StgVar c = mkStgVar(
- mkStgCon(nameMkC,singleton(d)),NIL);
- StgExpr test = nameEqChar;
- /* duplicates scrut but it should be atomic */
- return makeStgIf(
- makeStgLet(singleton(c),
- makeStgApp(test,doubleton(scrut,c))),
- stgExpr(snd(alt),co,sc,failExpr),
- stgExpr(ap(CASE,pair(fst(snd(e)),
- tl(alts))),co,sc,failExpr));
- } else {
- List as = NIL;
- for(; nonNull(alts); alts=tl(alts)) {
- as = cons(stgCaseAlt(hd(alts),co,sc,failExpr),as);
- }
- return mkStgCase(
- scrut,
- revOnto(
- as,
- singleton(mkStgDefault(mkStgVar(NIL,NIL),
- failExpr))));
- }
- }
- case NUMCASE:
- {
- Triple nc = snd(e);
- Offset o = fst3(nc);
- Cell discr = snd3(nc);
- Cell r = thd3(nc);
- Cell scrut = stgOffset(o,sc);
- Cell h = getHead(discr);
- Int da = discrArity(discr);
- char str[30];
-
- if (whatIs(h) == ADDPAT && argCount == 1) {
- /* ADDPAT num dictIntegral
- * ==>
- * let n = fromInteger num in
- * if pmLe dictIntegral n scrut
- * then let v = pmSubtract dictIntegral scrut v
- * else fail
- */
- Cell n = snd(h);
- Cell dictIntegral = arg(discr); /* Integral dictionary */
- StgVar v = NIL;
- List binds = NIL;
- StgVar dIntegral = NIL;
-
- /* bind dictionary */
- dIntegral = stgRhs(dictIntegral,co,sc,namePMFail);
- if (!isAtomic(dIntegral)) { /* wasn't atomic */
- dIntegral = mkStgVar(dIntegral,NIL);
- binds = cons(dIntegral,binds);
- }
-
- /* box number */
- sprintf(str, "%d", n);
- n = mkStgVar(mkStgCon(nameMkInteger,singleton(stringToBignum(str))),NIL);
- binds = cons(n,binds);
-
- /* coerce number to right type (using Integral dict) */
- n = mkStgVar(mkStgApp(
- namePmFromInteger,doubleton(dIntegral,n)),NIL);
- binds = cons(n,binds);
-
- ++co;
- v = mkStgVar(mkStgApp(
- namePmSubtract,tripleton(dIntegral,scrut,n)),NIL);
- return
- mkStgLet(
- binds,
- makeStgIf(
- mkStgApp(namePmLe,tripleton(dIntegral,n,scrut)),
- mkStgLet(singleton(v),
- stgExpr(r,
- co,
- cons(pair(mkOffset(co),v),sc),
- failExpr)),
- failExpr));
- }
-
- assert(isName(h) && argCount == 2);
- {
- /* This code is rather ugly.
- * We ought to desugar it using one of the following:
- * if (==) dEq (fromInt dNum pat) scrut
- * if (==) dEq (fromInteger dNum pat) scrut
- * if (==) dEq (fromFloat dFractional pat) scrut
- * But it would be very hard to obtain the Eq dictionary
- * from the Num or Fractional dictionary we have.
- * Instead, we rely on the Prelude to supply 3 helper
- * functions which do the test for us.
- * primPmInt :: Num a => Int -> a -> Bool
- * primPmInteger :: Num a => Integer -> a -> Bool
- * primPmDouble :: Fractional a => Double -> a -> Bool
- */
- Cell n = arg(discr);
- Cell dict = arg(fun(discr));
- StgExpr d = NIL;
- List binds = NIL;
- //StgExpr m = NIL;
- Name box
- = h == nameFromInt ? nameMkI
- : h == nameFromInteger ? nameMkInteger
- : nameMkD;
- Name testFun
- = h == nameFromInt ? namePmInt
- : h == nameFromInteger ? namePmInteger
- : namePmDouble;
- Cell altsc = sc;
- Cell vs = NIL;
- Int i;
-
- for(i=1; i<=da; ++i) {
- Cell nv = mkStgVar(NIL,NIL);
- vs = cons(nv,vs);
- altsc = cons(pair(mkOffset(co+i),nv),altsc);
- }
- /* bind dictionary */
- d = stgRhs(dict,co,sc,namePMFail);
- if (!isAtomic(d)) { /* wasn't atomic */
- d = mkStgVar(d,NIL);
- binds = cons(d,binds);
- }
- /* bind number */
- n = mkStgVar(mkStgCon(box,singleton(n)),NIL);
- binds = cons(n,binds);
-
- return
- makeStgIf(
- mkStgLet(binds,
- mkStgApp(testFun,tripleton(d,n,scrut))),
- stgExpr(r,co+da,altsc,failExpr),
- failExpr
- );
- }
- }
-
- case LETREC:
- {
- List binds = NIL;
- List vs = NIL;
- List bs;
- /* allocate variables, extend scope */
- for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
- Cell nv = mkStgVar(NIL,NIL);
- sc = cons(pair(fst3(hd(bs)),nv),sc);
- binds = cons(nv,binds);
- vs = cons(nv,vs);
- }
- for(bs = fst(fst(snd(e))); nonNull(bs); bs=tl(bs)) {
- Cell nv = mkStgVar(NIL,NIL);
- sc = cons(pair(mkOffset(++co),nv),sc);
- binds = cons(nv,binds);
- vs = cons(nv,vs);
- }
- vs = rev(vs);
- /* transform functions */
- for(bs = snd(fst(snd(e))); nonNull(bs); bs=tl(bs), vs=tl(vs)) {
- Cell fun = hd(bs);
- Cell nv = hd(vs);
- List as = NIL;
- List funsc = sc;
- Int arity = intOf(snd3(fun));
- Int i;
- for(i=1; i<=arity; ++i) {
- Cell v = mkStgVar(NIL,NIL);
- as = cons(v,as);
- funsc = cons(pair(mkOffset(co+i),v),funsc);
- }
- stgVarBody(nv)
- = mkStgLambda(
- as,
- stgExpr(thd3(thd3(fun)),co+arity,funsc,namePMFail));
- }
- /* transform expressions */
- 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,namePMFail);
- }
- return mkStgLet(binds,stgRhs(snd(snd(e)),co,sc,failExpr/*namePMFail*/));
- }
-
- default: /* convert to an StgApp or StgVar plus some bindings */
- {
- List args = NIL;
- List binds = NIL;
- List as = NIL;
- Int length_args;
-
- /* Unwind args */
- while (isAp(e)) {
- Cell arg = arg(e);
- e = fun(e);
- args = cons(arg,args);
- }
-
- /* Special cases */
- if (e == nameSel && length(args) == 3) {
- Cell con = hd(args);
- StgExpr v = stgExpr(hd(tl(args)),co,sc,namePMFail);
- Int ix = intOf(hd(tl(tl(args))));
- Int da = discrArity(con);
- List vs = NIL;
- Int i;
- for(i=1; i<=da; ++i) {
- Cell nv = mkStgVar(NIL,NIL);
- vs=cons(nv,vs);
- }
- return
- mkStgCase(v,
- doubleton(mkStgCaseAlt(con,vs,nth(ix-1,vs)),
- mkStgDefault(mkStgVar(NIL,NIL),namePMFail)));
- }
-
- /* Arguments must be StgAtoms */
- for(as=args; nonNull(as); as=tl(as)) {
- StgRhs a = stgRhs(hd(as),co,sc,namePMFail);
- if (whatIs(a) == LETREC) {
- binds = appendOnto(stgLetBinds(a),binds);
- a = stgLetBody(a);
- }
- if (!isAtomic(a)) {
- a = mkStgVar(a,NIL);
- binds = cons(a,binds);
- }
- hd(as) = a;
- }
-
- /* Special case: saturated constructor application */
- length_args = length(args);
- if ( (isName(e) && isCfun(e)
- && name(e).arity > 0
- && name(e).arity == length_args
- && !name(e).hasStrict
- && numQualifiers(name(e).type) == 0)
- ||
- (isTuple(e) && tycon(e).tuple == length_args)
- ) {
- StgVar v;
- /* fprintf ( stderr, "saturated application of %s\n",
- textToStr(isTuple(e) ? tycon(e).text : name(e).text)); */
- v = mkStgVar(mkStgCon(e,args),NIL);
- binds = cons(v,binds);
- return mkStgLet(binds,v);
-
-
- }
-
- /* Function must be StgVar or Name */
- e = stgRhs(e,co,sc,namePMFail);
- if (!isStgVar(e) && !isName(e)) {
- e = mkStgVar(e,NIL);
- binds = cons(e,binds);
- }
-
- return makeStgLet(binds,makeStgApp(e,args));
- }
- }
-}
-
-
-Void stgDefn( Name n, Int arity, Cell e )
-{
- List vs = NIL;
- List sc = NIL;
- Int i, s;
- for (i = 1; i <= arity; ++i) {
- Cell nv = mkStgVar(NIL,NIL);
- vs = cons(nv,vs);
- sc = cons(pair(mkOffset(i),nv),sc);
- }
- stgVarBody(name(n).closure)
- = makeStgLambda(vs,stgExpr(e,arity,sc,namePMFail));
-}
-
-Void implementCfun(c,scs) /* Build implementation for constr */
-Name c; /* fun c. scs lists integers (1..)*/
-List scs; { /* in incr order of strict fields. */
- Int a = name(c).arity; /* arity, not incl dictionaries */
- Int ad = numQualifiers(name(c).type); /* the number of dictionaries */
- Type t = name(c).type;
-
- /* a+ad is total arity for this fn */
- if (a+ad > 0) {
- StgVar vcurr, e1, v, vsi;
- List args = makeArgs(a);
- List argsd = makeArgs(ad);
- 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(dupOnto(argsd,args),e1),NIL);
- name(c).closure = v;
- } else {
- StgVar v = mkStgVar(mkStgCon(c,NIL),NIL);
- name(c).closure = v;
- }
- addToCodeList ( currentModule, c );
- /* printStg(stderr, name(c).closure); fprintf(stderr,"\n\n"); */
-}
-
-/* --------------------------------------------------------------------------
- * Foreign function calls and primops
- * ------------------------------------------------------------------------*/
-
-/* Outbound denotes data moving from Haskell world to elsewhere.
- Inbound denotes data moving from elsewhere to Haskell world.
-*/
-static String charListToString ( List cs );
-static Cell foreignTy ( Bool outBound, Type t );
-static Cell foreignOutboundTy ( Type t );
-static Cell foreignInboundTy ( Type t );
-static Name repToBox ( char c );
-static StgRhs makeStgPrim ( Name,Bool,List,String,String );
-
-static String charListToString( List cs )
-{
- static char s[100];
-
- Int i = 0;
- assert( length(cs) < 100 );
- for(; nonNull(cs); ++i, cs=tl(cs)) {
- s[i] = charOf(hd(cs));
- }
- s[i] = '\0';
- return textToStr(findText(s));
-}
-
-static Cell foreignTy ( Bool outBound, Type t )
-{
- if (t == typeChar) return mkChar(CHAR_REP);
- else if (t == typeInt) return mkChar(INT_REP);
-#if 0
- else if (t == typeInteger)return mkChar(INTEGER_REP);
-#endif
- else if (t == typeWord) return mkChar(WORD_REP);
- else if (t == typeAddr) return mkChar(ADDR_REP);
- else if (t == typeFloat) return mkChar(FLOAT_REP);
- else if (t == typeDouble) return mkChar(DOUBLE_REP);
- else if (t == typeStable) return mkChar(STABLE_REP);
-#ifdef PROVIDE_FOREIGN
- else if (t == typeForeign)return mkChar(FOREIGN_REP);
- /* ToDo: argty only! */
-#endif
-#if 0
- else if (t == typePrimByteArray) return mkChar(BARR_REP);
- /* ToDo: argty only! */
- else if (whatIs(t) == AP) {
- Type h = getHead(t);
- if (h == typePrimMutableByteArray) return mkChar(MUTBARR_REP);
- /* ToDo: argty only! */
- }
-#endif
- /* ToDo: decent line numbers! */
- if (outBound) {
- ERRMSG(0) "Illegal outbound (away from Haskell) type" ETHEN
- ERRTEXT " \"" ETHEN ERRTYPE(t);
- ERRTEXT "\""
- EEND;
- } else {
- ERRMSG(0) "Illegal inbound (towards Haskell) type" ETHEN
- ERRTEXT " \"" ETHEN ERRTYPE(t);
- ERRTEXT "\""
- EEND;
- }
-}
-
-static Cell foreignOutboundTy ( Type t )
-{
- return foreignTy ( TRUE, t );
-}
-
-static Cell foreignInboundTy ( Type t )
-{
- return foreignTy ( FALSE, t );
-}
-
-static Name repToBox( char c )
-{
- switch (c) {
- case CHAR_REP: return nameMkC;
- case INT_REP: return nameMkI;
- case INTEGER_REP: return nameMkInteger;
- case WORD_REP: return nameMkW;
- case ADDR_REP: return nameMkA;
- case FLOAT_REP: return nameMkF;
- case DOUBLE_REP: return nameMkD;
- case ARR_REP: return nameMkPrimArray;
- case BARR_REP: return nameMkPrimByteArray;
- case REF_REP: return nameMkRef;
- case MUTARR_REP: return nameMkPrimMutableArray;
- case MUTBARR_REP: return nameMkPrimMutableByteArray;
- case STABLE_REP: return nameMkStable;
- case THREADID_REP: return nameMkThreadId;
- case MVAR_REP: return nameMkPrimMVar;
-#ifdef PROVIDE_WEAK
- case WEAK_REP: return nameMkWeak;
-#endif
-#ifdef PROVIDE_FOREIGN
- case FOREIGN_REP: return nameMkForeign;
-#endif
- default: return NIL;
- }
-}
-
-static StgPrimAlt boxResults( String reps, StgVar state )
-{
- List rs = NIL; /* possibly unboxed results */
- List bs = NIL; /* boxed results of wrapper */
- List rbinds = NIL; /* bindings used to box results */
- StgExpr e = NIL;
- Int i;
- for(i=0; reps[i] != '\0'; ++i) {
- StgRep k = mkStgRep(reps[i]);
- Cell v = mkStgPrimVar(NIL,k,NIL);
- Name box = repToBox(reps[i]);
- if (isNull(box)) {
- bs = cons(v,bs);
- } else {
- StgRhs rhs = mkStgCon(box,singleton(v));
- StgVar bv = mkStgVar(rhs,NIL); /* boxed */
- bs = cons(bv,bs);
- rbinds = cons(bv,rbinds);
- }
- rs = cons(v,rs);
- }
-
- /* Construct tuple of results */
- if (i == 0) {
- e = nameUnit;
- } else
- if (i == 1) {
- e = hd(bs);
- } else {
- StgVar r = mkStgVar(mkStgCon(mkTuple(i),rev(bs)),NIL);
- rbinds = cons(r,rbinds);
- e = r;
- }
- /* construct result pair if needed */
- if (nonNull(state)) {
- /* Note that this builds a tuple directly - we know it's
- * saturated.
- */
- StgVar r = mkStgVar(mkStgCon(mkTuple(2),doubleton(e,state)),NIL);
- rbinds = cons(r,rbinds);
- rs = cons(state,rs); /* last result is a state */
- e = r;
- }
- return mkStgPrimAlt(rev(rs),makeStgLet(rbinds,e));
-}
-
-static List mkUnboxedVars( String reps )
-{
- List as = NIL;
- Int i;
- for(i=0; reps[i] != '\0'; ++i) {
- Cell v = mkStgPrimVar(NIL,mkStgRep(reps[i]),NIL);
- as = cons(v,as);
- }
- return rev(as);
-}
-
-static List mkBoxedVars( String reps )
-{
- List as = NIL;
- Int i;
- for(i=0; reps[i] != '\0'; ++i) {
- as = cons(mkStgVar(NIL,NIL),as);
- }
- return rev(as);
-}
-
-static StgRhs unboxVars( String reps, List b_args, List u_args, StgExpr e )
-{
- if (nonNull(b_args)) {
- StgVar b_arg = hd(b_args); /* boxed arg */
- StgVar u_arg = hd(u_args); /* unboxed arg */
- Name box = repToBox(*reps);
- e = unboxVars(reps+1,tl(b_args),tl(u_args),e);
- if (isNull(box)) {
- /* Use a trivial let-binding */
- stgVarBody(u_arg) = b_arg;
- return mkStgLet(singleton(u_arg),e);
- } else {
- StgCaseAlt alt = mkStgCaseAlt(box,singleton(u_arg),e);
- return mkStgCase(b_arg,singleton(alt));
- }
- } else {
- return e;
- }
-}
-
-/* Generate wrapper for primop based on list of arg types and result types:
- *
- * makeStgPrim op# False "II" "II" =
- * \ x y -> "case x of { I# x# ->
- * case y of { I# y# ->
- * case op#{x#,y#} of { r1# r2# ->
- * let r1 = I# r1#; r2 = I# r2# in
- * (r1, r2)
- * }}}"
- */
-static StgRhs local makeStgPrim(op,addState,extra_args,a_reps,r_reps)
-Name op;
-Bool addState;
-List extra_args;
-String a_reps;
-String r_reps; {
- List b_args = NIL; /* boxed args to primop */
- List u_args = NIL; /* possibly unboxed args to primop */
- List alts = NIL;
- StgVar s0 = addState ? mkStgVar(NIL,NIL) : NIL;
- StgVar s1 = addState ? mkStgVar(NIL,NIL) : NIL;
-
- /* box results */
- if (strcmp(r_reps,"B") == 0) {
- StgPrimAlt altF
- = mkStgPrimAlt(singleton(
- mkStgPrimVar(mkInt(0),
- mkStgRep(INT_REP),NIL)
- ),
- nameFalse);
- StgPrimAlt altT
- = mkStgPrimAlt(
- singleton(mkStgPrimVar(NIL,mkStgRep(INT_REP),NIL)),
- nameTrue);
- alts = doubleton(altF,altT);
- assert(nonNull(nameTrue));
- assert(!addState);
- } else {
- alts = singleton(boxResults(r_reps,s1));
- }
- b_args = mkBoxedVars(a_reps);
- u_args = mkUnboxedVars(a_reps);
- if (addState) {
- List actual_args
- = appendOnto(extra_args,dupListOnto(u_args,singleton(s0)));
- StgRhs rhs
- = makeStgLambda(singleton(s0),
- unboxVars(a_reps,b_args,u_args,
- mkStgPrimCase(mkStgPrim(op,actual_args),
- alts)));
- StgVar m = mkStgVar(rhs,NIL);
- return makeStgLambda(b_args,
- mkStgLet(singleton(m),
- mkStgApp(nameMkIO,singleton(m))));
- } else {
- List actual_args = appendOnto(extra_args,u_args);
- return makeStgLambda(
- b_args,
- unboxVars(a_reps,b_args,u_args,
- mkStgPrimCase(mkStgPrim(op,actual_args),alts))
- );
- }
-}
-
-Void implementPrim ( n )
-Name n; {
- const AsmPrim* p = name(n).primop;
- StgRhs rhs = makeStgPrim(n,p->monad!=MONAD_Id,NIL,p->args,p->results);
- StgVar v = mkStgVar(rhs,NIL);
- name(n).closure = v;
- addToCodeList ( currentModule, n );
-}
-
-/* Generate wrapper code from (in,out) type lists.
- *
- * For example:
- *
- * inTypes = [Int,Float]
- * outTypes = [Char,Addr]
- * ==>
- * \ fun a1 a2 ->
- * let m = (\ s0 ->
- * case a1 of { I# a1# ->
- * case s2 of { F# a2# ->
- * case ccall# "IF" "CA" fun a1# a2# s0 of { r1# r2# s1 ->
- * let r1 = C# r1# in
- * let r2 = A# r2# in
- * let r = (r1,r2) in
- * (r,s1)
- * }}})
- * in primMkIO m
- * ::
- * Addr -> (Int -> Float -> IO (Char,Addr))
- */
-Void implementForeignImport ( Name n )
-{
- Type t = name(n).type;
- List argTys = NIL;
- List resultTys = NIL;
- CFunDescriptor* descriptor = 0;
- Bool addState = TRUE;
- Bool dynamic = isNull(name(n).defn);
- while (getHead(t)==typeArrow && argCount==2) {
- Type ta = fullExpand(arg(fun(t)));
- Type tr = arg(t);
- argTys = cons(ta,argTys);
- t = tr;
- }
- argTys = rev(argTys);
-
- /* argTys now holds the argument tys. If this is a dynamic call,
- the first one had better be an Addr.
- */
- if (dynamic) {
- if (isNull(argTys) || hd(argTys) != typeAddr) {
- ERRMSG(name(n).line) "First argument in f-i-dynamic must be an Addr"
- EEND;
- }
- }
-
- if (getHead(t) == typeIO) {
- resultTys = getArgs(t);
- assert(length(resultTys) == 1);
- resultTys = hd(resultTys);
- addState = TRUE;
- } else {
- resultTys = t;
- addState = FALSE;
- }
- resultTys = fullExpand(resultTys);
- if (isTuple(getHead(resultTys))) {
- resultTys = getArgs(resultTys);
- } else if (getHead(resultTys) == typeUnit) {
- resultTys = NIL;
- } else {
- resultTys = singleton(resultTys);
- }
- mapOver(foreignOutboundTy,argTys); /* allows foreignObj, byteArrays, etc */
- mapOver(foreignInboundTy,resultTys); /* doesn't */
- descriptor
- = mkDescriptor(charListToString(argTys),
- charListToString(resultTys));
- if (!descriptor) {
- ERRMSG(name(n).line) "Can't allocate memory for call descriptor"
- EEND;
- }
-
- /* ccall is the default convention, if it wasn't specified */
- if (isNull(name(n).callconv)
- || name(n).callconv == textCcall) {
- name(n).primop = addState ? &ccall_ccall_IO : &ccall_ccall_Id;
- }
- else if (name(n).callconv == textStdcall) {
- if (!stdcallAllowed()) {
- ERRMSG(name(n).line) "stdcall is not supported on this platform"
- EEND;
- }
- name(n).primop = addState ? &ccall_stdcall_IO : &ccall_stdcall_Id;
- }
- else
- internal ( "implementForeignImport: unknown calling convention");
-
- {
- Pair extName;
- void* funPtr;
- List extra_args;
- StgRhs rhs;
- StgVar v;
-
- if (dynamic) {
- funPtr = NULL;
- extra_args = singleton(mkAddr(descriptor));
- /* and we know that the first arg will be the function pointer */
- } else {
- extName = name(n).defn;
- funPtr = getDLLSymbol(name(n).line,
- textToStr(textOf(fst(extName))),
- textToStr(textOf(snd(extName))));
- if (funPtr == 0) {
- ERRMSG(name(n).line)
- "Could not find foreign function \"%s\" in \"%s\"",
- textToStr(textOf(snd(extName))),
- textToStr(textOf(fst(extName)))
- EEND;
- }
- extra_args = doubleton(mkAddr(descriptor),mkAddr(funPtr));
- }
-
- rhs = makeStgPrim(n,addState,extra_args,
- descriptor->arg_tys,
- descriptor->result_tys);
- v = mkStgVar(rhs,NIL);
- name(n).defn = NIL;
- name(n).closure = v;
- addToCodeList ( currentModule, n );
- }
-
- /* At this point the descriptor contains a tag for each arg,
- because that makes makeStgPrim generate the correct unwrap
- code. From now on, the descriptor is only used at the time
- the actual ccall is made. So we need to zap the leading
- addr arg IF this is a f-i-dynamic call.
- */
- if (dynamic) {
- descriptor->arg_tys++;
- descriptor->num_args--;
- }
-}
-
-
-
-/* Generate code:
- *
- * \ fun ->
- let e1 = A# "...."
- e3 = C# 'c' -- (ccall), or 's' (stdcall)
- in primMkAdjThunk fun e1 e3
-
- we require, and check that,
- fun :: prim_arg* -> IO prim_result
- */
-Text makeTypeDescrText ( Type t )
-{
- List argTys = NIL;
- List resultTys = NIL;
- List tdList;
-
-#if 0
- // I don't understand what this achieves.
- if (getHead(t)==typeArrow && argCount==2) {
- t = arg(fun(t));
- } else {
- return NIL;
- }
-#endif
- while (getHead(t)==typeArrow && argCount==2) {
- Type ta = fullExpand(arg(fun(t)));
- Type tr = arg(t);
- argTys = cons(ta,argTys);
- t = tr;
- }
- argTys = rev(argTys);
- if (getHead(t) == typeIO) {
- resultTys = getArgs(t);
- assert(length(resultTys) == 1);
- resultTys = hd(resultTys);
- } else {
- return NIL;
- }
- resultTys = fullExpand(resultTys);
-
- mapOver(foreignInboundTy,argTys);
-
- tdList = cons(mkChar(':'),argTys);
- if (resultTys != typeUnit)
- tdList = cons(foreignOutboundTy(resultTys),tdList);
-
- return findText(charListToString ( tdList ));
-}
-
-
-Void implementForeignExport ( Name n )
-{
- Text tdText;
- List args;
- StgVar e1, e2, e3, v;
- StgExpr fun;
- Char cc_char;
-
- tdText = makeTypeDescrText ( name(n).type );
- if (isNull(tdText)) {
- ERRMSG(name(n).line) "foreign export has illegal type" ETHEN
- ERRTEXT " \"" ETHEN ERRTYPE(name(n).type);
- ERRTEXT "\""
- EEND;
- }
-
- /* ccall is the default convention, if it wasn't specified */
- if (isNull(name(n).callconv)
- || name(n).callconv == textCcall) {
- cc_char = 'c';
- }
- else if (name(n).callconv == textStdcall) {
- if (!stdcallAllowed()) {
- ERRMSG(name(n).line) "stdcall is not supported on this platform"
- EEND;
- }
- cc_char = 's';
- }
- else
- internal ( "implementForeignExport: unknown calling convention");
-
- args = makeArgs(1);
- e1 = mkStgVar(
- mkStgCon(nameMkA,singleton(ap(STRCELL,tdText))),
- NIL
- );
- e2 = mkStgVar(
- mkStgApp(nameUnpackString,singleton(e1)),
- NIL
- );
- e3 = mkStgVar(
- mkStgCon(nameMkC,singleton(mkChar(cc_char))),
- NIL
- );
- fun = mkStgLambda(
- args,
- mkStgLet(
- tripleton(e1,e2,e3),
- mkStgApp(
- nameCreateAdjThunk,
- cons(hd(args),cons(e2,cons(e3,NIL)))
- )
- )
- );
-
- v = mkStgVar(fun,NIL);
-
- name(n).defn = NIL;
- name(n).closure = v;
- addToCodeList ( currentModule, n );
-}
-
-Void implementTuple(size)
-Int size; {
- if (size > 0) {
- Tycon t = mkTuple(size);
- List args = makeArgs(size);
- StgVar tv = mkStgVar(mkStgCon(t,args),NIL);
- StgExpr e = mkStgLet(singleton(tv),tv);
- StgVar v = mkStgVar(mkStgLambda(args,e),NIL);
- tycon(t).closure = v;
- addToCodeList ( currentModule, t );
- } else {
- addToCodeList ( currentModule, nameUnit );
- }
-}
-
-/* --------------------------------------------------------------------------
- * Compiler control:
- * ------------------------------------------------------------------------*/
-
-Void translateControl(what)
-Int what; {
- switch (what) {
- case POSTPREL: break;
- case PREPREL:
- case RESET:
- break;
- case MARK:
- break;
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-
-/* --------------------------------------------------------------------------
- * This is the Hugs type checker
- *
- * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
- * Yale Haskell Group, and the Oregon Graduate Institute of Science and
- * Technology, 1994-1999, All rights reserved. It is distributed as
- * free software under the license in the file "License", which is
- * included in the distribution.
- *
- * $RCSfile: type.c,v $
- * $Revision: 1.36 $
- * $Date: 2000/05/26 17:42:18 $
- * ------------------------------------------------------------------------*/
-
-#include "hugsbasictypes.h"
-#include "storage.h"
-#include "connect.h"
-#include "errors.h"
-
-#include "Rts.h" /* to make StgPtr visible in Assembler.h */
-#include "Assembler.h" /* for AsmCTypes */
-
-/*#define DEBUG_TYPES*/
-/*#define DEBUG_KINDS*/
-/*#define DEBUG_DEFAULTS*/
-/*#define DEBUG_SELS*/
-/*#define DEBUG_DEPENDS*/
-/*#define DEBUG_DERIVING*/
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Void local emptyAssumption ( Void );
-static Void local enterBindings ( Void );
-static Void local leaveBindings ( Void );
-static Int local defType ( Cell );
-static Type local useType ( Cell );
-static Void local markAssumList ( List );
-static Cell local findAssum ( Text );
-static Pair local findInAssumList ( Text,List );
-static List local intsIntersect ( List,List );
-static List local genvarAllAss ( List );
-static List local genvarAnyAss ( List );
-static Int local newVarsBind ( Cell );
-static Void local newDefnBind ( Cell,Type );
-
-static Void local enterPendingBtyvs ( Void );
-static Void local leavePendingBtyvs ( Void );
-static Cell local patBtyvs ( Cell );
-static Void local doneBtyvs ( Int );
-static Void local enterSkolVars ( Void );
-static Void local leaveSkolVars ( Int,Type,Int,Int );
-
-static Void local typeError ( Int,Cell,Cell,String,Type,Int );
-static Void local reportTypeError ( Int,Cell,Cell,String,Type,Type );
-static Void local cantEstablish ( Int,String,Cell,Type,List );
-static Void local tooGeneral ( Int,Cell,Type,Type );
-
-static Cell local typeExpr ( Int,Cell );
-
-static Cell local typeAp ( Int,Cell );
-static Type local typeExpected ( Int,String,Cell,Type,Int,Int,Bool );
-static Void local typeAlt ( String,Cell,Cell,Type,Int,Int );
-static Int local funcType ( Int );
-static Void local typeCase ( Int,Int,Cell );
-static Void local typeComp ( Int,Type,Cell,List );
-static Cell local typeMonadComp ( Int,Cell );
-static Void local typeDo ( Int,Cell );
-static Void local typeConFlds ( Int,Cell );
-static Void local typeUpdFlds ( Int,Cell );
-#if IPARAM
-static Cell local typeWith ( Int,Cell );
-#endif
-static Cell local typeFreshPat ( Int,Cell );
-
-static Void local typeBindings ( List );
-static Void local removeTypeSigs ( Cell );
-
-static Void local monorestrict ( List );
-static Void local restrictedBindAss ( Cell );
-static Void local restrictedAss ( Int,Cell,Type );
-
-static Void local unrestricted ( List );
-static List local itbscc ( List );
-static Void local addEvidParams ( List,Cell );
-
-static Void local typeClassDefn ( Class );
-static Void local typeInstDefn ( Inst );
-static Void local typeMember ( String,Name,Cell,List,Cell,Int );
-
-static Void local typeBind ( Cell );
-static Void local typeDefAlt ( Int,Cell,Pair );
-static Cell local typeRhs ( Cell );
-static Void local guardedType ( Int,Cell );
-
-static Void local genBind ( List,Cell );
-static Void local genAss ( Int,List,Cell,Type );
-static Type local genTest ( Int,Cell,List,Type,Type,Int );
-static Type local generalize ( List,Type );
-static Bool local equalTypes ( Type,Type );
-
-static Void local typeDefnGroup ( List );
-static Pair local typeSel ( Name );
-
-
-
-/* --------------------------------------------------------------------------
- * Assumptions:
- *
- * A basic typing statement is a pair (Var,Type) and an assumption contains
- * an ordered list of basic typing statements in which the type for a given
- * variable is given by the most recently added assumption about that var.
- *
- * In practice, the assumption set is split between a pair of lists, one
- * holding assumptions for vars defined in bindings, the other for vars
- * defined in patterns/binding parameters etc. The reason for this
- * separation is that vars defined in bindings may be overloaded (with the
- * overloading being unknown until the whole binding is typed), whereas the
- * vars defined in patterns have no overloading. A form of dependency
- * analysis (at least as far as calculating dependents within the same group
- * of value bindings) is required to implement this. Where it is known that
- * no overloaded values are defined in a binding (i.e., when the `dreaded
- * monomorphism restriction' strikes), the list used to record dependents
- * is flagged with a NODEPENDS tag to avoid gathering dependents at that
- * level.
- *
- * To interleave between vars for bindings and vars for patterns, we use
- * a list of lists of typing statements for each. These lists are always
- * the same length. The implementation here is very similar to that of the
- * dependency analysis used in the static analysis component of this system.
- *
- * To deal with polymorphic recursion, variables defined in bindings can be
- * assigned types of the form (POLYREC,(def,use)), where def is a type
- * variable for the type of the defining occurence, and use is a type
- * scheme for (recursive) calls/uses of the variable.
- * ------------------------------------------------------------------------*/
-
-static List defnBounds; /*::[[(Var,Type)]] possibly ovrlded*/
-static List varsBounds; /*::[[(Var,Type)]] not overloaded */
-static List depends; /*::[?[Var]] dependents/NODEPENDS */
-static List skolVars; /*::[[Var]] skolem vars */
-static List localEvs; /*::[[(Pred,offset,ev)]] */
-static List savedPs; /*::[[(Pred,offset,ev)]] */
-static Cell dummyVar; /* Used to put extra tvars into ass*/
-
-Bool catchAmbigs = FALSE; /* TRUE => functions with ambig. */
- /* types produce error */
-
-
-#define saveVarsAss() List saveAssump = hd(varsBounds)
-#define restoreVarsAss() hd(varsBounds) = saveAssump
-#define addVarAssump(v,t) hd(varsBounds) = cons(pair(v,t),hd(varsBounds))
-#define findTopBinding(v) findInAssumList(textOf(v),hd(defnBounds))
-
-static Void local emptyAssumption() { /* set empty type assumption */
- defnBounds = NIL;
- varsBounds = NIL;
- depends = NIL;
- skolVars = NIL;
- localEvs = NIL;
- savedPs = NIL;
-}
-
-static Void local enterBindings() { /* Add new level to assumption sets */
- defnBounds = cons(NIL,defnBounds);
- varsBounds = cons(NIL,varsBounds);
- depends = cons(NIL,depends);
-}
-
-static Void local leaveBindings() { /* Drop one level of assumptions */
- defnBounds = tl(defnBounds);
- varsBounds = tl(varsBounds);
- depends = tl(depends);
-}
-
-static Int local defType(a) /* Return type for defining occ. */
-Cell a; { /* of a var from assumption pair */
- return (isPair(a) && fst(a)==POLYREC) ? fst(snd(a)) : a;
-}
-
-static Type local useType(a) /* Return type for use of a var */
-Cell a; { /* defined in an assumption */
- return (isPair(a) && fst(a)==POLYREC) ? snd(snd(a)) : a;
-}
-
-static Void local markAssumList(as) /* Mark all types in assumption set*/
-List as; { /* :: [(Var, Type)] */
- for (; nonNull(as); as=tl(as)) { /* No need to mark generic types; */
- Type t = defType(snd(hd(as))); /* the only free variables in those*/
- if (!isPolyType(t)) /* must have been free earlier too */
- markType(t,0);
- }
-}
-
-static Cell local findAssum(t) /* Find most recent assumption about*/
-Text t; { /* variable named t, if any */
- List defnBounds1 = defnBounds; /* return translated variable, with */
- List varsBounds1 = varsBounds; /* type in typeIs */
- List depends1 = depends;
-
- while (nonNull(defnBounds1)) {
- Pair ass = findInAssumList(t,hd(varsBounds1));/* search varsBounds */
- if (nonNull(ass)) {
- typeIs = snd(ass);
- return fst(ass);
- }
-
- ass = findInAssumList(t,hd(defnBounds1)); /* search defnBounds */
- if (nonNull(ass)) {
- Cell v = fst(ass);
- typeIs = snd(ass);
-
- if (hd(depends1)!=NODEPENDS && /* save dependent? */
- isNull(v=varIsMember(t,hd(depends1))))
- /* N.B. make new copy of variable and store this on list of*/
- /* dependents, and in the assumption so that all uses of */
- /* the variable will be at the same node, if we need to */
- /* overwrite the call of a function with a translation... */
- hd(depends1) = cons(v=mkVar(t),hd(depends1));
-
- return v;
- }
-
- defnBounds1 = tl(defnBounds1); /* look in next level*/
- varsBounds1 = tl(varsBounds1); /* of assumption set */
- depends1 = tl(depends1);
- }
- return NIL;
-}
-
-static Pair local findInAssumList(t,as)/* Search for assumption for var */
-Text t; /* named t in list of assumptions as*/
-List as; {
- for (; nonNull(as); as=tl(as))
- if (textOf(fst(hd(as)))==t)
- return hd(as);
- return NIL;
-}
-
-static List local intsIntersect(as,bs) /* calculate intersection of lists */
-List as, bs; { /* of integers (as sets) */
- List ts = NIL; /* destructively modifies as */
- while (nonNull(as))
- if (intIsMember(intOf(hd(as)),bs)) {
- List temp = tl(as);
- tl(as) = ts;
- ts = as;
- as = temp;
- }
- else
- as = tl(as);
- return ts;
-}
-
-static List local genvarAllAss(as) /* calculate generic vars that are */
-List as; { /* in every type in assumptions as */
- List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
- for (as=tl(as); nonNull(as) && nonNull(vs); as=tl(as))
- vs = intsIntersect(vs,genvarTyvar(intOf(defType(snd(hd(as)))),NIL));
- return vs;
-}
-
-static List local genvarAnyAss(as) /* calculate generic vars that are */
-List as; { /* in any type in assumptions as */
- List vs = genvarTyvar(intOf(defType(snd(hd(as)))),NIL);
- for (as=tl(as); nonNull(as); as=tl(as))
- vs = genvarTyvar(intOf(defType(snd(hd(as)))),vs);
- return vs;
-}
-
-static Int local newVarsBind(v) /* make new assump for pattern var */
-Cell v; {
- Int beta = newTyvars(1);
- addVarAssump(v,mkInt(beta));
-#ifdef DEBUG_TYPES
- Printf("variable, assume ");
- printExp(stdout,v);
- Printf(" :: _%d\n",beta);
-#endif
- return beta;
-}
-
-static Void local newDefnBind(v,type) /* make new assump for defn var */
-Cell v; /* and set type if given (nonNull) */
-Type type; {
- Int beta = newTyvars(1);
- Cell ta = mkInt(beta);
- instantiate(type);
- if (nonNull(type) && isPolyType(type))
- ta = pair(POLYREC,pair(ta,type));
- hd(defnBounds) = cons(pair(v,ta), hd(defnBounds));
-#ifdef DEBUG_TYPES
- Printf("definition, assume ");
- printExp(stdout,v);
- Printf(" :: _%d\n",beta);
-#endif
- bindTv(beta,typeIs,typeOff); /* Bind beta to new type skeleton */
-}
-
-/* --------------------------------------------------------------------------
- * Predicates:
- * ------------------------------------------------------------------------*/
-
-#include "preds.c"
-
-/* --------------------------------------------------------------------------
- * Bound and skolemized type variables:
- * ------------------------------------------------------------------------*/
-
-static List pendingBtyvs = NIL;
-
-static Void local enterPendingBtyvs() {
- enterBtyvs();
- pendingBtyvs = cons(NIL,pendingBtyvs);
-}
-
-static Void local leavePendingBtyvs() {
- List pts = hd(pendingBtyvs);
- pendingBtyvs = tl(pendingBtyvs);
- for (; nonNull(pts); pts=tl(pts)) {
- Int line = intOf(fst(hd(pts)));
- List vs = snd(hd(pts));
- Int i = 0;
- clearMarks();
- for (; nonNull(vs); vs=tl(vs)) {
- Cell v = fst(hd(vs));
- Cell t = copyTyvar(intOf(snd(hd(vs))));
- if (!isOffset(t)) {
- ERRMSG(line) "Type annotation uses variable " ETHEN ERREXPR(v);
- ERRTEXT " where a more specific type " ETHEN ERRTYPE(t);
- ERRTEXT " was inferred"
- EEND;
- }
- else if (offsetOf(t)!=i) {
- List us = snd(hd(pts));
- Int j = offsetOf(t);
- if (j>=i)
- internal("leavePendingBtyvs");
- for (; j>0; j--)
- us = tl(us);
- ERRMSG(line) "Type annotation uses distinct variables " ETHEN
- ERREXPR(v); ERRTEXT " and " ETHEN ERREXPR(fst(hd(us)));
- ERRTEXT " where a single variable was inferred"
- EEND;
- }
- else
- i++;
- }
- }
- leaveBtyvs();
-}
-
-static Cell local patBtyvs(p) /* Strip bound type vars from pat */
-Cell p; {
- if (whatIs(p)==BIGLAM) {
- List bts = hd(btyvars) = fst(snd(p));
- for (p=snd(snd(p)); nonNull(bts); bts=tl(bts)) {
- Int beta = newTyvars(1);
- tyvar(beta)->kind = snd(hd(bts));
- snd(hd(bts)) = mkInt(beta);
- }
- }
- return p;
-}
-
-static Void local doneBtyvs(l)
-Int l; {
- if (nonNull(hd(btyvars))) { /* Save bound tyvars */
- hd(pendingBtyvs) = cons(pair(mkInt(l),hd(btyvars)),hd(pendingBtyvs));
- hd(btyvars) = NIL;
- }
-}
-
-static Void local enterSkolVars() {
- skolVars = cons(NIL,skolVars);
- localEvs = cons(NIL,localEvs);
- savedPs = cons(preds,savedPs);
- preds = NIL;
-}
-
-static Void local leaveSkolVars(l,t,o,m)
-Int l;
-Type t;
-Int o;
-Int m; {
- if (nonNull(hd(localEvs))) { /* Check for local predicates */
- List sks = hd(skolVars);
- List sps = NIL;
- if (isNull(sks)) {
- internal("leaveSkolVars");
- }
- markAllVars(); /* Mark all variables in current */
- do { /* substitution, then unmark sks. */
- tyvar(intOf(fst(hd(sks))))->offs = UNUSED_GENERIC;
- sks = tl(sks);
- } while (nonNull(sks));
- normPreds(l);
- sps = elimPredsUsing(hd(localEvs),sps);
- preds = revOnto(preds,sps);
- }
-
- if (nonNull(hd(skolVars))) { /* Check that Skolem vars do not */
- List vs; /* escape their scope */
- Int i = 0;
-
- clearMarks(); /* Look for occurences in the */
- for (; i<m; i++) /* inferred type */
- markTyvar(o+i);
- markType(t,o);
-
- for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
- Int vn = intOf(fst(hd(vs)));
- if (tyvar(vn)->offs == FIXED_TYVAR) {
- Cell tv = copyTyvar(vn);
- Type ty = liftRank2(t,o,m);
- ERRMSG(l) "Existentially quantified variable in inferred type"
- ETHEN
- ERRTEXT "\n*** Variable : " ETHEN ERRTYPE(tv);
- ERRTEXT "\n*** From pattern : " ETHEN ERREXPR(snd(hd(vs)));
- ERRTEXT "\n*** Result type : " ETHEN ERRTYPE(ty);
- ERRTEXT "\n"
- EEND;
- }
- }
-
- markBtyvs(); /* Now check assumptions */
- mapProc(markAssumList,defnBounds);
- mapProc(markAssumList,varsBounds);
-
- for (vs=hd(skolVars); nonNull(vs); vs=tl(vs)) {
- Int vn = intOf(fst(hd(vs)));
- if (tyvar(vn)->offs == FIXED_TYVAR) {
- ERRMSG(l)
- "Existentially quantified variable escapes from pattern "
- ETHEN ERREXPR(snd(hd(vs)));
- ERRTEXT "\n"
- EEND;
- }
- }
- }
- localEvs = tl(localEvs);
- skolVars = tl(skolVars);
- preds = revOnto(preds,hd(savedPs));
- savedPs = tl(savedPs);
-}
-
-/* --------------------------------------------------------------------------
- * Type errors:
- * ------------------------------------------------------------------------*/
-
-static Void local typeError(l,e,in,wh,t,o)
-Int l; /* line number near type error */
-String wh; /* place in which error occurs */
-Cell e; /* source of error */
-Cell in; /* context if any (NIL if not) */
-Type t; /* should be of type (t,o) */
-Int o; { /* type inferred is (typeIs,typeOff) */
-
- clearMarks(); /* types printed here are monotypes */
- /* use marking to give sensible names*/
-#ifdef DEBUG_KINDS
-{ List vs = genericVars;
- for (; nonNull(vs); vs=tl(vs)) {
- Int v = intOf(hd(vs));
- Printf("%c :: ", ('a'+tyvar(v)->offs));
- printKind(stdout,tyvar(v)->kind);
- Putchar('\n');
- }
-}
-#endif
-
- reportTypeError(l,e,in,wh,copyType(typeIs,typeOff),copyType(t,o));
-}
-
-static Void local reportTypeError(l,e,in,wh,inft,expt)
-Int l; /* Error printing part of typeError*/
-Cell e, in;
-String wh;
-Type inft, expt; {
- ERRMSG(l) "Type error in %s", wh ETHEN
- if (nonNull(in)) {
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(in);
- }
- ERRTEXT "\n*** Term : " ETHEN ERREXPR(e);
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(inft);
- ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(expt);
- if (unifyFails) {
- ERRTEXT "\n*** Because : %s", unifyFails ETHEN
- }
- ERRTEXT "\n"
- EEND;
-}
-
-#define shouldBe(l,e,in,where,t,o) if (!unify(typeIs,typeOff,t,o)) \
- typeError(l,e,in,where,t,o);
-#define check(l,e,in,where,t,o) e=typeExpr(l,e); shouldBe(l,e,in,where,t,o)
-#define inferType(t,o) typeIs=t; typeOff=o
-#if IPARAM
-#define spTypeExpr(l,e) svPreds = preds; preds = NIL; e = typeExpr(l,e); preds = revOnto(preds,svPreds);
-#define spCheck(l,e,in,where,t,o) svPreds = preds; preds = NIL; check(l,e,in,where,t,o); preds = revOnto(preds,svPreds);
-#else
-#define spTypeExpr(l,e) e = typeExpr(l,e);
-#define spCheck(l,e,in,where,t,o) check(l,e,in,where,t,o);
-#endif
-
-static Void local cantEstablish(line,wh,e,t,ps)
-Int line; /* Complain when declared preds */
-String wh; /* are not sufficient to discharge */
-Cell e; /* or defer the inferred context. */
-Type t;
-List ps; {
- ERRMSG(line) "Cannot justify constraints in %s", wh ETHEN
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
- ERRTEXT "\n*** Type : " ETHEN ERRTYPE(t);
- ERRTEXT "\n*** Given context : " ETHEN ERRCONTEXT(ps);
- ERRTEXT "\n*** Constraints : " ETHEN ERRCONTEXT(copyPreds(preds));
- ERRTEXT "\n"
- EEND;
-}
-
-static Void local tooGeneral(l,e,dt,it) /* explicit type sig. too general */
-Int l;
-Cell e;
-Type dt, it; {
- ERRMSG(l) "Inferred type is not general enough" ETHEN
- ERRTEXT "\n*** Expression : " ETHEN ERREXPR(e);
- ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(dt);
- ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(it);
- ERRTEXT "\n"
- EEND;
-}
-
-/* --------------------------------------------------------------------------
- * Typing of expressions:
- * ------------------------------------------------------------------------*/
-
-#define EXPRESSION 0 /* type checking expression */
-#define NEW_PATTERN 1 /* pattern, introducing new vars */
-#define OLD_PATTERN 2 /* pattern, involving bound vars */
-static int tcMode = EXPRESSION;
-
-#ifdef DEBUG_TYPES
-static Cell local mytypeExpr ( Int,Cell));
-static Cell local typeExpr(l,e)
-Int l;
-Cell e; {
- static int number = 0;
- Cell retv;
- int mynumber = number++;
- List ps;
- STACK_CHECK
- Printf("%d) to check: ",mynumber);
- printExp(stdout,e);
- Putchar('\n');
- retv = mytypeExpr(l,e);
- Printf("%d) result: ",mynumber);
- printType(stdout,debugType(typeIs,typeOff));
- Printf("\n%d) preds: ",mynumber);
- printContext(stdout,debugContext(preds));
- Putchar('\n');
- return retv;
-}
-static Cell local mytypeExpr(l,e) /* Determine type of expr/pattern */
-#else
-static Cell local typeExpr(l,e) /* Determine type of expr/pattern */
-#endif
-Int l;
-Cell e; {
- static String cond = "conditional";
- static String list = "list";
- static String discr = "case discriminant";
- static String aspat = "as (@) pattern";
- static String typeSig = "type annotation";
- static String lambda = "lambda expression";
-#if IPARAM
- List svPreds;
-#endif
-
- switch (whatIs(e)) {
-
- /* The following cases can occur in either pattern or expr. mode */
-
- case AP :
- case NAME :
- case VAROPCELL :
- case VARIDCELL :
-#if IPARAM
- case IPVAR :
-#endif
- return typeAp(l,e);
-
- case TUPLE : typeTuple(e);
- break;
-
- case BIGCELL : { Int alpha = newTyvars(1);
- inferType(aVar,alpha);
- return ap(ap(nameFromInteger,
- assumeEvid(predNum,alpha)),
- e);
- }
-
- case INTCELL : { Int alpha = newTyvars(1);
- inferType(aVar,alpha);
- return ap(ap(nameFromInt,
- assumeEvid(predNum,alpha)),
- e);
- }
-
- case FLOATCELL : { Int alpha = newTyvars(1);
- inferType(aVar,alpha);
- return ap(ap(nameFromDouble,
- assumeEvid(predFractional,alpha)),
- e);
- }
-
- case STRCELL : inferType(typeString,0);
- break;
-
- case CHARCELL : inferType(typeChar,0);
- break;
-
- case CONFLDS : typeConFlds(l,e);
- break;
-
- case ESIGN : snd(snd(e)) = localizeBtyvs(snd(snd(e)));
- return typeExpected(l,typeSig,
- fst(snd(e)),snd(snd(e)),
- 0,0,FALSE);
-
-#if TREX
- case EXT : { Int beta = newTyvars(2);
- Cell pi = ap(e,aVar);
- Type t = fn(aVar,
- fn(ap(typeRec,bVar),
- ap(typeRec,ap(ap(e,aVar),bVar))));
- tyvar(beta+1)->kind = ROW;
- inferType(t,beta);
- return ap(e,assumeEvid(pi,beta+1));
- }
-#endif
-
- /* The following cases can only occur in expr mode */
-
- case UPDFLDS : typeUpdFlds(l,e);
- break;
-
-#if IPARAM
- case WITHEXP : return typeWith(l,e);
-#endif
-
- case COND : { Int beta = newTyvars(1);
- check(l,fst3(snd(e)),e,cond,typeBool,0);
- spCheck(l,snd3(snd(e)),e,cond,aVar,beta);
- spCheck(l,thd3(snd(e)),e,cond,aVar,beta);
- tyvarType(beta);
- }
- break;
-
- case LETREC : enterBindings();
- enterSkolVars();
- mapProc(typeBindings,fst(snd(e)));
- spTypeExpr(l,snd(snd(e)));
- leaveBindings();
- leaveSkolVars(l,typeIs,typeOff,0);
- break;
-
- case FINLIST : { Int beta = newTyvars(1);
- List xs;
- for (xs=snd(e); nonNull(xs); xs=tl(xs)) {
- spCheck(l,hd(xs),e,list,aVar,beta);
- }
- inferType(listof,beta);
- }
- break;
-
- case DOCOMP : typeDo(l,e);
- break;
-
- case COMP : return typeMonadComp(l,e);
-
- case CASE : { Int beta = newTyvars(2); /* discr result */
- check(l,fst(snd(e)),NIL,discr,aVar,beta);
- map2Proc(typeCase,l,beta,snd(snd(e)));
- tyvarType(beta+1);
- }
- break;
-
- case LAMBDA : { Int beta = newTyvars(1);
- enterPendingBtyvs();
- typeAlt(lambda,e,snd(e),aVar,beta,1);
- leavePendingBtyvs();
- tyvarType(beta);
- }
- break;
-
-#if TREX
- case RECSEL : { Int beta = newTyvars(2);
- Cell pi = ap(snd(e),aVar);
- Type t = fn(ap(typeRec,
- ap(ap(snd(e),aVar),
- bVar)),aVar);
- tyvar(beta+1)->kind = ROW;
- inferType(t,beta);
- return ap(e,assumeEvid(pi,beta+1));
- }
-#endif
-
- /* The remaining cases can only occur in pattern mode: */
-
- case WILDCARD : inferType(aVar,newTyvars(1));
- break;
-
- case ASPAT : { Int beta = newTyvars(1);
- snd(snd(e)) = typeExpr(l,snd(snd(e)));
- bindTv(beta,typeIs,typeOff);
- check(l,fst(snd(e)),e,aspat,aVar,beta);
- tyvarType(beta);
- }
- break;
-
- case LAZYPAT : snd(e) = typeExpr(l,snd(e));
- break;
-
- case ADDPAT : { Int alpha = newTyvars(1);
- inferType(typeVarToVar,alpha);
- return ap(e,assumeEvid(predIntegral,alpha));
- }
-
- default : internal("typeExpr");
- }
-
- return e;
-}
-
-/* --------------------------------------------------------------------------
- * Typing rules for particular special forms:
- * ------------------------------------------------------------------------*/
-
-static Cell local typeAp(l,e) /* Type check application, which */
-Int l; /* may be headed with a variable */
-Cell e; { /* requires polymorphism, qualified*/
- static String app = "application"; /* types, and possible rank2 args. */
- Cell h = getHead(e);
- Int n = argCount;
- Cell p = NIL;
- Cell a = e;
- Int i;
-#if IPARAM
- List svPreds;
-#endif
-
- switch (whatIs(h)) {
- case NAME : typeIs = name(h).type;
- break;
-
- case VAROPCELL :
- case VARIDCELL : if (tcMode==NEW_PATTERN) {
- inferType(aVar,newVarsBind(e));
- }
- else {
- Cell v = findAssum(textOf(h));
- if (nonNull(v)) {
- h = v;
- typeIs = (tcMode==OLD_PATTERN)
- ? defType(typeIs)
- : useType(typeIs);
- }
- else {
- h = findName(textOf(h));
- if (isNull(h))
- internal("typeAp0");
- typeIs = name(h).type;
- }
- }
- break;
-
-#if IPARAM
- case IPVAR : { Text t = textOf(h);
- Int alpha = newTyvars(1);
- Cell ip = pair(ap(IPCELL,t),aVar);
- Cell ev = assumeEvid(ip,alpha);
- typeIs = mkInt(alpha);
- h = ap(h,ev);
- }
- break;
-#endif
-
- default : h = typeExpr(l,h);
- break;
- }
-
- if (isNull(typeIs)) {
- internal("typeAp1");
- }
-
- instantiate(typeIs); /* Deal with polymorphism ... */
- if (nonNull(predsAre)) { /* ... and with qualified types. */
- List evs = NIL;
- for (; nonNull(predsAre); predsAre=tl(predsAre)) {
- evs = cons(assumeEvid(hd(predsAre),typeOff),evs);
- }
- /* we now _always_ do this: if (!isName(h) || !isCfun(h)) */ {
- h = applyToArgs(h,rev(evs));
- }
- }
-
- if (whatIs(typeIs)==CDICTS) { /* Deal with local dictionaries */
- List evs = makePredAss(fst(snd(typeIs)),typeOff);
- List ps = evs;
- typeIs = snd(snd(typeIs));
- for (; nonNull(ps); ps=tl(ps)) {
- h = ap(h,thd3(hd(ps)));
- }
- if (tcMode==EXPRESSION) {
- preds = revOnto(evs,preds);
- } else {
- hd(localEvs) = revOnto(evs,hd(localEvs));
- }
- }
-
- if (whatIs(typeIs)==EXIST) { /* Deal with existential arguments */
- Int n = intOf(fst(snd(typeIs)));
- typeIs = snd(snd(typeIs));
- if (!isCfun(getHead(h)) || n>typeFree) {
- internal("typeAp2");
- } else if (tcMode!=EXPRESSION) {
- Int alpha = typeOff + typeFree;
- for (; n>0; n--) {
- bindTv(alpha-n,SKOLEM,0);
- hd(skolVars) = cons(pair(mkInt(alpha-n),e),hd(skolVars));
- }
- }
- }
-
- if (whatIs(typeIs)==RANK2) { /* Deal with rank 2 arguments */
- Int alpha = typeOff;
- Int m = typeFree;
- Int nr2 = intOf(fst(snd(typeIs)));
- Type body = snd(snd(typeIs));
- List as = e;
- Bool added = FALSE;
-
- if (n<nr2) { /* Must have enough arguments */
- ERRMSG(l) "Use of " ETHEN ERREXPR(h);
- if (n>1) {
- ERRTEXT " in " ETHEN ERREXPR(e);
- }
- ERRTEXT " requires at least %d argument%s\n",
- nr2, (nr2==1 ? "" : "s")
- EEND;
- }
-
- for (i=nr2; i<n; ++i) /* Find rank two arguments */
- as = fun(as);
-
- for (as=getArgs(as); nonNull(as); as=tl(as), body=arg(body)) {
- Type expect = dropRank1(arg(fun(body)),alpha,m);
- if (isPolyOrQualType(expect)) {
- if (tcMode==EXPRESSION) /* poly/qual type in expr */
- hd(as) = typeExpected(l,app,hd(as),expect,alpha,m,TRUE);
- else if (hd(as)!=WILDCARD) { /* Pattern binding/match */
- if (!isVar(hd(as))) {
- ERRMSG(l) "Argument " ETHEN ERREXPR(arg(as));
- ERRTEXT " in pattern " ETHEN ERREXPR(e);
- ERRTEXT " where a variable is required\n"
- EEND;
- }
- if (tcMode==NEW_PATTERN) { /* Pattern match */
- if (m>0 && !added) {
- for (i=0; i<m; i++)
- addVarAssump(dummyVar,mkInt(alpha+i));
- added = TRUE;
- }
- addVarAssump(hd(as),expect);
- }
- else { /* Pattern binding */
- Text t = textOf(hd(as));
- Cell a = findInAssumList(t,hd(defnBounds));
- if (isNull(a))
- internal("typeAp3");
- instantiate(expect);
- if (nonNull(predsAre)) {
- ERRMSG(l) "Cannot use pattern binding for " ETHEN
- ERREXPR(hd(as));
- ERRTEXT " as a component with a qualified type\n"
- EEND;
- }
- shouldBe(l,hd(as),e,app,aVar,intOf(defType(snd(a))));
- }
- }
- }
- else { /* Not a poly/qual type */
- spCheck(l,hd(as),e,app,expect,alpha);
- }
- h = ap(h,hd(as)); /* Save checked argument */
- }
- inferType(body,alpha);
- n -= nr2;
- }
-
- if (n>0) { /* Deal with remaining args */
- Int beta = funcType(n); /* check h::t1->t2->...->tn->rn+1 */
- shouldBe(l,h,e,app,aVar,beta);
- for (i=n; i>0; --i) { /* check e_i::t_i for each i */
- spCheck(l,arg(a),e,app,aVar,beta+2*i-1);
- p = a;
- a = fun(a);
- }
- tyvarType(beta+2*n); /* Inferred type is r_n+1 */
- }
-
- if (isNull(p)) /* Replace head with translation */
- e = h;
- else
- fun(p) = h;
-
- return e;
-}
-
-static Cell local typeExpected(l,wh,e,reqd,alpha,n,addEvid)
-Int l; /* Type check expression e in wh */
-String wh; /* at line l, expecting type reqd, */
-Cell e; /* and treating vars alpha through */
-Type reqd; /* (alpha+n-1) as fixed. */
-Int alpha;
-Int n;
-Bool addEvid; { /* TRUE => add \ev -> ... */
- List savePreds = preds;
- Type t;
- Int o;
- Int m;
- List ps;
- Int i;
-
- instantiate(reqd);
- t = typeIs;
- o = typeOff;
- m = typeFree;
- ps = makePredAss(predsAre,o);
-
- preds = NIL;
- check(l,e,NIL,wh,t,o);
- improve(l,ps,preds);
-
- clearMarks();
- mapProc(markAssumList,defnBounds);
- mapProc(markAssumList,varsBounds);
- mapProc(markPred,savePreds);
- markBtyvs();
-
- if (n > 0) { /* mark alpha thru alpha+n-1, plus any */
- /* type vars that are functionally */
- List us = NIL, vs = NIL; /* dependent on them */
- List fds = calcFunDepsPreds(preds);
- for (i=0; i<n; i++) {
- Type t1 = zonkTyvar(alpha+i);
- us = zonkTyvarsIn(t1,us);
- }
- vs = oclose(fds,us);
- for (; nonNull(vs); vs=tl(vs))
- markTyvar(intOf(hd(vs)));
- }
-
- normPreds(l);
- savePreds = elimPredsUsing(ps,savePreds);
- if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
- savePreds = elimPredsUsing(ps,savePreds);
- if (nonNull(preds)) {
- Type ty = copyType(t,o);
- List qs = copyPreds(ps);
- cantEstablish(l,wh,e,ty,qs);
- }
-
- resetGenerics();
- for (i=0; i<m; i++)
- if (copyTyvar(o+i)!=mkOffset(i)) {
- List qs = copyPreds(ps);
- Type it = copyType(t,o);
- tooGeneral(l,e,reqd,generalize(qs,it));
- }
-
- if (addEvid) {
- e = qualifyExpr(l,ps,e);
- preds = savePreds;
- }
- else
- preds = revOnto(ps,savePreds);
-
- inferType(t,o);
- return e;
-}
-
-static Void local typeAlt(wh,e,a,t,o,m) /* Type check abstraction (Alt) */
-String wh; /* a = ( [p1, ..., pn], rhs ) */
-Cell e;
-Cell a;
-Type t;
-Int o;
-Int m; {
- Type origt = t;
- List ps = fst(a) = patBtyvs(fst(a));
- Int n = length(ps);
- Int l = rhsLine(snd(a));
- Int nr2 = 0;
- List as = NIL;
- Bool added = FALSE;
-
- saveVarsAss();
- enterSkolVars();
- if (whatIs(t)==RANK2) {
- if (n<(nr2=intOf(fst(snd(t))))) {
- ERRMSG(l) "Definition requires at least %d parameters on lhs",
- intOf(fst(snd(t)))
- EEND;
- }
- t = snd(snd(t));
- }
-
- while (getHead(t)==typeArrow && argCount==2 && nonNull(ps)) {
- Type ta = arg(fun(t));
- if (isPolyOrQualType(ta)) {
- if (hd(ps)!=WILDCARD) {
- if (!isVar(hd(ps))) {
- ERRMSG(l) "Argument " ETHEN ERREXPR(hd(ps));
- ERRTEXT " used where a variable or wildcard is required\n"
- EEND;
- }
- if (m>0 && !added) {
- Int i = 0;
- for (; i<m; i++)
- addVarAssump(dummyVar,mkInt(o+i));
- added = TRUE;
- }
- addVarAssump(hd(ps),ta);
- }
- }
- else {
- hd(ps) = typeFreshPat(l,hd(ps));
- shouldBe(l,hd(ps),NIL,wh,ta,o);
- }
- t = arg(t);
- ps = tl(ps);
- as = fn(ta,as);
- n--;
- }
-
- if (n==0)
- snd(a) = typeRhs(snd(a));
- else {
- Int beta = funcType(n);
- Int i = 0;
- for (; i<n; ++i) {
- hd(ps) = typeFreshPat(l,hd(ps));
- bindTv(beta+2*i+1,typeIs,typeOff);
- ps = tl(ps);
- }
- snd(a) = typeRhs(snd(a));
- bindTv(beta+2*n,typeIs,typeOff);
- tyvarType(beta);
- }
-
- if (!unify(typeIs,typeOff,t,o)) {
- Type req, got;
- clearMarks();
- req = liftRank2(origt,o,m);
- liftRank2Args(as,o,m);
- got = ap(RANK2,pair(mkInt(nr2),revOnto(as,copyType(typeIs,typeOff))));
- reportTypeError(l,e,NIL,wh,got,req);
- }
-
- restoreVarsAss();
- doneBtyvs(l);
- leaveSkolVars(l,origt,o,m);
-}
-
-static Int local funcType(n) /*return skeleton for function type*/
-Int n; { /*with n arguments, taking the form*/
- Int beta = newTyvars(2*n+1); /* r1 t1 r2 t2 ... rn tn rn+1 */
- Int i; /* with r_i := t_i -> r_i+1 */
- for (i=0; i<n; ++i)
- bindTv(beta+2*i,arrow,beta+2*i+1);
- return beta;
-}
-
-static Void local typeCase(l,beta,c) /* type check case: pat -> rhs */
-Int l; /* (case given by c == (pat,rhs)) */
-Int beta; /* need: pat :: (var,beta) */
-Cell c; { /* rhs :: (var,beta+1) */
- static String casePat = "case pattern";
- static String caseExpr = "case expression";
-
- saveVarsAss();
- enterSkolVars();
- fst(c) = typeFreshPat(l,patBtyvs(fst(c)));
- shouldBe(l,fst(c),NIL,casePat,aVar,beta);
- snd(c) = typeRhs(snd(c));
- shouldBe(l,rhsExpr(snd(c)),NIL,caseExpr,aVar,beta+1);
-
- restoreVarsAss();
- doneBtyvs(l);
- leaveSkolVars(l,typeIs,typeOff,0);
-}
-
-static Void local typeComp(l,m,e,qs) /* type check comprehension */
-Int l;
-Type m; /* monad (mkOffset(0)) */
-Cell e;
-List qs; {
- static String boolQual = "boolean qualifier";
- static String genQual = "generator";
-#if IPARAM
- List svPreds;
-#endif
-
- STACK_CHECK
- if (isNull(qs)) { /* no qualifiers left */
- spTypeExpr(l,fst(e));
- } else {
- Cell q = hd(qs);
- List qs1 = tl(qs);
- switch (whatIs(q)) {
- case BOOLQUAL : spCheck(l,snd(q),NIL,boolQual,typeBool,0);
- typeComp(l,m,e,qs1);
- break;
-
- case QWHERE : enterBindings();
- enterSkolVars();
- mapProc(typeBindings,snd(q));
- typeComp(l,m,e,qs1);
- leaveBindings();
- leaveSkolVars(l,typeIs,typeOff,0);
- break;
-
- case FROMQUAL : { Int beta = newTyvars(1);
- saveVarsAss();
- enterPendingBtyvs();
- spCheck(l,snd(snd(q)),NIL,genQual,m,beta);
- enterSkolVars();
- fst(snd(q))
- = typeFreshPat(l,patBtyvs(fst(snd(q))));
- shouldBe(l,fst(snd(q)),NIL,genQual,aVar,beta);
- typeComp(l,m,e,qs1);
- restoreVarsAss();
- leavePendingBtyvs();
- leaveSkolVars(l,typeIs,typeOff,0);
- }
- break;
-
- case DOQUAL : spCheck(l,snd(q),NIL,genQual,m,newTyvars(1));
- typeComp(l,m,e,qs1);
- break;
- }
- }
-}
-
-static Cell local typeMonadComp(l,e) /* type check monad comprehension */
-Int l;
-Cell e; {
- Int alpha = newTyvars(1);
- Int beta = newTyvars(1);
- Cell mon = ap(mkInt(beta),aVar);
- Cell m = assumeEvid(predMonad,beta);
- tyvar(beta)->kind = starToStar;
-#if !MONAD_COMPS
- bindTv(beta,typeList,0);
- m = nameListMonad;
-#endif
-
- typeComp(l,mon,snd(e),snd(snd(e)));
- bindTv(alpha,typeIs,typeOff);
- inferType(mon,alpha);
- return ap(MONADCOMP,pair(m,snd(e)));
-}
-
-static Void local typeDo(l,e) /* type check do-notation */
-Int l;
-Cell e; {
- static String finGen = "final generator";
- Int alpha = newTyvars(1);
- Int beta = newTyvars(1);
- Cell mon = ap(mkInt(beta),aVar);
- Cell m = assumeEvid(predMonad,beta);
- tyvar(beta)->kind = starToStar;
-
- typeComp(l,mon,snd(e),snd(snd(e)));
- shouldBe(l,fst(snd(e)),NIL,finGen,mon,alpha);
- snd(e) = pair(m,snd(e));
-}
-
-static Void local typeConFlds(l,e) /* Type check a construction */
-Int l;
-Cell e; {
- static String conExpr = "value construction";
- Name c = fst(snd(e));
- List fs = snd(snd(e));
- Type tc;
- Int to;
- Int tf;
- Int i;
-#if IPARAM
- List svPreds;
-#endif
-
- instantiate(name(c).type);
- for (; nonNull(predsAre); predsAre=tl(predsAre))
- assumeEvid(hd(predsAre),typeOff);
- if (whatIs(typeIs)==RANK2)
- typeIs = snd(snd(typeIs));
- tc = typeIs;
- to = typeOff;
- tf = typeFree;
-
- for (; nonNull(fs); fs=tl(fs)) {
- Type t = tc;
- for (i=sfunPos(fst(hd(fs)),c); --i>0; t=arg(t))
- ;
- t = dropRank1(arg(fun(t)),to,tf);
- if (isPolyOrQualType(t))
- snd(hd(fs)) = typeExpected(l,conExpr,snd(hd(fs)),t,to,tf,TRUE);
- else {
- spCheck(l,snd(hd(fs)),e,conExpr,t,to);
- }
- }
- for (i=name(c).arity; i>0; i--)
- tc = arg(tc);
- inferType(tc,to);
-}
-
-static Void local typeUpdFlds(line,e) /* Type check an update */
-Int line; /* (Written in what might seem a */
-Cell e; { /* bizarre manner for the benefit */
- static String update = "update"; /* of as yet unreleased extensions)*/
- List cs = snd3(snd(e)); /* List of constructors */
- List fs = thd3(snd(e)); /* List of field specifications */
- List ts = NIL; /* List of types for fields */
- Int n = length(fs);
- Int alpha = newTyvars(2+n);
- Int i;
- List fs1;
-#if IPARAM
- List svPreds;
-#endif
-
- /* Calculate type and translation for each expr in the field list */
- for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
- spTypeExpr(line,snd(hd(fs1)));
- bindTv(i,typeIs,typeOff);
- }
-
- clearMarks();
- mapProc(markAssumList,defnBounds);
- mapProc(markAssumList,varsBounds);
- mapProc(markPred,preds);
- markBtyvs();
-
- for (fs1=fs, i=alpha+2; nonNull(fs1); fs1=tl(fs1), i++) {
- resetGenerics();
- ts = cons(generalize(NIL,copyTyvar(i)),ts);
- }
- ts = rev(ts);
-
- /* Type check expression to be updated */
- spTypeExpr(line,fst3(snd(e)));
- bindTv(alpha,typeIs,typeOff);
-
- for (; nonNull(cs); cs=tl(cs)) { /* Loop through constrs */
- Name c = hd(cs);
- List ta = replicate(name(c).arity,NIL);
- Type td, tr;
- Int od, or;
-
- tcMode = NEW_PATTERN; /* Domain type */
- instantiate(name(c).type);
- tcMode = EXPRESSION;
- td = typeIs;
- od = typeOff;
- for (; nonNull(predsAre); predsAre=tl(predsAre))
- assumeEvid(hd(predsAre),typeOff);
-
- if (whatIs(typeIs)==RANK2) {
- ERRMSG(line) "Sorry, record update syntax cannot currently be "
- "used for datatypes with polymorphic components"
- EEND;
- }
-
- instantiate(name(c).type); /* Range type */
- tr = typeIs;
- or = typeOff;
- for (; nonNull(predsAre); predsAre=tl(predsAre))
- assumeEvid(hd(predsAre),typeOff);
-
- for (fs1=fs, i=1; nonNull(fs1); fs1=tl(fs1), i++) {
- Int n = sfunPos(fst(hd(fs1)),c);
- Cell ta1 = ta;
- for (; n>1; n--)
- ta1 = tl(ta1);
- hd(ta1) = mkInt(i);
- }
-
- for (; nonNull(ta); ta=tl(ta)) { /* For each cfun arg */
- if (nonNull(hd(ta))) { /* Field to updated? */
- Int n = intOf(hd(ta));
- Cell f = fs;
- Cell t = ts;
- for (; n-- > 1; f=tl(f), t=tl(t))
- ;
- f = hd(f);
- t = hd(t);
- instantiate(t);
- shouldBe(line,snd(f),e,update,arg(fun(tr)),or);
- } /* Unmentioned component */
- else if (!unify(arg(fun(td)),od,arg(fun(tr)),or))
- internal("typeUpdFlds");
-
- tr = arg(tr);
- td = arg(td);
- }
-
- inferType(td,od); /* Check domain type */
- shouldBe(line,fst3(snd(e)),e,update,aVar,alpha);
- inferType(tr,or); /* Check range type */
- shouldBe(line,e,NIL,update,aVar,alpha+1);
- }
- /* (typeIs,typeOff) still carry the result type when we exit the loop */
-}
-
-#if IPARAM
-static Cell local typeWith(line,e) /* Type check a with */
-Int line;
-Cell e; {
- List fs = snd(snd(e)); /* List of field specifications */
- Int n = length(fs);
- Int alpha = newTyvars(2+n);
- Int i;
- List fs1;
- Cell tIs;
- Cell tOff;
- List dpreds = NIL, dp;
- Cell bs = NIL;
-
- /* Type check expression to be updated */
- fst(snd(e)) = typeExpr(line,fst(snd(e)));
- bindTv(alpha,typeIs,typeOff);
- tIs = typeIs;
- tOff = typeOff;
- /* elim duplicate uses of imp params */
- preds = scSimplify(preds);
- /* extract preds that we're going to bind */
- for (fs1=fs; nonNull(fs1); fs1=tl(fs1)) {
- Text t = textOf(fst(hd(fs1)));
- Cell p = findIPEvid(t);
- dpreds = cons(p, dpreds);
- if (nonNull(p)) {
- removeIPEvid(t);
- } else {
- /* maybe give a warning message here... */
- }
- }
- dpreds = rev(dpreds);
-
- /* Calculate type and translation for each expr in the field list */
- for (fs1=fs, dp=dpreds, i=alpha+2; nonNull(fs1); fs1=tl(fs1), dp=tl(dp), i++) {
- static String with = "with";
- Cell ev = hd(dp);
- snd(hd(fs1)) = typeExpr(line,snd(hd(fs1)));
- bindTv(i,typeIs,typeOff);
- if (nonNull(ev)) {
- shouldBe(line,fst(hd(fs1)),e,with,snd(fst3(ev)),intOf(snd3(ev)));
- bs = cons(cons(pair(thd3(ev), cons(triple(NIL, mkInt(line), snd(hd(fs1))), NIL)), NIL), bs);
- }
- }
- typeIs = tIs;
- typeOff = tOff;
- return (ap(LETREC,pair(bs,fst(snd(e)))));
-}
-#endif
-
-static Cell local typeFreshPat(l,p) /* find type of pattern, assigning */
-Int l; /* fresh type variables to each var */
-Cell p; { /* bound in the pattern */
- tcMode = NEW_PATTERN;
- p = typeExpr(l,p);
- tcMode = EXPRESSION;
- return p;
-}
-
-/* --------------------------------------------------------------------------
- * Type check group of bindings:
- * ------------------------------------------------------------------------*/
-
-static Void local typeBindings(bs) /* type check a binding group */
-List bs; {
- Bool usesPatBindings = FALSE; /* TRUE => pattern binding in bs */
- Bool usesUntypedVar = FALSE; /* TRUE => var bind w/o type decl */
- List bs1;
-
- /* The following loop is used to determine whether the monomorphism */
- /* restriction should be applied. It could be written marginally more */
- /* efficiently by using breaks, but clarity is more important here ... */
-
- for (bs1=bs; nonNull(bs1); bs1=tl(bs1)) { /* Analyse binding group */
- Cell b = hd(bs1);
- if (!isVar(fst(b)))
- usesPatBindings = TRUE;
- else if (isNull(fst(hd(snd(snd(b))))) /* no arguments */
- && whatIs(fst(snd(b)))==IMPDEPS) /* implicitly typed*/
- usesUntypedVar = TRUE;
- }
-
- if (usesPatBindings || usesUntypedVar)
- monorestrict(bs);
- else
- unrestricted(bs);
-
- mapProc(removeTypeSigs,bs); /* Remove binding type info */
- hd(varsBounds) = revOnto(hd(defnBounds), /* transfer completed assmps*/
- hd(varsBounds)); /* out of defnBounds */
- hd(defnBounds) = NIL;
- hd(depends) = NIL;
-}
-
-static Void local removeTypeSigs(b) /* Remove type info from a binding */
-Cell b; {
- snd(b) = snd(snd(b));
-}
-
-/* --------------------------------------------------------------------------
- * Type check a restricted binding group:
- * ------------------------------------------------------------------------*/
-
-static Void local monorestrict(bs) /* Type restricted binding group */
-List bs; {
- List savePreds = preds;
- Int line = isVar(fst(hd(bs))) ? rhsLine(snd(hd(snd(snd(hd(bs))))))
- : rhsLine(snd(snd(snd(hd(bs)))));
- hd(defnBounds) = NIL;
- hd(depends) = NODEPENDS; /* No need for dependents here */
-
- preds = NIL; /* Type check the bindings */
- mapProc(restrictedBindAss,bs);
- mapProc(typeBind,bs);
- improve(line,NIL,preds);
- normPreds(line);
- elimTauts();
- preds = revOnto(preds,savePreds);
-
- clearMarks(); /* Mark fixed variables */
- mapProc(markAssumList,tl(defnBounds));
- mapProc(markAssumList,tl(varsBounds));
- mapProc(markPred,preds);
- markBtyvs();
-
- if (isNull(tl(defnBounds))) { /* Top-level may need defaulting */
- normPreds(line);
- if (nonNull(preds) && resolveDefs(genvarAnyAss(hd(defnBounds))))
- elimTauts();
-
- clearMarks();
- reducePreds();
- if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
- elimTauts();
-
- if (nonNull(preds)) { /* Look for unresolved overloading */
- Cell v = isVar(fst(hd(bs))) ? fst(hd(bs)) : hd(fst(hd(bs)));
- Cell ass = findInAssumList(textOf(v),hd(varsBounds));
- preds = scSimplify(preds);
-
- ERRMSG(line) "Unresolved top-level overloading" ETHEN
- ERRTEXT "\n*** Binding : %s", textToStr(textOf(v))
- ETHEN
- if (nonNull(ass)) {
- ERRTEXT "\n*** Inferred type : " ETHEN ERRTYPE(snd(ass));
- }
- ERRTEXT "\n*** Outstanding context : " ETHEN
- ERRCONTEXT(copyPreds(preds));
- ERRTEXT "\n"
- EEND;
- }
- }
-
- map1Proc(genBind,NIL,bs); /* Generalize types of def'd vars */
-}
-
-static Void local restrictedBindAss(b) /* Make assums for vars in binding */
-Cell b; { /* gp with restricted overloading */
-
- if (isVar(fst(b))) { /* function-binding? */
- Cell t = fst(snd(b));
- if (whatIs(t)==IMPDEPS) { /* Discard implicitly typed deps */
- fst(snd(b)) = t = NIL; /* in a restricted binding group. */
- }
- fst(snd(b)) = localizeBtyvs(t);
- restrictedAss(rhsLine(snd(hd(snd(snd(b))))), fst(b), t);
- } else { /* pattern-binding? */
- List vs = fst(b);
- List ts = fst(snd(b));
- Int line = rhsLine(snd(snd(snd(b))));
-
- for (; nonNull(vs); vs=tl(vs)) {
- if (nonNull(ts)) {
- restrictedAss(line,hd(vs),hd(ts)=localizeBtyvs(hd(ts)));
- ts = tl(ts);
- } else {
- restrictedAss(line,hd(vs),NIL);
- }
- }
- }
-}
-
-static Void local restrictedAss(l,v,t) /* Assume that type of binding var v*/
-Int l; /* is t (if nonNull) in restricted */
-Cell v; /* binding group */
-Type t; {
- newDefnBind(v,t);
- if (nonNull(predsAre)) {
- ERRMSG(l) "Explicit overloaded type for \"%s\"",textToStr(textOf(v))
- ETHEN
- ERRTEXT " not permitted in restricted binding"
- EEND;
- }
-}
-
-/* --------------------------------------------------------------------------
- * Unrestricted binding group:
- * ------------------------------------------------------------------------*/
-
-static Void local unrestricted(bs) /* Type unrestricted binding group */
-List bs; {
- List savePreds = preds;
- List imps = NIL; /* Implicitly typed bindings */
- List exps = NIL; /* Explicitly typed bindings */
- List bs1;
-
- /* ----------------------------------------------------------------------
- * STEP 1: Separate implicitly typed bindings from explicitly typed
- * bindings and do a dependency analyis, where f depends on g iff f
- * is implicitly typed and involves a call to g.
- * --------------------------------------------------------------------*/
-
- for (; nonNull(bs); bs=tl(bs)) {
- Cell b = hd(bs);
- if (whatIs(fst(snd(b)))==IMPDEPS)
- imps = cons(b,imps); /* N.B. New lists are built to */
- else /* avoid breaking the original */
- exps = cons(b,exps); /* list structure for bs. */
- }
-
- for (bs=imps; nonNull(bs); bs=tl(bs)) {
- Cell b = hd(bs); /* Restrict implicitly typed dep */
- List ds = snd(fst(snd(b))); /* lists to bindings in imps */
- List cs = NIL;
- while (nonNull(ds)) {
- bs1 = tl(ds);
- if (cellIsMember(hd(ds),imps)) {
- tl(ds) = cs;
- cs = ds;
- }
- ds = bs1;
- }
- fst(snd(b)) = cs;
- }
- imps = itbscc(imps); /* Dependency analysis on imps */
- for (bs=imps; nonNull(bs); bs=tl(bs))
- for (bs1=hd(bs); nonNull(bs1); bs1=tl(bs1))
- fst(snd(hd(bs1))) = NIL; /* reset imps type fields */
-
-#ifdef DEBUG_DEPENDS
- Printf("Binding group:");
- for (bs1=imps; nonNull(bs1); bs1=tl(bs1)) {
- Printf(" [imp:");
- for (bs=hd(bs1); nonNull(bs); bs=tl(bs))
- Printf(" %s",textToStr(textOf(fst(hd(bs)))));
- Printf("]");
- }
- if (nonNull(exps)) {
- Printf(" [exp:");
- for (bs=exps; nonNull(bs); bs=tl(bs))
- Printf(" %s",textToStr(textOf(fst(hd(bs)))));
- Printf("]");
- }
- Printf("\n");
-#endif
-
- /* ----------------------------------------------------------------------
- * STEP 2: Add type assumptions about any explicitly typed variable.
- * --------------------------------------------------------------------*/
-
- for (bs=exps; nonNull(bs); bs=tl(bs)) {
- fst(snd(hd(bs))) = localizeBtyvs(fst(snd(hd(bs))));
- hd(varsBounds) = cons(pair(fst(hd(bs)),fst(snd(hd(bs)))),
- hd(varsBounds));
- }
-
- /* ----------------------------------------------------------------------
- * STEP 3: Calculate types for each group of implicitly typed bindings.
- * --------------------------------------------------------------------*/
-
- for (; nonNull(imps); imps=tl(imps)) {
- Cell b = hd(hd(imps));
- Int line = isVar(fst(b)) ? rhsLine(snd(hd(snd(snd(b)))))
- : rhsLine(snd(snd(snd(b))));
- hd(defnBounds) = NIL;
- hd(depends) = NIL;
- for (bs1=hd(imps); nonNull(bs1); bs1=tl(bs1))
- newDefnBind(fst(hd(bs1)),NIL);
-
- preds = NIL;
- mapProc(typeBind,hd(imps));
- improve(line,NIL,preds);
-
- clearMarks();
- mapProc(markAssumList,tl(defnBounds));
- mapProc(markAssumList,tl(varsBounds));
- mapProc(markPred,savePreds);
- markBtyvs();
-
- normPreds(line);
- savePreds = elimOuterPreds(savePreds);
- if (nonNull(preds) && resolveDefs(genvarAllAss(hd(defnBounds)))) {
- savePreds = elimOuterPreds(savePreds);
- }
-
- map1Proc(genBind,preds,hd(imps));
- if (nonNull(preds)) {
- map1Proc(addEvidParams,preds,hd(depends));
- map1Proc(qualifyBinding,preds,hd(imps));
- }
-
- h98CheckType(line,"inferred type",
- fst(hd(hd(defnBounds))),snd(hd(hd(defnBounds))));
- hd(varsBounds) = revOnto(hd(defnBounds),hd(varsBounds));
- }
-
- /* ----------------------------------------------------------------------
- * STEP 4: Now infer a type for each explicitly typed variable and
- * check for compatibility with the declared type.
- * --------------------------------------------------------------------*/
-
- for (; nonNull(exps); exps=tl(exps)) {
- static String extbind = "explicitly typed binding";
- Cell b = hd(exps);
- List alts = snd(snd(b));
- Int line = rhsLine(snd(hd(alts)));
- Type t;
- Int o;
- Int m;
- List ps;
-
- hd(defnBounds) = NIL;
- hd(depends) = NODEPENDS;
- preds = NIL;
-
- instantiate(fst(snd(b)));
- o = typeOff;
- m = typeFree;
- t = dropRank2(typeIs,o,m);
- ps = makePredAss(predsAre,o);
-
- enterPendingBtyvs();
- for (; nonNull(alts); alts=tl(alts))
- typeAlt(extbind,fst(b),hd(alts),t,o,m);
- improve(line,ps,preds);
- leavePendingBtyvs();
-
- if (nonNull(ps)) /* Add dict params, if necessary */
- qualifyBinding(ps,b);
-
- clearMarks();
- mapProc(markAssumList,tl(defnBounds));
- mapProc(markAssumList,tl(varsBounds));
- mapProc(markPred,savePreds);
- markBtyvs();
-
- normPreds(line);
- savePreds = elimPredsUsing(ps,savePreds);
- if (nonNull(preds)) {
- List vs = NIL;
- Int i = 0;
- for (; i<m; ++i)
- vs = cons(mkInt(o+i),vs);
- if (resolveDefs(vs)) {
- savePreds = elimPredsUsing(ps,savePreds);
- }
- if (nonNull(preds)) {
- clearMarks();
- reducePreds();
- if (nonNull(preds) && resolveDefs(vs))
- savePreds = elimPredsUsing(ps,savePreds);
- }
- }
-
- resetGenerics(); /* Make sure we're general enough */
- ps = copyPreds(ps);
- t = generalize(ps,liftRank2(t,o,m));
-
- if (!sameSchemes(t,fst(snd(b))))
- tooGeneral(line,fst(b),fst(snd(b)),t);
- h98CheckType(line,"inferred type",fst(b),t);
-
- if (nonNull(preds)) /* Check context was strong enough */
- cantEstablish(line,extbind,fst(b),t,ps);
- }
-
- preds = savePreds; /* Restore predicates */
- hd(defnBounds) = NIL;
-}
-
-#define SCC itbscc /* scc for implicitly typed binds */
-#define LOWLINK itblowlink
-#define DEPENDS(t) fst(snd(t))
-#define SETDEPENDS(c,v) fst(snd(c))=v
-#include "scc.c"
-#undef SETDEPENDS
-#undef DEPENDS
-#undef LOWLINK
-#undef SCC
-
-static Void local addEvidParams(qs,v) /* overwrite VARID/OPCELL v with */
-List qs; /* application of variable to evid. */
-Cell v; { /* parameters given by qs */
- if (nonNull(qs)) {
- Cell nv;
-
- if (!isVar(v))
- internal("addEvidParams");
-
- for (nv=mkVar(textOf(v)); nonNull(tl(qs)); qs=tl(qs))
- nv = ap(nv,thd3(hd(qs)));
- fst(v) = nv;
- snd(v) = thd3(hd(qs));
- }
-}
-
-/* --------------------------------------------------------------------------
- * Type check bodies of class and instance declarations:
- * ------------------------------------------------------------------------*/
-
-static Void local typeClassDefn(c) /* Type check implementations of */
-Class c; { /* defaults for class c */
-
- /* ----------------------------------------------------------------------
- * Generate code for default dictionary builder functions:
- * --------------------------------------------------------------------*/
-
- Int beta = newKindedVars(cclass(c).kinds);
- Cell d = inventDictVar();
- List dparam = singleton(triple(cclass(c).head,mkInt(beta),d));
- List mems = cclass(c).members;
- List defs = cclass(c).defaults;
- List dsels = cclass(c).dsels;
- Cell pat = cclass(c).dcon;
- Int width = cclass(c).numSupers + cclass(c).numMembers;
- char buf[FILENAME_MAX+1];
- Int i = 0;
- Int j = 0;
-
- if (isNull(defs) && nonNull(mems)) {
- defs = cclass(c).defaults = cons(NIL,NIL);
- }
-
- for (; nonNull(mems); mems=tl(mems)) {
- /* static String deftext = "default_"; */
- static String deftext = "$dm";
- String s = textToStr(name(hd(mems)).text);
- Name n;
- i = j = 0;
- for (; i<FILENAME_MAX && deftext[i]!='\0'; i++) {
- buf[i] = deftext[i];
- }
- for(; (i+j)<FILENAME_MAX && s[j]!='\0'; j++) {
- buf[i+j] = s[j];
- }
- buf[i+j] = '\0';
- n = newName(findText(buf),c);
-
- if (isNull(hd(defs))) { /* No default definition */
- static String header = "Undefined member: ";
- for (i=0; i<FILENAME_MAX && header[i]!='\0'; i++)
- buf[i] = header[i];
- for (j=0; (i+j)<FILENAME_MAX && s[j]!='\0'; j++)
- buf[i+j] = s[j];
- buf[i+j] = '\0';
- name(n).line = cclass(c).line;
- name(n).arity = 1;
- name(n).defn = singleton(pair(singleton(d),
- ap(mkInt(cclass(c).line),
- ap(nameError,
- mkStr(fixLitText(
- findText(buf)))))));
- } else { /* User supplied default defn */
- List alts = snd(hd(defs));
- Int line = rhsLine(snd(hd(alts)));
-
- typeMember("default member binding",
- hd(mems),
- alts,
- dparam,
- cclass(c).head,
- beta);
-
- name(n).line = line;
- name(n).arity = 1+length(fst(hd(alts)));
- name(n).defn = alts;
-
- for (; nonNull(alts); alts=tl(alts)) {
- fst(hd(alts)) = cons(d,fst(hd(alts)));
- }
- }
-
- hd(defs) = n;
- genDefns = cons(n,genDefns);
- if (isNull(tl(defs)) && nonNull(tl(mems))) {
- tl(defs) = cons(NIL,NIL);
- }
- defs = tl(defs);
- }
-
- /* ----------------------------------------------------------------------
- * Generate code for superclass and member function selectors:
- * --------------------------------------------------------------------*/
-
- for (i=0; i<width; i++) {
- pat = ap(pat,inventVar());
- }
- pat = singleton(pat);
- for (i=0; nonNull(dsels); dsels=tl(dsels)) {
- name(hd(dsels)).defn = singleton(pair(pat,
- ap(mkInt(cclass(c).line),
- nthArg(i++,hd(pat)))));
- genDefns = cons(hd(dsels),genDefns);
- }
- for (mems=cclass(c).members; nonNull(mems); mems=tl(mems)) {
- name(hd(mems)).defn = singleton(pair(pat,
- ap(mkInt(name(hd(mems)).line),
- nthArg(i++,hd(pat)))));
- genDefns = cons(hd(mems),genDefns);
- }
-}
-
-static Void local typeInstDefn(in) /* Type check implementations of */
-Inst in; { /* member functions for instance in*/
-
- /* ----------------------------------------------------------------------
- * Generate code for instance specific dictionary builder function:
- *
- * inst.maker d1 ... dn = let sc1 = ...
- * .
- * .
- * .
- * scm = ...
- * vj ... = ...
- * d = Make.C sc1 ... scm v1 ... vk
- * in d
- *
- * where sci are superclass dictionaries, d is a new name, vj
- * is a newly generated name corresponding to the implementation of a
- * member function. (Additional line number values must be added at
- * appropriate places but, for clarity, these are not shown above.)
- * If no implementation of a particular vj is available, then we use
- * the default implementation, partially applied to d.
- * --------------------------------------------------------------------*/
-
- Int alpha = newKindedVars(cclass(inst(in).c).kinds);
- List supers = makePredAss(cclass(inst(in).c).supers,alpha);
- Int beta = newKindedVars(inst(in).kinds);
- List params = makePredAss(inst(in).specifics,beta);
- Cell d = inventDictVar();
- /*
- List evids = cons(triple(inst(in).head,mkInt(beta),d),
- appendOnto(dupList(params),supers));
- */
- List evids = dupList(params);
-
- List imps = inst(in).implements;
- Cell l = mkInt(inst(in).line);
- Cell dictDef = cclass(inst(in).c).dcon;
- List mems = cclass(inst(in).c).members;
- List defs = cclass(inst(in).c).defaults;
- List args = NIL;
- List locs = NIL;
- List ps;
-
- if (!unifyPred(cclass(inst(in).c).head,alpha,inst(in).head,beta))
- internal("typeInstDefn");
-
- for (ps=params; nonNull(ps); ps=tl(ps)) /* Build arglist */
- args = cons(thd3(hd(ps)),args);
- args = rev(args);
-
- for (ps=supers; nonNull(ps); ps=tl(ps)) { /* Superclass dictionaries */
- Cell pi = hd(ps);
- Cell ev = NIL;
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- fputs("scEntail: ", stdout);
- printContext(stdout,copyPreds(params));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
- fputc('\n', stdout);
- }
-#endif
- ev = scEntail(params,fst3(pi),intOf(snd3(pi)),0);
- if (isNull(ev)) {
-#if EXPLAIN_INSTANCE_RESOLUTION
- if (showInstRes) {
- fputs("inEntail: ", stdout);
- printContext(stdout,copyPreds(evids));
- fputs(" ||- ", stdout);
- printPred(stdout, copyPred(fst3(pi),intOf(snd3(pi))));
- fputc('\n', stdout);
- }
-#endif
- ev = inEntail(evids,fst3(pi),intOf(snd3(pi)),0);
- }
- if (isNull(ev)) {
- clearMarks();
- ERRMSG(inst(in).line) "Cannot build superclass instance" ETHEN
- ERRTEXT "\n*** Instance : " ETHEN
- ERRPRED(copyPred(inst(in).head,beta));
- ERRTEXT "\n*** Context supplied : " ETHEN
- ERRCONTEXT(copyPreds(params));
- ERRTEXT "\n*** Required superclass : " ETHEN
- ERRPRED(copyPred(fst3(pi),intOf(snd3(pi))));
- ERRTEXT "\n"
- EEND;
- }
- locs = cons(pair(thd3(pi),singleton(pair(NIL,ap(l,ev)))),locs);
- dictDef = ap(dictDef,thd3(pi));
- }
-
- for (; nonNull(defs); defs=tl(defs)) {
- Cell imp = NIL;
- if (nonNull(imps)) {
- imp = hd(imps);
- imps = tl(imps);
- }
- if (isNull(imp)) {
- dictDef = ap(dictDef,ap(hd(defs),d));
- } else {
- Cell v = inventVar();
- dictDef = ap(dictDef,v);
- typeMember("instance member binding",
- hd(mems),
- snd(imp),
- evids,
- inst(in).head,
- beta);
- locs = cons(pair(v,snd(imp)),locs);
- }
- mems = tl(mems);
- }
- locs = cons(pair(d,singleton(pair(NIL,ap(l,dictDef)))),locs);
-
- name(inst(in).builder).defn /* Register builder imp */
- = singleton(pair(args,ap(LETREC,pair(singleton(locs),
- ap(l,d)))));
-
- /* Invent a GHC-compatible name for the instance decl */
- {
- char buf[FILENAME_MAX+1];
- char buf2[10];
- Int i, j;
- String str;
- Cell qq = inst(in).head;
- Cell pp = NIL;
- static String zdftext = "$f";
-
- while (isAp(qq)) {
- pp = cons(arg(qq),pp);
- qq = fun(qq);
- }
- // pp is now the fwd list of args(?) to this pred
-
- i = 0;
- for (j = 0; i<FILENAME_MAX && zdftext[j]!='\0'; i++, j++) {
- buf[i] = zdftext[j];
- }
- str = textToStr(cclass(inst(in).c).text);
- for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
- buf[i] = str[j];
- }
- if (nonNull(pp)) {
- qq = hd(pp);
- while (isAp(qq)) qq = fun(qq);
- switch (whatIs(qq)) {
- case TYCON: str = textToStr(tycon(qq).text); break;
- case TUPLE: str = textToStr(ghcTupleText(qq)); break;
- case OFFSET: sprintf(buf2,"%d",offsetOf(qq));
- str = buf2;
- break;
- default: internal("typeInstDefn: making GHC name"); break;
- }
- for (j = 0; i<FILENAME_MAX && str[j]!='\0'; i++, j++) {
- buf[i] = str[j];
- }
- }
-
- buf[i++] = '\0';
- name(inst(in).builder).text = findText(buf);
- //fprintf ( stderr, "result = %s\n", buf );
- }
-
- genDefns = cons(inst(in).builder,genDefns);
-}
-
-static Void local typeMember(wh,mem,alts,evids,head,beta)
-String wh; /* Type check alternatives alts of */
-Name mem; /* member mem for inst type head */
-Cell alts; /* at offset beta using predicate */
-List evids; /* assignment evids */
-Cell head;
-Int beta; {
- Int line = rhsLine(snd(hd(alts)));
- Type t;
- Int o;
- Int m;
- List ps;
- List qs;
- Type rt;
-
-#ifdef DEBUG_TYPES
- Printf("\nType check member: ");
- printExp(stdout,mem);
- Printf(" :: ");
- printType(stdout,name(mem).type);
- Printf("\n for the instance: ");
- printPred(stdout,head);
- Printf("\n");
-#endif
-
- instantiate(name(mem).type); /* Find required type */
- o = typeOff;
- m = typeFree;
- t = dropRank2(typeIs,o,m);
- ps = makePredAss(predsAre,o);
- if (!unifyPred(hd(predsAre),typeOff,head,beta))
- internal("typeMember1");
- clearMarks();
- qs = copyPreds(ps);
- rt = generalize(qs,liftRank2(t,o,m));
-
-#ifdef DEBUG_TYPES
- Printf("Required type is: ");
- printType(stdout,rt);
- Printf("\n");
-#endif
-
- hd(defnBounds) = NIL; /* Type check each alternative */
- hd(depends) = NODEPENDS;
- enterPendingBtyvs();
- for (preds=NIL; nonNull(alts); alts=tl(alts)) {
- typeAlt(wh,mem,hd(alts),t,o,m);
- qualify(tl(ps),hd(alts)); /* Add any extra dict params */
- }
- improve(line,evids,preds);
- leavePendingBtyvs();
-
- evids = appendOnto(dupList(tl(ps)), /* Build full complement of dicts */
- evids);
- clearMarks();
- normPreds(line);
- qs = elimPredsUsing(evids,NIL);
- if (nonNull(preds) && resolveDefs(genvarType(t,o,NIL)))
- qs = elimPredsUsing(evids,qs);
- if (nonNull(qs)) {
- ERRMSG(line)
- "Implementation of %s requires extra context",
- textToStr(name(mem).text) ETHEN
- ERRTEXT "\n*** Expected type : " ETHEN ERRTYPE(rt);
- ERRTEXT "\n*** Missing context : " ETHEN ERRCONTEXT(copyPreds(qs));
- ERRTEXT "\n"
- EEND;
- }
-
- resetGenerics(); /* Make sure we're general enough */
- ps = copyPreds(ps);
- t = generalize(ps,liftRank2(t,o,m));
-#ifdef DEBUG_TYPES
- Printf(" Inferred type is: ");
- printType(stdout,t);
- Printf("\n");
-#endif
- if (!sameSchemes(t,rt))
- tooGeneral(line,mem,rt,t);
- if (nonNull(preds)) {
- preds = scSimplify(preds);
- cantEstablish(line,wh,mem,t,ps);
- }
-}
-
-/* --------------------------------------------------------------------------
- * Type check bodies of bindings:
- * ------------------------------------------------------------------------*/
-
-static Void local typeBind(b) /* Type check binding */
-Cell b; {
- if (isVar(fst(b))) { /* function binding */
- Cell ass = findTopBinding(fst(b));
- Int beta;
-
- if (isNull(ass))
- internal("typeBind");
-
- beta = intOf(defType(snd(ass)));
- enterPendingBtyvs();
- map2Proc(typeDefAlt,beta,fst(b),snd(snd(b)));
- leavePendingBtyvs();
- }
- else { /* pattern binding */
- static String lhsPat = "lhs pattern";
- static String rhs = "right hand side";
- Int beta = newTyvars(1);
- Pair pb = snd(snd(b));
- Int l = rhsLine(snd(pb));
-
- tcMode = OLD_PATTERN;
- enterPendingBtyvs();
- fst(pb) = patBtyvs(fst(pb));
- check(l,fst(pb),NIL,lhsPat,aVar,beta);
- tcMode = EXPRESSION;
- snd(pb) = typeRhs(snd(pb));
- shouldBe(l,rhsExpr(snd(pb)),NIL,rhs,aVar,beta);
- doneBtyvs(l);
- leavePendingBtyvs();
- }
-}
-
-static Void local typeDefAlt(beta,v,a) /* type check alt in func. binding */
-Int beta;
-Cell v;
-Pair a; {
- static String valDef = "function binding";
- typeAlt(valDef,v,a,aVar,beta,0);
-}
-
-static Cell local typeRhs(e) /* check type of rhs of definition */
-Cell e; {
- switch (whatIs(e)) {
- case GUARDED : { Int beta = newTyvars(1);
- map1Proc(guardedType,beta,snd(e));
- tyvarType(beta);
- }
- break;
-
- case LETREC : enterBindings();
- enterSkolVars();
- mapProc(typeBindings,fst(snd(e)));
- snd(snd(e)) = typeRhs(snd(snd(e)));
- leaveBindings();
- leaveSkolVars(rhsLine(snd(snd(e))),typeIs,typeOff,0);
- break;
-
- case RSIGN : fst(snd(e)) = typeRhs(fst(snd(e)));
- shouldBe(rhsLine(fst(snd(e))),
- rhsExpr(fst(snd(e))),NIL,
- "result type",
- snd(snd(e)),0);
- return fst(snd(e));
-
- default : snd(e) = typeExpr(intOf(fst(e)),snd(e));
- break;
- }
- return e;
-}
-
-static Void local guardedType(beta,gded)/* check type of guard (li,(gd,ex))*/
-Int beta; /* should have gd :: Bool, */
-Cell gded; { /* ex :: (var,beta) */
- static String guarded = "guarded expression";
- static String guard = "guard";
- Int line = intOf(fst(gded));
-#if IPARAM
- List svPreds;
-#endif
-
- gded = snd(gded);
- spCheck(line,fst(gded),NIL,guard,typeBool,0);
- spCheck(line,snd(gded),NIL,guarded,aVar,beta);
-}
-
-Cell rhsExpr(rhs) /* find first expression on a rhs */
-Cell rhs; {
- STACK_CHECK
- switch (whatIs(rhs)) {
- case GUARDED : return snd(snd(hd(snd(rhs))));
- case LETREC : return rhsExpr(snd(snd(rhs)));
- case RSIGN : return rhsExpr(fst(snd(rhs)));
- default : return snd(rhs);
- }
-}
-
-Int rhsLine(rhs) /* find line number associated with */
-Cell rhs; { /* a right hand side */
- STACK_CHECK
- switch (whatIs(rhs)) {
- case GUARDED : return intOf(fst(hd(snd(rhs))));
- case LETREC : return rhsLine(snd(snd(rhs)));
- case RSIGN : return rhsLine(fst(snd(rhs)));
- default : return intOf(fst(rhs));
- }
-}
-
-/* --------------------------------------------------------------------------
- * Calculate generalization of types and compare with declared type schemes:
- * ------------------------------------------------------------------------*/
-
-static Void local genBind(ps,b) /* Generalize the type of each var */
-List ps; /* defined in binding b, qualifying*/
-Cell b; { /* each with the predicates in ps. */
- Cell v = fst(b);
- Cell t = fst(snd(b));
-
- if (isVar(fst(b)))
- genAss(rhsLine(snd(hd(snd(snd(b))))),ps,v,t);
- else {
- Int line = rhsLine(snd(snd(snd(b))));
- for (; nonNull(v); v=tl(v)) {
- Type ty = NIL;
- if (nonNull(t)) {
- ty = hd(t);
- t = tl(t);
- }
- genAss(line,ps,hd(v),ty);
- }
- }
-}
-
-static Void local genAss(l,ps,v,dt) /* Calculate inferred type of v and*/
-Int l; /* compare with declared type, dt, */
-List ps; /* if given & check for ambiguity. */
-Cell v;
-Type dt; {
- Cell ass = findTopBinding(v);
-
- if (isNull(ass))
- internal("genAss");
-
- snd(ass) = genTest(l,v,ps,dt,aVar,intOf(defType(snd(ass))));
-
-#ifdef DEBUG_TYPES
- printExp(stdout,v);
- Printf(" :: ");
- printType(stdout,snd(ass));
- Printf("\n");
-#endif
-}
-
-static Type local genTest(l,v,ps,dt,t,o)/* Generalize and test inferred */
-Int l; /* type (t,o) with context ps */
-Cell v; /* against declared type dt for v. */
-List ps;
-Type dt;
-Type t;
-Int o; {
- Type bt = NIL; /* Body of inferred type */
- Type it = NIL; /* Full inferred type */
-
- resetGenerics(); /* Calculate Haskell typing */
- ps = copyPreds(ps);
- bt = copyType(t,o);
- it = generalize(ps,bt);
-
- if (nonNull(dt)) { /* If a declared type was given, */
- instantiate(dt); /* check body for match. */
- if (!equalTypes(typeIs,bt))
- tooGeneral(l,v,dt,it);
- }
- else if (nonNull(ps)) /* Otherwise test for ambiguity in */
- if (isAmbiguous(it)) /* inferred type. */
- ambigError(l,"inferred type",v,it);
-
- return it;
-}
-
-static Type local generalize(qs,t) /* calculate generalization of t */
-List qs; /* having already marked fixed vars*/
-Type t; { /* with qualifying preds qs */
- if (nonNull(qs))
- t = ap(QUAL,pair(qs,t));
- if (nonNull(genericVars)) {
- Kind k = STAR;
- List vs = genericVars;
- for (; nonNull(vs); vs=tl(vs)) {
- Tyvar *tyv = tyvar(intOf(hd(vs)));
- Kind ka = tyv->kind;
- k = ap(ka,k);
- }
- t = mkPolyType(k,t);
-#ifdef DEBUG_KINDS
- Printf("Generalized type: ");
- printType(stdout,t);
- Printf(" ::: ");
- printKind(stdout,k);
- Printf("\n");
-#endif
- }
- return t;
-}
-
-static Bool local equalTypes(t1,t2) /* Compare simple types for equality*/
-Type t1, t2; {
- STACK_CHECK
-et: if (whatIs(t1)!=whatIs(t2))
- return FALSE;
-
- switch (whatIs(t1)) {
-#if TREX
- case EXT :
-#endif
- case TYCON :
- case OFFSET :
- case TUPLE : return t1==t2;
-
- case INTCELL : return intOf(t1)!=intOf(t2);
-
- case AP : if (equalTypes(fun(t1),fun(t2))) {
- t1 = arg(t1);
- t2 = arg(t2);
- goto et;
- }
- return FALSE;
-
- default : internal("equalTypes");
- }
-
- return TRUE;/*NOTREACHED*/
-}
-
-/* --------------------------------------------------------------------------
- * Entry points to type checker:
- * ------------------------------------------------------------------------*/
-
-Type typeCheckExp(useDefs) /* Type check top level expression */
-Bool useDefs; { /* using defaults if reqd */
- Type type;
- List ctxt;
- Int beta;
-
- typeChecker(RESET);
- emptySubstitution();
- enterBindings();
- inputExpr = typeExpr(0,inputExpr);
- type = typeIs;
- beta = typeOff;
- clearMarks();
- improve(0,NIL,preds);
- normPreds(0);
- elimTauts();
- preds = scSimplify(preds);
- if (useDefs && nonNull(preds)) {
- clearMarks();
- reducePreds();
- if (nonNull(preds) && resolveDefs(NIL)) /* Nearly Haskell 1.4? */
- elimTauts();
- }
- resetGenerics();
- ctxt = copyPreds(preds);
- type = generalize(ctxt,copyType(type,beta));
- inputExpr = qualifyExpr(0,preds,inputExpr);
- h98CheckType(0,"inferred type",inputExpr,type);
- typeChecker(RESET);
- emptySubstitution();
- return type;
-}
-
-Void typeCheckDefns() { /* Type check top level bindings */
- Target t = length(selDefns) + length(valDefns) +
- length(instDefns) + length(classDefns);
- Target i = 0;
- List gs;
-
- typeChecker(RESET);
- emptySubstitution();
- enterSkolVars();
- enterBindings();
- setGoal("Type checking",t);
-
- for (gs=selDefns; nonNull(gs); gs=tl(gs)) {
- mapOver(typeSel,hd(gs));
- soFar(i++);
- }
- for (gs=valDefns; nonNull(gs); gs=tl(gs)) {
- typeDefnGroup(hd(gs));
- soFar(i++);
- }
- clearTypeIns();
- for (gs=classDefns; nonNull(gs); gs=tl(gs)) {
- emptySubstitution();
- typeClassDefn(hd(gs));
- soFar(i++);
- }
- for (gs=instDefns; nonNull(gs); gs=tl(gs)) {
- emptySubstitution();
- typeInstDefn(hd(gs));
- soFar(i++);
- }
-
- typeChecker(RESET);
- emptySubstitution();
- done();
-}
-
-static Void local typeDefnGroup(bs) /* type check group of value defns */
-List bs; { /* (one top level scc) */
- List as;
-
- emptySubstitution();
- hd(defnBounds) = NIL;
- preds = NIL;
- setTypeIns(bs);
- typeBindings(bs); /* find types for vars in bindings */
-
- if (nonNull(preds)) {
- Cell v = fst(hd(hd(varsBounds)));
- Name n = findName(textOf(v));
- Int l = nonNull(n) ? name(n).line : 0;
- preds = scSimplify(preds);
- ERRMSG(l) "Instance%s of ", (length(preds)==1 ? "" : "s") ETHEN
- ERRCONTEXT(copyPreds(preds));
- ERRTEXT " required for definition of " ETHEN
- ERREXPR(nonNull(n)?n:v);
- ERRTEXT "\n"
- EEND;
- }
-
- if (nonNull(hd(skolVars))) {
- Cell b = hd(bs);
- Name n = findName(isVar(fst(b)) ? textOf(fst(b)) : textOf(hd(fst(b))));
- Int l = nonNull(n) ? name(n).line : 0;
- leaveSkolVars(l,typeUnit,0,0);
- enterSkolVars();
- }
-
- for (as=hd(varsBounds); nonNull(as); as=tl(as)) {
- Cell a = hd(as); /* add infered types to environment*/
- Name n = findName(textOf(fst(a)));
- if (isNull(n))
- internal("typeDefnGroup");
- name(n).type = snd(a);
- }
- hd(varsBounds) = NIL;
-}
-
-static Pair local typeSel(s) /* Calculate a suitable type for a */
-Name s; { /* particular selector, s. */
- List cns = name(s).defn;
- Int line = name(s).line;
- Type dom = NIL; /* Inferred domain */
- Type rng = NIL; /* Inferred range */
- Cell nv = inventVar();
- List alts = NIL;
- Int o = 0; /* bogus init to keep gcc -O happy */
- Int m = 0; /* bogus init to keep gcc -O happy */
-
-#ifdef DEBUG_SELS
- Printf("Selector %s, cns=",textToStr(name(s).text));
- printExp(stdout,cns);
- Putchar('\n');
-#endif
-
- emptySubstitution();
- preds = NIL;
-
- for (; nonNull(cns); cns=tl(cns)) {
- Name c = fst(hd(cns));
- Int n = intOf(snd(hd(cns)));
- Int a = name(c).arity;
- Cell pat = c;
- Type dom1;
- Type rng1;
- Int o1;
- Int m1;
-
- instantiate(name(c).type); /* Instantiate constructor type */
- o1 = typeOff;
- m1 = typeFree;
- for (; nonNull(predsAre); predsAre=tl(predsAre))
- assumeEvid(hd(predsAre),o1);
-
- if (whatIs(typeIs)==RANK2) /* Skip rank2 annotation, if any */
- typeIs = snd(snd(typeIs));
- for (; --n>0; a--) { /* Get range */
- pat = ap(pat,WILDCARD);
- typeIs = arg(typeIs);
- }
- rng1 = dropRank1(arg(fun(typeIs)),o1,m1);
- pat = ap(pat,nv);
- typeIs = arg(typeIs);
- while (--a>0) { /* And then look for domain */
- pat = ap(pat,WILDCARD);
- typeIs = arg(typeIs);
- }
- dom1 = typeIs;
-
- if (isNull(dom)) { /* Save first domain type and then */
- dom = dom1; /* unify with subsequent domains to*/
- o = o1; /* match up preds and range types */
- m = m1;
- }
- else if (!unify(dom1,o1,dom,o))
- internal("typeSel1");
-
- if (isNull(rng)) /* Compare component types */
- rng = rng1;
- else if (!sameSchemes(rng1,rng)) {
- clearMarks();
- rng = liftRank1(rng,o,m);
- rng1 = liftRank1(rng1,o1,m1);
- ERRMSG(name(s).line) "Mismatch in field types for selector \"%s\"",
- textToStr(name(s).text) ETHEN
- ERRTEXT "\n*** Field type : " ETHEN ERRTYPE(rng1);
- ERRTEXT "\n*** Does not match : " ETHEN ERRTYPE(rng);
- ERRTEXT "\n"
- EEND;
- }
- alts = cons(pair(singleton(pat),pair(mkInt(line),nv)),alts);
- }
- alts = rev(alts);
-
- if (isNull(dom) || isNull(rng)) /* Should have been initialized by */
- internal("typeSel2"); /* now, assuming length cns >= 1. */
-
- clearMarks(); /* No fixed variables here */
- preds = scSimplify(preds); /* Simplify context */
- dom = copyType(dom,o); /* Calculate domain type */
- instantiate(rng);
- rng = copyType(typeIs,typeOff);
- if (nonNull(predsAre)) {
- List ps = makePredAss(predsAre,typeOff);
- List alts1 = alts;
- for (; nonNull(alts1); alts1=tl(alts1)) {
- Cell body = nv;
- List qs = ps;
- for (; nonNull(qs); qs=tl(qs))
- body = ap(body,thd3(hd(qs)));
- snd(snd(hd(alts1))) = body;
- }
- preds = appendOnto(preds,ps);
- }
- name(s).type = generalize(copyPreds(preds),fn(dom,rng));
- name(s).arity = 1 + length(preds);
- map1Proc(qualify,preds,alts);
-
-#ifdef DEBUG_SELS
- Printf("Inferred arity = %d, type = ",name(s).arity);
- printType(stdout,name(s).type);
- Putchar('\n');
-#endif
-
- return pair(s,alts);
-}
-
-
-/* --------------------------------------------------------------------------
- * Local function prototypes:
- * ------------------------------------------------------------------------*/
-
-static Type local basicType ( Char );
-
-
-static Type stateVar = NIL;
-static Type alphaVar = NIL;
-static Type betaVar = NIL;
-static Type gammaVar = NIL;
-static Type deltaVar = NIL;
-static Int nextVar = 0;
-
-static Void clearTyVars( void )
-{
- stateVar = NIL;
- alphaVar = NIL;
- betaVar = NIL;
- gammaVar = NIL;
- deltaVar = NIL;
- nextVar = 0;
-}
-
-static Type mkStateVar( void )
-{
- if (isNull(stateVar)) {
- stateVar = mkOffset(nextVar++);
- }
- return stateVar;
-}
-
-static Type mkAlphaVar( void )
-{
- if (isNull(alphaVar)) {
- alphaVar = mkOffset(nextVar++);
- }
- return alphaVar;
-}
-
-static Type mkBetaVar( void )
-{
- if (isNull(betaVar)) {
- betaVar = mkOffset(nextVar++);
- }
- return betaVar;
-}
-
-static Type mkGammaVar( void )
-{
- if (isNull(gammaVar)) {
- gammaVar = mkOffset(nextVar++);
- }
- return gammaVar;
-}
-
-static Type mkDeltaVar( void )
-{
- if (isNull(deltaVar)) {
- deltaVar = mkOffset(nextVar++);
- }
- return deltaVar;
-}
-
-static Type local basicType(k)
-Char k; {
- switch (k) {
- case CHAR_REP:
- return typeChar;
- case INT_REP:
- return typeInt;
- case INTEGER_REP:
- return typeInteger;
- case ADDR_REP:
- return typeAddr;
- case WORD_REP:
- return typeWord;
- case FLOAT_REP:
- return typeFloat;
- case DOUBLE_REP:
- return typeDouble;
- case ARR_REP:
- return ap(typePrimArray,mkAlphaVar());
- case BARR_REP:
- return typePrimByteArray;
- case REF_REP:
- return ap2(typeRef,mkStateVar(),mkAlphaVar());
- case MUTARR_REP:
- return ap2(typePrimMutableArray,mkStateVar(),mkAlphaVar());
- case MUTBARR_REP:
- return ap(typePrimMutableByteArray,mkStateVar());
- case STABLE_REP:
- return ap(typeStable,mkAlphaVar());
-#ifdef PROVIDE_WEAK
- case WEAK_REP:
- return ap(typeWeak,mkAlphaVar());
- case IO_REP:
- return ap(typeIO,typeUnit);
-#endif
-#ifdef PROVIDE_FOREIGN
- case FOREIGN_REP:
- return typeForeign;
-#endif
- case THREADID_REP:
- return typeThreadId;
- case MVAR_REP:
- return ap(typeMVar,mkAlphaVar());
- case BOOL_REP:
- return typeBool;
- case HANDLER_REP:
- return fn(typeException,mkAlphaVar());
- case ERROR_REP:
- return typeException;
- case ALPHA_REP:
- return mkAlphaVar(); /* polymorphic */
- case BETA_REP:
- return mkBetaVar(); /* polymorphic */
- case GAMMA_REP:
- return mkGammaVar(); /* polymorphic */
- case DELTA_REP:
- return mkDeltaVar(); /* polymorphic */
- default:
- printf("Kind: '%c'\n",k);
- internal("basicType");
- }
- assert(0); return 0; /* NOTREACHED */
-}
-
-/* Generate type of primop based on list of arg types and result types:
- *
- * eg primType "II" "II" = Int -> Int -> (Int,Int)
- *
- */
-Type primType( Int /*AsmMonad*/ monad, String a_kinds, String r_kinds )
-{
- List rs = NIL;
- List as = NIL;
- List tvars = NIL; /* for polymorphic types */
- Type r;
-
- clearTyVars();
-
- /* build result types */
- for(; *r_kinds; ++r_kinds) {
- rs = cons(basicType(*r_kinds),rs);
- }
- /* Construct tuple of results */
- if (length(rs) == 0) {
- r = typeUnit;
- } else if (length(rs) == 1) {
- r = hd(rs);
- } else {
- r = mkTuple(length(rs));
- for(rs = rev(rs); nonNull(rs); rs=tl(rs)) {
- r = ap(r,hd(rs));
- }
- }
- /* Construct list of arguments */
- for(; *a_kinds; ++a_kinds) {
- as = cons(basicType(*a_kinds),as);
- }
- /* Apply any monad magic */
- if (monad == MONAD_IO) {
- r = ap(typeIO,r);
- } else if (monad == MONAD_ST) {
- r = ap2(typeST,mkStateVar(),r);
- }
- /* glue it all together */
- for(; nonNull(as); as=tl(as)) {
- r = fn(hd(as),r);
- }
- tvars = offsetTyvarsIn(r,NIL);
- if (nonNull(tvars)) {
- assert(length(tvars) == nextVar);
- r = mkPolyType(simpleKind(length(tvars)),r);
- }
- return r;
-}
-
-/* forall a1 .. am. TC a1 ... am -> Int */
-Type conToTagType(t)
-Tycon t; {
- Type ty = t;
- List tvars = NIL;
- Int i = 0;
- for (i=0; i<tycon(t).arity; ++i) {
- Offset tv = mkOffset(i);
- ty = ap(ty,tv);
- tvars = cons(tv,tvars);
- }
- ty = fn(ty,typeInt);
- if (nonNull(tvars)) {
- ty = mkPolyType(simpleKind(tycon(t).arity),ty);
- }
- return ty;
-}
-
-/* forall a1 .. am. Int -> TC a1 ... am */
-Type tagToConType(t)
-Tycon t; {
- Type ty = t;
- List tvars = NIL;
- Int i = 0;
- for (i=0; i<tycon(t).arity; ++i) {
- Offset tv = mkOffset(i);
- ty = ap(ty,tv);
- tvars = cons(tv,tvars);
- }
- ty = fn(typeInt,ty);
- if (nonNull(tvars)) {
- ty = mkPolyType(simpleKind(tycon(t).arity),ty);
- }
- return ty;
-}
-
-/* --------------------------------------------------------------------------
- * Type checker control:
- * ------------------------------------------------------------------------*/
-
-Void typeChecker(what)
-Int what; {
- switch (what) {
- case RESET : tcMode = EXPRESSION;
- daSccs = NIL;
- preds = NIL;
- pendingBtyvs = NIL;
- daSccs = NIL;
- emptyAssumption();
- break;
-
- case MARK : mark(defnBounds);
- mark(varsBounds);
- mark(depends);
- mark(pendingBtyvs);
- mark(skolVars);
- mark(localEvs);
- mark(savedPs);
- mark(dummyVar);
- mark(daSccs);
- mark(preds);
- mark(stdDefaults);
- mark(arrow);
- mark(boundPair);
- mark(listof);
- mark(typeVarToVar);
- mark(predNum);
- mark(predFractional);
- mark(predIntegral);
- mark(starToStar);
- mark(predMonad);
- mark(typeProgIO);
- break;
-
- case POSTPREL:
-
- if (combined) {
- setCurrModule(modulePrelude);
- dummyVar = inventVar();
- typeUnit = mkTuple(0);
- arrow = fn(aVar,bVar);
- listof = ap(typeList,aVar);
- boundPair = ap(ap(mkTuple(2),aVar),aVar);
- nameUnit = findQualNameWithoutConsultingExportList
- (mkQVar(findText("PrelBase"),
- findText("()")));
- typeVarToVar = fn(aVar,aVar);
- }
- break;
-
- case PREPREL :
- typeChecker(RESET);
-
- if (combined) {
- Module m = findFakeModule(findText("PrelBase"));
- setCurrModule(m);
-
- starToStar = simpleKind(1);
- typeList = addPrimTycon(findText("[]"),
- starToStar,1,
- DATATYPE,NIL);
-
- listof = ap(typeList,aVar);
- nameNil = addPrimCfun(findText("[]"),0,1,
- mkPolyType(starToStar,
- listof));
- nameCons = addPrimCfun(findText(":"),2,2,
- mkPolyType(starToStar,
- fn(aVar,
- fn(listof,
- listof))));
- name(nameNil).parent =
- name(nameCons).parent = typeList;
-
- name(nameCons).syntax
- = mkSyntax(RIGHT_ASS,5);
-
- tycon(typeList).defn
- = cons(nameNil,cons(nameCons,NIL));
-
- } else {
- dummyVar = inventVar();
-
- setCurrModule(modulePrelPrim);
-
- starToStar = simpleKind(1);
-
- typeUnit = findTycon(findText("()"));
- assert(nonNull(typeUnit));
-
- typeArrow = addPrimTycon(findText("(->)"),
- simpleKind(2),2,
- DATATYPE,NIL);
- typeList = addPrimTycon(findText("[]"),
- starToStar,1,
- DATATYPE,NIL);
-
- arrow = fn(aVar,bVar);
- listof = ap(typeList,aVar);
- boundPair = ap(ap(mkTuple(2),aVar),aVar);
-
- nameUnit = addPrimCfun(findText("()"),0,0,typeUnit);
- tycon(typeUnit).defn
- = singleton(nameUnit);
-
- nameNil = addPrimCfun(findText("[]"),0,1,
- mkPolyType(starToStar,
- listof));
- nameCons = addPrimCfun(findText(":"),2,2,
- mkPolyType(starToStar,
- fn(aVar,
- fn(listof,
- listof))));
- name(nameNil).parent =
- name(nameCons).parent = typeList;
-
- name(nameCons).syntax
- = mkSyntax(RIGHT_ASS,5);
-
- tycon(typeList).defn
- = cons(nameNil,cons(nameCons,NIL));
-
- typeVarToVar = fn(aVar,aVar);
-#if TREX
- typeNoRow = addPrimTycon(findText("EmptyRow"),
- ROW,0,DATATYPE,NIL);
- typeRec = addPrimTycon(findText("Rec"),
- pair(ROW,STAR),1,
- DATATYPE,NIL);
- nameNoRec = addPrimCfun(findText("EmptyRec"),0,0,
- ap(typeRec,typeNoRow));
-#else
- /* bogus definitions to avoid changing the prelude */
- addPrimCfun(findText("Rec"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRow"), 0,0,typeUnit);
- addPrimCfun(findText("EmptyRec"), 0,0,typeUnit);
-#endif
- }
- break;
-
- }
-}
-
-/*-------------------------------------------------------------------------*/
+++ /dev/null
-/* --------------------------------------------------------------------------
- * Version number
- * ------------------------------------------------------------------------*/
-
-/* Define this as a 14 character string uniquely identifying the current
- * version.
- * Major releases from Nottingham/Yale are of the form "<month><year>"
- * Minor releases from Nottingham/Yale are of the form "[Beta YYMMDD]"
- * Anyone else should use a different format to avoid confusion.
- */
-#define MAJOR_RELEASE 0
-
-#if MAJOR_RELEASE
-#define HUGS_VERSION "March 2000 "
-#else
-#define HUGS_VERSION "STGHugs-000425"
-#endif
-
projects / ghc-hetmet.git / commitdiff