From: sewardj Date: Wed, 17 Jan 2001 15:23:48 +0000 (+0000) Subject: [project @ 2001-01-17 15:23:39 by sewardj] X-Git-Tag: Approximately_9120_patches~2870 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f1dffa0224c9e8dcf1d3908e888e7d683485791b;p=ghc-hetmet.git [project @ 2001-01-17 15:23:39 by sewardj] Bye bye STG Hugs! --- diff --git a/ghc/interpreter/Dh_Demo.hs b/ghc/interpreter/Dh_Demo.hs deleted file mode 100644 index 2802b2f..0000000 --- a/ghc/interpreter/Dh_Demo.hs +++ /dev/null @@ -1,8 +0,0 @@ - -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") diff --git a/ghc/interpreter/DietHEP.def b/ghc/interpreter/DietHEP.def deleted file mode 100644 index 705a322..0000000 --- a/ghc/interpreter/DietHEP.def +++ /dev/null @@ -1,3 +0,0 @@ -EXPORTS -DH_GetProcAddress@12 -DH_LoadLibrary@4 diff --git a/ghc/interpreter/Makefile b/ghc/interpreter/Makefile deleted file mode 100644 index 68d34f1..0000000 --- a/ghc/interpreter/Makefile +++ /dev/null @@ -1,136 +0,0 @@ - -# --------------------------------------------------------------------------- # -# $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 - - diff --git a/ghc/interpreter/Makefile-DietHEP b/ghc/interpreter/Makefile-DietHEP deleted file mode 100644 index 98a7675..0000000 --- a/ghc/interpreter/Makefile-DietHEP +++ /dev/null @@ -1,137 +0,0 @@ - -# --------------------------------------------------------------------------- # -# $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 diff --git a/ghc/interpreter/README.BUILDING.DIETHEP b/ghc/interpreter/README.BUILDING.DIETHEP deleted file mode 100644 index ffd3685..0000000 --- a/ghc/interpreter/README.BUILDING.DIETHEP +++ /dev/null @@ -1,9 +0,0 @@ - -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. - - diff --git a/ghc/interpreter/README.BUILDING.HUGS b/ghc/interpreter/README.BUILDING.HUGS deleted file mode 100644 index c4be6ea..0000000 --- a/ghc/interpreter/README.BUILDING.HUGS +++ /dev/null @@ -1,43 +0,0 @@ - -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 - - diff --git a/ghc/interpreter/codegen.c b/ghc/interpreter/codegen.c deleted file mode 100644 index c356c1b..0000000 --- a/ghc/interpreter/codegen.c +++ /dev/null @@ -1,853 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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); -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/compiler.c b/ghc/interpreter/compiler.c deleted file mode 100644 index f536ae2..0000000 --- a/ghc/interpreter/compiler.c +++ /dev/null @@ -1,1650 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 ] ==> T[] - * T [indirect ] ==> T[] - */ - 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 ""] - */ - 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 (00; 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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h deleted file mode 100644 index a93a265..0000000 --- a/ghc/interpreter/connect.h +++ /dev/null @@ -1,1000 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 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 - -#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 -# include -#endif - -extern int chdir ( const char* ); - -#if HAVE_STDLIB_H -# include -#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 -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/derive.c b/ghc/interpreter/derive.c deleted file mode 100644 index fccff4f..0000000 --- a/ghc/interpreter/derive.c +++ /dev/null @@ -1,1027 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 [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); i1; --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) 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 [ (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 [ (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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/dh_demo.c b/ghc/interpreter/dh_demo.c deleted file mode 100644 index e925b7e..0000000 --- a/ghc/interpreter/dh_demo.c +++ /dev/null @@ -1,39 +0,0 @@ - - -#include -#include -#include -//#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; -} diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c deleted file mode 100644 index 1f37491..0000000 --- a/ghc/interpreter/dynamic.c +++ /dev/null @@ -1,168 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 - -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 -#include - -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 - -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 */ - diff --git a/ghc/interpreter/errors.h b/ghc/interpreter/errors.h deleted file mode 100644 index 63f9325..0000000 --- a/ghc/interpreter/errors.h +++ /dev/null @@ -1,50 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 ); - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/free.c b/ghc/interpreter/free.c deleted file mode 100644 index 08d0a33..0000000 --- a/ghc/interpreter/free.c +++ /dev/null @@ -1,131 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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"); - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c deleted file mode 100644 index bdb4bf6..0000000 --- a/ghc/interpreter/hugs.c +++ /dev/null @@ -1,2957 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 -#include -#include - -#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 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 load modules from specified files\n"); - Printf(":load clear all files except prelude\n"); - Printf(":also read additional modules\n"); - Printf(":reload repeat last load command\n"); - Printf(":project use project file\n"); - Printf(":edit edit file\n"); - Printf(":edit edit last module\n"); - Printf(":module set module for evaluating expressions\n"); - Printf(" evaluate expression\n"); - Printf(":type print type of expression\n"); - Printf(":? display this list of commands\n"); - Printf(":set set command line options\n"); - Printf(":set help on command line options\n"); - Printf(":names [pat] list names currently in scope\n"); - Printf(":info describe named objects\n"); - Printf(":browse browse names defined in \n"); -#if EXPLAIN_INSTANCE_RESOLUTION - Printf(":xplain explain instance resolution for \n"); -#endif - Printf(":find 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 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= 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"); - 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(""); - } - 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 -#else -#include -#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); - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/hugsbasictypes.h b/ghc/interpreter/hugsbasictypes.h deleted file mode 100644 index 497c7e4..0000000 --- a/ghc/interpreter/hugsbasictypes.h +++ /dev/null @@ -1,266 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 - -/*--------------------------------------------------------------------------- - * 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 /* 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 -#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 -#endif -#ifndef isascii -#define isascii(c) (((unsigned)(c))<128) -#endif - -/*--------------------------------------------------------------------------- - * Memory allocation - *-------------------------------------------------------------------------*/ - -#if HAVE_FARCALLOC -# include -# define farCalloc(n,s) farcalloc((unsigned long)n,(unsigned long)s) -#elif HAVE_VALLOC -# include -# include -# 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 -#ifndef alloca -#define alloca _alloca -#endif -#endif - -/*--------------------------------------------------------------------------- - * Assertions - *-------------------------------------------------------------------------*/ - -#if HAVE_ASSERT_H -#include -#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 -#else -#include -#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 - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c deleted file mode 100644 index 63ebe07..0000000 --- a/ghc/interpreter/input.c +++ /dev/null @@ -1,1784 +0,0 @@ -/* -------------------------------------------------------------------------- - * 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 -#if HAVE_GETDELIM_H -#include "getdelim.h" -#endif - -#if IS_WIN32 -#include -#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 -#include -#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)?@\\^|-~"); - - 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 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=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=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"); - 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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/interface.c b/ghc/interpreter/interface.c deleted file mode 100644 index 8b81bfe..0000000 --- a/ghc/interpreter/interface.c +++ /dev/null @@ -1,2857 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/lib/Makefile b/ghc/interpreter/lib/Makefile deleted file mode 100644 index e67cab7..0000000 --- a/ghc/interpreter/lib/Makefile +++ /dev/null @@ -1,120 +0,0 @@ -# -------------------------------------------------------------------------- # -# $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 - diff --git a/ghc/interpreter/library/Array.hs b/ghc/interpreter/library/Array.hs deleted file mode 100644 index e171c4b..0000000 --- a/ghc/interpreter/library/Array.hs +++ /dev/null @@ -1,171 +0,0 @@ -#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 */ diff --git a/ghc/interpreter/library/Char.hs b/ghc/interpreter/library/Char.hs deleted file mode 100644 index fbc891f..0000000 --- a/ghc/interpreter/library/Char.hs +++ /dev/null @@ -1,157 +0,0 @@ -#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 */ diff --git a/ghc/interpreter/library/Complex.hs b/ghc/interpreter/library/Complex.hs deleted file mode 100644 index c579579..0000000 --- a/ghc/interpreter/library/Complex.hs +++ /dev/null @@ -1,92 +0,0 @@ - -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)) diff --git a/ghc/interpreter/library/Directory.hs b/ghc/interpreter/library/Directory.hs deleted file mode 100644 index 548c54b..0000000 --- a/ghc/interpreter/library/Directory.hs +++ /dev/null @@ -1,17 +0,0 @@ -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 () - - - - diff --git a/ghc/interpreter/library/IO.hs b/ghc/interpreter/library/IO.hs deleted file mode 100644 index 0f84849..0000000 --- a/ghc/interpreter/library/IO.hs +++ /dev/null @@ -1,69 +0,0 @@ -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 diff --git a/ghc/interpreter/library/Int.hs b/ghc/interpreter/library/Int.hs deleted file mode 100644 index 911246a..0000000 --- a/ghc/interpreter/library/Int.hs +++ /dev/null @@ -1,332 +0,0 @@ ------------------------------------------------------------------------------ --- 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 ------------------------------------------------------------------------------ diff --git a/ghc/interpreter/library/Ix.hs b/ghc/interpreter/library/Ix.hs deleted file mode 100644 index 445ca69..0000000 --- a/ghc/interpreter/library/Ix.hs +++ /dev/null @@ -1,65 +0,0 @@ -#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 diff --git a/ghc/interpreter/library/List.hs b/ghc/interpreter/library/List.hs deleted file mode 100644 index bab1eb8..0000000 --- a/ghc/interpreter/library/List.hs +++ /dev/null @@ -1,265 +0,0 @@ -#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 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 diff --git a/ghc/interpreter/library/Maybe.hs b/ghc/interpreter/library/Maybe.hs deleted file mode 100644 index d1fde8b..0000000 --- a/ghc/interpreter/library/Maybe.hs +++ /dev/null @@ -1,41 +0,0 @@ -#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 */ diff --git a/ghc/interpreter/library/Monad.hs b/ghc/interpreter/library/Monad.hs deleted file mode 100644 index 026ab94..0000000 --- a/ghc/interpreter/library/Monad.hs +++ /dev/null @@ -1,79 +0,0 @@ -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 diff --git a/ghc/interpreter/library/Numeric.hs b/ghc/interpreter/library/Numeric.hs deleted file mode 100644 index 47e08b1..0000000 --- a/ghc/interpreter/library/Numeric.hs +++ /dev/null @@ -1,308 +0,0 @@ -#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 */ diff --git a/ghc/interpreter/library/Ratio.hs b/ghc/interpreter/library/Ratio.hs deleted file mode 100644 index e301438..0000000 --- a/ghc/interpreter/library/Ratio.hs +++ /dev/null @@ -1,103 +0,0 @@ --- 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 */ diff --git a/ghc/interpreter/library/UnicodePrims.hs b/ghc/interpreter/library/UnicodePrims.hs deleted file mode 100644 index 1ccf96d..0000000 --- a/ghc/interpreter/library/UnicodePrims.hs +++ /dev/null @@ -1,33 +0,0 @@ -#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 */ diff --git a/ghc/interpreter/library/Word.hs b/ghc/interpreter/library/Word.hs deleted file mode 100644 index ba08f81..0000000 --- a/ghc/interpreter/library/Word.hs +++ /dev/null @@ -1,397 +0,0 @@ ------------------------------------------------------------------------------ --- 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 ------------------------------------------------------------------------------ diff --git a/ghc/interpreter/lift.c b/ghc/interpreter/lift.c deleted file mode 100644 index a71e6ac..0000000 --- a/ghc/interpreter/lift.c +++ /dev/null @@ -1,216 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c deleted file mode 100644 index 7e405d0..0000000 --- a/ghc/interpreter/link.c +++ /dev/null @@ -1,813 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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)"), - 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)"), - 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 - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/machdep.c b/ghc/interpreter/machdep.c deleted file mode 100644 index b5d9217..0000000 --- a/ghc/interpreter/machdep.c +++ /dev/null @@ -1,1099 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 -#endif -#ifdef HAVE_SYS_TYPES_H -# include -#else -# ifdef HAVE_TYPES_H -# include -# endif -#endif - -#if 0 -#if HAVE_SYS_PARAM_H -# include -#endif -#endif - -#ifdef HAVE_SYS_STAT_H -# include -#else -# ifdef HAVE_STAT_H -# include -# endif -#endif -#ifdef HAVE_TIME_H -# include -#endif - -/* Windows/DOS include files */ -#ifdef HAVE_DOS_H -# include -#endif -#if defined HAVE_CONIO_H -# include -#endif -#ifdef HAVE_IO_H -# include -#endif -#ifdef HAVE_STD_H -# include -#endif -#ifdef HAVE_WINDOWS_H -# include -#endif - -#if DOS -#include -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 -#endif -#ifdef HAVE_PASCAL_H -# include -#endif -#ifdef HAVE_FILES_H -# include -#endif -#ifdef HAVE_FCNTL_H -# include -#endif -#ifdef HAVE_ERRNO_H -# include -#endif -#ifdef HAVE_STDLIB_H -# include -#endif -#ifdef HAVE_UNIX_H -#include -#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 - -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; - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/machdep_time.h b/ghc/interpreter/machdep_time.h deleted file mode 100644 index 63f9bb5..0000000 --- a/ghc/interpreter/machdep_time.h +++ /dev/null @@ -1,22 +0,0 @@ - -#ifndef MACHDEP_TIME_INCLUDED -#define MACHDEP_TIME_INCLUDED - -#ifdef HAVE_TIME_H -# include -#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 diff --git a/ghc/interpreter/nHandle.c b/ghc/interpreter/nHandle.c deleted file mode 100644 index ecc5f8f..0000000 --- a/ghc/interpreter/nHandle.c +++ /dev/null @@ -1,175 +0,0 @@ - -/* 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 -#include -#include -#include -#include -#include -#ifndef _WIN32 -#include -#include -#include -#include -#endif -#include - -#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 ); -} - diff --git a/ghc/interpreter/nHandle.def b/ghc/interpreter/nHandle.def deleted file mode 100644 index 1f38a6c..0000000 --- a/ghc/interpreter/nHandle.def +++ /dev/null @@ -1,22 +0,0 @@ -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 diff --git a/ghc/interpreter/object.c b/ghc/interpreter/object.c deleted file mode 100644 index 75a1b7f..0000000 --- a/ghc/interpreter/object.c +++ /dev/null @@ -1,1401 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 -#include -#include -#include -#include -#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 - -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) */ - - - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/object.h b/ghc/interpreter/object.h deleted file mode 100644 index 10f8be8..0000000 --- a/ghc/interpreter/object.h +++ /dev/null @@ -1,120 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 - -/*-------------------------------------------------------------------------*/ - diff --git a/ghc/interpreter/output.c b/ghc/interpreter/output.c deleted file mode 100644 index c4ed363..0000000 --- a/ghc/interpreter/output.c +++ /dev/null @@ -1,999 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 - -#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(""); -} - -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(' '); - } - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/parser.y b/ghc/interpreter/parser.y deleted file mode 100644 index 13b3b0a..0000000 --- a/ghc/interpreter/parser.y +++ /dev/null @@ -1,1512 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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)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 - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/preds.c b/ghc/interpreter/preds.c deleted file mode 100644 index 7c5a7a8..0000000 --- a/ghc/interpreter/preds.c +++ /dev/null @@ -1,1070 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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= 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=tycon(h).arity) { - expandSyn(h,a,&t,&o); - return anyGenerics(t,o); - } - else { - Tyvar* tyv; - for (; 0offs == 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; -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/runallnofib b/ghc/interpreter/runallnofib deleted file mode 100644 index 1d1a060..0000000 --- a/ghc/interpreter/runallnofib +++ /dev/null @@ -1,119 +0,0 @@ -#!/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 diff --git a/ghc/interpreter/runnofib b/ghc/interpreter/runnofib deleted file mode 100644 index f1f5d54..0000000 --- a/ghc/interpreter/runnofib +++ /dev/null @@ -1,51 +0,0 @@ -#!/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 diff --git a/ghc/interpreter/sainteger.c b/ghc/interpreter/sainteger.c deleted file mode 100644 index 837cf33..0000000 --- a/ghc/interpreter/sainteger.c +++ /dev/null @@ -1,968 +0,0 @@ - -/* -------------------------------------------------------------------------- - * Yet another implementation of Integer - * - * Copyright (c) Glasgow University, 1999. - * All rights reserved. See NOTICE for details and conditions of use etc... - * ------------------------------------------------------------------------*/ - -#include -#include -#include -#include - -#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 - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/scc.c b/ghc/interpreter/scc.c deleted file mode 100644 index 96d19f8..0000000 --- a/ghc/interpreter/scc.c +++ /dev/null @@ -1,108 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c deleted file mode 100644 index 7636dd7..0000000 --- a/ghc/interpreter/static.c +++ /dev/null @@ -1,5294 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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; /* "| of |" */ -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; i0) { /* 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=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= (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 ... -> 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 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 (00) { - 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 - } -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/stg.c b/ghc/interpreter/stg.c deleted file mode 100644 index 08defee..0000000 --- a/ghc/interpreter/stg.c +++ /dev/null @@ -1,608 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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"); - 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); -} - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/stgSubst.c b/ghc/interpreter/stgSubst.c deleted file mode 100644 index 07c3d3e..0000000 --- a/ghc/interpreter/stgSubst.c +++ /dev/null @@ -1,119 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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; -} - - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c deleted file mode 100644 index 9d743bf..0000000 --- a/ghc/interpreter/storage.c +++ /dev/null @@ -1,3387 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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 -#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 savedText) { - ERRMSG(0) "Character string storage space exhausted" - EEND; - } - while ((text[textHw++] = *s++) != 0) { - } - if (hashno 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= 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= 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; inext) { - 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'); - break; - case ZTUP3: - Printf("'); - 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 (00; --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>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)=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)=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)=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 -#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 ); - -/*-------------------------------------------------------------------------*/ diff --git a/ghc/interpreter/subst.c b/ghc/interpreter/subst.c deleted file mode 100644 index 812a31c..0000000 --- a/ghc/interpreter/subst.c +++ /dev/null @@ -1,1972 +0,0 @@ - -/* -------------------------------------------------------------------------- - * 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; i0; 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 (; 0offs = UNUSED_GENERIC; - genericVars = NIL; - nextGeneric = 0; -} - -Void markAllVars() { /* Set all unbound type vars to */ - Int i; /* be fixed vars */ - for (i=0; ioffs = FIXED_TYVAR; - genericVars = NIL; - nextGeneric = 0; -} - -Void resetGenerics() { /* Reset all generic vars to unused*/ - Int i; - for (i=0; ioffs>=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 (; i0; 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 * -> * */ - 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)bound==SKOLEM) { - if (tyvNum(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)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) - 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 * -> ... -> * -> * 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" unless $ARGV[0]; - -$start = $ARGV[0]; - -# Filter that trims lines before regexp - -# skip the initial part -while () { - last if /$start/; -} -# print the good bit -while () { - print; -} - -exit 0; diff --git a/ghc/interpreter/test/before b/ghc/interpreter/test/before deleted file mode 100644 index 7235e8e..0000000 --- a/ghc/interpreter/test/before +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/perl - -die "Usage: before " unless $ARGV[0]; - -$pat = $ARGV[0]; - -# Filter that trims lines after regexp - -# print the initial part -while () { - last if /$pat/; - print; -} - -exit 0; diff --git a/ghc/interpreter/test/exts/FixIO.in1 b/ghc/interpreter/test/exts/FixIO.in1 deleted file mode 100644 index caf74b8..0000000 --- a/ghc/interpreter/test/exts/FixIO.in1 +++ /dev/null @@ -1,6 +0,0 @@ -look env "f" -look env "g" -look env2 "f" -look env2 "g" -main -main2 \ No newline at end of file diff --git a/ghc/interpreter/test/exts/FixIO.lhs b/ghc/interpreter/test/exts/FixIO.lhs deleted file mode 100644 index e7dec73..0000000 --- a/ghc/interpreter/test/exts/FixIO.lhs +++ /dev/null @@ -1,97 +0,0 @@ ---!!! 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 - - diff --git a/ghc/interpreter/test/exts/FixIO.out1 b/ghc/interpreter/test/exts/FixIO.out1 deleted file mode 100644 index 2428f80..0000000 --- a/ghc/interpreter/test/exts/FixIO.out1 +++ /dev/null @@ -1,22 +0,0 @@ -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) - diff --git a/ghc/interpreter/test/exts/intTest.hs b/ghc/interpreter/test/exts/intTest.hs deleted file mode 100644 index 2d12f50..0000000 --- a/ghc/interpreter/test/exts/intTest.hs +++ /dev/null @@ -1,134 +0,0 @@ ---!!! 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 diff --git a/ghc/interpreter/test/exts/intTest.in1 b/ghc/interpreter/test/exts/intTest.in1 deleted file mode 100644 index 9daeafb..0000000 --- a/ghc/interpreter/test/exts/intTest.in1 +++ /dev/null @@ -1 +0,0 @@ -test diff --git a/ghc/interpreter/test/exts/intTest.out1 b/ghc/interpreter/test/exts/intTest.out1 deleted file mode 100644 index 8f1f344..0000000 --- a/ghc/interpreter/test/exts/intTest.out1 +++ /dev/null @@ -1,7573 +0,0 @@ -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 -# --------------------------------- - diff --git a/ghc/interpreter/test/exts/mvar.hs b/ghc/interpreter/test/exts/mvar.hs deleted file mode 100644 index 0e63ac4..0000000 --- a/ghc/interpreter/test/exts/mvar.hs +++ /dev/null @@ -1,113 +0,0 @@ ---!!! 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 diff --git a/ghc/interpreter/test/exts/mvar.in1 b/ghc/interpreter/test/exts/mvar.in1 deleted file mode 100644 index cb038f2..0000000 --- a/ghc/interpreter/test/exts/mvar.in1 +++ /dev/null @@ -1,4 +0,0 @@ -test1 -test3 -test4 -test5 diff --git a/ghc/interpreter/test/exts/mvar.out1 b/ghc/interpreter/test/exts/mvar.out1 deleted file mode 100644 index da23161..0000000 --- a/ghc/interpreter/test/exts/mvar.out1 +++ /dev/null @@ -1,16 +0,0 @@ -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} - diff --git a/ghc/interpreter/test/exts/refs1.hs b/ghc/interpreter/test/exts/refs1.hs deleted file mode 100644 index 0ac7943..0000000 --- a/ghc/interpreter/test/exts/refs1.hs +++ /dev/null @@ -1,20 +0,0 @@ ---!!! 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) - - diff --git a/ghc/interpreter/test/exts/refs1.in1 b/ghc/interpreter/test/exts/refs1.in1 deleted file mode 100644 index 2cdcdb0..0000000 --- a/ghc/interpreter/test/exts/refs1.in1 +++ /dev/null @@ -1,3 +0,0 @@ -a1 -a2 -a3 diff --git a/ghc/interpreter/test/exts/refs1.out1 b/ghc/interpreter/test/exts/refs1.out1 deleted file mode 100644 index 6f886da..0000000 --- a/ghc/interpreter/test/exts/refs1.out1 +++ /dev/null @@ -1,13 +0,0 @@ -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) - diff --git a/ghc/interpreter/test/exts/refs2.hs b/ghc/interpreter/test/exts/refs2.hs deleted file mode 100644 index 7491ee6..0000000 --- a/ghc/interpreter/test/exts/refs2.hs +++ /dev/null @@ -1,30 +0,0 @@ ---!!! 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) - diff --git a/ghc/interpreter/test/exts/refs2.in1 b/ghc/interpreter/test/exts/refs2.in1 deleted file mode 100644 index 2cdcdb0..0000000 --- a/ghc/interpreter/test/exts/refs2.in1 +++ /dev/null @@ -1,3 +0,0 @@ -a1 -a2 -a3 diff --git a/ghc/interpreter/test/exts/refs2.out1 b/ghc/interpreter/test/exts/refs2.out1 deleted file mode 100644 index 3b11880..0000000 --- a/ghc/interpreter/test/exts/refs2.out1 +++ /dev/null @@ -1,8 +0,0 @@ -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)" diff --git a/ghc/interpreter/test/exts/refs3.hs b/ghc/interpreter/test/exts/refs3.hs deleted file mode 100644 index c280798..0000000 --- a/ghc/interpreter/test/exts/refs3.hs +++ /dev/null @@ -1,12 +0,0 @@ ---!!! Testing typechecking of runST -module RunSTTest where - -import ST - -t1 = runST (return '1') - -t2 = runST (do - v <- newSTRef '2' - readSTRef v - ) - diff --git a/ghc/interpreter/test/exts/refs3.in1 b/ghc/interpreter/test/exts/refs3.in1 deleted file mode 100644 index ba21892..0000000 --- a/ghc/interpreter/test/exts/refs3.in1 +++ /dev/null @@ -1,2 +0,0 @@ -t1 -t2 diff --git a/ghc/interpreter/test/exts/refs3.out1 b/ghc/interpreter/test/exts/refs3.out1 deleted file mode 100644 index 712e138..0000000 --- a/ghc/interpreter/test/exts/refs3.out1 +++ /dev/null @@ -1,7 +0,0 @@ -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' diff --git a/ghc/interpreter/test/runstdtest b/ghc/interpreter/test/runstdtest deleted file mode 100644 index 1312070..0000000 --- a/ghc/interpreter/test/runstdtest +++ /dev/null @@ -1,257 +0,0 @@ -#!/usr/bin/perl -#! /usr/local/bin/perl -# -# Given: -# * a program to run (1st arg) -# * some "command-line opts" ( -O -O ... ) -# [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 ) [default: $dev_null ] -# * a "time" command to use (-t ). -# * a "start" line (-s ) - all preceeding lines of output -# * are ignored (from stdout). -# * a "start" pattern (-f ) - all preceeding lines of output -# * are deleted (from stdout). -# * an "end" pattern (-l ) - all later lines of output -# * are deleted (from stdout). -# -# * alternatively, a "-script