From 2cc5b907318f97e19b28b2ad8ed9ff8c1f401dcc Mon Sep 17 00:00:00 2001 From: simonmar Date: Tue, 12 Feb 2002 15:17:36 +0000 Subject: [PATCH] [project @ 2002-02-12 15:17:13 by simonmar] Switch over to the new hierarchical libraries --------------------------------------------- This commit reorganises our libraries to use the new hierarchical module namespace extension. The basic story is this: - fptools/libraries contains the new hierarchical libraries. Everything in here is "clean", i.e. most deprecated stuff has been removed. - fptools/libraries/base is the new base package (replacing "std") and contains roughly what was previously in std, lang, and concurrent, minus deprecated stuff. Things that are *not allowed* in libraries/base include: Addr, ForeignObj, ByteArray, MutableByteArray, _casm_, _ccall_, ``'', PrimIO For ByteArrays and MutableByteArrays we use UArray and STUArray/IOUArray respectively now. Modules previously called PrelFoo are now under fptools/libraries/GHC. eg. PrelBase is now GHC.Base. - fptools/libraries/haskell98 provides the Haskell 98 std. libraries (Char, IO, Numeric etc.) as a package. This package is enabled by default. - fptools/libraries/network is a rearranged version of the existing net package (the old package net is still available; see below). - Other packages will migrate to fptools/libraries in due course. NB. you need to checkout fptools/libraries as well as fptools/hslibs now. The nightly build scripts will need to be tweaked. - fptools/hslibs still contains (almost) the same stuff as before. Where libraries have moved into the new hierarchy, the hslibs version contains a "stub" that just re-exports the new version. The idea is that code will gradually migrate from fptools/hslibs into fptools/libraries as it gets cleaned up, and in a version or two we can remove the old packages altogether. - I've taken the opportunity to make some changes to the build system, ripping out the old hslibs Makefile stuff from mk/target.mk; the new package building Makefile code is in mk/package.mk (auto-included from mk/target.mk). The main improvement is that packages now register themselves at make boot time using ghc-pkg, and the monolithic package.conf in ghc/driver is gone. I've updated the standard packages but haven't tested win32, graphics, xlib, object-io, or OpenGL yet. The Makefiles in these packages may need some further tweaks, and they'll need pkg.conf.in files added. - Unfortunately all this rearrangement meant I had to bump the interface-file version and create a bunch of .hi-boot-6 files :-( --- ghc/Makefile | 8 +- ghc/compiler/Makefile | 25 +- ghc/compiler/basicTypes/DataCon.hi-boot-6 | 5 + ghc/compiler/basicTypes/IdInfo.hi-boot-6 | 8 + ghc/compiler/basicTypes/MkId.hi-boot-6 | 5 + ghc/compiler/basicTypes/Name.hi-boot-6 | 3 + ghc/compiler/basicTypes/Unique.lhs | 2 +- ghc/compiler/basicTypes/Var.hi-boot-6 | 8 + ghc/compiler/codeGen/CgBindery.hi-boot-6 | 7 + ghc/compiler/codeGen/CgExpr.hi-boot-6 | 3 + ghc/compiler/codeGen/CgUsages.hi-boot-6 | 3 + ghc/compiler/codeGen/ClosureInfo.hi-boot-6 | 4 + ghc/compiler/compMan/CompManager.lhs | 3 +- ghc/compiler/coreSyn/CoreSyn.hi-boot-6 | 6 + ghc/compiler/coreSyn/Subst.hi-boot-6 | 5 + ghc/compiler/deSugar/DsExpr.hi-boot-6 | 4 + ghc/compiler/deSugar/Match.hi-boot-6 | 6 + ghc/compiler/ghci/ByteCodeFFI.lhs | 16 +- ghc/compiler/ghci/ByteCodeGen.lhs | 33 +- ghc/compiler/ghci/ByteCodeInstr.lhs | 9 +- ghc/compiler/ghci/ByteCodeLink.lhs | 132 +-- ghc/compiler/ghci/InteractiveUI.hs | 7 +- ghc/compiler/ghci/Linker.lhs | 45 +- ghc/compiler/hsSyn/HsExpr.hi-boot-6 | 12 + ghc/compiler/main/DriverState.hs | 18 +- ghc/compiler/main/SysTools.lhs | 35 +- ghc/compiler/nativeGen/MachMisc.hi-boot-6 | 6 + ghc/compiler/nativeGen/StixInfo.lhs | 24 +- ghc/compiler/nativeGen/StixPrim.hi-boot-6 | 3 + ghc/compiler/parser/Ctype.lhs | 2 +- ghc/compiler/prelude/PrelNames.lhs | 61 +- ghc/compiler/rename/RnBinds.hi-boot-6 | 3 + ghc/compiler/rename/RnHiFiles.hi-boot-6 | 3 + ghc/compiler/simplCore/SimplMonad.lhs | 6 +- ghc/compiler/typecheck/TcEnv.hi-boot-6 | 3 + ghc/compiler/typecheck/TcExpr.hi-boot-6 | 6 + ghc/compiler/typecheck/TcMatches.hi-boot-6 | 13 + ghc/compiler/typecheck/TcType.hi-boot-6 | 3 + ghc/compiler/typecheck/TcUnify.hi-boot-6 | 8 + ghc/compiler/types/Generics.hi-boot-6 | 4 + ghc/compiler/types/PprType.hi-boot-6 | 5 + ghc/compiler/types/TyCon.hi-boot-6 | 7 + ghc/compiler/types/TypeRep.hi-boot-6 | 7 + ghc/compiler/utils/FastString.lhs | 76 +- ghc/compiler/utils/PrimPacked.lhs | 70 +- ghc/compiler/utils/StringBuffer.lhs | 28 +- ghc/driver/Makefile | 66 +- ghc/driver/PackageSrc.hs | 496 ---------- ghc/driver/Utils.hs | 10 - ghc/lib/Makefile | 9 - ghc/lib/std/Array.lhs | 148 --- ghc/lib/std/BigInteger.cs | 1472 ---------------------------- ghc/lib/std/CPUTime.hsc | 122 --- ghc/lib/std/Char.lhs | 43 - ghc/lib/std/Complex.lhs | 163 --- ghc/lib/std/Directory.lhs | 568 ----------- ghc/lib/std/IO.lhs | 94 -- ghc/lib/std/Ix.lhs | 41 - ghc/lib/std/List.lhs | 531 ---------- ghc/lib/std/Locale.lhs | 71 -- ghc/lib/std/Makefile | 211 ---- ghc/lib/std/Maybe.lhs | 86 -- ghc/lib/std/Monad.lhs | 178 ---- ghc/lib/std/Numeric.lhs | 372 ------- ghc/lib/std/PrelArr.lhs | 609 ------------ ghc/lib/std/PrelArrExtra.lhs | 57 -- ghc/lib/std/PrelBase.lhs | 827 ---------------- ghc/lib/std/PrelBits.lhs | 81 -- ghc/lib/std/PrelByteArr.lhs | 184 ---- ghc/lib/std/PrelCError.lhs | 612 ------------ ghc/lib/std/PrelCString.lhs | 125 --- ghc/lib/std/PrelCTypes.lhs | 88 -- ghc/lib/std/PrelCTypesISO.lhs | 71 -- ghc/lib/std/PrelConc.lhs | 205 ---- ghc/lib/std/PrelDynamic.lhs | 35 - ghc/lib/std/PrelEnum.lhs | 408 -------- ghc/lib/std/PrelErr.hi-boot | 12 - ghc/lib/std/PrelErr.lhs | 133 --- ghc/lib/std/PrelException.lhs | 123 --- ghc/lib/std/PrelFloat.lhs | 924 ----------------- ghc/lib/std/PrelForeign.lhs | 69 -- ghc/lib/std/PrelGHC.hi-boot.pp | 471 --------- ghc/lib/std/PrelGHC.ilx.pp | 662 ------------- ghc/lib/std/PrelHandle.hs | 1226 ----------------------- ghc/lib/std/PrelIO.hs | 676 ------------- ghc/lib/std/PrelIOBase.lhs | 633 ------------ ghc/lib/std/PrelInt.lhs | 783 --------------- ghc/lib/std/PrelList.lhs | 597 ----------- ghc/lib/std/PrelMarshalAlloc.lhs | 124 --- ghc/lib/std/PrelMarshalArray.lhs | 272 ----- ghc/lib/std/PrelMarshalError.lhs | 149 --- ghc/lib/std/PrelMarshalUtils.lhs | 163 --- ghc/lib/std/PrelMaybe.lhs | 65 -- ghc/lib/std/PrelNum.hi-boot | 14 - ghc/lib/std/PrelNum.lhs | 461 --------- ghc/lib/std/PrelPArr.hs | 644 ------------ ghc/lib/std/PrelPack.lhs | 231 ----- ghc/lib/std/PrelPosix.hs | 331 ------- ghc/lib/std/PrelPtr.lhs | 60 -- ghc/lib/std/PrelRead.lhs | 607 ------------ ghc/lib/std/PrelReal.lhs | 370 ------- ghc/lib/std/PrelST.lhs | 120 --- ghc/lib/std/PrelShow.lhs | 378 ------- ghc/lib/std/PrelSplit.lhs | 9 - ghc/lib/std/PrelStable.lhs | 44 - ghc/lib/std/PrelStorable.lhs | 292 ------ ghc/lib/std/PrelTopHandler.hs | 94 -- ghc/lib/std/PrelTup.lhs | 238 ----- ghc/lib/std/PrelWeak.lhs | 65 -- ghc/lib/std/PrelWord.lhs | 887 ----------------- ghc/lib/std/Prelude.lhs | 146 --- ghc/lib/std/Random.lhs | 307 ------ ghc/lib/std/Ratio.lhs | 97 -- ghc/lib/std/System.lhs | 142 --- ghc/lib/std/Time.hsc | 640 ------------ ghc/lib/std/cbits/CTypes.h | 199 ---- ghc/lib/std/cbits/HsStd.h | 100 -- ghc/lib/std/cbits/Makefile | 23 - ghc/lib/std/cbits/PrelIOUtils.c | 310 ------ ghc/lib/std/cbits/PrelIOUtils.h | 74 -- ghc/lib/std/cbits/dirUtils.c | 126 --- ghc/lib/std/cbits/dirUtils.h | 41 - ghc/lib/std/cbits/errUtils.h | 112 --- ghc/lib/std/cbits/errno.c | 610 ------------ ghc/lib/std/cbits/ghc_errno.h | 15 - ghc/lib/std/cbits/ilxstubs.c | 113 --- ghc/lib/std/cbits/inputReady.c | 67 -- ghc/lib/std/cbits/lockFile.c | 128 --- ghc/lib/std/cbits/lockFile.h | 10 - ghc/lib/std/cbits/longlong.c | 126 --- ghc/lib/std/cbits/system.c | 72 -- ghc/lib/std/cbits/writeError.c | 49 - ghc/mk/paths.mk | 97 +- ghc/mk/version.mk | 2 +- ghc/rts/Linker.c | 4 +- ghc/rts/Makefile | 14 +- ghc/rts/Prelude.h | 160 +-- ghc/rts/StgMiscClosures.hc | 6 +- ghc/rts/StgStartup.h | 4 +- ghc/rts/StgStartup.hc | 10 +- ghc/rts/rts.conf.in | 121 +++ ghc/tests/lib/should_run/Makefile | 48 + ghc/tests/lib/should_run/uri001.hs | 55 ++ ghc/utils/genprimopcode/Main.hs | 6 +- ghc/utils/ghc-pkg/Main.hs | 17 +- ghc/utils/ghc-pkg/Makefile | 7 +- ghc/utils/hsc2hs/Main.hs | 9 +- glafp-utils/mk/target.mk | 6 +- mk/config.mk.in | 25 +- mk/package.mk | 122 +++ mk/paths.mk | 3 + mk/target.mk | 120 +-- 152 files changed, 956 insertions(+), 24047 deletions(-) create mode 100644 ghc/compiler/basicTypes/DataCon.hi-boot-6 create mode 100644 ghc/compiler/basicTypes/IdInfo.hi-boot-6 create mode 100644 ghc/compiler/basicTypes/MkId.hi-boot-6 create mode 100644 ghc/compiler/basicTypes/Name.hi-boot-6 create mode 100644 ghc/compiler/basicTypes/Var.hi-boot-6 create mode 100644 ghc/compiler/codeGen/CgBindery.hi-boot-6 create mode 100644 ghc/compiler/codeGen/CgExpr.hi-boot-6 create mode 100644 ghc/compiler/codeGen/CgUsages.hi-boot-6 create mode 100644 ghc/compiler/codeGen/ClosureInfo.hi-boot-6 create mode 100644 ghc/compiler/coreSyn/CoreSyn.hi-boot-6 create mode 100644 ghc/compiler/coreSyn/Subst.hi-boot-6 create mode 100644 ghc/compiler/deSugar/DsExpr.hi-boot-6 create mode 100644 ghc/compiler/deSugar/Match.hi-boot-6 create mode 100644 ghc/compiler/hsSyn/HsExpr.hi-boot-6 create mode 100644 ghc/compiler/nativeGen/MachMisc.hi-boot-6 create mode 100644 ghc/compiler/nativeGen/StixPrim.hi-boot-6 create mode 100644 ghc/compiler/rename/RnBinds.hi-boot-6 create mode 100644 ghc/compiler/rename/RnHiFiles.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcEnv.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcExpr.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcMatches.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcType.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcUnify.hi-boot-6 create mode 100644 ghc/compiler/types/Generics.hi-boot-6 create mode 100644 ghc/compiler/types/PprType.hi-boot-6 create mode 100644 ghc/compiler/types/TyCon.hi-boot-6 create mode 100644 ghc/compiler/types/TypeRep.hi-boot-6 delete mode 100644 ghc/driver/PackageSrc.hs delete mode 100644 ghc/driver/Utils.hs delete mode 100644 ghc/lib/Makefile delete mode 100644 ghc/lib/std/Array.lhs delete mode 100644 ghc/lib/std/BigInteger.cs delete mode 100644 ghc/lib/std/CPUTime.hsc delete mode 100644 ghc/lib/std/Char.lhs delete mode 100644 ghc/lib/std/Complex.lhs delete mode 100644 ghc/lib/std/Directory.lhs delete mode 100644 ghc/lib/std/IO.lhs delete mode 100644 ghc/lib/std/Ix.lhs delete mode 100644 ghc/lib/std/List.lhs delete mode 100644 ghc/lib/std/Locale.lhs delete mode 100644 ghc/lib/std/Makefile delete mode 100644 ghc/lib/std/Maybe.lhs delete mode 100644 ghc/lib/std/Monad.lhs delete mode 100644 ghc/lib/std/Numeric.lhs delete mode 100644 ghc/lib/std/PrelArr.lhs delete mode 100644 ghc/lib/std/PrelArrExtra.lhs delete mode 100644 ghc/lib/std/PrelBase.lhs delete mode 100644 ghc/lib/std/PrelBits.lhs delete mode 100644 ghc/lib/std/PrelByteArr.lhs delete mode 100644 ghc/lib/std/PrelCError.lhs delete mode 100644 ghc/lib/std/PrelCString.lhs delete mode 100644 ghc/lib/std/PrelCTypes.lhs delete mode 100644 ghc/lib/std/PrelCTypesISO.lhs delete mode 100644 ghc/lib/std/PrelConc.lhs delete mode 100644 ghc/lib/std/PrelDynamic.lhs delete mode 100644 ghc/lib/std/PrelEnum.lhs delete mode 100644 ghc/lib/std/PrelErr.hi-boot delete mode 100644 ghc/lib/std/PrelErr.lhs delete mode 100644 ghc/lib/std/PrelException.lhs delete mode 100644 ghc/lib/std/PrelFloat.lhs delete mode 100644 ghc/lib/std/PrelForeign.lhs delete mode 100644 ghc/lib/std/PrelGHC.hi-boot.pp delete mode 100644 ghc/lib/std/PrelGHC.ilx.pp delete mode 100644 ghc/lib/std/PrelHandle.hs delete mode 100644 ghc/lib/std/PrelIO.hs delete mode 100644 ghc/lib/std/PrelIOBase.lhs delete mode 100644 ghc/lib/std/PrelInt.lhs delete mode 100644 ghc/lib/std/PrelList.lhs delete mode 100644 ghc/lib/std/PrelMarshalAlloc.lhs delete mode 100644 ghc/lib/std/PrelMarshalArray.lhs delete mode 100644 ghc/lib/std/PrelMarshalError.lhs delete mode 100644 ghc/lib/std/PrelMarshalUtils.lhs delete mode 100644 ghc/lib/std/PrelMaybe.lhs delete mode 100644 ghc/lib/std/PrelNum.hi-boot delete mode 100644 ghc/lib/std/PrelNum.lhs delete mode 100644 ghc/lib/std/PrelPArr.hs delete mode 100644 ghc/lib/std/PrelPack.lhs delete mode 100644 ghc/lib/std/PrelPosix.hs delete mode 100644 ghc/lib/std/PrelPtr.lhs delete mode 100644 ghc/lib/std/PrelRead.lhs delete mode 100644 ghc/lib/std/PrelReal.lhs delete mode 100644 ghc/lib/std/PrelST.lhs delete mode 100644 ghc/lib/std/PrelShow.lhs delete mode 100644 ghc/lib/std/PrelSplit.lhs delete mode 100644 ghc/lib/std/PrelStable.lhs delete mode 100644 ghc/lib/std/PrelStorable.lhs delete mode 100644 ghc/lib/std/PrelTopHandler.hs delete mode 100644 ghc/lib/std/PrelTup.lhs delete mode 100644 ghc/lib/std/PrelWeak.lhs delete mode 100644 ghc/lib/std/PrelWord.lhs delete mode 100644 ghc/lib/std/Prelude.lhs delete mode 100644 ghc/lib/std/Random.lhs delete mode 100644 ghc/lib/std/Ratio.lhs delete mode 100644 ghc/lib/std/System.lhs delete mode 100644 ghc/lib/std/Time.hsc delete mode 100644 ghc/lib/std/cbits/CTypes.h delete mode 100644 ghc/lib/std/cbits/HsStd.h delete mode 100644 ghc/lib/std/cbits/Makefile delete mode 100644 ghc/lib/std/cbits/PrelIOUtils.c delete mode 100644 ghc/lib/std/cbits/PrelIOUtils.h delete mode 100644 ghc/lib/std/cbits/dirUtils.c delete mode 100644 ghc/lib/std/cbits/dirUtils.h delete mode 100644 ghc/lib/std/cbits/errUtils.h delete mode 100644 ghc/lib/std/cbits/errno.c delete mode 100644 ghc/lib/std/cbits/ghc_errno.h delete mode 100644 ghc/lib/std/cbits/ilxstubs.c delete mode 100644 ghc/lib/std/cbits/inputReady.c delete mode 100644 ghc/lib/std/cbits/lockFile.c delete mode 100644 ghc/lib/std/cbits/lockFile.h delete mode 100644 ghc/lib/std/cbits/longlong.c delete mode 100644 ghc/lib/std/cbits/system.c delete mode 100644 ghc/lib/std/cbits/writeError.c create mode 100644 ghc/rts/rts.conf.in create mode 100644 ghc/tests/lib/should_run/Makefile create mode 100644 ghc/tests/lib/should_run/uri001.hs create mode 100644 mk/package.mk diff --git a/ghc/Makefile b/ghc/Makefile index e88bc3c..5d13069 100644 --- a/ghc/Makefile +++ b/ghc/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.19 2001/10/24 10:07:57 rrt Exp $ +# $Id: Makefile,v 1.20 2002/02/12 15:17:13 simonmar Exp $ # TOP=. @@ -21,13 +21,13 @@ include $(TOP)/mk/boilerplate.mk # we descend into compiler/ and lib/. # ifeq "$(BootingFromHc)" "YES" -SUBDIRS = includes utils rts docs lib compiler driver +SUBDIRS = includes utils rts docs compiler driver else ifneq "$(ILXized)" "YES" -SUBDIRS = includes utils driver docs compiler rts lib +SUBDIRS = includes utils driver docs compiler rts else # No RTS for ILX -SUBDIRS = includes utils driver docs compiler lib +SUBDIRS = includes utils driver docs compiler endif endif diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 33bbd9e..fbf266c 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.209 2002/02/11 08:20:38 chak Exp $ +# $Id: Makefile,v 1.210 2002/02/12 15:17:13 simonmar Exp $ TOP = .. @@ -61,17 +61,18 @@ $(CONFIG_HS) : $(FPTOOLS_TOP)/mk/config.mk Makefile @echo "cRAWCPP_FLAGS = \"$(RAWCPP_FLAGS)\"" >> $(CONFIG_HS) @echo "cGCC = \"$(WhatGccIsCalled)\"" >> $(CONFIG_HS) @echo "cMKDLL = \"$(BLD_DLL)\"" >> $(CONFIG_HS) - @echo "cGHC_DRIVER_DIR = \"$(GHC_DRIVER_DIR)\"" >> $(CONFIG_HS) - @echo "cGHC_TOUCHY = \"$(GHC_TOUCHY)\"" >> $(CONFIG_HS) - @echo "cGHC_TOUCHY_DIR = \"$(GHC_TOUCHY_DIR)\"" >> $(CONFIG_HS) - @echo "cGHC_UNLIT = \"$(GHC_UNLIT)\"" >> $(CONFIG_HS) - @echo "cGHC_UNLIT_DIR = \"$(GHC_UNLIT_DIR)\"" >> $(CONFIG_HS) - @echo "cGHC_MANGLER = \"$(GHC_MANGLER)\"" >> $(CONFIG_HS) - @echo "cGHC_MANGLER_DIR = \"$(GHC_MANGLER_DIR)\"" >> $(CONFIG_HS) - @echo "cGHC_SPLIT = \"$(GHC_SPLIT)\"" >> $(CONFIG_HS) - @echo "cGHC_SPLIT_DIR = \"$(GHC_SPLIT_DIR)\"" >> $(CONFIG_HS) - @echo "cGHC_SYSMAN = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS) - @echo "cGHC_SYSMAN_DIR = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS) + @echo "cPROJECT_DIR = \"$(PROJECT_DIR)\"" >> $(CONFIG_HS) + @echo "cGHC_DRIVER_DIR_REL = \"$(GHC_DRIVER_DIR_REL)\"" >> $(CONFIG_HS) + @echo "cGHC_TOUCHY_PGM = \"$(GHC_TOUCHY_PGM)\"" >> $(CONFIG_HS) + @echo "cGHC_TOUCHY_DIR_REL = \"$(GHC_TOUCHY_DIR_REL)\"" >> $(CONFIG_HS) + @echo "cGHC_UNLIT_PGM = \"$(GHC_UNLIT_PGM)\"" >> $(CONFIG_HS) + @echo "cGHC_UNLIT_DIR_REL = \"$(GHC_UNLIT_DIR_REL)\"" >> $(CONFIG_HS) + @echo "cGHC_MANGLER_PGM = \"$(GHC_MANGLER_PGM)\"" >> $(CONFIG_HS) + @echo "cGHC_MANGLER_DIR_REL = \"$(GHC_MANGLER_DIR_REL)\"" >> $(CONFIG_HS) + @echo "cGHC_SPLIT_PGM = \"$(GHC_SPLIT_PGM)\"" >> $(CONFIG_HS) + @echo "cGHC_SPLIT_DIR_REL = \"$(GHC_SPLIT_DIR_REL)\"" >> $(CONFIG_HS) + @echo "cGHC_SYSMAN_PGM = \"$(GHC_SYSMAN)\"" >> $(CONFIG_HS) + @echo "cGHC_SYSMAN_DIR_REL = \"$(GHC_SYSMAN_DIR)\"" >> $(CONFIG_HS) @echo "cGHC_CP = \"$(GHC_CP)\"" >> $(CONFIG_HS) @echo "cGHC_PERL = \"$(GHC_PERL)\"" >> $(CONFIG_HS) ifeq ($(GhcWithIlx),YES) diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot-6 b/ghc/compiler/basicTypes/DataCon.hi-boot-6 new file mode 100644 index 0000000..4359bbf --- /dev/null +++ b/ghc/compiler/basicTypes/DataCon.hi-boot-6 @@ -0,0 +1,5 @@ +__interface DataCon 1 0 where +__export DataCon DataCon dataConRepType isExistentialDataCon ; +1 data DataCon ; +1 dataConRepType :: DataCon -> TypeRep.Type ; +1 isExistentialDataCon :: DataCon -> GHCziBase.Bool ; diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot-6 b/ghc/compiler/basicTypes/IdInfo.hi-boot-6 new file mode 100644 index 0000000..ded7dfe --- /dev/null +++ b/ghc/compiler/basicTypes/IdInfo.hi-boot-6 @@ -0,0 +1,8 @@ +__interface IdInfo 1 0 where +__export IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo ; +1 data IdInfo ; +1 data GlobalIdDetails ; +1 notGlobalId :: GlobalIdDetails ; +1 seqIdInfo :: IdInfo -> GHCziBase.Z0T ; +1 vanillaIdInfo :: IdInfo ; + diff --git a/ghc/compiler/basicTypes/MkId.hi-boot-6 b/ghc/compiler/basicTypes/MkId.hi-boot-6 new file mode 100644 index 0000000..3d56963 --- /dev/null +++ b/ghc/compiler/basicTypes/MkId.hi-boot-6 @@ -0,0 +1,5 @@ +__interface MkId 1 0 where +__export MkId mkDataConId mkDataConWrapId ; +1 mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id ; +1 mkDataConWrapId :: DataCon.DataCon -> Var.Id ; + diff --git a/ghc/compiler/basicTypes/Name.hi-boot-6 b/ghc/compiler/basicTypes/Name.hi-boot-6 new file mode 100644 index 0000000..634d954 --- /dev/null +++ b/ghc/compiler/basicTypes/Name.hi-boot-6 @@ -0,0 +1,3 @@ +__interface Name 1 0 where +__export Name Name; +1 data Name ; diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 44c8c07..802f6a7 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -52,7 +52,7 @@ import BasicTypes ( Boxity(..) ) import FastString ( FastString, uniqueOfFS ) import GlaExts import ST -import PrelBase ( Char(..), chr, ord ) +import Char ( chr, ord ) import FastTypes import Outputable diff --git a/ghc/compiler/basicTypes/Var.hi-boot-6 b/ghc/compiler/basicTypes/Var.hi-boot-6 new file mode 100644 index 0000000..ee50bf2 --- /dev/null +++ b/ghc/compiler/basicTypes/Var.hi-boot-6 @@ -0,0 +1,8 @@ +__interface Var 1 0 where +__export Var Var TyVar Id setIdName ; +-- Used by Name +1 type Id = Var; +1 type TyVar = Var; +1 data Var ; +1 setIdName :: Id -> Name.Name -> Id ; + diff --git a/ghc/compiler/codeGen/CgBindery.hi-boot-6 b/ghc/compiler/codeGen/CgBindery.hi-boot-6 new file mode 100644 index 0000000..f375fcc --- /dev/null +++ b/ghc/compiler/codeGen/CgBindery.hi-boot-6 @@ -0,0 +1,7 @@ +__interface CgBindery 1 0 where +__export CgBindery CgBindings CgIdInfo VolatileLoc StableLoc nukeVolatileBinds; +1 type CgBindings = VarEnv.IdEnv CgIdInfo; +1 data CgIdInfo; +1 data VolatileLoc; +1 data StableLoc; +1 nukeVolatileBinds :: CgBindings -> CgBindings ; diff --git a/ghc/compiler/codeGen/CgExpr.hi-boot-6 b/ghc/compiler/codeGen/CgExpr.hi-boot-6 new file mode 100644 index 0000000..588e63f --- /dev/null +++ b/ghc/compiler/codeGen/CgExpr.hi-boot-6 @@ -0,0 +1,3 @@ +__interface CgExpr 1 0 where +__export CgExpr cgExpr; +1 cgExpr :: StgSyn.StgExpr -> CgMonad.Code ; diff --git a/ghc/compiler/codeGen/CgUsages.hi-boot-6 b/ghc/compiler/codeGen/CgUsages.hi-boot-6 new file mode 100644 index 0000000..abb98ce --- /dev/null +++ b/ghc/compiler/codeGen/CgUsages.hi-boot-6 @@ -0,0 +1,3 @@ +__interface CgUsages 1 0 where +__export CgUsages getSpRelOffset; +1 getSpRelOffset :: AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ; diff --git a/ghc/compiler/codeGen/ClosureInfo.hi-boot-6 b/ghc/compiler/codeGen/ClosureInfo.hi-boot-6 new file mode 100644 index 0000000..2291f93 --- /dev/null +++ b/ghc/compiler/codeGen/ClosureInfo.hi-boot-6 @@ -0,0 +1,4 @@ +__interface ClosureInfo 1 0 where +__export ClosureInfo ClosureInfo LambdaFormInfo; +1 data LambdaFormInfo; +1 data ClosureInfo; diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 15203f4..2e56d37 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -101,8 +101,7 @@ import VarEnv ( emptyTidyEnv ) import BasicTypes ( Fixity, defaultFixity ) import Interpreter ( HValue ) import HscMain ( hscStmt ) -import PrelGHC ( unsafeCoerce# ) - +import GlaExts ( unsafeCoerce# ) import Foreign import CForeign import Exception ( Exception, try ) diff --git a/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 new file mode 100644 index 0000000..6031131 --- /dev/null +++ b/ghc/compiler/coreSyn/CoreSyn.hi-boot-6 @@ -0,0 +1,6 @@ +__interface CoreSyn 1 0 where +__export CoreSyn CoreExpr ; + +-- Needed by Var.lhs +1 type CoreExpr = Expr Var.Var; +1 data Expr b ; diff --git a/ghc/compiler/coreSyn/Subst.hi-boot-6 b/ghc/compiler/coreSyn/Subst.hi-boot-6 new file mode 100644 index 0000000..7be51e9 --- /dev/null +++ b/ghc/compiler/coreSyn/Subst.hi-boot-6 @@ -0,0 +1,5 @@ +__interface Subst 2 0 where +__export Subst Subst substTyWith ; +1 data Subst; +1 substTyWith :: [Var.TyVar] -> [TypeRep.Type] -> TypeRep.Type -> TypeRep.Type ; + diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot-6 b/ghc/compiler/deSugar/DsExpr.hi-boot-6 new file mode 100644 index 0000000..11c0fa0 --- /dev/null +++ b/ghc/compiler/deSugar/DsExpr.hi-boot-6 @@ -0,0 +1,4 @@ +__interface DsExpr 1 0 where +__export DsExpr dsExpr dsLet; +1 dsExpr :: TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ; +1 dsLet :: TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; diff --git a/ghc/compiler/deSugar/Match.hi-boot-6 b/ghc/compiler/deSugar/Match.hi-boot-6 new file mode 100644 index 0000000..2e4d223 --- /dev/null +++ b/ghc/compiler/deSugar/Match.hi-boot-6 @@ -0,0 +1,6 @@ +__interface Match 1 0 where +__export Match match matchExport matchSimply matchSinglePat; +1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; +1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; +1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; +1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ; diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs index c6c9eef..480deab 100644 --- a/ghc/compiler/ghci/ByteCodeFFI.lhs +++ b/ghc/compiler/ghci/ByteCodeFFI.lhs @@ -15,13 +15,12 @@ import ForeignCall ( CCallConv(..) ) -- DON'T remove apparently unused imports here .. there is ifdeffery -- below import Bits ( Bits(..), shiftR, shiftL ) +import Foreign ( newArray ) import Word ( Word8, Word32 ) -import Addr ( Addr(..), writeWord8OffAddr ) import Foreign ( Ptr(..), mallocBytes ) import IOExts ( trace, unsafePerformIO ) import IO ( hPutStrLn, stderr ) - \end{code} %************************************************************************ @@ -49,15 +48,6 @@ sizeOfTagW :: PrimRep -> Int sizeOfTagW pr | isFollowableRep pr = 0 | otherwise = 1 - --- Blast a bunch of bytes into malloc'd memory and return the addr. -sendBytesToMallocville :: [Word8] -> IO Addr -sendBytesToMallocville bytes - = do let n = length bytes - (Ptr a#) <- mallocBytes n - mapM ( \(off,byte) -> writeWord8OffAddr (A# a#) off byte ) - (zip [0 ..] bytes) - return (A# a#) \end{code} %************************************************************************ @@ -103,11 +93,11 @@ we don't clear our own (single) arg off the C stack. -} mkMarshalCode :: CCallConv -> (Int, PrimRep) -> Int -> [(Int, PrimRep)] - -> IO Addr + -> IO (Ptr Word8) mkMarshalCode cconv (r_offW, r_rep) addr_offW arg_offs_n_reps = let bytes = mkMarshalCode_wrk cconv (r_offW, r_rep) addr_offW arg_offs_n_reps - in sendBytesToMallocville bytes + in Foreign.newArray bytes diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 411f1ad..f6cf787 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -56,16 +56,15 @@ import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) import Linker ( lookupSymbol ) import List ( intersperse, sortBy, zip4 ) -import Foreign ( Ptr(..), mallocBytes ) -import Addr ( Addr(..), writeCharOffAddr ) +import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 ) import CTypes ( CInt ) import Exception ( throwDyn ) -import PrelBase ( Int(..) ) -import PrelGHC ( ByteArray# ) -import PrelIOBase ( IO(..) ) +import GlaExts ( Int(..), ByteArray# ) + import Monad ( when ) import Maybe ( isJust ) +import Char ( ord ) \end{code} %************************************************************************ @@ -885,7 +884,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l -> let sym_to_find = _UNPK_ target in ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> case res of - Just aa -> case aa of Ptr a# -> returnBc (True, A# a#) + Just aa -> returnBc (True, aa) Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall" sym_to_find) CasmTarget _ @@ -935,7 +934,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l recordMallocBc addr_of_marshaller `thenBc_` let -- do the call - do_call = unitOL (CCALL addr_of_marshaller) + do_call = unitOL (CCALL (castPtr addr_of_marshaller)) -- slide and return wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s) `snocOL` RETURN r_rep @@ -1189,7 +1188,7 @@ pushAtom False d p (AnnLit lit) pushStr s = let getMallocvilleAddr = case s of - CharStr s i -> returnBc (A# s) + CharStr s i -> returnBc (Ptr s) FastString _ l ba -> -- sigh, a string in the heap is no good to us. @@ -1199,12 +1198,12 @@ pushAtom False d p (AnnLit lit) -- at the same time. let n = I# l -- CAREFUL! Chars are 32 bits in ghc 4.09+ - in ioToBc (mallocBytes (n+1)) `thenBc` \ (Ptr a#) -> - recordMallocBc (A# a#) `thenBc_` + in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr -> + recordMallocBc ptr `thenBc_` ioToBc ( - do memcpy (Ptr a#) ba (fromIntegral n) - writeCharOffAddr (A# a#) n '\0' - return (A# a#) + do memcpy ptr ba (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + return ptr ) other -> panic "ByteCodeGen.pushAtom.pushStr" in @@ -1406,7 +1405,7 @@ bind x f = f x data BcM_State = BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs nextlabel :: Int, -- for generating local labels - malloced :: [Addr] } -- ptrs malloced for current BCO + malloced :: [Ptr ()] } -- ptrs malloced for current BCO -- Should be free()d when it is GCd type BcM r = BcM_State -> IO (BcM_State, r) @@ -1441,7 +1440,7 @@ mapBc f (x:xs) mapBc f xs `thenBc` \ rs -> returnBc (r:rs) -emitBc :: ([Addr] -> ProtoBCO Name) -> BcM () +emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM () emitBc bco st = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ()) @@ -1452,9 +1451,9 @@ newbcoBc st | otherwise = return (st, ()) -recordMallocBc :: Addr -> BcM () +recordMallocBc :: Ptr a -> BcM () recordMallocBc a st - = return (st{malloced = a : malloced st}, ()) + = return (st{malloced = castPtr a : malloced st}, ()) getLabelBc :: BcM Int getLabelBc st diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 7a965a1..58e8eda 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -19,8 +19,7 @@ import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) -import Foreign ( Addr ) - +import Ptr \end{code} %************************************************************************ @@ -37,7 +36,7 @@ data ProtoBCO a -- what the BCO came from (Either [AnnAlt Id VarSet] (AnnExpr Id VarSet)) - [Addr] -- malloc'd; free when BCO is GCd + [Ptr ()] -- malloc'd; free when BCO is GCd nameOfProtoBCO (ProtoBCO nm insns origin malloced) = nm @@ -57,7 +56,7 @@ data BCInstr | PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info -- PrimRep so we know which itbl -- Pushing literals - | PUSH_UBX (Either Literal Addr) + | PUSH_UBX (Either Literal (Ptr ())) Int -- push this int/float/double/addr, NO TAG, on the stack -- Int is # of words to copy from literal pool -- Eitherness reflects the difficulty of dealing with @@ -100,7 +99,7 @@ data BCInstr | JMP LocalLabel -- For doing calls to C (via glue code generated by ByteCodeFFI) - | CCALL Addr -- of the glue code + | CCALL (Ptr ()) -- of the glue code | SWIZZLE Int Int -- to the ptr N words down the stack, -- add M (interpreted as a signed 16-bit entity) diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 5e93817..76b56d6 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -31,34 +31,35 @@ import Linker ( lookupSymbol ) import FastString ( FastString(..) ) import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) import ByteCodeItbls ( ItblEnv, ItblPtr ) +import FiniteMap +import Panic ( GhcException(..) ) +import Control.Monad ( when, foldM ) +import Control.Monad.ST ( runST ) +import Data.Array.IArray ( array ) -import Monad ( when, foldM ) -import ST ( runST ) -import IArray ( array ) -import MArray ( castSTUArray, - newInt64Array, writeInt64Array, - newFloatArray, writeFloatArray, - newDoubleArray, writeDoubleArray, - newIntArray, writeIntArray, - newAddrArray, writeAddrArray, - readWordArray ) +import GHC.Word ( Word ) +import Data.Array.MArray ( MArray, newArray_, readArray, writeArray ) +import Data.Array.ST ( castSTUArray ) +import Data.Array.Base ( UArray(..) ) +import Foreign.Ptr ( Ptr, nullPtr ) import Foreign ( Word16, Ptr(..), free ) -import Addr ( Word, Addr(..), nullAddr ) -import Weak ( addFinalizer ) -import FiniteMap +import System.Mem.Weak ( addFinalizer ) +import Data.Int ( Int64 ) -import PrelBase ( Int(..) ) -import PrelGHC ( BCO#, newBCO#, unsafeCoerce#, +import System.IO ( fixIO ) +import Control.Exception ( throwDyn ) + +import GlaExts ( BCO#, newBCO#, unsafeCoerce#, ByteArray#, Array#, addrToHValue#, mkApUpd0# ) -import IOExts ( fixIO ) -import Exception ( throwDyn ) -import Panic ( GhcException(..) ) + +#if __GLASGOW_HASKELL__ >= 503 +import GHC.Arr ( Array(..) ) +import GHC.IOBase ( IO(..) ) +#else import PrelArr ( Array(..) ) -import ArrayBase ( UArray(..) ) import PrelIOBase ( IO(..) ) -import Int ( Int64 ) - +#endif \end{code} %************************************************************************ @@ -206,8 +207,8 @@ assembleBCO (ProtoBCO nm instrs origin malloced) return ul_bco where - zonk (A# a#) = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) - free (Ptr a#) + zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) + free ptr -- instrs nonptrs ptrs itbls type AsmState = (SizedSeq Word16, SizedSeq Word, @@ -329,7 +330,7 @@ mkBits findLabel st proto_insns return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) addr (st_i0,st_l0,st_p0,st_I0) a - = do let ws = mkLitA a + = do let ws = mkLitPtr a st_l1 <- addListToSS st_l0 ws return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) @@ -376,19 +377,19 @@ mkBits findLabel st proto_insns AddrRep -> stg_gc_unbx_r1_info FloatRep -> stg_gc_f1_info DoubleRep -> stg_gc_d1_info - VoidRep -> nullAddr + VoidRep -> nullPtr -- Interpreter.c spots this special case other -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) -foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr -foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr -foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr -foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr -foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Addr +foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr () +foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr () +foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr () +foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr () +foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr () -foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr -foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr -foreign label "stg_gc_d1_info" stg_gc_d1_info :: Addr +foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr () +foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr () +foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr () -- The size in 16-bit entities of an instruction. instrSize16s :: BCInstr -> Int @@ -430,74 +431,73 @@ instrSize16s instr mkLitI :: Int -> [Word] mkLitF :: Float -> [Word] mkLitD :: Double -> [Word] -mkLitA :: Addr -> [Word] +mkLitPtr :: Ptr () -> [Word] mkLitI64 :: Int64 -> [Word] mkLitF f = runST (do - arr <- newFloatArray ((0::Int),0) - writeFloatArray arr 0 f + arr <- newArray_ ((0::Int),0) + writeArray arr 0 f f_arr <- castSTUArray arr - w0 <- readWordArray f_arr 0 - return [w0] + w0 <- readArray f_arr 0 + return [w0 :: Word] ) mkLitD d | wORD_SIZE == 4 = runST (do - arr <- newDoubleArray ((0::Int),1) - writeDoubleArray arr 0 d + arr <- newArray_ ((0::Int),1) + writeArray arr 0 d d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - w1 <- readWordArray d_arr 1 - return [w0,w1] + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word, w1] ) | wORD_SIZE == 8 = runST (do - arr <- newDoubleArray ((0::Int),0) - writeDoubleArray arr 0 d + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - return [w0] + w0 <- readArray d_arr 0 + return [w0 :: Word] ) mkLitI64 ii | wORD_SIZE == 4 = runST (do - arr <- newInt64Array ((0::Int),1) - writeInt64Array arr 0 ii + arr <- newArray_ ((0::Int),1) + writeArray arr 0 ii d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - w1 <- readWordArray d_arr 1 - return [w0,w1] + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] ) | wORD_SIZE == 8 = runST (do - arr <- newInt64Array ((0::Int),0) - writeInt64Array arr 0 ii + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii d_arr <- castSTUArray arr - w0 <- readWordArray d_arr 0 - return [w0] + w0 <- readArray d_arr 0 + return [w0 :: Word] ) mkLitI i = runST (do - arr <- newIntArray ((0::Int),0) - writeIntArray arr 0 i + arr <- newArray_ ((0::Int),0) + writeArray arr 0 i i_arr <- castSTUArray arr - w0 <- readWordArray i_arr 0 - return [w0] + w0 <- readArray i_arr 0 + return [w0 :: Word] ) -mkLitA a +mkLitPtr a = runST (do - arr <- newAddrArray ((0::Int),0) - writeAddrArray arr 0 a + arr <- newArray_ ((0::Int),0) + writeArray arr 0 a a_arr <- castSTUArray arr - w0 <- readWordArray a_arr 0 - return [w0] + w0 <- readArray a_arr 0 + return [w0 :: Word] ) - \end{code} %************************************************************************ diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index b09690b..1e98d0c 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.112 2002/01/28 13:34:10 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.113 2002/02/12 15:17:15 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -67,7 +67,8 @@ import IO import Char import Monad -import PrelGHC ( unsafeCoerce# ) +import GlaExts ( unsafeCoerce# ) + import Foreign ( nullPtr ) import CString ( peekCString ) @@ -271,7 +272,7 @@ interactiveLoop is_tty = do checkPerms :: String -> IO Bool checkPerms name = - handle (\_ -> return False) $ do + DriverUtil.handle (\_ -> return False) $ do #ifdef mingw32_TARGET_OS doesFileExist name #else diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 475f707..32a34f1 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -15,12 +15,9 @@ module Linker ( addDLL -- :: String -> IO (Ptr CChar) ) where -import PrelByteArr -import PrelPack ( packString ) - import Monad ( when ) -import CTypes ( CChar ) +import Foreign.C import Foreign ( Ptr, nullPtr ) import Panic ( panic ) import DriverUtil ( prefixUnderscore ) @@ -32,20 +29,23 @@ import DriverUtil ( prefixUnderscore ) lookupSymbol :: String -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - addr <- c_lookupSymbol (packString str) - if addr == nullPtr + withCString str $ \c_str -> do + addr <- c_lookupSymbol c_str + if addr == nullPtr then return Nothing else return (Just addr) loadObj :: String -> IO () -loadObj str = do - r <- c_loadObj (packString str) - when (r == 0) (panic "loadObj: failed") +loadObj str = + withCString str $ \c_str -> do + r <- c_loadObj c_str + when (r == 0) (panic "loadObj: failed") unloadObj :: String -> IO () -unloadObj str = do - r <- c_unloadObj (packString str) - when (r == 0) (panic "unloadObj: failed") +unloadObj str = + withCString str $ \c_str -> do + r <- c_unloadObj c_str + when (r == 0) (panic "unloadObj: failed") resolveObjs :: IO Bool resolveObjs = do @@ -54,31 +54,30 @@ resolveObjs = do addDLL :: String -> String -> IO (Ptr CChar) addDLL path lib = do - maybe_errmsg <- c_addDLL (packString path) (packString lib) - return maybe_errmsg - - -foreign import "initLinker" unsafe - initLinker :: IO () + withCString path $ \c_path -> do + withCString lib $ \c_lib -> do + maybe_errmsg <- c_addDLL c_path c_lib + return maybe_errmsg -- --------------------------------------------------------------------------- -- Foreign declaractions to RTS entry points which does the real work; -- --------------------------------------------------------------------------- -type PackedString = ByteArray Int +foreign import "initLinker" unsafe + initLinker :: IO () foreign import "lookupSymbol" unsafe - c_lookupSymbol :: PackedString -> IO (Ptr a) + c_lookupSymbol :: CString -> IO (Ptr a) foreign import "loadObj" unsafe - c_loadObj :: PackedString -> IO Int + c_loadObj :: CString -> IO Int foreign import "unloadObj" unsafe - c_unloadObj :: PackedString -> IO Int + c_unloadObj :: CString -> IO Int foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int foreign import "addDLL" unsafe - c_addDLL :: PackedString -> PackedString -> IO (Ptr CChar) + c_addDLL :: CString -> CString -> IO (Ptr CChar) \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 new file mode 100644 index 0000000..bf952e3 --- /dev/null +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 @@ -0,0 +1,12 @@ +__interface HsExpr 1 0 where +__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ; + +1 data HsExpr i p ; +1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ; + +1 data Match a b ; +1 data GRHSs a b ; + +1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ; +1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ; + diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 39934b9..c64e2f6 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.67 2002/02/11 08:20:41 chak Exp $ +-- $Id: DriverState.hs,v 1.68 2002/02/12 15:17:15 simonmar Exp $ -- -- Settings for the driver -- @@ -432,7 +432,7 @@ GLOBAL_VAR(v_HCHeader, "", String) -- Packages -- package list is maintained in dependency order -GLOBAL_VAR(v_Packages, ("std":"rts":"gmp":[]), [String]) +GLOBAL_VAR(v_Packages, ("haskell98":"base":"rts":[]), [String]) readPackageConf :: String -> IO () readPackageConf conf_file = do @@ -491,23 +491,23 @@ getPackageLibraries = do where -- This is a totally horrible (temporary) hack, for Win32. Problem is -- that package.conf for Win32 says that the main prelude lib is - -- split into HSstd1 and HSstd2, which is needed due to limitations in + -- split into HSbase1 and HSbase2, which is needed due to limitations in -- the PEi386 file format, to make GHCi work. However, we still only - -- have HSstd.a for static linking, not HSstd1.a and HSstd2.a. + -- have HSbase.a for static linking, not HSbase1.a and HSbase2.a. -- getPackageLibraries is called to find the .a's to add to the static - -- link line. On Win32, this hACK detects HSstd1 and HSstd2 and - -- replaces them with HSstd, so static linking still works. + -- link line. On Win32, this hACK detects HSbase1 and HSbase2 and + -- replaces them with HSbase, so static linking still works. -- Libraries needed for dynamic (GHCi) linking are discovered via -- different route (in InteractiveUI.linkPackage). - -- See driver/PackageSrc.hs for the HSstd1/HSstd2 split definition. + -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition. -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...) -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2] hACK libs # ifndef mingw32_TARGET_OS = libs # else - = if "HSstd1" `elem` libs && "HSstd2" `elem` libs - then "HSstd" : filter ((/= "HSstd").(take 5)) libs + = if "HSbase1" `elem` libs && "HSbase2" `elem` libs + then "HSbase" : filter ((/= "HSbase").(take 5)) libs else if "HSwin321" `elem` libs && "HSwin322" `elem` libs then "HSwin32" : filter ((/= "HSwin32").(take 7)) libs diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 1ed190c..f8818ba 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -89,7 +89,11 @@ import MarshalArray -- use the line below when we can be sure of compiling with GHC >= -- 5.02, and remove the implementation of rawSystem at the end of this -- file +#if __GLASGOW_HASKELL__ >= 503 +import GHC.IOBase +#else import PrelIOBase -- this can be removed when SystemExts is used +#endif import CError ( throwErrnoIfMinus1 ) -- as can this -- import SystemExts ( rawSystem ) #else @@ -141,9 +145,9 @@ Config.hs contains two sorts of things etc They do *not* include paths - cUNLIT_DIR The *path* to the directory containing unlit, split etc - cSPLIT_DIR *relative* to the root of the build tree, - for use when running *in-place* in a build tree (only) + cUNLIT_DIR_REL The *path* to the directory containing unlit, split etc + cSPLIT_DIR_REL *relative* to the root of the build tree, + for use when running *in-place* in a build tree (only) @@ -238,30 +242,31 @@ initSysTools minusB_args ; let installed, installed_bin :: FilePath -> FilePath installed_bin pgm = pgmPath top_dir pgm installed file = pgmPath top_dir file - inplace dir pgm = pgmPath (top_dir `slash` dir) pgm + inplace dir pgm = pgmPath (top_dir `slash` + cPROJECT_DIR `slash` dir) pgm ; let pkgconfig_path | am_installed = installed "package.conf" - | otherwise = inplace cGHC_DRIVER_DIR "package.conf.inplace" + | otherwise = inplace cGHC_DRIVER_DIR_REL "package.conf.inplace" ghc_usage_msg_path | am_installed = installed "ghc-usage.txt" - | otherwise = inplace cGHC_DRIVER_DIR "ghc-usage.txt" + | otherwise = inplace cGHC_DRIVER_DIR_REL "ghc-usage.txt" -- For all systems, unlit, split, mangle are GHC utilities -- architecture-specific stuff is done when building Config.hs unlit_path - | am_installed = installed_bin cGHC_UNLIT - | otherwise = inplace cGHC_UNLIT_DIR cGHC_UNLIT + | am_installed = installed_bin cGHC_UNLIT_PGM + | otherwise = inplace cGHC_UNLIT_DIR_REL cGHC_UNLIT_PGM -- split and mangle are Perl scripts split_script - | am_installed = installed_bin cGHC_SPLIT - | otherwise = inplace cGHC_SPLIT_DIR cGHC_SPLIT + | am_installed = installed_bin cGHC_SPLIT_PGM + | otherwise = inplace cGHC_SPLIT_DIR_REL cGHC_SPLIT_PGM mangle_script - | am_installed = installed_bin cGHC_MANGLER - | otherwise = inplace cGHC_MANGLER_DIR cGHC_MANGLER + | am_installed = installed_bin cGHC_MANGLER_PGM + | otherwise = inplace cGHC_MANGLER_DIR_REL cGHC_MANGLER_PGM #ifndef mingw32_TARGET_OS -- check whether TMPDIR is set in the environment @@ -334,8 +339,8 @@ initSysTools minusB_args | otherwise = cGHC_PERL -- 'touch' is a GHC util for Windows, and similarly unlit, mangle - ; let touch_path | am_installed = installed_bin cGHC_TOUCHY - | otherwise = inplace cGHC_TOUCHY_DIR cGHC_TOUCHY + ; let touch_path | am_installed = installed_bin cGHC_TOUCHY_PGM + | otherwise = inplace cGHC_TOUCHY_DIR_REL cGHC_TOUCHY_PGM -- On Win32 we don't want to rely on #!/bin/perl, so we prepend -- a call to Perl to get the invocation of split and mangle @@ -349,7 +354,7 @@ initSysTools minusB_args -- in the same place whether we are running "in-place" or "installed" -- That place is wherever the build-time configure script found them. ; let gcc_path = cGCC - touch_path = cGHC_TOUCHY + touch_path = "touch" mkdll_path = panic "Can't build DLLs on a non-Win32 system" -- On Unix, scripts are invoked using the '#!' method. Binary diff --git a/ghc/compiler/nativeGen/MachMisc.hi-boot-6 b/ghc/compiler/nativeGen/MachMisc.hi-boot-6 new file mode 100644 index 0000000..7d7b402 --- /dev/null +++ b/ghc/compiler/nativeGen/MachMisc.hi-boot-6 @@ -0,0 +1,6 @@ +__interface MachMisc 1 0 where +__export MachMisc Instr fixedHdrSize fmtAsmLbl underscorePrefix; +1 fixedHdrSize :: GHCziBase.Int ; +2 fmtAsmLbl :: GHCziBase.String -> GHCziBase.String ; +1 underscorePrefix :: GHCziBase.Bool ; +1 data Instr ; diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index bf822e2..974a6be 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -31,10 +31,6 @@ import Maybes ( maybeToBool ) import Bits import Word - -#if __GLASGOW_HASKELL__ >= 404 -import GlaExts ( fromInt ) -#endif \end{code} Generating code for info tables (arrays of data). @@ -64,11 +60,11 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) -- ToDo: do this using .byte and .word directives. type_info :: Word32 #ifdef WORDS_BIGENDIAN - type_info = (fromInt closure_type `shiftL` 16) .|. - (fromInt srt_len) + type_info = (fromIntegral closure_type `shiftL` 16) .|. + (fromIntegral srt_len) #else - type_info = (fromInt closure_type) .|. - (fromInt srt_len `shiftL` 16) + type_info = (fromIntegral closure_type) .|. + (fromIntegral srt_len `shiftL` 16) #endif srt = closureSRT cl_info needs_srt = needsSRT srt @@ -87,9 +83,9 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) layout_info :: Word32 #ifdef WORDS_BIGENDIAN - layout_info = (fromInt ptrs `shiftL` 16) .|. fromInt nptrs + layout_info = (fromIntegral ptrs `shiftL` 16) .|. fromIntegral nptrs #else - layout_info = (fromInt ptrs) .|. (fromInt nptrs `shiftL` 16) + layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` 16) #endif ptrs = closurePtrsSize cl_info @@ -133,11 +129,11 @@ genBitmapInfoTable liveness srt closure_type include_srt type_info :: Word32 #ifdef WORDS_BIGENDIAN - type_info = (fromInt closure_type `shiftL` 16) .|. - (fromInt srt_len) + type_info = (fromIntegral closure_type `shiftL` 16) .|. + (fromIntegral srt_len) #else - type_info = (fromInt closure_type) .|. - (fromInt srt_len `shiftL` 16) + type_info = (fromIntegral closure_type) .|. + (fromIntegral srt_len `shiftL` 16) #endif (srt_label,srt_len) = diff --git a/ghc/compiler/nativeGen/StixPrim.hi-boot-6 b/ghc/compiler/nativeGen/StixPrim.hi-boot-6 new file mode 100644 index 0000000..f1b3b9e --- /dev/null +++ b/ghc/compiler/nativeGen/StixPrim.hi-boot-6 @@ -0,0 +1,3 @@ +__interface StixPrim 1 0 where +__export StixPrim amodeToStix; +1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr ; diff --git a/ghc/compiler/parser/Ctype.lhs b/ghc/compiler/parser/Ctype.lhs index 4d9c600..645f31e 100644 --- a/ghc/compiler/parser/Ctype.lhs +++ b/ghc/compiler/parser/Ctype.lhs @@ -15,7 +15,7 @@ module Ctype \begin{code} import Bits ( Bits((.&.)) ) import Int ( Int32 ) -import PrelBase ( Char#, Char(..) ) +import GlaExts ( Char#, Char(..) ) \end{code} Bit masks diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 8a82330..74ce7df 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -118,7 +118,6 @@ knownKeyNames numClassName, -- mentioned, numeric enumClassName, -- derivable monadClassName, - monadPlusClassName, functorClassName, showClassName, -- derivable realClassName, -- numeric @@ -233,35 +232,35 @@ knownKeyNames \begin{code} pRELUDE_Name = mkModuleName "Prelude" -pREL_GHC_Name = mkModuleName "PrelGHC" -- Primitive types and values -pREL_BASE_Name = mkModuleName "PrelBase" -pREL_ENUM_Name = mkModuleName "PrelEnum" -pREL_SHOW_Name = mkModuleName "PrelShow" -pREL_READ_Name = mkModuleName "PrelRead" -pREL_NUM_Name = mkModuleName "PrelNum" -pREL_LIST_Name = mkModuleName "PrelList" -pREL_PARR_Name = mkModuleName "PrelPArr" -pREL_TUP_Name = mkModuleName "PrelTup" -pREL_PACK_Name = mkModuleName "PrelPack" -pREL_CONC_Name = mkModuleName "PrelConc" -pREL_IO_BASE_Name = mkModuleName "PrelIOBase" -pREL_IO_Name = mkModuleName "PrelIO" -pREL_ST_Name = mkModuleName "PrelST" -pREL_ARR_Name = mkModuleName "PrelArr" +pREL_GHC_Name = mkModuleName "GHC.Prim" -- Primitive types and values +pREL_BASE_Name = mkModuleName "GHC.Base" +pREL_ENUM_Name = mkModuleName "GHC.Enum" +pREL_SHOW_Name = mkModuleName "GHC.Show" +pREL_READ_Name = mkModuleName "GHC.Read" +pREL_NUM_Name = mkModuleName "GHC.Num" +pREL_LIST_Name = mkModuleName "GHC.List" +pREL_PARR_Name = mkModuleName "GHC.PArr" +pREL_TUP_Name = mkModuleName "Data.Tuple" +pREL_PACK_Name = mkModuleName "GHC.Pack" +pREL_CONC_Name = mkModuleName "GHC.Conc" +pREL_IO_BASE_Name = mkModuleName "GHC.IOBase" +pREL_IO_Name = mkModuleName "GHC.IO" +pREL_ST_Name = mkModuleName "GHC.ST" +pREL_ARR_Name = mkModuleName "GHC.Arr" pREL_BYTEARR_Name = mkModuleName "PrelByteArr" -pREL_FOREIGN_Name = mkModuleName "PrelForeign" -pREL_STABLE_Name = mkModuleName "PrelStable" -pREL_SPLIT_Name = mkModuleName "PrelSplit" -pREL_ADDR_Name = mkModuleName "PrelAddr" -pREL_PTR_Name = mkModuleName "PrelPtr" -pREL_ERR_Name = mkModuleName "PrelErr" -pREL_REAL_Name = mkModuleName "PrelReal" -pREL_FLOAT_Name = mkModuleName "PrelFloat" -pREL_TOP_HANDLER_Name = mkModuleName "PrelTopHandler" +fOREIGN_PTR_Name = mkModuleName "Foreign.ForeignPtr" +pREL_STABLE_Name = mkModuleName "GHC.Stable" +pREL_SPLIT_Name = mkModuleName "GHC.Split" +pREL_ADDR_Name = mkModuleName "GHC.Addr" +pREL_PTR_Name = mkModuleName "GHC.Ptr" +pREL_ERR_Name = mkModuleName "GHC.Err" +pREL_REAL_Name = mkModuleName "GHC.Real" +pREL_FLOAT_Name = mkModuleName "GHC.Float" +pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler" mAIN_Name = mkModuleName "Main" -pREL_INT_Name = mkModuleName "PrelInt" -pREL_WORD_Name = mkModuleName "PrelWord" +pREL_INT_Name = mkModuleName "GHC.Int" +pREL_WORD_Name = mkModuleName "GHC.Word" fOREIGNOBJ_Name = mkModuleName "ForeignObj" aDDR_Name = mkModuleName "Addr" @@ -442,7 +441,6 @@ geName = varQual pREL_BASE_Name SLIT(">=") geClassOpKey -- Class Monad monadClassName = clsQual pREL_BASE_Name SLIT("Monad") monadClassKey -monadPlusClassName = clsQual pREL_BASE_Name SLIT("MonadPlus") monadPlusClassKey thenMName = varQual pREL_BASE_Name SLIT(">>=") thenMClassOpKey returnMName = varQual pREL_BASE_Name SLIT("return") returnMClassOpKey failMName = varQual pREL_BASE_Name SLIT("fail") failMClassOpKey @@ -566,8 +564,8 @@ mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") m -- Foreign objects and weak pointers foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey -foreignPtrTyConName = tcQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrTyConKey -foreignPtrDataConName = dataQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrDataConKey +foreignPtrTyConName = tcQual fOREIGN_PTR_Name SLIT("ForeignPtr") foreignPtrTyConKey +foreignPtrDataConName = dataQual fOREIGN_PTR_Name SLIT("ForeignPtr") foreignPtrDataConKey stablePtrTyConName = tcQual pREL_STABLE_Name SLIT("StablePtr") stablePtrTyConKey stablePtrDataConName = dataQual pREL_STABLE_Name SLIT("StablePtr") stablePtrDataConKey deRefStablePtrName = varQual pREL_STABLE_Name SLIT("deRefStablePtr") deRefStablePtrIdKey @@ -737,7 +735,6 @@ floatingClassKey = mkPreludeClassUnique 5 fractionalClassKey = mkPreludeClassUnique 6 integralClassKey = mkPreludeClassUnique 7 monadClassKey = mkPreludeClassUnique 8 -monadPlusClassKey = mkPreludeClassUnique 9 functorClassKey = mkPreludeClassUnique 10 numClassKey = mkPreludeClassUnique 11 ordClassKey = mkPreludeClassUnique 12 @@ -746,7 +743,7 @@ realClassKey = mkPreludeClassUnique 14 realFloatClassKey = mkPreludeClassUnique 15 realFracClassKey = mkPreludeClassUnique 16 showClassKey = mkPreludeClassUnique 17 - + cCallableClassKey = mkPreludeClassUnique 18 cReturnableClassKey = mkPreludeClassUnique 19 diff --git a/ghc/compiler/rename/RnBinds.hi-boot-6 b/ghc/compiler/rename/RnBinds.hi-boot-6 new file mode 100644 index 0000000..b2fcc90 --- /dev/null +++ b/ghc/compiler/rename/RnBinds.hi-boot-6 @@ -0,0 +1,3 @@ +__interface RnBinds 1 0 where +__export RnBinds rnBinds; +1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ; diff --git a/ghc/compiler/rename/RnHiFiles.hi-boot-6 b/ghc/compiler/rename/RnHiFiles.hi-boot-6 new file mode 100644 index 0000000..da5dcc3 --- /dev/null +++ b/ghc/compiler/rename/RnHiFiles.hi-boot-6 @@ -0,0 +1,3 @@ +__interface RnHiFiles 1 0 where +__export RnHiFiles loadInterface; +1 loadInterface :: __forall [d] => Outputable.SDoc -> Module.ModuleName -> Module.WhereFrom -> RnMonad.RnM d HscTypes.ModIface; diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 800334c..d3f10a0 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -86,10 +86,10 @@ import Array ( array, (//) ) import FastTypes import GlaExts ( indexArray# ) -#if __GLASGOW_HASKELL__ < 301 -import ArrBase ( Array(..) ) -#else +#if __GLASGOW_HASKELL__ < 503 import PrelArr ( Array(..) ) +#else +import GHC.Arr ( Array(..) ) #endif infixr 0 `thenSmpl`, `thenSmpl_` diff --git a/ghc/compiler/typecheck/TcEnv.hi-boot-6 b/ghc/compiler/typecheck/TcEnv.hi-boot-6 new file mode 100644 index 0000000..4c3e1fd --- /dev/null +++ b/ghc/compiler/typecheck/TcEnv.hi-boot-6 @@ -0,0 +1,3 @@ +__interface TcEnv 1 0 where +__export TcEnv TcEnv; +1 data TcEnv ; diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-6 b/ghc/compiler/typecheck/TcExpr.hi-boot-6 new file mode 100644 index 0000000..75e2ce9 --- /dev/null +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-6 @@ -0,0 +1,6 @@ +__interface TcExpr 1 0 where +__export TcExpr tcExpr ; +1 tcExpr :: + RnHsSyn.RenamedHsExpr + -> TcType.TcType + -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE) ; diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-6 b/ghc/compiler/typecheck/TcMatches.hi-boot-6 new file mode 100644 index 0000000..a8190d9 --- /dev/null +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-6 @@ -0,0 +1,13 @@ +__interface TcMatches 1 0 where +__export TcMatches tcGRHSs tcMatchesFun; +1 tcGRHSs :: HsExpr.HsMatchContext Name.Name + -> RnHsSyn.RenamedGRHSs + -> TcType.TcType + -> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ; +1 tcMatchesFun :: + [(Name.Name,Var.Id)] + -> Name.Name + -> TcType.TcType + -> [RnHsSyn.RenamedMatch] + -> TcMonad.TcM ([TcHsSyn.TcMatch], Inst.LIE) ; + diff --git a/ghc/compiler/typecheck/TcType.hi-boot-6 b/ghc/compiler/typecheck/TcType.hi-boot-6 new file mode 100644 index 0000000..23b3a9c --- /dev/null +++ b/ghc/compiler/typecheck/TcType.hi-boot-6 @@ -0,0 +1,3 @@ +__interface TcType 1 0 where +__export TcType TyVarDetails; +1 data TyVarDetails ; diff --git a/ghc/compiler/typecheck/TcUnify.hi-boot-6 b/ghc/compiler/typecheck/TcUnify.hi-boot-6 new file mode 100644 index 0000000..8023e28 --- /dev/null +++ b/ghc/compiler/typecheck/TcUnify.hi-boot-6 @@ -0,0 +1,8 @@ +-- This boot file exists only to tie the knot between +-- TcUnify and TcSimplify + +__interface TcUnify 1 0 where +__export TcUnify unifyTauTy ; +1 unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM GHCziBase.Z0T ; + + diff --git a/ghc/compiler/types/Generics.hi-boot-6 b/ghc/compiler/types/Generics.hi-boot-6 new file mode 100644 index 0000000..536dccb --- /dev/null +++ b/ghc/compiler/types/Generics.hi-boot-6 @@ -0,0 +1,4 @@ +__interface Generics 1 0 where +__export Generics mkTyConGenInfo ; + +2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> DataziMaybe.Maybe (BasicTypes.EP Var.Id) ; diff --git a/ghc/compiler/types/PprType.hi-boot-6 b/ghc/compiler/types/PprType.hi-boot-6 new file mode 100644 index 0000000..75ea5c9 --- /dev/null +++ b/ghc/compiler/types/PprType.hi-boot-6 @@ -0,0 +1,5 @@ +__interface PprType 1 0 where +__export PprType pprType pprPred ; +1 pprType :: TypeRep.Type -> Outputable.SDoc ; +1 pprPred :: Type.PredType -> Outputable.SDoc ; + diff --git a/ghc/compiler/types/TyCon.hi-boot-6 b/ghc/compiler/types/TyCon.hi-boot-6 new file mode 100644 index 0000000..75cadcc --- /dev/null +++ b/ghc/compiler/types/TyCon.hi-boot-6 @@ -0,0 +1,7 @@ +__interface TyCon 1 0 where +__export TyCon TyCon isTupleTyCon isUnboxedTupleTyCon isFunTyCon setTyConName ; +1 data TyCon ; +1 isTupleTyCon :: TyCon -> GHCziBase.Bool ; +1 isUnboxedTupleTyCon :: TyCon -> GHCziBase.Bool ; +1 isFunTyCon :: TyCon -> GHCziBase.Bool ; +1 setTyConName :: TyCon -> Name.Name -> TyCon ; diff --git a/ghc/compiler/types/TypeRep.hi-boot-6 b/ghc/compiler/types/TypeRep.hi-boot-6 new file mode 100644 index 0000000..5679aa8 --- /dev/null +++ b/ghc/compiler/types/TypeRep.hi-boot-6 @@ -0,0 +1,7 @@ +__interface TypeRep 1 0 where +__export TypeRep Type PredType Kind SuperKind ; +1 data Type ; +1 data PredType ; +1 type Kind = Type ; +1 type SuperKind = Type ; + diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index 838544b..86b2a8a 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -50,8 +50,13 @@ module FastString #define COMPILING_FAST_STRING #include "HsVersions.h" +#if __GLASGOW_HASKELL__ < 503 import PrelPack import PrelIOBase ( IO(..) ) +#else +import CString +import GHC.IOBase ( IO(..) ) +#endif import PrimPacked import GlaExts @@ -61,11 +66,14 @@ import PrelAddr ( Addr(..) ) import Addr ( Addr(..) ) import Ptr ( Ptr(..) ) #endif -#if __GLASGOW_HASKELL__ < 407 -import MutableArray ( MutableArray(..) ) -#else +#if __GLASGOW_HASKELL__ < 503 import PrelArr ( STArray(..), newSTArray ) import IOExts ( hPutBufFull, hPutBufBAFull ) +#else +import GHC.Arr ( STArray(..), newSTArray ) +import System.IO ( hPutBuf ) +import IOExts ( hPutBufBA ) +import CString ( unpackNBytesBA# ) #endif import IOExts ( IORef, newIORef, readIORef, writeIORef ) @@ -73,6 +81,11 @@ import IO import Char ( chr, ord ) #define hASH_TBL_SIZE 993 + +#if __GLASGOW_HASKELL__ < 503 +hPutBuf = hPutBufFull +hPutBufBA = hPutBufBAFull +#endif \end{code} @FastString@s are packed representations of strings @@ -216,16 +229,8 @@ type FastStringTableVar = IORef FastStringTable string_table :: FastStringTableVar string_table = unsafePerformIO ( -#if __GLASGOW_HASKELL__ < 405 - stToIO (newArray (0::Int,hASH_TBL_SIZE) []) - >>= \ (MutableArray _ arr#) -> -#elif __GLASGOW_HASKELL__ < 407 - stToIO (newArray (0::Int,hASH_TBL_SIZE) []) - >>= \ (MutableArray _ _ arr#) -> -#else stToIO (newSTArray (0::Int,hASH_TBL_SIZE) []) >>= \ (STArray _ _ arr#) -> -#endif newIORef (FastStringTable 0# arr#)) lookupTbl :: FastStringTable -> Int# -> IO [FastString] @@ -254,11 +259,7 @@ mkFastString# a# len# = -- the string into a ByteArray -- _trace "empty bucket" $ case copyPrefixStr (A# a#) (I# len#) of -#if __GLASGOW_HASKELL__ < 405 - (ByteArray _ barr#) -> -#else (ByteArray _ _ barr#) -> -#endif let f_str = FastString uid# len# barr# in updTbl string_table ft h [f_str] >> ({- _trace ("new: " ++ show f_str) $ -} return f_str) @@ -269,11 +270,7 @@ mkFastString# a# len# = case bucket_match ls len# a# of Nothing -> case copyPrefixStr (A# a#) (I# len#) of -#if __GLASGOW_HASKELL__ < 405 - (ByteArray _ barr#) -> -#else (ByteArray _ _ barr#) -> -#endif let f_str = FastString uid# len# barr# in updTbl string_table ft h (f_str:ls) >> ( {- _trace ("new: " ++ show f_str) $ -} return f_str) @@ -305,13 +302,8 @@ mkFastSubStringBA# barr# start# len# = -- no match, add it to table by copying out the -- the string into a ByteArray -- _trace "empty bucket(b)" $ -#if __GLASGOW_HASKELL__ < 405 - case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of - (ByteArray _ ba#) -> -#else case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of (ByteArray _ _ ba#) -> -#endif let f_str = FastString uid# len# ba# in updTbl string_table ft h [f_str] >> -- _trace ("new(b): " ++ show f_str) $ @@ -322,13 +314,8 @@ mkFastSubStringBA# barr# start# len# = -- _trace ("non-empty bucket(b)"++show ls) $ case bucket_match ls start# len# barr# of Nothing -> -#if __GLASGOW_HASKELL__ < 405 - case copySubStrBA (ByteArray btm barr#) (I# start#) (I# len#) of - (ByteArray _ ba#) -> -#else case copySubStrBA (ByteArray btm btm barr#) (I# start#) (I# len#) of (ByteArray _ _ ba#) -> -#endif let f_str = FastString uid# len# ba# in updTbl string_table ft h (f_str:ls) >> -- _trace ("new(b): " ++ show f_str) $ @@ -401,11 +388,7 @@ mkFastCharString2 a@(A# a#) (I# len#) = CharStr a# len# mkFastStringNarrow :: String -> FastString mkFastStringNarrow str = case packString str of -#if __GLASGOW_HASKELL__ < 405 - (ByteArray (_,I# len#) frozen#) -> -#else (ByteArray _ (I# len#) frozen#) -> -#endif mkFastSubStringBA# frozen# 0# len# {- 0-indexed array, len# == index to one beyond end of string, i.e., (0,1) => empty string. -} @@ -488,22 +471,14 @@ cmpFS (FastString u1# _ b1#) (FastString u2# _ b2#) = -- assume non-null chars EQ else unsafePerformIO ( -#if __GLASGOW_HASKELL__ < 405 - _ccall_ strcmp (ByteArray bot b1#) (ByteArray bot b2#) >>= \ (I# res) -> -#else _ccall_ strcmp (ByteArray bot bot b1#) (ByteArray bot bot b2#) >>= \ (I# res) -> -#endif return ( if res <# 0# then LT else if res ==# 0# then EQ else GT )) where -#if __GLASGOW_HASKELL__ < 405 - bot :: (Int,Int) -#else bot :: Int -#endif bot = error "tagCmp" cmpFS (CharStr bs1 len1) (CharStr bs2 len2) = unsafePerformIO ( @@ -525,11 +500,7 @@ cmpFS (FastString _ len1 bs1) (CharStr bs2 len2) else GT )) where -#if __GLASGOW_HASKELL__ < 405 - ba1 = ByteArray ((error "")::(Int,Int)) bs1 -#else ba1 = ByteArray (error "") ((error "")::Int) bs1 -#endif ba2 = A# bs2 cmpFS a@(CharStr _ _) b@(FastString _ _ _) @@ -545,13 +516,8 @@ Outputting @FastString@s is quick, just block copying the chunk (using hPutFS :: Handle -> FastString -> IO () hPutFS handle (FastString _ l# ba#) | l# ==# 0# = return () -#if __GLASGOW_HASKELL__ < 405 - | otherwise = hPutBufBA handle (ByteArray bot ba#) (I# l#) -#elif __GLASGOW_HASKELL__ < 407 - | otherwise = hPutBufBA handle (ByteArray bot bot ba#) (I# l#) -#else | otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#) - hPutBufBAFull handle mba (I# l#) + hPutBufBA handle mba (I# l#) where bot = error "hPutFS.ba" @@ -559,18 +525,14 @@ hPutFS handle (FastString _ l# ba#) hPutFS handle (CharStr a# l#) | l# ==# 0# = return () -#if __GLASGOW_HASKELL__ < 407 +#if __GLASGOW_HASKELL__ < 411 | otherwise = hPutBuf handle (A# a#) (I# l#) -#elif __GLASGOW_HASKELL__ < 411 - | otherwise = hPutBufFull handle (A# a#) (I# l#) #else - | otherwise = hPutBufFull handle (Ptr a#) (I# l#) + | otherwise = hPutBuf handle (Ptr a#) (I# l#) #endif -- ONLY here for debugging the NCG (so -ddump-stix works for string -- literals); no idea if this is really necessary. JRS, 010131 hPutFS handle (UnicodeStr _ is) = hPutStr handle ("(UnicodeStr " ++ show is ++ ")") - -#endif \end{code} diff --git a/ghc/compiler/utils/PrimPacked.lhs b/ghc/compiler/utils/PrimPacked.lhs index 286cf12..5c4e27e 100644 --- a/ghc/compiler/utils/PrimPacked.lhs +++ b/ghc/compiler/utils/PrimPacked.lhs @@ -38,16 +38,10 @@ import Addr ( Addr(..) ) import ST import Foreign -#if __GLASGOW_HASKELL__ < 301 -import ArrBase ( StateAndMutableByteArray#(..), - StateAndByteArray#(..) ) -import STBase -#elif __GLASGOW_HASKELL__ < 400 -import PrelArr ( StateAndMutableByteArray#(..), - StateAndByteArray#(..) ) +#if __GLASGOW_HASKELL__ < 503 import PrelST #else -import PrelST +import GHC.ST #endif \end{code} @@ -117,11 +111,7 @@ addrOffset# a# i# = A# a -> a copySubStrBA :: ByteArray Int -> Int -> Int -> ByteArray Int -#if __GLASGOW_HASKELL__ >= 405 copySubStrBA (ByteArray _ _ barr#) (I# start#) len@(I# length#) = -#else -copySubStrBA (ByteArray _ barr#) (I# start#) len@(I# length#) = -#endif runST ( {- allocate an array that will hold the string (not forgetting the NUL at the end) @@ -153,13 +143,7 @@ write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s () freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int) new_ps_array size = ST $ \ s -> -#if __GLASGOW_HASKELL__ < 400 - case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# -> - STret s2# (MutableByteArray bot barr#) } -#elif __GLASGOW_HASKELL__ < 405 - case (newCharArray# size s) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray bot barr# #) } -#elif __GLASGOW_HASKELL__ < 411 +#if __GLASGOW_HASKELL__ < 411 case (newCharArray# size s) of { (# s2#, barr# #) -> (# s2#, MutableByteArray bot bot barr# #) } #else /* 411 and higher */ @@ -169,34 +153,14 @@ new_ps_array size = ST $ \ s -> where bot = error "new_ps_array" -#if __GLASGOW_HASKELL__ < 400 -write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# -> - case writeCharArray# barr# n ch s# of { s2# -> - STret s2# () } -#elif __GLASGOW_HASKELL__ < 405 -write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# -> - case writeCharArray# barr# n ch s# of { s2# -> - (# s2#, () #) } -#else write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# -> case writeCharArray# barr# n ch s# of { s2# -> (# s2#, () #) } -#endif -- same as unsafeFreezeByteArray -#if __GLASGOW_HASKELL__ < 400 -freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> - STret s2# (ByteArray (0,I# len#) frozen#) } -#elif __GLASGOW_HASKELL__ < 405 -freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray (0,I# len#) frozen# #) } -#else freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# -> case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> (# s2#, ByteArray 0 (I# len#) frozen# #) } -#endif \end{code} @@ -206,18 +170,10 @@ Compare two equal-length strings for equality: eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool eqStrPrefix a# barr# len# = unsafePerformIO ( -#if __GLASGOW_HASKELL__ < 405 - _ccall_ strncmp (A# a#) (ByteArray bot barr#) (I# len#) >>= \ (I# x#) -> -#else _ccall_ strncmp (A# a#) (ByteArray bot bot barr#) (I# len#) >>= \ (I# x#) -> -#endif return (x# ==# 0#)) where -#if __GLASGOW_HASKELL__ < 405 - bot :: (Int,Int) -#else bot :: Int -#endif bot = error "eqStrPrefix" eqCharStrPrefix :: Addr# -> Addr# -> Int# -> Bool @@ -230,45 +186,25 @@ eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool eqStrPrefixBA b1# b2# start# len# = unsafePerformIO ( _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' -#if __GLASGOW_HASKELL__ < 405 - (ByteArray bot b2#) -#else (ByteArray bot bot b2#) -#endif (I# start#) -#if __GLASGOW_HASKELL__ < 405 - (ByteArray bot b1#) -#else (ByteArray bot bot b1#) -#endif (I# len#) >>= \ (I# x#) -> return (x# ==# 0#)) where -#if __GLASGOW_HASKELL__ < 405 - bot :: (Int,Int) -#else bot :: Int -#endif bot = error "eqStrPrefixBA" eqCharStrPrefixBA :: Addr# -> ByteArray# -> Int# -> Int# -> Bool eqCharStrPrefixBA a# b2# start# len# = unsafePerformIO ( _casm_ ``%r=(int)strncmp((char *)%0+(int)%1,%2,%3); '' -#if __GLASGOW_HASKELL__ < 405 - (ByteArray bot b2#) -#else (ByteArray bot bot b2#) -#endif (I# start#) (A# a#) (I# len#) >>= \ (I# x#) -> return (x# ==# 0#)) where -#if __GLASGOW_HASKELL__ < 405 - bot :: (Int,Int) -#else bot :: Int -#endif bot = error "eqCharStrPrefixBA" \end{code} diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 291fee4..d5ea832 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -78,26 +78,34 @@ import Addr ( Addr(..) ) import Ptr ( Ptr(..) ) #endif -#if __GLASGOW_HASKELL__ >= 501 +#if __GLASGOW_HASKELL__ < 501 +import Char ( chr ) +#elif __GLASGOW_HASKELL__ < 503 import PrelIO ( hGetcBuffered ) #else -import Char ( chr ) +import GHC.IO ( hGetcBuffered ) #endif +import PrimPacked +import FastString + import GlaExts import Foreign - -import IO ( openFile ) +import IO ( openFile, isEOFError ) import IOExts ( slurpFile ) -import PrelIOBase -import PrelHandle import Addr +import Exception ( bracket ) -import PrelPack ( unpackCStringBA ) +import CString ( unpackCStringBA ) + +#if __GLASGOW_HASKELL__ < 503 +import PrelIOBase +import PrelHandle +#else +import GHC.IOBase +import GHC.Handle +#endif -import Exception ( bracket ) -import PrimPacked -import FastString import Char ( isDigit ) \end{code} diff --git a/ghc/driver/Makefile b/ghc/driver/Makefile index cd27d6f..88bd495 100644 --- a/ghc/driver/Makefile +++ b/ghc/driver/Makefile @@ -1,71 +1,25 @@ -#----------------------------------------------------------------------------- +# -----------------------------------------------------------------------------= +# $Id: Makefile,v 1.73 2002/02/12 15:17:17 simonmar Exp $ +# +# (c) The University of Glasgow 2002 # TOP=.. -CURRENT_DIR=ghc/driver include $(TOP)/mk/boilerplate.mk -# hack for ghci-inplace script, see below -INSTALLING=1 - -ifeq "$(INSTALLING)" "1" SUBDIRS = mangler split ghc ghci -endif - -# ----------------------------------------------------------------------------- -# package configuration files... - -PKGCONF_OPTS = "$(TARGETPLATFORM)" \ - "$(CURRENT_DIR)" \ - "$(HaveLibGmp)" \ - "$(LibsReadline)" \ - "$(GHC_LIB_DIR)" \ - "$(GHC_RUNTIME_DIR)" \ - "$(GHC_UTILS_DIR)" \ - "$(GHC_INCLUDE_DIR)" \ - "$(X_CFLAGS)" \ - "$(X_LIBS)" - -# the latter two are needed to setup the package details for hslibs/xlib - -SRC_HC_OPTS += -fglasgow-exts -cpp - -ghc_407_at_least = $(shell if (test $(GhcCanonVersion) -ge 407); then echo YES; else echo NO; fi) -ifeq "$(ghc_407_at_least)" "YES" -SRC_HC_OPTS += -package concurrent -package text -ifneq "$(mingw32_TARGET_OS)" "1" -SRC_HC_OPTS += -package posix -endif -else -SRC_HC_OPTS += -syslib concurrent -syslib posix -syslib misc -endif +boot all :: package.conf.inplace package.conf -ifeq "$(GhcRtsThreaded)" "YES" -SRC_HC_OPTS +=-DTHREADED_RTS -endif +package.conf.inplace : + echo "[]" > $@ -SRC_HC_OPTS += -DWANT_PRETTY -SRC_HC_OPTS += $(filter -D% -U%,$(GhcRtsCcOpts)) - -all :: package.conf package.conf.inplace - -HS_OBJS = Package.o PackageSrc.o Utils.o -HS_PROG = pkgconf - -package.conf.inplace : $(HS_PROG) - ./$(HS_PROG) in-place $(PKGCONF_OPTS) >$@ - -package.conf : pkgconf - ./$(HS_PROG) install $(PKGCONF_OPTS) >$@ - -Package.o : ../utils/ghc-pkg/Package.hs +package.conf : + echo "[]" > $@ override datadir = $(libdir) INSTALL_DATAS += package.conf ghc-usage.txt -CLEAN_FILES += Main.hi pkgconf package.conf.inplace package.conf - -# ----------------------------------------------------------------------------- +CLEAN_FILES += package.conf.inplace package.conf include $(TOP)/mk/target.mk diff --git a/ghc/driver/PackageSrc.hs b/ghc/driver/PackageSrc.hs deleted file mode 100644 index 6a1036a..0000000 --- a/ghc/driver/PackageSrc.hs +++ /dev/null @@ -1,496 +0,0 @@ -#include "../includes/config.h" -#include "../includes/Derived.h" - -module Main (main) where - -import Utils - -import IO -import System -import Package - -main :: IO () -main = do - args <- getArgs - case args of - ("install":rest) -> do { putStrLn (dumpPackages (package_details True rest)) } - ("in-place":rest) -> do { putStrLn (dumpPackages (package_details False rest)) } - _ -> do hPutStr stderr "usage: pkgconf (install | in-place) ...\n" - exitWith (ExitFailure 1) - --- The compiler automatically replaces the string "$libdir" at the --- beginning of a path with the directory passed to the compiler via --- the -B flag. Absolute path names will be unchanged. --- --- This is how we make package.conf independent of GHC's installation --- location. - -package_details :: Bool -> [String] -> [PackageConfig] -package_details installing - [ cTARGETPLATFORM - , cCURRENT_DIR - , cHaveLibGmp - , cLibsReadline - , cGHC_LIB_DIR - , cGHC_RUNTIME_DIR - , cGHC_UTILS_DIR - , cGHC_INCLUDE_DIR - , cX_CFLAGS - , cX_LIBS - ] = - - [ - Package { - name = "gmp", -- GMP is at the bottom of the heap - import_dirs = [], - source_dirs = [], - library_dirs = if cHaveLibGmp == "YES" - then [] - else if installing - then [ "$libdir" ] - else [ ghc_src_dir cGHC_RUNTIME_DIR ++ "/gmp" ], - hs_libraries = [], - extra_libraries = [ "gmp" ], - include_dirs = [], - c_includes = [], - package_deps = [], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "rts", -- The RTS is just another package! - import_dirs = [], - source_dirs = [], - library_dirs = if installing - then -#ifdef mingw32_TARGET_OS - -- force the dist-provided gcc-lib/ into scope. - [ "$libdir", "$libdir/gcc-lib" ] -#else - [ "$libdir" ] -#endif - else [ ghc_src_dir cGHC_RUNTIME_DIR ], - hs_libraries = [ "HSrts" ], - extra_libraries = - "m": -- for ldexp() -#ifdef mingw32_TARGET_OS - "winmm": -- for the threadDelay timer - "wsock32": -- for the linker -#endif -#ifdef USING_LIBBFD - "bfd": "iberty": -- for debugging -#endif -#ifdef THREADED_RTS - "pthread" : -#endif - - [], - include_dirs = if installing - then [ "$libdir/include" -#ifdef mingw32_TARGET_OS - , "$libdir/include/mingw" -#endif - ] - else [ ghc_src_dir cGHC_INCLUDE_DIR ], - c_includes = [ "Stg.h" ], -- ha! - package_deps = [ "gmp" ], - extra_ghc_opts = [], - extra_cc_opts = [], - -- the RTS forward-references to a bunch of stuff in the prelude, - -- so we force it to be included with special options to ld. - extra_ld_opts = - foldr (\ x xs -> "-u" : x : xs) [] - (map ( -#ifndef LEADING_UNDERSCORE - "" -#else - "_" -#endif - ++ ) [ - "PrelBase_Izh_static_info" - , "PrelBase_Czh_static_info" - , "PrelFloat_Fzh_static_info" - , "PrelFloat_Dzh_static_info" - , "PrelPtr_Ptr_static_info" - , "PrelWord_Wzh_static_info" - , "PrelInt_I8zh_static_info" - , "PrelInt_I16zh_static_info" - , "PrelInt_I32zh_static_info" - , "PrelInt_I64zh_static_info" - , "PrelWord_W8zh_static_info" - , "PrelWord_W16zh_static_info" - , "PrelWord_W32zh_static_info" - , "PrelWord_W64zh_static_info" - , "PrelStable_StablePtr_static_info" - , "PrelBase_Izh_con_info" - , "PrelBase_Czh_con_info" - , "PrelFloat_Fzh_con_info" - , "PrelFloat_Dzh_con_info" - , "PrelPtr_Ptr_con_info" - , "PrelStable_StablePtr_con_info" - , "PrelBase_False_closure" - , "PrelBase_True_closure" - , "PrelPack_unpackCString_closure" - , "PrelIOBase_stackOverflow_closure" - , "PrelIOBase_heapOverflow_closure" - , "PrelIOBase_NonTermination_closure" - , "PrelIOBase_BlockedOnDeadMVar_closure" - , "PrelIOBase_Deadlock_closure" - , "PrelWeak_runFinalizzerBatch_closure" - , "__stginit_Prelude" - ]) - }, - - Package { - name = "std", -- The Prelude & Standard Hs_libraries - import_dirs = if installing - then [ "$libdir/imports/std" ] - else [ ghc_src_dir cGHC_LIB_DIR ++ "/std" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ ghc_src_dir cGHC_LIB_DIR ++ "/std" - , ghc_src_dir cGHC_LIB_DIR ++ "/std/cbits" ], - - hs_libraries = -# ifndef mingw32_TARGET_OS - [ "HSstd" ] -# else - -- This splitting is the subject of a totally - -- horrible hack, which glues HSstd1 and HSstd2 - -- back into HSstd for the purposes of static linking. - -- See DriverState.getPackageLibraries for details. - [ "HSstd1", "HSstd2" ] -# endif - , - extra_libraries = [ "HSstd_cbits" ] ++ -# ifdef mingw32_TARGET_OS - [ "wsock32", "msvcrt", "kernel32", "user32" ] -# else - [ ] -# endif - , - include_dirs = if installing - then [] - else [ ghc_src_dir cGHC_LIB_DIR ++ "/std/cbits" ], - c_includes = [ "HsStd.h" ], - package_deps = [ "rts" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "lang", - import_dirs = if installing - then [ "$libdir/imports/lang" ] - else [ "$libdir/hslibs/lang" - , "$libdir/hslibs/lang/monads" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/lang" - , "$libdir/hslibs/lang/cbits" ], - hs_libraries = [ "HSlang" ], - extra_libraries = [ "HSlang_cbits" ], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/lang/cbits" ], - c_includes = [ "HsLang.h" ], - package_deps = [], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [ -#ifndef LEADING_UNDERSCORE - "-u", "Addr_Azh_static_info" -#else - "-u", "_Addr_Azh_static_info" -#endif - ] - }, - - Package { - name = "concurrent", - import_dirs = if installing - then [ "$libdir/imports/concurrent" ] - else [ "$libdir/hslibs/concurrent" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/concurrent" ], - hs_libraries = [ "HSconcurrent" ], - extra_libraries = [], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/concurrent/cbits" ], - c_includes = [], - package_deps = [ "lang" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "data", - import_dirs = if installing - then [ "$libdir/imports/data" ] - else [ "$libdir/hslibs/data" - , "$libdir/hslibs/data/edison" - , "$libdir/hslibs/data/edison/Assoc" - , "$libdir/hslibs/data/edison/Coll" - , "$libdir/hslibs/data/edison/Seq" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/data" ], - hs_libraries = [ "HSdata" ], - extra_libraries = [], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/data/cbits" ], - c_includes = [], - package_deps = [ "lang", "util" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "net", - import_dirs = if installing - then [ "$libdir/imports/net" ] - else [ "$libdir/hslibs/net" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/net" - , "$libdir/hslibs/net/cbits" ], - hs_libraries = [ "HSnet" ], - extra_libraries = if suffixMatch "solaris2" cTARGETPLATFORM - then [ "nsl", "socket" ] - else [] - , - include_dirs = if installing - then [] - else [ "$libdir/hslibs/net/cbits" ], - c_includes = [ "HsNet.h" ], - package_deps = [ "lang", "text", "concurrent" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "posix", - import_dirs = if installing - then [ "$libdir/imports/posix" ] - else [ "$libdir/hslibs/posix" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/posix" - , "$libdir/hslibs/posix/cbits" ], - hs_libraries = [ "HSposix" ], - extra_libraries = [ "HSposix_cbits" ], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/posix/cbits" ], - c_includes = [ "HsPosix.h" ], - package_deps = [ "lang" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "text", - import_dirs = if installing - then [ "$libdir/imports/text" ] - else [ "$libdir/hslibs/text" - , "$libdir/hslibs/text/html" - , "$libdir/hslibs/text/HaXml/lib" - , "$libdir/hslibs/text/parsec" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/text" - , "$libdir/hslibs/text/cbits" ], - hs_libraries = [ "HStext" ], - extra_libraries = [ "HStext_cbits" ], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/text/cbits" ], - c_includes = [ "HsText.h" ], - package_deps = [ "lang" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "util", - import_dirs = if installing - then [ "$libdir/imports/util" ] - else [ "$libdir/hslibs/util" - , "$libdir/hslibs/util/check" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/util" - , "$libdir/hslibs/util/cbits" ], - hs_libraries = [ "HSutil" ], - extra_libraries = [ "HSutil_cbits" ] -#ifndef mingw32_TARGET_OS - ++ words cLibsReadline -#endif - , - include_dirs = if installing - then [] - else [ "$libdir/hslibs/util/cbits" ], - c_includes = [ "HsUtil.h" ], - package_deps = [ "lang", "concurrent" -#ifndef mingw32_TARGET_OS - , "posix" -#endif - ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - -- no cbits at the moment, we'll need to add one if this library - -- ever calls out to any C libs. - Package { - name = "hssource", - import_dirs = if installing - then [ "$libdir/imports/hssource" ] - else [ "$libdir/hslibs/hssource" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/hssource" ], - hs_libraries = [ "HShssource" ], - extra_libraries = [], - include_dirs = [], - c_includes = [], - package_deps = [ "text" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - }, - - Package { - name = "greencard", - import_dirs = if installing - then [ "$libdir/imports/greencard" ] - else [ "$libdir/green-card/lib/ghc" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/green-card/lib/ghc" ], - hs_libraries = [ "HSgreencard" ], - extra_libraries = [], - include_dirs = [], - c_includes = [], - package_deps = [ "lang" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [], - } - -#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) - ,Package { - name = "win32", - import_dirs = if installing - then [ "$libdir/imports/win32" ] - else [ "$libdir/hslibs/win32" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/win32" ], - hs_libraries = [ "HSwin321", "HSwin322" ], - extra_libraries = [ "user32", "gdi32", "winmm", - "kernel32", "advapi32" ], - include_dirs = [], - c_includes = [], -- ??? - package_deps = [ "lang" ], -- greencard now built in - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - } - ,Package { - name = "objectio", - import_dirs = if installing - then ["$libdir/imports/objectio"] - else ["$libdir/hslibs/object-io/ObjectIO","$libdir/hslibs/object-io/OSWindows"], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/object-io"], - hs_libraries = ["HSobjectio"], - extra_libraries = - ["user32", - "gdi32", - "kernel32", - "comctl32", - "comdlg32", - "shell32", - "winmm", - "winspool", - "ole32"], - include_dirs = [], - c_includes = [], - package_deps = ["concurrent", "lang"], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - } -#endif - - ,Package { - name = "xlib", - import_dirs = if installing - then [ "$libdir/imports/xlib" ] - else [ "$libdir/hslibs/xlib" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/xlib" - , "$libdir/hslibs/xlib/cbits" ], - hs_libraries = [ "HSxlib" ], - extra_libraries = [ "HSxlib_cbits", "X11" ], - include_dirs = if installing - then [] - else [ "$libdir/hslibs/xlib/cbits" ], - c_includes = [ "HsXlib.h" ], - package_deps = [ "greencard" ], - extra_ghc_opts = [], - extra_cc_opts = [ cX_CFLAGS ], - extra_ld_opts = [ cX_LIBS ] - } - - ,Package { - name = "HGL", - import_dirs = if installing - then [ "$libdir/imports/HGL" ] - else [ "$libdir/hslibs/graphics/lib/x11" ], - source_dirs = [], - library_dirs = if installing - then [ "$libdir" ] - else [ "$libdir/hslibs/graphics/lib/x11"], - hs_libraries = [ "HSHGL" ], - extra_libraries= [], - include_dirs = [], - c_includes = [], - package_deps = [ "xlib", "concurrent" ], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [] - } - - ] - where - ghc_src_dir :: String -> String - ghc_src_dir path = "$libdir/" ++ cCURRENT_DIR ++ '/':path diff --git a/ghc/driver/Utils.hs b/ghc/driver/Utils.hs deleted file mode 100644 index c176130..0000000 --- a/ghc/driver/Utils.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Utils where - -prefixMatch :: Eq a => [a] -> [a] -> Bool -prefixMatch [] _str = True -prefixMatch _pat [] = False -prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss - | otherwise = False - -suffixMatch :: String -> String -> Bool -suffixMatch pat str = prefixMatch (reverse pat) (reverse str) diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile deleted file mode 100644 index b7e87f1..0000000 --- a/ghc/lib/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -# ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.33 1999/11/26 16:29:12 simonmar Exp $ - -TOP = .. -include $(TOP)/mk/boilerplate.mk - -SUBDIRS = std - -include $(TOP)/mk/target.mk diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs deleted file mode 100644 index cfeb648..0000000 --- a/ghc/lib/std/Array.lhs +++ /dev/null @@ -1,148 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Array.lhs,v 1.16 2001/04/14 22:27:00 qrczak Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% -\section[Array]{Module @Array@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module Array - - ( - module Ix -- export all of Ix - , Array -- Array type is abstract - - , array -- :: (Ix a) => (a,a) -> [(a,b)] -> Array a b - , listArray -- :: (Ix a) => (a,a) -> [b] -> Array a b - , (!) -- :: (Ix a) => Array a b -> a -> b - , bounds -- :: (Ix a) => Array a b -> (a,a) - , indices -- :: (Ix a) => Array a b -> [a] - , elems -- :: (Ix a) => Array a b -> [b] - , assocs -- :: (Ix a) => Array a b -> [(a,b)] - , accumArray -- :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b - , (//) -- :: (Ix a) => Array a b -> [(a,b)] -> Array a b - , accum -- :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b - , ixmap -- :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a b - - -- Array instances: - -- - -- Ix a => Functor (Array a) - -- (Ix a, Eq b) => Eq (Array a b) - -- (Ix a, Ord b) => Ord (Array a b) - -- (Ix a, Show a, Show b) => Show (Array a b) - -- (Ix a, Read a, Read b) => Read (Array a b) - -- - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - - ) where -\end{code} - -#ifndef __HUGS__ - -\begin{code} - ------------ GHC -------------------- -import Ix -import PrelArr -- Most of the hard work is done here - ------------ End of GHC -------------------- -\end{code} - -#else - -\begin{code} - ------------ HUGS (rest of file) -------------------- -import PrelPrim ( PrimArray - , runST - , primNewArray - , primWriteArray - , primReadArray - , primUnsafeFreezeArray - , primIndexArray - ) -import Ix -import List( (\\) ) - -infixl 9 !, // -\end{code} - - -%********************************************************* -%* * -\subsection{The Array type} -%* * -%********************************************************* - - -\begin{code} -data Array ix elt = Array (ix,ix) (PrimArray elt) - -array :: Ix a => (a,a) -> [(a,b)] -> Array a b -array ixs@(ix_start, ix_end) ivs = runST (do - { mut_arr <- primNewArray (rangeSize ixs) arrEleBottom - ; mapM_ (\ (i,v) -> primWriteArray mut_arr (index ixs i) v) ivs - ; arr <- primUnsafeFreezeArray mut_arr - ; return (Array ixs arr) - } - ) - where - arrEleBottom = error "(Array.!): undefined array element" - -listArray :: Ix a => (a,a) -> [b] -> Array a b -listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) - -(!) :: Ix a => Array a b -> a -> b -(Array bounds arr) ! i = primIndexArray arr (index bounds i) - -bounds :: Ix a => Array a b -> (a,a) -bounds (Array b _) = b - -indices :: Ix a => Array a b -> [a] -indices = range . bounds - -elems :: Ix a => Array a b -> [b] -elems a = [a!i | i <- indices a] - -assocs :: Ix a => Array a b -> [(a,b)] -assocs a = [(i, a!i) | i <- indices a] - -(//) :: Ix a => Array a b -> [(a,b)] -> Array a b -(//) a us = array (bounds a) - ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]] - ++ us) - -accum :: Ix a => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b -accum f = foldl (\a (i,v) -> a // [(i,f (a!i) v)]) - -accumArray :: Ix a => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b -accumArray f z b = accum f (array b [(i,z) | i <- range b]) - -ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c -ixmap b f a = array b [(i, a ! f i) | i <- range b] - - -instance (Ix a) => Functor (Array a) where - fmap f a = array (bounds a) [(i, f(a!i)) | i <- indices a] - -instance (Ix a, Eq b) => Eq (Array a b) where - a == a' = assocs a == assocs a' - -instance (Ix a, Ord b) => Ord (Array a b) where - a <= a' = assocs a <= assocs a' - - -instance (Ix a, Show a, Show b) => Show (Array a b) where - showsPrec p a = showParen (p > 9) ( - showString "array " . - shows (bounds a) . showChar ' ' . - shows (assocs a) ) - -instance (Ix a, Read a, Read b) => Read (Array a b) where - readsPrec p = readParen (p > 9) - (\r -> [(array b as, u) | ("array",s) <- lex r, - (b,t) <- reads s, - (as,u) <- reads t ]) - -\end{code} -#endif diff --git a/ghc/lib/std/BigInteger.cs b/ghc/lib/std/BigInteger.cs deleted file mode 100644 index 8e5aaad..0000000 --- a/ghc/lib/std/BigInteger.cs +++ /dev/null @@ -1,1472 +0,0 @@ -// Big Integer class for .NET -// (c) The GHC Team 2001 - -// TODO: -// Constructors from Single, Double, Currency, String -// - -using System; -using System.Diagnostics; - -public class BigInteger : IComparable, IConvertible, IFormattable { - - int sign; - int size; - int used; - byte[] body; - - const int B_BASE = 256; - const double B_BASE_FLT = 256.0; - - - // Constructors - - public BigInteger() { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - public BigInteger(Int32 n) { - this.size = 4; - this.body = new byte[this.size]; - this.sign = this.used = 0; - if (n == 0) { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - return; - } - if (n < 0) { - this.sign = -1; - } - else { - this.sign = 1; - } - if (n < 0) { - n = -n; - } - while (n != 0) { - this.body[this.used] = (byte)(n % B_BASE); - n /= B_BASE; - this.used++; - } -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - public BigInteger(UInt32 n) { - this.size = 4; - this.body = new byte[this.size]; - this.sign = this.used = 0; - if (n == 0) { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - return; - } - this.sign = 1; - while (n != 0) { - this.body[this.used] = (byte)(n % B_BASE); - n /= B_BASE; - this.used++; - } -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - public BigInteger(Int64 n) { - this.size = 8; - this.body = new byte[this.size]; - this.sign = this.used = 0; - if (n == 0) { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - return; - } - if (n < 0) { - this.sign = -1; - } - else { - this.sign = 1; - } - if (n < 0) { - n = -n; - } - while (n != 0) { - this.body[this.used] = (byte)(n % B_BASE); - n /= B_BASE; - this.used++; - } -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - public BigInteger(UInt64 n) { - this.size = 8; - this.body = new byte[this.size]; - this.sign = this.used = 0; - if (n == 0) { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - return; - } - this.sign = 1; - while (n != 0) { - this.body[this.used] = (byte)(n % B_BASE); - n /= B_BASE; - this.used++; - } -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - // NOTE: This only works currectly if B_BASE >= 10 - // TODO: Turn this into a Parse method taking a String - public BigInteger (char [] str) { - int sign, d, t, i, j, carry; - - for (i = 0; str[i] != 0; i++) { - } - this.size = i; - this.body = new byte[this.size]; - this.sign = this.used = 0; - sign = 1; - i = 0; - if (str[0] == '-') { - i++; - sign = -1; - } - - while (Char.IsDigit(str[i])) { - - // multiply this by 10 - carry = 0; - for (j = 0; j < this.used; j++) { - t = 10 * this.body[j] + carry; - this.body[j] = (byte)(t % B_BASE); - carry = t / B_BASE; - } -#if BIGINTEGER_DEBUG - Debug.Assert(carry < B_BASE); -#endif - if (carry > 0) { - this.body[this.used++] = (byte)carry; - } - // add a digit on - d = str[i] - '0'; - i++; - - carry = d; - for (j = 0; j < this.used; j++) { - carry += this.body[j]; - this.body[j] = (byte)(carry % B_BASE); - carry /= B_BASE; - if (carry == 0) { - break; - } - } - if (carry > 0) { - this.body[this.used++] = (byte)carry; - } - } - - this.sign = sign; -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - } - - - // Constants - static readonly BigInteger Zero = new BigInteger(0); - static readonly BigInteger One = new BigInteger(1); - static readonly BigInteger MinusOne = new BigInteger(-1); - - - // Conversions - - // Implicit - public static implicit operator BigInteger(SByte n) { - return new BigInteger((Int32)n); - } - - public static implicit operator BigInteger(Byte n) { - return new BigInteger((UInt32)n); - } - - public static implicit operator BigInteger(Int16 n) { - return new BigInteger((Int32)n); - } - - public static implicit operator BigInteger(UInt16 n) { - return new BigInteger((UInt32)n); - } - - public static implicit operator BigInteger(Char n) { - return new BigInteger((Int32)n); - } - - public static implicit operator BigInteger(Int32 n) { - return new BigInteger(n); - } - - public static implicit operator BigInteger(UInt32 n) { - return new BigInteger(n); - } - - public static implicit operator BigInteger(Int64 n) { - return new BigInteger(n); - } - - public static implicit operator BigInteger(UInt64 n) { - return new BigInteger(n); - } - - // Explicit - - public static Boolean ToBoolean(BigInteger n) { - throw new InvalidCastException(); - } - - public static explicit operator Boolean(BigInteger n) { - return ToBoolean(n); - } - - Boolean IConvertible.ToBoolean(IFormatProvider p) { - return ToBoolean(this); - } - - public static DateTime ToDateTime(BigInteger n) { - throw new InvalidCastException(); - } - - DateTime IConvertible.ToDateTime(IFormatProvider p) { - return ToDateTime(this); - } - - public static explicit operator DateTime(BigInteger n) { - return ToDateTime(n); - } - - public static SByte ToSByte(BigInteger n) { - SByte res; - if (n.sign == 0) { - return 0; - } - res = 0; - if (n.used > 0) { - res = (SByte)n.body[0]; - } - if (n.sign < 0) { - res = (SByte)(-res); - } - return res; - } - - SByte IConvertible.ToSByte(IFormatProvider p) { - return ToSByte(this); - } - - public static explicit operator SByte(BigInteger n) { - return ToSByte(n); - } - - public static Byte ToByte(BigInteger n) { - Byte res; - if (n.sign == 0) { - return 0; - } - res = 0; - if (n.used > 0) { - res = (Byte)n.body[0]; - } - return res; - } - - Byte IConvertible.ToByte(IFormatProvider p) { - return ToByte(this); - } - - public static explicit operator Byte(BigInteger n) { - return ToByte(n); - } - - public static Int16 ToInt16(BigInteger n) { - int i, d; - Int16 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = (Int16)(res * B_BASE + d); - } - if (n.sign < 0) { - res = (Int16)(-res); - } - return res; - } - - Int16 IConvertible.ToInt16(IFormatProvider p) { - return ToInt16(this); - } - - public static explicit operator Int16(BigInteger n) { - return ToInt16(n); - } - - public static UInt16 ToUInt16(BigInteger n) { - int i, d; - UInt16 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = (UInt16)(res * B_BASE + d); - } - return res; - } - - UInt16 IConvertible.ToUInt16(IFormatProvider p) { - return ToUInt16(this); - } - - public static explicit operator UInt16(BigInteger n) { - return ToUInt16(n); - } - - public static Char ToChar(BigInteger n) { - throw new InvalidCastException(); - } - - Char IConvertible.ToChar(IFormatProvider p) { - return ToChar(this); - } - - public static explicit operator Char(BigInteger n) { - return ToChar(n); - } - - public static Int32 ToInt32(BigInteger n) { - int i, d; - Int32 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE + d; - } - if (n.sign < 0) { - res = -res; - } - return res; - } - - Int32 IConvertible.ToInt32(IFormatProvider p) { - return ToInt32(this); - } - - public static explicit operator Int32(BigInteger n) { - return ToInt32(n); - } - - public static UInt32 ToUInt32(BigInteger n) { - int i, d; - UInt32 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE + (UInt32)d; - } - return res; - } - - UInt32 IConvertible.ToUInt32(IFormatProvider p) { - return ToUInt32(this); - } - - public static explicit operator UInt32(BigInteger n) { - return ToUInt32(n); - } - - public static Int64 ToInt64(BigInteger n) { - int i, d; - Int64 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE + d; - } - if (n.sign < 0) { - res = -res; - } - return res; - } - - Int64 IConvertible.ToInt64(IFormatProvider p) { - return ToInt64(this); - } - - public static explicit operator Int64(BigInteger n) { - return ToInt64(n); - } - - public static UInt64 ToUInt64(BigInteger n) { - int i, d; - UInt64 res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE + (UInt64)d; - } - return res; - } - - UInt64 IConvertible.ToUInt64(IFormatProvider p) { - return ToUInt64(this); - } - - public static explicit operator UInt64(BigInteger n) { - return ToUInt64(n); - } - - public static Decimal ToDecimal(BigInteger n) { - int i, d; - Decimal res; - if (n.sign == 0) { - return 0; - } - res = 0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE + (Decimal)d; - } - return res; - } - - Decimal IConvertible.ToDecimal(IFormatProvider p) { - return ToDecimal(this); - } - - public static explicit operator Decimal(BigInteger n) { - return ToDecimal(n); - } - - public static Single ToSingle(BigInteger n) { - int i, d; - Single res; - if (n.sign == 0) { - return 0.0F; - } - res = 0.0F; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * (Single)B_BASE_FLT + d; - } - if (n.sign < 0) { - res = -res; - } - return res; - } - - Single IConvertible.ToSingle(IFormatProvider p) { - return ToSingle(this); - } - - public static explicit operator Single(BigInteger n) { - return ToSingle(n); - } - - public static Double ToDouble(BigInteger n) { - int i, d; - Double res; - if (n.sign == 0) { - return 0.0; - } - res = 0.0; - for (i = n.used-1; i >= 0; i--) { - d = n.body[i]; - res = res * B_BASE_FLT + d; - } - if (n.sign < 0) { - res = -res; - } - return res; - } - - Double IConvertible.ToDouble(IFormatProvider p) { - return ToDouble(this); - } - - public static explicit operator Double(BigInteger n) { - return ToDouble(n); - } - - override public String ToString() { - int i; - Console.Write ( "sign={0} used={1} size={2} ", this.sign, this.used, this.size ); - for (i = this.used-1; i >= 0; i--) { - Console.Write ( "{0} ", (int)(this.body[i]) ); - } - Console.Write ( "\n" ); - return "(some number or other)"; - } - - public String ToString(IFormatProvider p) { - return ToString(null, p); - } - - public String ToString(String fmt) { - return this.ToString(); - } - - public String ToString(String fmt, IFormatProvider p) { - throw new InvalidCastException(); - } - - public Object ToType(Type ty, IFormatProvider n) { - throw new InvalidCastException(); - } - - // public object GetFormat(Type - - public TypeCode GetTypeCode() { - return TypeCode.Int64; - } - - // Basics - - bool sane() { - if (this.sign == 0 && this.used != 0) { - return false; - } - if (this.sign != -1 && this.sign != 0 && this.sign != 1) { - return false; - } - if (this.used < 0) { - return false; - } - if (this.size < 0) { - return false; - } - if (this.used > this.size) { - return false; - } - if (this.used == 0) { - return true; - } - if (this.body[this.used-1] == 0) { - return false; - } - return true; - } - - void u_renormalise() { - while (this.used > 0 && this.body[this.used-1] == 0) { - this.used--; - } - if (this.used == 0) { - this.sign = 0; - } - else { - this.sign = 1; - } - } - - - public void renormalise() { - while (this.used > 0 && this.body[this.used-1] == 0) { - this.used--; - } - if (this.used == 0) { - this.sign = 0; - } - } - - - // Size of things - - static int maxused_addsub ( BigInteger x, BigInteger y ) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - return 1 + (x.used > y.used ? x.used : y.used); - } - - static int maxused_mul ( BigInteger x, BigInteger y ) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - return x.used + y.used; - } - - static int maxused_qrm ( BigInteger x, BigInteger y ) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - return (x.used > y.used ? x.used : y.used); - } - - int maxused_neg() { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - return this.used; - } - - - // 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(BigInteger x, BigInteger y, BigInteger res) { - int t; -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); - Debug.Assert(res.size == maxused_addsub(x,y)); -#endif - 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; - } -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - } - - public BigInteger Negate() { -#if BIGINTEGER_DEBUG - Debug.Assert(this.sane()); -#endif - BigInteger res = new BigInteger(); - res.size = this.used; - res.body = new byte[res.used]; - res.used = this.used; - for (int i = 0; i < this.used; i++) { - res.body[i] = this.body[i]; - } - res.sign = -(this.sign); - return res; - } - - public static BigInteger Add(BigInteger x, BigInteger y) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - BigInteger res = new BigInteger(); - res.size = maxused_addsub(x, y); - 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; use sdiff - if (x.sign >= 0 && y.sign < 0) { - sdiff(x,y,res); - } - else { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sign < 0 && y.sign >= 0); -#endif - sdiff(y,x,res); - } - } -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - return res; - } - - public BigInteger Increment() { - return this + 1; - } - - public static BigInteger Sub(BigInteger x, BigInteger y) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - BigInteger res = new BigInteger(); - res.size = maxused_addsub(x, y); - 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); -#if BIGINTEGER_DEBUG - Debug.Assert(res.sign != 0); -#endif - if (x.sign < 0) { - res.sign = -1; - } - } - else - // signs are the same; use sdiff - if (x.sign >= 0 && y.sign >= 0) { - sdiff(x,y,res); - } - else { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sign < 0 && y.sign < 0); -#endif - sdiff(y,x,res); - } -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - return res; - } - - public BigInteger Decrement() { - return this - 1; - } - - public static BigInteger Multiply(BigInteger x, BigInteger y) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - BigInteger res = new BigInteger(); - res.size = maxused_mul(x, y); - res.body = new byte[res.size]; - res.used = res.sign = 0; - - if (x.sign == 0 || y.sign == 0) { - res.sign = res.used = 0; -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - return res; - } - umul(x,y,res); - if (x.sign != y.sign) { - res.sign = -1; - } -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - return res; - } - - public static BigInteger Divide(BigInteger x, BigInteger y) { - BigInteger q, r; - QuotientRemainder(x, y, out q, out r); - return q; - } - - public static BigInteger Remainder(BigInteger x, BigInteger y) { - BigInteger q, r; - QuotientRemainder(x, y, out q, out r); - return r; - } - - public static Int32 Compare(BigInteger x, BigInteger y) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - if (x.sign < y.sign) { - return -1; - } - if (x.sign > y.sign) { - return 1; - } -#if BIGINTEGER_DEBUG - Debug.Assert(x.sign == y.sign); -#endif - if (x.sign == 0) { - return 0; - } - if (x.sign == 1) { - return ucmp(x,y); - } - else { - return ucmp(y,x); - } - } - - public Int32 CompareTo(Object o) { - return Compare(this, (BigInteger)o); - } - - public static Boolean Equals(BigInteger x, BigInteger y) { - return Compare(x, y) == 0; - } - - override public Boolean Equals(Object o) { - return this == (BigInteger)o; - } - - override public Int32 GetHashCode() { - int i; - UInt32 h = 0; - for (i = 0; i < this.used; i++) { - h = (h << 4) + this.body[i]; - UInt32 g = h & 0xf0000000; - if (g != 0) { - h ^= g >> 24; - h ^= g; - } - } - return (Int32)h; - } - - // Overloaded operators - - public static BigInteger operator +(BigInteger x) { - return x; - } - - public static BigInteger operator -(BigInteger x) { - return x.Negate(); - } - - public static BigInteger operator +(BigInteger x, BigInteger y) { - return Add(x, y); - } - - public static BigInteger operator -(BigInteger x, BigInteger y) { - return Sub(x, y); - } - - public static BigInteger operator ++(BigInteger x) { - return x + 1; - } - - public static BigInteger operator --(BigInteger x) { - return x - 1; - } - - public static BigInteger operator *(BigInteger x, BigInteger y) { - return Multiply(x, y); - } - - public static BigInteger operator /(BigInteger x, BigInteger y) { - return Divide(x, y); - } - - public static BigInteger operator %(BigInteger x, BigInteger y) { - return Remainder(x, y); - } - - public static Boolean operator ==(BigInteger x, BigInteger y) { - return Equals(x, y); - } - - public static Boolean operator !=(BigInteger x, BigInteger y) { - return !Equals(x, y); - } - public static Boolean operator <(BigInteger x, BigInteger y) { - return Compare(x, y) == -1; - } - - public static Boolean operator <=(BigInteger x, BigInteger y) { - return Compare(x, y) < 1; - } - - public static Boolean operator >(BigInteger x, BigInteger y) { - return Compare(x, y) == 1; - } - - public static Boolean operator >=(BigInteger x, BigInteger y) { - return Compare(x, y) > 0; - } - - - // Quotient and remainder (private) - - public static void QuotientRemainder(BigInteger x, BigInteger y, out BigInteger q, out BigInteger r) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - - if (y.sign == 0) { - throw(new System.DivideByZeroException()); - } - - if (x.sign == 0) { - q = new BigInteger(); - r = new BigInteger(); - q.used = r.used = q.sign = r.sign = 0; -#if BIGINTEGER_DEBUG - Debug.Assert(q.sane()); - Debug.Assert(r.sane()); -#endif - return; - } - - uqrm(x, y, out q, out r); - if (x.sign != y.sign && q.sign != 0) { - q.sign = -1; - } - if (x.sign == -1 && r.sign != 0) { - r.sign = -1; - } - -#if BIGINTEGER_DEBUG - Debug.Assert(q.sane()); - Debug.Assert(r.sane()); -#endif - } - - - // Unsigned ops (private) - - static int ucmp(BigInteger x, BigInteger y) { - int i; -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); -#endif - if (x.used < y.used) { - return -1; - } - if (x.used > y.used) { - return 1; - } - for (i = x.used-1; i >= 0; i--) { - if (x.body[i] < y.body[i]) { - return -1; - } - if (x.body[i] > y.body[i]) { - return 1; - } - } - return 0; - } - - static void uadd ( BigInteger x, BigInteger y, BigInteger res ) { - int c, i, t, n; - BigInteger longer; - -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); - Debug.Assert (res.size == maxused_addsub(x,y)); -#endif - res.used = res.size; - res.body[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.body[i] + y.body[i] + c; - if (t >= B_BASE) { - res.body[i] = (byte)(t-B_BASE); - c = 1; - } - else { - res.body[i] = (byte)t; - c = 0; - } - } - - for (i = n; i < longer.used; i++) { - t = longer.body[i] + c; - if (t >= B_BASE) { - res.body[i] = (byte)(t-B_BASE); - } - else { - res.body[i] = (byte)t; - c = 0; - } - } - if (c > 0) { -#if BIGINTEGER_DEBUG - Debug.Assert(res.used == longer.used+1); -#endif - res.body[longer.used] = (byte)c; - } - - res.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - } - - static void usub(BigInteger x, BigInteger y, BigInteger res) { -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); - Debug.Assert(x.used >= y.used); - Debug.Assert(res.size == maxused_addsub(x,y)); -#endif - - int b, i, t; - - b = 0; - for (i = 0; i < y.used; i++) { - t = x.body[i] - y.body[i] - b; - if (t < 0) { - res.body[i] = (byte)(t + B_BASE); - b = 1; - } - else { - res.body[i] = (byte)t; - b = 0; - } - } - - for (i = y.used; i < x.used; i++) { - t = x.body[i] - b; - if (t < 0) { - res.body[i] = (byte)(t + B_BASE); - } - else { - res.body[i] = (byte)t; - b = 0; - } - } -#if BIGINTEGER_DEBUG - Debug.Assert (b == 0); -#endif - - res.used = x.used; - res.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - } - - static void umul(BigInteger x, BigInteger y, BigInteger res) { - int i, j, carry; - -#if BIGINTEGER_DEBUG - Debug.Assert(x.sane()); - Debug.Assert(y.sane()); - Debug.Assert(res.size == maxused_mul(x,y)); -#endif - - for (j = 0; j < y.used; j++) { - res.body[j] = 0; - } - - for (i = 0; i < x.used; i++) { - carry = 0; - for (j = 0; j < y.used; j++) { - carry += res.body[i+j] + x.body[i]*y.body[j]; - res.body[i+j] = (byte)(carry % B_BASE); - carry /= B_BASE; -#if BIGINTEGER_DEBUG - Debug.Assert (carry < B_BASE); -#endif - } - res.body[i+y.used] = (byte)carry; - } - - res.used = x.used+y.used; - res.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(res.sane()); -#endif - } - - static void uqrm(BigInteger dend, BigInteger isor, out BigInteger dres, out BigInteger mres) { - int i, j, t, vh, delta, carry, scaleup; - byte [] dend_body, isor_body, tmp; - bool toolarge; - -#if BIGINTEGER_DEBUG - Debug.Assert(isor.sane()); - Debug.Assert(dend.sane()); - Debug.Assert(isor.used > 0); // against division by zero -#endif - dres = new BigInteger(); - mres = new BigInteger(); - mres.size = dres.size = maxused_qrm(isor, dend); - dres.body = new byte[dres.size]; - mres.body = new byte[mres.size]; - - 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.body[j] = dend.body[j]; - } - dres.u_renormalise(); - mres.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(dres.sane()); - Debug.Assert(mres.sane()); -#endif - return; - } - - if (isor.used == 1) { - - // Simple case; divisor is a single digit - carry = 0; - for (j = dend.used-1; j >= 0; j--) { - carry += dend.body[j]; - dres.body[j] = (byte)(carry/isor.body[0]); - carry = B_BASE*(carry%isor.body[0]); - } - carry /= B_BASE; - dres.used = dend.used; - dres.u_renormalise(); - - // Remainder is the final carry value - mres.used = 0; - if (carry > 0) { - mres.used = 1; - mres.body[0] = (byte)carry; - } - dres.u_renormalise(); - mres.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(dres.sane()); - Debug.Assert(mres.sane()); -#endif - return; - - } - else { - - // Complex case: both dividend and divisor have two or more digits. -#if BIGINTEGER_DEBUG - Debug.Assert(isor.used >= 2); - Debug.Assert(dend.used >= 2); -#endif - - // 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_body = new byte[dend.used+1]; - isor_body = new byte[isor.used]; - tmp = new byte[isor.used+1]; - - // 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.body[isor.used-1]); -#if BIGINTEGER_DEBUG - Debug.Assert (1 <= scaleup && scaleup <= B_BASE/2); -#endif - - if (scaleup == 1) { - // Don't bother to multiply; just copy. - for (j = 0; j < dend.used; j++) { - dend_body[j] = dend.body[j]; - } - for (j = 0; j < isor.used; j++) { - isor_body[j] = isor.body[j]; - } - - // Extend dividend with leading zero. - dend_body[dend.used] = tmp[isor.used] = 0; - - } - else { - carry = 0; - for (j = 0; j < isor.used; j++) { - t = scaleup * isor.body[j] + carry; - isor_body[j] = (byte)(t % B_BASE); - carry = t / B_BASE; - } -#if BIGINTEGER_DEBUG - Debug.Assert (carry == 0); -#endif - - carry = 0; - for (j = 0; j < dend.used; j++) { - t = scaleup * dend.body[j] + carry; - dend_body[j] = (byte)(t % B_BASE); - carry = t / B_BASE; - } - dend_body[dend.used] = (byte)carry; - tmp[isor.used] = 0; - } - - // For each quotient digit ... - for (i = dend.used; i >= isor.used; i--) { -#if BIGINTEGER_DEBUG - Debug.Assert (i-2 >= 0); - Debug.Assert (i <= dend.used); - Debug.Assert (isor.used >= 2); -#endif - -#if BIGINTEGER_DEBUG - Console.WriteLine("\n---------\nqdigit {0}", i ); - Console.Write("dend_body is "); - for (j = dend.used; j>= 0; j--) { - Console.Write("{0} ",dend_body[j]); - } - Console.Write("\n"); -#endif - // Make a guess vh of the quotient digit - vh = (B_BASE*B_BASE*dend_body[i] + B_BASE*dend_body[i-1] + dend_body[i-2]) - / - (B_BASE*isor_body[isor.used-1] + isor_body[isor.used-2]); - if (vh > B_BASE-1) { - vh = B_BASE-1; - } -#if BIGINTEGER_DEBUG - Console.WriteLine("guess formed from {0} {1} {2} {3} {4}", - dend_body[i], dend_body[i-1] , dend_body[i-2], - isor_body[isor.used-1], isor_body[isor.used-2]); - Console.WriteLine("guess is {0}", 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_body[j] + carry; - tmp[j] = (byte)(t % B_BASE); - carry = t / B_BASE; - } - tmp[isor.used] = (byte)carry; - delta = i - isor.used; -#if BIGINTEGER_DEBUG - Console.WriteLine("final carry is {0}", carry); - Console.Write("vh * isor is " ); - for (j = isor.used; j >=0; j--) { - Console.Write("{0} ",tmp[j]);Console.Write("\n"); - } - Console.WriteLine("delta = {0}", delta ); -#endif - toolarge = false; - for (j = isor.used; j >= 0; j--) { -#if BIGINTEGER_DEBUG - Console.Write ( "({0},{1}) ", (int)(tmp[j]), (int)(dend_body[j+delta]) ); -#endif - if (tmp[j] > dend_body[j+delta]) { - toolarge=true; - break; - } - if (tmp[j] < dend_body[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 BIGINTEGER_DEBUG - Console.WriteLine ( "guess too large" ); -#endif - vh--; - carry = 0; - for (j = 0; j < isor.used; j++) { - if (carry + isor_body[j] > tmp[j]) { - tmp[j] = (byte)((B_BASE + tmp[j]) - isor_body[j] - carry); - carry = 1; - } - else { - tmp[j] = (byte)(tmp[j] - isor_body[j] - carry); - carry = 0; - } - } - //if (carry > 0) {pp(isor);pp(dend);}; - //Debug.Assert(carry == 0); - if (carry > 0) { - Debug.Assert(tmp[isor.used] > 0); - tmp[isor.used]--; - } -#if BIGINTEGER_DEBUG - Console.Write("after adjustment of tmp "); - for (j = isor.used; j >=0; j--) { - Console.Write("{0} ",tmp[j]); - } - Console.Write("\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_body[j+delta]) { - dend_body[j+delta] = (byte)((B_BASE+dend_body[j+delta]) - tmp[j] - - carry); - carry = 1; - } - else { - dend_body[j+delta] = (byte)(dend_body[j+delta] - tmp[j] - carry); - carry = 0; - } - } -#if BIGINTEGER_DEBUG - Debug.Assert(carry==0); -#endif - -#if BIGINTEGER_DEBUG - Console.Write("after final sub "); - for(j=dend.used; j>=0; j--) Console.Write("{0} ", dend_body[j]); - Console.Write("\n"); -#endif - - // park vh in the result array -#if DEBUG_SAINTEGER_UDIV - Console.WriteLine("[{0}] <- {1}", i-isor.used, vh ); -#endif - dres.body[i-isor.used] = (byte)vh; - } - } - - // Now we've got all the quotient digits. Zap leading zeroes. - dres.used = dend.used - isor.used + 1; - dres.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(dres.sane()); -#endif - - // The remainder is in dend_body. Copy, divide by the original scaling - // factor, and zap leading zeroes. - mres.used = dend.used; - for (j = 0; j < dend.used; j++) { - mres.body[j] = dend_body[j]; - } - mres.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(mres.sane()); -#endif - - if (scaleup > 1) { - carry = 0; - for (j = mres.used-1; j >= 0; j--) { - carry += mres.body[j]; - mres.body[j] = (byte)(carry/scaleup); - carry = B_BASE*(carry%scaleup); - } -#if BIGINTEGER_DEBUG - Debug.Assert (carry == 0); -#endif - mres.u_renormalise(); -#if BIGINTEGER_DEBUG - Debug.Assert(mres.sane()); -#endif - } - - } - - - // Test framework - -#if BIGINTEGER_DEBUG - public static void Test ( ) { - int i, j, t, k, m; - BigInteger bi, bj, bk, bm; - - BigInteger a, b; - a = new BigInteger(1); - for (int n = 1; n <= 10; n++) { - b = new BigInteger(n); - a *= n; - } - Console.WriteLine("{0}", (double)a); - - for (i = -10007; i <= 10007; i++) { - Console.WriteLine ( "i = {0}", i ); - - bi = new BigInteger(i); - t = (int)bi; - Debug.Assert(i == t); - - for (j = -10007; j <= 10007; j++) { - bj = new BigInteger(j); - t = (int)bj; - Debug.Assert(j == t); - bk = bi + bj; - k = (int)bk; - if (i+j != k) { - bi.ToString(); - bj.ToString(); - bk.ToString(); - Debug.Assert(i + j == k); - } - - bk = bi - bj; - k = (int)bk; - if (i-j != k) { - bi.ToString(); - bj.ToString(); - bk.ToString(); - Debug.Assert(i - j == k); - } - - bk = bi * bj; - k = (int)bk; - if (i*j != k) { - bi.ToString(); - bj.ToString(); - bk.ToString(); - Debug.Assert(i * j == k); - } - - if (j != 0) { - QuotientRemainder(bi, bj, out bk, out bm); - k = (int)bk; - m = (int)bm; - Debug.Assert(k == i / j); - Debug.Assert(m == i % j); - } - } - } - Console.WriteLine("done"); - } -#endif - -} diff --git a/ghc/lib/std/CPUTime.hsc b/ghc/lib/std/CPUTime.hsc deleted file mode 100644 index c34a3cb..0000000 --- a/ghc/lib/std/CPUTime.hsc +++ /dev/null @@ -1,122 +0,0 @@ --- ----------------------------------------------------------------------------- --- $Id: CPUTime.hsc,v 1.13 2001/09/06 15:15:23 sewardj Exp $ --- --- (c) The University of Glasgow, 1995-2001 --- - -module CPUTime - ( - getCPUTime, -- :: IO Integer - cpuTimePrecision -- :: Integer - ) where - -import PrelMarshalAlloc -import PrelMarshalUtils ( toBool ) -import PrelCTypesISO -import PrelCTypes -import PrelStorable -import PrelPtr - -import PrelBase ( Int(..) ) -import PrelByteArr ( ByteArray(..), newIntArray ) -import PrelArrExtra ( unsafeFreezeByteArray ) -import PrelIOBase ( IOException(..) ) -import Ratio - -#include "HsStd.h" - --- ----------------------------------------------------------------------------- --- Computation `getCPUTime' returns the number of picoseconds CPU time --- used by the current program. The precision of this result is --- implementation-dependent. - --- The `cpuTimePrecision' constant is the smallest measurable difference --- in CPU time that the implementation can record, and is given as an --- integral number of picoseconds. - -getCPUTime :: IO Integer -getCPUTime = do - -#if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS) --- getrusage() is right royal pain to deal with when targetting multiple --- versions of Solaris, since some versions supply it in libc (2.3 and 2.5), --- while 2.4 has got it in libucb (I wouldn't be too surprised if it was back --- again in libucb in 2.6..) --- --- Avoid the problem by resorting to times() instead. --- -#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS && ! solaris2_TARGET_OS - allocaBytes (#const sizeof(struct rusage)) $ \ p_rusage -> do - getrusage (#const RUSAGE_SELF) p_rusage - - let ru_utime = (#ptr struct rusage, ru_utime) p_rusage - let ru_stime = (#ptr struct rusage, ru_stime) p_rusage - u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime - u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime - s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime - s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime - - return ((fromIntegral u_sec * 1000000 + fromIntegral u_usec + - fromIntegral s_sec * 1000000 + fromIntegral s_usec) - * 1000000) - -type CRUsage = () -foreign import unsafe getrusage :: CInt -> Ptr CRUsage -> IO CInt -#else -# if defined(HAVE_TIMES) - allocaBytes (#const sizeof(struct tms)) $ \ p_tms -> do - times p_tms - u_ticks <- (#peek struct tms,tms_utime) p_tms :: IO CClock - s_ticks <- (#peek struct tms,tms_stime) p_tms :: IO CClock - return (( (fromIntegral u_ticks + fromIntegral s_ticks) * 1000000000000) - `div` fromIntegral clockTicks) - -type CTms = () -foreign import unsafe times :: Ptr CTms -> IO CClock -# else - ioException (IOError Nothing UnsupportedOperation - "getCPUTime" - "can't get CPU time" - Nothing) -# endif -#endif - -#else /* win32 */ - allocaBytes (#const sizeof(FILETIME)) $ \ p_creationTime -> do - allocaBytes (#const sizeof(FILETIME)) $ \ p_exitTime -> do - allocaBytes (#const sizeof(FILETIME)) $ \ p_kernelTime -> do - allocaBytes (#const sizeof(FILETIME)) $ \ p_userTime -> do - pid <- getCurrentProcess - ok <- getProcessTimes pid p_creationTime p_exitTime p_kernelTime p_userTime - if toBool ok then do - ut <- ft2psecs p_userTime - kt <- ft2psecs p_kernelTime - return (fromIntegral (ut + kt)) - else return 0 - where ft2psecs ft = do - high <- (#peek FILETIME,dwHighDateTime) ft :: IO CLong - low <- (#peek FILETIME,dwLowDateTime) ft :: IO CLong - return (((fromIntegral high) * (2^32) + (fromIntegral low)) * 100000) - - -- ToDo: pin down elapsed times to just the OS thread(s) that - -- are evaluating/managing Haskell code. - -type FILETIME = () -type HANDLE = () --- need proper Haskell names (initial lower-case character) -foreign import "GetCurrentProcess" unsafe getCurrentProcess :: IO (Ptr HANDLE) -foreign import "GetProcessTimes" unsafe getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt - -#endif /* not _WIN32 */ - -cpuTimePrecision :: Integer -cpuTimePrecision = round ((1000000000000::Integer) % fromIntegral (clockTicks)) - -clockTicks :: Int -clockTicks = -#if defined(CLK_TCK) - (#const CLK_TCK) -#else - unsafePerformIO (sysconf (#const _SC_CLK_TCK) >>= return . fromIntegral) -foreign import unsafe sysconf :: CInt -> IO CLong -#endif diff --git a/ghc/lib/std/Char.lhs b/ghc/lib/std/Char.lhs deleted file mode 100644 index 1fbc390..0000000 --- a/ghc/lib/std/Char.lhs +++ /dev/null @@ -1,43 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Char.lhs,v 1.8 2000/12/11 17:51:34 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% -\section[Char]{Module @Char@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module Char - ( - Char - - , isAscii, isLatin1, isControl - , isPrint, isSpace, isUpper - , isLower, isAlpha, isDigit - , isOctDigit, isHexDigit, isAlphaNum -- :: Char -> Bool - - , toUpper, toLower -- :: Char -> Char - - , digitToInt -- :: Char -> Int - , intToDigit -- :: Int -> Char - - , ord -- :: Char -> Int - , chr -- :: Int -> Char - , readLitChar -- :: ReadS Char - , showLitChar -- :: Char -> ShowS - , lexLitChar -- :: ReadS String - - , String - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - ) where - -#ifndef __HUGS__ -import PrelBase -import PrelShow -import PrelRead (readLitChar, lexLitChar, digitToInt) -#else -isLatin1 c = True -#endif -\end{code} diff --git a/ghc/lib/std/Complex.lhs b/ghc/lib/std/Complex.lhs deleted file mode 100644 index b7849d2..0000000 --- a/ghc/lib/std/Complex.lhs +++ /dev/null @@ -1,163 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Complex.lhs,v 1.7 2001/09/19 14:06:03 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Complex]{Module @Complex@} - -\begin{code} -module Complex - ( Complex((:+)) - - , realPart -- :: (RealFloat a) => Complex a -> a - , imagPart -- :: (RealFloat a) => Complex a -> a - , conjugate -- :: (RealFloat a) => Complex a -> Complex a - , mkPolar -- :: (RealFloat a) => a -> a -> Complex a - , cis -- :: (RealFloat a) => a -> Complex a - , polar -- :: (RealFloat a) => Complex a -> (a,a) - , magnitude -- :: (RealFloat a) => Complex a -> a - , phase -- :: (RealFloat a) => Complex a -> a - - -- Complex instances: - -- - -- (RealFloat a) => Eq (Complex a) - -- (RealFloat a) => Read (Complex a) - -- (RealFloat a) => Show (Complex a) - -- (RealFloat a) => Num (Complex a) - -- (RealFloat a) => Fractional (Complex a) - -- (RealFloat a) => Floating (Complex a) - -- - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - - ) where - -import Prelude - -infix 6 :+ -\end{code} - -%********************************************************* -%* * -\subsection{The @Complex@ type} -%* * -%********************************************************* - -\begin{code} -data (RealFloat a) => Complex a = !a :+ !a deriving (Eq, Read, Show) -\end{code} - - -%********************************************************* -%* * -\subsection{Functions over @Complex@} -%* * -%********************************************************* - -\begin{code} -realPart, imagPart :: (RealFloat a) => Complex a -> a -realPart (x :+ _) = x -imagPart (_ :+ y) = y - -{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-} -conjugate :: (RealFloat a) => Complex a -> Complex a -conjugate (x:+y) = x :+ (-y) - -{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-} -mkPolar :: (RealFloat a) => a -> a -> Complex a -mkPolar r theta = r * cos theta :+ r * sin theta - -{-# SPECIALISE cis :: Double -> Complex Double #-} -cis :: (RealFloat a) => a -> Complex a -cis theta = cos theta :+ sin theta - -{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-} -polar :: (RealFloat a) => Complex a -> (a,a) -polar z = (magnitude z, phase z) - -{-# SPECIALISE magnitude :: Complex Double -> Double #-} -magnitude :: (RealFloat a) => Complex a -> a -magnitude (x:+y) = scaleFloat k - (sqrt ((scaleFloat mk x)^(2::Int) + (scaleFloat mk y)^(2::Int))) - where k = max (exponent x) (exponent y) - mk = - k - -{-# SPECIALISE phase :: Complex Double -> Double #-} -phase :: (RealFloat a) => Complex a -> a -phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson -phase (x:+y) = atan2 y x -\end{code} - - -%********************************************************* -%* * -\subsection{Instances of @Complex@} -%* * -%********************************************************* - -\begin{code} -instance (RealFloat a) => Num (Complex a) where - {-# SPECIALISE instance Num (Complex Float) #-} - {-# SPECIALISE instance Num (Complex Double) #-} - (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 - {-# SPECIALISE instance Fractional (Complex Float) #-} - {-# SPECIALISE instance Fractional (Complex Double) #-} - (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 - {-# SPECIALISE instance Floating (Complex Float) #-} - {-# SPECIALISE instance Floating (Complex Double) #-} - 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 = 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)) -\end{code} diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs deleted file mode 100644 index 84effa4..0000000 --- a/ghc/lib/std/Directory.lhs +++ /dev/null @@ -1,568 +0,0 @@ -% ----------------------------------------------------------------------------- -% -% (c) The University of Glasgow, 1994- -% -% The Directory Interface - -A directory contains a series of entries, each of which is a named -reference to a file system object (file, directory etc.). Some -entries may be hidden, inaccessible, or have some administrative -function (e.g. "." or ".." under POSIX), but in this standard all such -entries are considered to form part of the directory contents. -Entries in sub-directories are not, however, considered to form part -of the directory contents. - -Each file system object is referenced by a {\em path}. There is -normally at least one absolute path to each file system object. In -some operating systems, it may also be possible to have paths which -are relative to the current directory. - -\begin{code} -{-# OPTIONS -#include "dirUtils.h" -#include "PrelIOUtils.h" #-} -module Directory - ( - Permissions -- instance of (Eq, Ord, Read, Show) - ( Permissions - , readable -- :: Permissions -> Bool - , writable -- :: Permissions -> Bool - , executable -- :: Permissions -> Bool - , searchable -- :: Permissions -> Bool - ) - - , createDirectory -- :: FilePath -> IO () - , removeDirectory -- :: FilePath -> IO () - , renameDirectory -- :: FilePath -> FilePath -> IO () - - , getDirectoryContents -- :: FilePath -> IO [FilePath] - , getCurrentDirectory -- :: IO FilePath - , setCurrentDirectory -- :: FilePath -> IO () - - , removeFile -- :: FilePath -> IO () - , renameFile -- :: FilePath -> FilePath -> IO () - - , doesFileExist -- :: FilePath -> IO Bool - , doesDirectoryExist -- :: FilePath -> IO Bool - - , getPermissions -- :: FilePath -> IO Permissions - , setPermissions -- :: FilePath -> Permissions -> IO () - - , getModificationTime -- :: FilePath -> IO ClockTime - ) where - -import Prelude -- Just to get it in the dependencies - -import Time ( ClockTime(..) ) - -import PrelPosix -import PrelStorable -import PrelCString -import PrelMarshalAlloc -import PrelCTypesISO -import PrelCTypes -import PrelCError -import PrelPtr -import PrelIOBase -import PrelBase -\end{code} - ------------------------------------------------------------------------------ --- Permissions - -The @Permissions@ type is used to record whether certain -operations are permissible on a file/directory: -[to whom? - presumably the "current user"] - -\begin{code} -data Permissions - = Permissions { - readable, writable, - executable, searchable :: Bool - } deriving (Eq, Ord, Read, Show) -\end{code} - ------------------------------------------------------------------------------ --- Implementation - -@createDirectory dir@ creates a new directory {\em dir} which is -initially empty, or as near to empty as the operating system -allows. - -The operation may fail with: - -\begin{itemize} -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EROFS, EACCES]@ -\item @isAlreadyExistsError@ / @AlreadyExists@ -The operand refers to a directory that already exists. -@ [EEXIST]@ -\item @HardwareFault@ -A physical I/O error has occurred. -@ [EIO]@ -\item @InvalidArgument@ -The operand is not a valid directory name. -@[ENAMETOOLONG, ELOOP]@ -\item @NoSuchThing@ -There is no path to the directory. -@[ENOENT, ENOTDIR]@ -\item @ResourceExhausted@ -Insufficient resources (virtual memory, process file descriptors, -physical disk space, etc.) are available to perform the operation. -@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ -\item @InappropriateType@ -The path refers to an existing non-directory object. -@[EEXIST]@ -\end{itemize} - -\begin{code} -createDirectory :: FilePath -> IO () -createDirectory path = do - withCString path $ \s -> do - throwErrnoIfMinus1Retry_ "createDirectory" $ - mkdir s 0o777 -\end{code} - -@removeDirectory dir@ removes an existing directory {\em dir}. The -implementation may specify additional constraints which must be -satisfied before a directory can be removed (e.g. the directory has to -be empty, or may not be in use by other processes). It is not legal -for an implementation to partially remove a directory unless the -entire directory is removed. A conformant implementation need not -support directory removal in all situations (e.g. removal of the root -directory). - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -[@EIO@] -\item @InvalidArgument@ -The operand is not a valid directory name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExist@ / @NoSuchThing@ -The directory does not exist. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EROFS, EACCES, EPERM]@ -\item @UnsatisfiedConstraints@ -Implementation-dependent constraints are not satisfied. -@[EBUSY, ENOTEMPTY, EEXIST]@ -\item @UnsupportedOperation@ -The implementation does not support removal in this situation. -@[EINVAL]@ -\item @InappropriateType@ -The operand refers to an existing non-directory object. -@[ENOTDIR]@ -\end{itemize} - -\begin{code} -removeDirectory :: FilePath -> IO () -removeDirectory path = do - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeDirectory" (rmdir s) - -\end{code} - -@Removefile file@ removes the directory entry for an existing file -{\em file}, where {\em file} is not itself a directory. The -implementation may specify additional constraints which must be -satisfied before a file can be removed (e.g. the file may not be in -use by other processes). - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @InvalidArgument@ -The operand is not a valid file name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExist@ / @NoSuchThing@ -The file does not exist. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EROFS, EACCES, EPERM]@ -\item @UnsatisfiedConstraints@ -Implementation-dependent constraints are not satisfied. -@[EBUSY]@ -\item @InappropriateType@ -The operand refers to an existing directory. -@[EPERM, EINVAL]@ -\end{itemize} - -\begin{code} -removeFile :: FilePath -> IO () -removeFile path = do - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "removeFile" (unlink s) - -\end{code} - -@renameDirectory@ {\em old} {\em new} changes the name of an existing -directory from {\em old} to {\em new}. If the {\em new} directory -already exists, it is atomically replaced by the {\em old} directory. -If the {\em new} directory is neither the {\em old} directory nor an -alias of the {\em old} directory, it is removed as if by -$removeDirectory$. A conformant implementation need not support -renaming directories in all situations (e.g. renaming to an existing -directory, or across different physical devices), but the constraints -must be documented. - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @InvalidArgument@ -Either operand is not a valid directory name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExistError@ / @NoSuchThing@ -The original directory does not exist, or there is no path to the target. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EROFS, EACCES, EPERM]@ -\item @ResourceExhausted@ -Insufficient resources are available to perform the operation. -@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ -\item @UnsatisfiedConstraints@ -Implementation-dependent constraints are not satisfied. -@[EBUSY, ENOTEMPTY, EEXIST]@ -\item @UnsupportedOperation@ -The implementation does not support renaming in this situation. -@[EINVAL, EXDEV]@ -\item @InappropriateType@ -Either path refers to an existing non-directory object. -@[ENOTDIR, EISDIR]@ -\end{itemize} - -\begin{code} -renameDirectory :: FilePath -> FilePath -> IO () -renameDirectory opath npath = - withFileStatus opath $ \st -> do - is_dir <- isDirectory st - if (not is_dir) - then ioException (IOError Nothing InappropriateType "renameDirectory" - ("not a directory") (Just opath)) - else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameDirectory" (rename s1 s2) - -\end{code} - -@renameFile@ {\em old} {\em new} changes the name of an existing file system -object from {\em old} to {\em new}. If the {\em new} object already -exists, it is atomically replaced by the {\em old} object. Neither -path may refer to an existing directory. A conformant implementation -need not support renaming files in all situations (e.g. renaming -across different physical devices), but the constraints must be -documented. - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @InvalidArgument@ -Either operand is not a valid file name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExistError@ / @NoSuchThing@ -The original file does not exist, or there is no path to the target. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EROFS, EACCES, EPERM]@ -\item @ResourceExhausted@ -Insufficient resources are available to perform the operation. -@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ -\item @UnsatisfiedConstraints@ -Implementation-dependent constraints are not satisfied. -@[EBUSY]@ -\item @UnsupportedOperation@ -The implementation does not support renaming in this situation. -@[EXDEV]@ -\item @InappropriateType@ -Either path refers to an existing directory. -@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ -\end{itemize} - -\begin{code} -renameFile :: FilePath -> FilePath -> IO () -renameFile opath npath = - withFileOrSymlinkStatus opath $ \st -> do - is_dir <- isDirectory st - if is_dir - then ioException (IOError Nothing InappropriateType "renameFile" - "is a directory" (Just opath)) - else do - - withCString opath $ \s1 -> - withCString npath $ \s2 -> - throwErrnoIfMinus1Retry_ "renameFile" (rename s1 s2) - -\end{code} - -@getDirectoryContents dir@ returns a list of {\em all} entries -in {\em dir}. - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @InvalidArgument@ -The operand is not a valid directory name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExistError@ / @NoSuchThing@ -The directory does not exist. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EACCES]@ -\item @ResourceExhausted@ -Insufficient resources are available to perform the operation. -@[EMFILE, ENFILE]@ -\item @InappropriateType@ -The path refers to an existing non-directory object. -@[ENOTDIR]@ -\end{itemize} - -\begin{code} -getDirectoryContents :: FilePath -> IO [FilePath] -getDirectoryContents path = do - alloca $ \ ptr_dEnt -> do - p <- withCString path $ \s -> - throwErrnoIfNullRetry "getDirectoryContents" (opendir s) - loop ptr_dEnt p - where - loop :: Ptr (Ptr CDirent) -> Ptr CDir -> IO [String] - loop ptr_dEnt dir = do - resetErrno - r <- readdir dir ptr_dEnt - if (r == 0) - then do - dEnt <- peek ptr_dEnt - if (dEnt == nullPtr) - then return [] - else do - entry <- (d_name dEnt >>= peekCString) - freeDirEnt dEnt - entries <- loop ptr_dEnt dir - return (entry:entries) - else do errno <- getErrno - if (errno == eINTR) then loop ptr_dEnt dir else do - throwErrnoIfMinus1_ "getDirectoryContents" $ closedir dir - let (Errno eo) = errno - if (eo == end_of_dir) - then return [] - else throwErrno "getDirectoryContents" - -foreign import ccall "prel_end_of_dir" unsafe end_of_dir :: CInt -foreign import ccall "prel_d_name" unsafe d_name :: Ptr CDirent -> IO CString - -\end{code} - -If the operating system has a notion of current directories, -@getCurrentDirectory@ returns an absolute path to the -current directory of the calling process. - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @isDoesNotExistError@ / @NoSuchThing@ -There is no path referring to the current directory. -@[EPERM, ENOENT, ESTALE...]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EACCES]@ -\item @ResourceExhausted@ -Insufficient resources are available to perform the operation. -\item @UnsupportedOperation@ -The operating system has no notion of current directory. -\end{itemize} - -\begin{code} -getCurrentDirectory :: IO FilePath -getCurrentDirectory = do - p <- mallocBytes path_max - go p path_max - where go p bytes = do - p' <- getcwd p (fromIntegral bytes) - if p' /= nullPtr - then do s <- peekCString p' - free p' - return s - else do errno <- getErrno - if errno == eRANGE - then do let bytes' = bytes * 2 - p' <- reallocBytes p bytes' - go p' bytes' - else throwErrno "getCurrentDirectory" - -foreign import ccall "prel_path_max" unsafe path_max :: Int - -\end{code} - -If the operating system has a notion of current directories, -@setCurrentDirectory dir@ changes the current -directory of the calling process to {\em dir}. - -The operation may fail with: -\begin{itemize} -\item @HardwareFault@ -A physical I/O error has occurred. -@[EIO]@ -\item @InvalidArgument@ -The operand is not a valid directory name. -@[ENAMETOOLONG, ELOOP]@ -\item @isDoesNotExistError@ / @NoSuchThing@ -The directory does not exist. -@[ENOENT, ENOTDIR]@ -\item @isPermissionError@ / @PermissionDenied@ -The process has insufficient privileges to perform the operation. -@[EACCES]@ -\item @UnsupportedOperation@ -The operating system has no notion of current directory, or the -current directory cannot be dynamically changed. -\item @InappropriateType@ -The path refers to an existing non-directory object. -@[ENOTDIR]@ -\end{itemize} - -\begin{code} -setCurrentDirectory :: FilePath -> IO () -setCurrentDirectory path = do - withCString path $ \s -> - throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s) - -- ToDo: add path to error - -\end{code} - -To clarify, @doesDirectoryExist@ returns True if a file system object -exist, and it's a directory. @doesFileExist@ returns True if the file -system object exist, but it's not a directory (i.e., for every other -file system object that is not a directory.) - -\begin{code} -doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - catch - (withFileStatus name $ \st -> isDirectory st) - (\ _ -> return False) - -doesFileExist :: FilePath -> IO Bool -doesFileExist name = do - catch - (withFileStatus name $ \st -> do b <- isDirectory st; return (not b)) - (\ _ -> return False) - -getModificationTime :: FilePath -> IO ClockTime -getModificationTime name = - withFileStatus name $ \ st -> - modificationTime st - -getPermissions :: FilePath -> IO Permissions -getPermissions name = do - withCString name $ \s -> do - read <- access s r_OK - write <- access s w_OK - exec <- access s x_OK - withFileStatus name $ \st -> do - is_dir <- isDirectory st - is_reg <- isRegularFile st - return ( - Permissions { - readable = read == 0, - writable = write == 0, - executable = not is_dir && exec == 0, - searchable = not is_reg && exec == 0 - } - ) - -foreign import ccall "prel_R_OK" unsafe r_OK :: CMode -foreign import ccall "prel_W_OK" unsafe w_OK :: CMode -foreign import ccall "prel_X_OK" unsafe x_OK :: CMode - -setPermissions :: FilePath -> Permissions -> IO () -setPermissions name (Permissions r w e s) = do - let - read = if r then s_IRUSR else emptyCMode - write = if w then s_IWUSR else emptyCMode - exec = if e || s then s_IXUSR else emptyCMode - - mode = read `unionCMode` (write `unionCMode` exec) - - withCString name $ \s -> - throwErrnoIfMinus1_ "setPermissions" $ chmod s mode - -foreign import ccall "prel_S_IRUSR" unsafe s_IRUSR :: CMode -foreign import ccall "prel_S_IWUSR" unsafe s_IWUSR :: CMode -foreign import ccall "prel_S_IXUSR" unsafe s_IXUSR :: CMode - -withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a -withFileStatus name f = do - allocaBytes sizeof_stat $ \p -> - withCString name $ \s -> do - throwErrnoIfMinus1Retry_ "withFileStatus" (stat s p) - f p - -withFileOrSymlinkStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a -withFileOrSymlinkStatus name f = do - allocaBytes sizeof_stat $ \p -> - withCString name $ \s -> do - throwErrnoIfMinus1Retry_ "withFileOrSymlinkStatus" (lstat s p) - f p - -modificationTime :: Ptr CStat -> IO ClockTime -modificationTime stat = do - mtime <- st_mtime stat - return (TOD (toInteger (mtime :: CTime)) 0) - -isDirectory :: Ptr CStat -> IO Bool -isDirectory stat = do - mode <- st_mode stat - return (s_ISDIR mode /= 0) - -isRegularFile :: Ptr CStat -> IO Bool -isRegularFile stat = do - mode <- st_mode stat - return (s_ISREG mode /= 0) - -foreign import ccall "prel_s_ISDIR" unsafe s_ISDIR :: CMode -> Int -foreign import ccall "prel_s_ISREG" unsafe s_ISREG :: CMode -> Int - -emptyCMode :: CMode -emptyCMode = 0 - -unionCMode :: CMode -> CMode -> CMode -unionCMode = (+) - -foreign import ccall "prel_mkdir" unsafe mkdir :: CString -> CInt -> IO CInt - -foreign import ccall unsafe chmod :: CString -> CMode -> IO CInt -foreign import ccall unsafe access :: CString -> CMode -> IO CInt -foreign import ccall unsafe rmdir :: CString -> IO CInt -foreign import ccall unsafe chdir :: CString -> IO CInt -foreign import ccall unsafe getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar) -foreign import ccall unsafe unlink :: CString -> IO CInt -foreign import ccall unsafe rename :: CString -> CString -> IO CInt - -foreign import ccall unsafe opendir :: CString -> IO (Ptr CDir) -foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt - -foreign import ccall unsafe stat :: CString -> Ptr CStat -> IO CInt - -foreign import ccall "prel_lstat" unsafe lstat :: CString -> Ptr CStat -> IO CInt -foreign import ccall "prel_readdir" unsafe readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt -foreign import ccall "prel_free_dirent" unsafe freeDirEnt :: Ptr CDirent -> IO () - - -type CDirent = () - -\end{code} diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs deleted file mode 100644 index d078d7b..0000000 --- a/ghc/lib/std/IO.lhs +++ /dev/null @@ -1,94 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: IO.lhs,v 1.44 2001/06/09 07:06:05 qrczak Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[IO]{Module @IO@} - -Implementation of the standard Haskell IO interface, see -@http://haskell.org/onlinelibrary/io.html@ for the official -definition. - -\begin{code} -module IO ( - Handle, -- abstract, instance of: Eq, Show. - HandlePosn(..), -- abstract, instance of: Eq, Show. - - IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), - BufferMode(NoBuffering,LineBuffering,BlockBuffering), - SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), - - stdin, stdout, stderr, -- :: Handle - - openFile, -- :: FilePath -> IOMode -> IO Handle - hClose, -- :: Handle -> IO () - hFileSize, -- :: Handle -> IO Integer - hIsEOF, -- :: Handle -> IO Bool - isEOF, -- :: IO Bool - - hSetBuffering, -- :: Handle -> BufferMode -> IO () - hGetBuffering, -- :: Handle -> IO BufferMode - hFlush, -- :: Handle -> IO () - hGetPosn, -- :: Handle -> IO HandlePosn - hSetPosn, -- :: HandlePosn -> IO () - hSeek, -- :: Handle -> SeekMode -> Integer -> IO () - hWaitForInput, -- :: Handle -> Int -> IO Bool - hReady, -- :: Handle -> IO Bool - hGetChar, -- :: Handle -> IO Char - hGetLine, -- :: Handle -> IO [Char] - hLookAhead, -- :: Handle -> IO Char - hGetContents, -- :: Handle -> IO [Char] - hPutChar, -- :: Handle -> Char -> IO () - hPutStr, -- :: Handle -> [Char] -> IO () - hPutStrLn, -- :: Handle -> [Char] -> IO () - hPrint, -- :: Show a => Handle -> a -> IO () - hIsOpen, hIsClosed, -- :: Handle -> IO Bool - hIsReadable, hIsWritable, -- :: Handle -> IO Bool - hIsSeekable, -- :: Handle -> IO Bool - - isAlreadyExistsError, isDoesNotExistError, -- :: IOError -> Bool - isAlreadyInUseError, isFullError, - isEOFError, isIllegalOperation, - isPermissionError, isUserError, - - ioeGetErrorString, -- :: IOError -> String - ioeGetHandle, -- :: IOError -> Maybe Handle - ioeGetFileName, -- :: IOError -> Maybe FilePath - - try, -- :: IO a -> IO (Either IOError a) - bracket, -- :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c - bracket_, -- :: IO a -> (a -> IO b) -> IO c -> IO c - - -- Non-standard extension (but will hopefully become standard with 1.5) is - -- to export the Prelude io functions via IO (in addition to exporting them - -- from the prelude...for now.) - IO, - FilePath, -- :: String - IOError, - ioError, -- :: IOError -> IO a - userError, -- :: String -> IOError - catch, -- :: IO a -> (IOError -> IO a) -> IO a - interact, -- :: (String -> String) -> IO () - - putChar, -- :: Char -> IO () - putStr, -- :: String -> IO () - putStrLn, -- :: String -> IO () - print, -- :: Show a => a -> IO () - getChar, -- :: IO Char - getLine, -- :: IO String - getContents, -- :: IO String - readFile, -- :: FilePath -> IO String - writeFile, -- :: FilePath -> String -> IO () - appendFile, -- :: FilePath -> String -> IO () - readIO, -- :: Read a => String -> IO a - readLn, -- :: Read a => IO a - - ) where - -import PrelIOBase -- Together these four Prelude modules define -import PrelRead -import PrelHandle -- all the stuff exported by IO for the GHC version -import PrelIO -import PrelException -\end{code} diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs deleted file mode 100644 index f72f915..0000000 --- a/ghc/lib/std/Ix.lhs +++ /dev/null @@ -1,41 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Ix.lhs,v 1.19 2001/08/29 09:34:05 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Ix]{Module @Ix@} - -\begin{code} -module Ix - ( - Ix - ( range -- :: (Ix a) => (a,a) -> [a] - , index -- :: (Ix a) => (a,a) -> a -> Int - , inRange -- :: (Ix a) => (a,a) -> a -> Bool - , rangeSize -- :: (Ix a) => (a,a) -> Int - ) - -- Ix instances: - -- - -- Ix Char - -- Ix Int - -- Ix Integer - -- Ix Bool - -- Ix Ordering - -- Ix () - -- (Ix a, Ix b) => Ix (a, b) - -- ... - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - ) where - -import Prelude -#ifndef __HUGS__ -import PrelArr -#endif --- This module is empty, because Ix is defined in PrelArr. --- Reason: it's needed internally in the Prelude. --- This module serves solely to export it to the user. - -\end{code} - diff --git a/ghc/lib/std/List.lhs b/ghc/lib/std/List.lhs deleted file mode 100644 index 4633099..0000000 --- a/ghc/lib/std/List.lhs +++ /dev/null @@ -1,531 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: List.lhs,v 1.13 2001/08/29 10:12:34 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[List]{Module @List@} - -\begin{code} -module List - ( -#ifndef __HUGS__ - []((:), []) - , -#endif - - elemIndex -- :: (Eq a) => a -> [a] -> Maybe Int - , elemIndices -- :: (Eq a) => a -> [a] -> [Int] - - , find -- :: (a -> Bool) -> [a] -> Maybe a - , findIndex -- :: (a -> Bool) -> [a] -> Maybe Int - , findIndices -- :: (a -> Bool) -> [a] -> [Int] - - , nub -- :: (Eq a) => [a] -> [a] - , nubBy -- :: (a -> a -> Bool) -> [a] -> [a] - - , delete -- :: (Eq a) => a -> [a] -> [a] - , deleteBy -- :: (a -> a -> Bool) -> a -> [a] -> [a] - , (\\) -- :: (Eq a) => [a] -> [a] -> [a] - , deleteFirstsBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] - - , union -- :: (Eq a) => [a] -> [a] -> [a] - , unionBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] - - , intersect -- :: (Eq a) => [a] -> [a] -> [a] - , intersectBy -- :: (a -> a -> Bool) -> [a] -> [a] -> [a] - - , intersperse -- :: a -> [a] -> [a] - , transpose -- :: [[a]] -> [[a]] - , partition -- :: (a -> Bool) -> [a] -> ([a], [a]) - - , group -- :: Eq a => [a] -> [[a]] - , groupBy -- :: (a -> a -> Bool) -> [a] -> [[a]] - - , inits -- :: [a] -> [[a]] - , tails -- :: [a] -> [[a]] - - , isPrefixOf -- :: (Eq a) => [a] -> [a] -> Bool - , isSuffixOf -- :: (Eq a) => [a] -> [a] -> Bool - - , mapAccumL -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) - , mapAccumR -- :: (a -> b -> (a,c)) -> a -> [b] -> (a,[c]) - - , sort -- :: (Ord a) => [a] -> [a] - , sortBy -- :: (a -> a -> Ordering) -> [a] -> [a] - - , insert -- :: (Ord a) => a -> [a] -> [a] - , insertBy -- :: (a -> a -> Ordering) -> a -> [a] -> [a] - - , maximumBy -- :: (a -> a -> Ordering) -> [a] -> a - , minimumBy -- :: (a -> a -> Ordering) -> [a] -> a - - , genericLength -- :: (Integral a) => [b] -> a - , genericTake -- :: (Integral a) => a -> [b] -> [b] - , genericDrop -- :: (Integral a) => a -> [b] -> [b] - , genericSplitAt -- :: (Integral a) => a -> [b] -> ([b], [b]) - , genericIndex -- :: (Integral a) => [b] -> a -> b - , genericReplicate -- :: (Integral a) => a -> b -> [b] - - , unfoldr -- :: (b -> Maybe (a, b)) -> b -> [a] - - , zip4, zip5, zip6, zip7 - , zipWith4, zipWith5, zipWith6, zipWith7 - , unzip4, unzip5, unzip6, unzip7 - - , map -- :: ( a -> b ) -> [a] -> [b] - , (++) -- :: [a] -> [a] -> [a] - , concat -- :: [[a]] -> [a] - , filter -- :: (a -> Bool) -> [a] -> [a] - , head -- :: [a] -> a - , last -- :: [a] -> a - , tail -- :: [a] -> [a] - , init -- :: [a] -> [a] - , null -- :: [a] -> Bool - , length -- :: [a] -> Int - , (!!) -- :: [a] -> Int -> a - , foldl -- :: (a -> b -> a) -> a -> [b] -> a - , foldl1 -- :: (a -> a -> a) -> [a] -> a - , scanl -- :: (a -> b -> a) -> a -> [b] -> [a] - , scanl1 -- :: (a -> a -> a) -> [a] -> [a] - , foldr -- :: (a -> b -> b) -> b -> [a] -> b - , foldr1 -- :: (a -> a -> a) -> [a] -> a - , scanr -- :: (a -> b -> b) -> b -> [a] -> [b] - , scanr1 -- :: (a -> a -> a) -> [a] -> [a] - , iterate -- :: (a -> a) -> a -> [a] - , repeat -- :: a -> [a] - , replicate -- :: Int -> a -> [a] - , cycle -- :: [a] -> [a] - , take -- :: Int -> [a] -> [a] - , drop -- :: Int -> [a] -> [a] - , splitAt -- :: Int -> [a] -> ([a], [a]) - , takeWhile -- :: (a -> Bool) -> [a] -> [a] - , dropWhile -- :: (a -> Bool) -> [a] -> [a] - , span -- :: (a -> Bool) -> [a] -> ([a], [a]) - , break -- :: (a -> Bool) -> [a] -> ([a], [a]) - - , lines -- :: String -> [String] - , words -- :: String -> [String] - , unlines -- :: [String] -> String - , unwords -- :: [String] -> String - , reverse -- :: [a] -> [a] - , and -- :: [Bool] -> Bool - , or -- :: [Bool] -> Bool - , any -- :: (a -> Bool) -> [a] -> Bool - , all -- :: (a -> Bool) -> [a] -> Bool - , elem -- :: a -> [a] -> Bool - , notElem -- :: a -> [a] -> Bool - , lookup -- :: (Eq a) => a -> [(a,b)] -> Maybe b - , sum -- :: (Num a) => [a] -> a - , product -- :: (Num a) => [a] -> a - , maximum -- :: (Ord a) => [a] -> a - , minimum -- :: (Ord a) => [a] -> a - , concatMap -- :: (a -> [b]) -> [a] -> [b] - , zip -- :: [a] -> [b] -> [(a,b)] - , zip3 - , zipWith -- :: (a -> b -> c) -> [a] -> [b] -> [c] - , zipWith3 - , unzip -- :: [(a,b)] -> ([a],[b]) - , unzip3 - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - ) where - -import Prelude -import Maybe ( listToMaybe ) - -#ifndef __HUGS__ -import PrelShow ( lines, words, unlines, unwords ) -import PrelBase ( Int(..), map, (++) ) -import PrelGHC ( (+#) ) -#endif - -infix 5 \\ -\end{code} - -%********************************************************* -%* * -\subsection{List functions} -%* * -%********************************************************* - -\begin{code} -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] - -#ifdef USE_REPORT_PRELUDE -findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] -#else -#ifdef __HUGS__ -findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] -#else --- Efficient definition -findIndices p ls = loop 0# ls - where - loop _ [] = [] - loop n (x:xs) | p x = I# n : loop (n +# 1#) xs - | otherwise = loop (n +# 1#) xs -#endif /* __HUGS__ */ -#endif /* USE_REPORT_PRELUDE */ - -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 - --- nub (meaning "essence") remove duplicate elements from its list argument. -nub :: (Eq a) => [a] -> [a] -#ifdef USE_REPORT_PRELUDE -nub = nubBy (==) -#else --- stolen from HBC -nub l = nub' l [] -- ' - where - nub' [] _ = [] -- ' - nub' (x:xs) ls -- ' - | x `elem` ls = nub' xs ls -- ' - | otherwise = x : nub' xs (x:ls) -- ' -#endif - -nubBy :: (a -> a -> Bool) -> [a] -> [a] -#ifdef USE_REPORT_PRELUDE -nubBy eq [] = [] -nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) -#else -nubBy eq l = nubBy' l [] - where - nubBy' [] _ = [] - nubBy' (y:ys) xs - | elem_by eq y xs = nubBy' ys xs - | otherwise = y : nubBy' ys (y:xs) - --- Not exported: --- Note that we keep the call to `eq` with arguments in the --- same order as in the reference implementation --- 'xs' is the list of things we've seen so far, --- 'y' is the potential new element -elem_by :: (a -> a -> Bool) -> a -> [a] -> Bool -elem_by _ _ [] = False -elem_by eq y (x:xs) = x `eq` y || elem_by eq y xs -#endif - - --- delete x removes the first occurrence of x from its list argument. -delete :: (Eq a) => a -> [a] -> [a] -delete = deleteBy (==) - -deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] -deleteBy _ _ [] = [] -deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys - --- list difference (non-associative). In the result of xs \\ ys, --- the first occurrence of each element of ys in turn (if any) --- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. -(\\) :: (Eq a) => [a] -> [a] -> [a] -(\\) = foldl (flip delete) - --- List union, remove the elements of first list from second. -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 sep inserts sep between the elements of its list argument. --- e.g. intersperse ',' "abcde" == "a,b,c,d,e" -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse _ [x] = [x] -intersperse sep (x:xs) = x : sep : intersperse sep xs - -transpose :: [[a]] -> [[a]] -transpose [] = [] -transpose ([] : xss) = transpose xss -transpose ((x:xs) : xss) = (x : [h | (h:t) <- xss]) : transpose (xs : [ t | (h:t) <- xss]) - - --- partition takes a predicate and a list and returns a pair of lists: --- those elements of the argument list that do and do not satisfy the --- predicate, respectively; i,e,, --- partition p xs == (filter p xs, filter (not . p) xs). -partition :: (a -> Bool) -> [a] -> ([a],[a]) -{-# INLINE partition #-} -partition p xs = foldr (select p) ([],[]) xs - -select p x (ts,fs) | p x = (x:ts,fs) - | otherwise = (ts, x:fs) -\end{code} - -@mapAccumL@ behaves like a combination -of @map@ and @foldl@; -it applies a function to each element of a list, passing an accumulating -parameter from left to right, and returning a final value of this -accumulator together with the new list. - -\begin{code} - -mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list -mapAccumL _ s [] = (s, []) -mapAccumL f s (x:xs) = (s'',y:ys) - where (s', y ) = f s x - (s'',ys) = mapAccumL f s' xs -\end{code} - -@mapAccumR@ does the same, but working from right to left instead. Its type is -the same as @mapAccumL@, though. - -\begin{code} -mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list - -- and accumulator, returning new - -- accumulator and elt of result list - -> acc -- Initial accumulator - -> [x] -- Input list - -> (acc, [y]) -- Final accumulator and result list -mapAccumR _ s [] = (s, []) -mapAccumR f s (x:xs) = (s'', y:ys) - where (s'',y ) = f s' x - (s', ys) = mapAccumR f s xs -\end{code} - -\begin{code} -insert :: Ord a => a -> [a] -> [a] -insert e ls = insertBy (compare) e ls - -insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] -insertBy _ x [] = [x] -insertBy cmp x ys@(y:ys') - = case cmp x y of - GT -> y : insertBy cmp x ys' - _ -> x : ys - -maximumBy :: (a -> a -> Ordering) -> [a] -> a -maximumBy _ [] = error "List.maximumBy: empty list" -maximumBy cmp xs = foldl1 max xs - where - max x y = case cmp x y of - GT -> x - _ -> y - -minimumBy :: (a -> a -> Ordering) -> [a] -> a -minimumBy _ [] = error "List.minimumBy: empty list" -minimumBy cmp xs = foldl1 min xs - where - min x y = case cmp x y of - GT -> y - _ -> x - -genericLength :: (Num i) => [b] -> i -genericLength [] = 0 -genericLength (_:l) = 1 + genericLength l - -genericTake :: (Integral i) => i -> [a] -> [a] -genericTake 0 _ = [] -genericTake _ [] = [] -genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs -genericTake _ _ = error "List.genericTake: negative argument" - -genericDrop :: (Integral i) => i -> [a] -> [a] -genericDrop 0 xs = xs -genericDrop _ [] = [] -genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs -genericDrop _ _ = error "List.genericDrop: negative argument" - -genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) -genericSplitAt 0 xs = ([],xs) -genericSplitAt _ [] = ([],[]) -genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where - (xs',xs'') = genericSplitAt (n-1) xs -genericSplitAt _ _ = error "List.genericSplitAt: negative argument" - - -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 i) => i -> a -> [a] -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)) - ([],[],[],[],[],[],[]) - - - -deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] -deleteFirstsBy eq = foldl (flip (deleteBy eq)) - - --- 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 _ [] = [] -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 - -\end{code} - -%----------------------------------------------------------------------------- -Quick Sort algorithm taken from HBC's QSort library. - -\begin{code} -sort :: (Ord a) => [a] -> [a] -sortBy :: (a -> a -> Ordering) -> [a] -> [a] - -#ifdef USE_REPORT_PRELUDE -sort = sortBy compare -sortBy cmp = foldr (insertBy cmp) [] -#else - -sortBy cmp l = qsort cmp l [] -sort l = qsort compare l [] - --- rest is not exported: - --- qsort is stable and does not concatenate. -qsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -qsort _ [] r = r -qsort _ [x] r = x:r -qsort cmp (x:xs) r = qpart cmp x xs [] [] r - --- qpart partitions and sorts the sublists -qpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] -qpart cmp x [] rlt rge r = - -- rlt and rge are in reverse order and must be sorted with an - -- anti-stable sorting - rqsort cmp rlt (x:rqsort cmp rge r) -qpart cmp x (y:ys) rlt rge r = - case cmp x y of - GT -> qpart cmp x ys (y:rlt) rge r - _ -> qpart cmp x ys rlt (y:rge) r - --- rqsort is as qsort but anti-stable, i.e. reverses equal elements -rqsort :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -rqsort _ [] r = r -rqsort _ [x] r = x:r -rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r - -rqpart :: (a -> a -> Ordering) -> a -> [a] -> [a] -> [a] -> [a] -> [a] -rqpart cmp x [] rle rgt r = - qsort cmp rle (x:qsort cmp rgt r) -rqpart cmp x (y:ys) rle rgt r = - case cmp y x of - GT -> rqpart cmp x ys rle (y:rgt) r - _ -> rqpart cmp x ys (y:rle) rgt r - -#endif /* USE_REPORT_PRELUDE */ -\end{code} - -\begin{verbatim} - unfoldr f' (foldr f z xs) == (z,xs) - - if the following holds: - - f' (f x y) = Just (x,y) - f' z = Nothing -\end{verbatim} - -\begin{code} -unfoldr :: (b -> Maybe (a, b)) -> b -> [a] -unfoldr f b = - case f b of - Just (a,new_b) -> a : unfoldr f new_b - Nothing -> [] -\end{code} diff --git a/ghc/lib/std/Locale.lhs b/ghc/lib/std/Locale.lhs deleted file mode 100644 index 40a2e9f..0000000 --- a/ghc/lib/std/Locale.lhs +++ /dev/null @@ -1,71 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Locale.lhs,v 1.5 2000/06/30 13:39:35 simonmar Exp $ -% -% (c) The University of Glasgow, 1995-2000 -% - -\section[Time]{Haskell 1.4 Locale Library} - - -\begin{code} -module Locale - ( TimeLocale(..) - , defaultTimeLocale - - , iso8601DateFormat - , rfc822DateFormat - ) -where - -import Prelude -- so as to force recompilations when reqd. - -data TimeLocale = TimeLocale { - wDays :: [(String, String)], -- full and abbreviated week days - months :: [(String, String)], -- full and abbreviated months - intervals :: [(String, String)], - amPm :: (String, String), -- AM/PM symbols - dateTimeFmt, dateFmt, -- formatting strings - timeFmt, time12Fmt :: String - } deriving (Eq, Ord, Show) - -defaultTimeLocale :: TimeLocale -defaultTimeLocale = TimeLocale { - wDays = [("Sunday", "Sun"), ("Monday", "Mon"), - ("Tuesday", "Tue"), ("Wednesday", "Wed"), - ("Thursday", "Thu"), ("Friday", "Fri"), - ("Saturday", "Sat")], - - months = [("January", "Jan"), ("February", "Feb"), - ("March", "Mar"), ("April", "Apr"), - ("May", "May"), ("June", "Jun"), - ("July", "Jul"), ("August", "Aug"), - ("September", "Sep"), ("October", "Oct"), - ("November", "Nov"), ("December", "Dec")], - - intervals = [ ("year","years") - , ("month", "months") - , ("day","days") - , ("hour","hours") - , ("min","mins") - , ("sec","secs") - , ("usec","usecs") - ], - - amPm = ("AM", "PM"), - dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", - dateFmt = "%m/%d/%y", - timeFmt = "%H:%M:%S", - time12Fmt = "%I:%M:%S %p" - } - - -iso8601DateFormat :: Maybe String -> String -iso8601DateFormat timeFmt = - "%Y-%m-%d" ++ case timeFmt of - Nothing -> "" -- normally, ISO-8601 just defines YYYY-MM-DD - Just fmt -> ' ' : fmt -- but we can add a time spec - - -rfc822DateFormat :: String -rfc822DateFormat = "%a, %_d %b %Y %H:%M:%S %Z" -\end{code} diff --git a/ghc/lib/std/Makefile b/ghc/lib/std/Makefile deleted file mode 100644 index fe93463..0000000 --- a/ghc/lib/std/Makefile +++ /dev/null @@ -1,211 +0,0 @@ -################################################################################# -# -# ghc/lib/std/Makefile -# -# Makefile for building the GHC Prelude libraries umpteen ways -# -# -################################################################################# - -TOP = ../.. -include $(TOP)/mk/boilerplate.mk - -WAYS=$(GhcLibWays) - - -ifeq "$(way)" "" -SUBDIRS = cbits -else -SUBDIRS= -endif - -#----------------------------------------------------------------------------- -# Setting the standard variables -# - -HC = $(GHC_INPLACE) - -# *** THIS WON'T WORK ANY MORE *** (PACKAGE is now set in fptools/mk/target.mk) -ifeq "$(DLLized)" "YES" -# Hack by SPJ to delay if-then-else until the pattern rule when we have $* -PACKAGE = $(subst ~, ,$(word $(words dummy $(findstring $(notdir $*), PrelMain )), -package-name~std)) -endif - -PACKAGE = std - -ALL_SRCS += PrelPrimopWrappers.hs -CLEAN_FILES += PrelPrimopWrappers.hs - -#----------------------------------------------------------------------------- -# Setting the GHC compile options - -# -fvia-C added because NCG still can't cope with some primops used in the standard library -SRC_HC_OPTS += -fvia-C -cpp -fglasgow-exts $(GhcLibHcOpts) -SRC_HSC2HS_OPTS += -Icbits - -ifdef USE_REPORT_PRELUDE -SRC_HC_OPTS += -DUSE_REPORT_PRELUDE=1 -endif - -# ESSENTIAL, for getting reasonable performance from the I/O library: -PrelIOBase_HC_OPTS = -funbox-strict-fields - -# debugging... -PrelIOBase_HC_OPTS += -fno-ignore-asserts -PrelHandle_HC_OPTS += -fno-ignore-asserts -PrelIO_HC_OPTS += -fno-ignore-asserts - -# Special options -PrelStorable_HC_OPTS = -monly-3-regs -PrelCError_HC_OPTS = +RTS -K4m -RTS -PrelPArr_HC_OPTS = -fparr - -#----------------------------------------------------------------------------- -# Dependency generation - -SRC_MKDEPENDHS_OPTS += -I$(GHC_INCLUDE_DIR) - -#----------------------------------------------------------------------------- -# Pre-processing (.pp) files -SRC_CPP_OPTS += -I$(GHC_INCLUDE_DIR) -traditional -SRC_CPP_OPTS += ${GhcLibCppOpts} - -#----------------------------------------------------------------------------- -# Rules - -PrelPrimopWrappers.hs: ../../compiler/prelude/primops.txt - rm -f $@ - ../../utils/genprimopcode/genprimopcode --make-haskell-wrappers < $< > $@ - -PrelGHC.$(way_)hi : PrelGHC.hi-boot - cp $< $@ - -boot :: PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi) - -ifneq "$(BootingFromHc)" "YES" -boot :: PrelPrimopWrappers.hs -all :: PrelPrimopWrappers.hs -endif - -DLL_DESCRIPTION="GHC-compiled Haskell Prelude" - -CLEAN_FILES += PrelGHC.hi-boot PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi) - -#----------------------------------------------------------------------------- -# Building the library for GHCi -# -# The procedure differs from that in fptools/mk/target.mk in one way: -# (*) on Win32 we must split it into two, because a single .o file can't -# have more than 65536 relocations in it. -# - -GHCI_LIBOBJS = $(HS_OBJS) - -# Turn off standard rule which creates HSstd.o from LIBOBJS. -DONT_WANT_STD_GHCI_LIB_RULE=YES - -ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -# Standard rule -HSstd.o : $(GHCI_LIBOBJS) - $(LD) -r -x -o $@ $(GHCI_LIBOBJS) - -else -# Rule for Win32 platform -# Keep HSstd.o as a pseudo-target (I think) - -HSstd.o : $(GHCI_LIBOBJS) - $(LD) -r -x -o HSstd1.o $(filter Prel%, $(GHCI_LIBOBJS)) - $(LD) -r -x -o HSstd2.o $(filter-out Prel%, $(GHCI_LIBOBJS)) - @touch HSstd.o - -INSTALL_LIBS += HSstd1.o HSstd2.o -endif # TARGETPLATFORM = i386-unknown-mingw32 - - -#----------------------------------------------------------------------------- -# Installation; need to install .hi files as well as libraries -# -# The interface files are put inside the $(libdir), since they -# might (potentially) be platform specific.. -# -# override is used here because for binary distributions, datadir is -# set on the command line. sigh. -# -override datadir:=$(libdir)/imports/std - -# -# Files to install from here -# - -INSTALL_DATAS += PrelGHC.$(way_)hi - - - -#----------------------------------------------------------------------------- -# ILX stuff. PLEASE IGNORE THIS UNLESS YOU'RE WORKING ON GHC.NET - -ilxstd: - $(MAKE) way=i std.dll std.i_vlb -# $(MAKE) way=ilx-Onot-mono std.ilx-Onot.mono.dll std.ilx-Onot.mono.vlb -# $(MAKE) way=ilx-O-mono std.ilx-O.mono.dll std.ilx-O.mono.vlb -# $(MAKE) way=ilx-Onot-generic std.ilx-Onot.generic.dll -# $(MAKE) way=ilx-O-generic std.ilx-O.generic.dll -# $(MAKE) way=ilx-Onot-mono-traced std.ilx-Onot.mono.dll std.ilx-Onot.mono-traced.vlb -# $(MAKE) way=ilx-O-mono-traced std.ilx-O.mono.dll std.ilx-O.mono-traced.vlb -# $(MAKE) way=ilx-Onot-generic-traced std.ilx-Onot.generic-traced.dll -# $(MAKE) way=ilx-O-generic-traced std.ilx-O.generic-traced.dll -# $(MAKE) way=ilx-Onot-mono-verifiable std.ilx-Onot.mono-verifiable.dll std.ilx-Onot.mono-verifiable.vlb -# $(MAKE) way=ilx-O-mono-verifiable std.ilx-O.mono-verifiable.dll std.ilx-O.mono-verifiable.vlb - -ilxcheck: -# (cd //c/devel/fcom/src; make) -# (cd ../../compiler; make) - $(MAKE) way=ilx-Onot-mono std.ilx-Onot.mono.mvl - $(MAKE) way=ilx-O-mono std.ilx-O.mono.mvl - $(MAKE) way=ilx-Onot-mono-verifiable std.ilx-Onot.mono-verifiable.mvl - $(MAKE) way=ilx-O-mono-verifiable std.ilx-O.mono-verifiable.mvl - $(MAKE) way=ilx-Onot-mono-verifiable std.ilx-Onot.mono-verifiable.mvr - $(MAKE) way=ilx-O-mono-verifiable std.ilx-O.mono-verifiable.mvr - - -ifeq "$(ILXized)" "YES" - -SRC_HC_OPTS += -optI--assembly-name -optIstd.$(way_)o -optI--module -DILX -keep-il-file - -HS_ILX+=PrelGHC.$(way_)o - -PrelGHC.ilx: PrelGHC.ilx.pp - $(CP) $< $@ - -PrelGHC.il: PrelGHC.ilx -# sed -e "s/'PrelBase.dll'/'PrelBase.$(way_)o'/g" $< > $@.tmp - $(ILX2IL) --module --assembly-name std.dll --add-suffix-to-assembly msilxlib --suffix-to-add .mono -o $@ $< -# mv $@.tmp $@ - -PrelGHC.$(way_)o: PrelGHC.il - $(ILASM) /QUIET /DLL /OUT=$@ $< - -std.$(way_)mvl: $(HS_IL) PrelGHC.$(way_)o - ((ILSDK_HOME=c:\\devel\\fcom $(ILVALID) c:\\devel\\fcom\\bin\\msilxlib.mono.ilo std.dll $(HS_IL)) 2>&1) | tee $@ -# .mono should be $(ilx2il_suffix), but that doesn't work at the moment - -std.$(way_)vlb: std.dll - mkvlb.exe -V -o $@.tmp std - cmd /c tmp.bat - mv $@.tmp $@ - -MINI_IL=PrelBase.ilx-Onot.mono.il Prelude.ilx-Onot.mono.il PrelGHC.ilx-Onot.mono.il PrelPrimopWrappers.ilx-Onot.mono.il PrelErr.ilx-Onot.mono.il PrelIOBase.ilx-Onot.mono.il PrelTup.ilx-Onot.mono.il PrelShow.ilx-Onot.mono.il PrelList.ilx-Onot.mono.il PrelPtr.ilx-Onot.mono.il PrelMaybe.ilx-Onot.mono.il PrelPack.ilx-Onot.mono.il PrelST.ilx-Onot.mono.il PrelByteArr.ilx-Onot.mono.il PrelArr.ilx-Onot.mono.il PrelNum.ilx-Onot.mono.il PrelEnum.ilx-Onot.mono.il PrelFloat.ilx-Onot.mono.il PrelReal.ilx-Onot.mono.il PrelConc.ilx-Onot.mono.il -mini.mvl: $(MINI_IL) - ((ILSDK_HOME=c:\\devel\\fcom $(ILVALID) c:\\devel\\fcom\\bin\\msilxlib$(ilx2il_suffix).ilo $(MINI_IL)) 2>&1) | tee $@ - - -std.$(ilx_way).mvlx: $(HS_ILX) - ILSDK_HOME=c:\\devel\\fcom $(ILVALID) c:\\devel\\fcom\\bin\\msilxlib.ilo $(HS_ILX) | tee $@ - -endif # ILXized - -# End ILX stuff. -#----------------------------------------------------------------------------- - - -include $(TOP)/mk/target.mk diff --git a/ghc/lib/std/Maybe.lhs b/ghc/lib/std/Maybe.lhs deleted file mode 100644 index 61b9c12..0000000 --- a/ghc/lib/std/Maybe.lhs +++ /dev/null @@ -1,86 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Maybe.lhs,v 1.5 2000/06/30 13:39:35 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Maybe]{Module @Maybe@} - -The standard Haskell 1.3 library for working with -@Maybe@ values. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module Maybe - ( - Maybe(Nothing,Just) - -- instance of: Eq, Ord, Show, Read, - -- Functor, Monad, MonadPlus - - , maybe -- :: b -> (a -> b) -> Maybe a -> b - - , isJust -- :: Maybe a -> Bool - , isNothing -- :: Maybe a -> Bool - , fromJust -- :: Maybe a -> a - , fromMaybe -- :: a -> Maybe a -> a - , listToMaybe -- :: [a] -> Maybe a - , maybeToList -- :: Maybe a -> [a] - , catMaybes -- :: [Maybe a] -> [a] - , mapMaybe -- :: (a -> Maybe b) -> [a] -> [b] - - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - ) where - -#ifndef __HUGS__ -import PrelErr ( error ) -import PrelList -import PrelMaybe -import PrelBase -#endif -\end{code} - - -%********************************************************* -%* * -\subsection{Functions} -%* * -%********************************************************* - -\begin{code} -isJust :: Maybe a -> Bool -isJust Nothing = False -isJust _ = True - -isNothing :: Maybe a -> Bool -isNothing Nothing = True -isNothing _ = False - -fromJust :: Maybe a -> a -fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck -fromJust (Just x) = x - -fromMaybe :: a -> Maybe a -> a -fromMaybe d x = case x of {Nothing -> d;Just v -> v} - -maybeToList :: Maybe a -> [a] -maybeToList Nothing = [] -maybeToList (Just x) = [x] - -listToMaybe :: [a] -> Maybe a -listToMaybe [] = Nothing -listToMaybe (a:_) = Just a - -catMaybes :: [Maybe a] -> [a] -catMaybes ls = [x | Just x <- ls] - -mapMaybe :: (a -> Maybe b) -> [a] -> [b] -mapMaybe _ [] = [] -mapMaybe f (x:xs) = - let rs = mapMaybe f xs in - case f x of - Nothing -> rs - Just r -> r:rs - -\end{code} - diff --git a/ghc/lib/std/Monad.lhs b/ghc/lib/std/Monad.lhs deleted file mode 100644 index 3d491c2..0000000 --- a/ghc/lib/std/Monad.lhs +++ /dev/null @@ -1,178 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Monad.lhs,v 1.13 2001/05/18 16:54:05 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Monad]{Module @Monad@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module Monad - ( MonadPlus ( -- class context: Monad - mzero -- :: (MonadPlus m) => m a - , mplus -- :: (MonadPlus m) => m a -> m a -> m a - ) - , join -- :: (Monad m) => m (m a) -> m a - , guard -- :: (MonadPlus m) => Bool -> m () - , when -- :: (Monad m) => Bool -> m () -> m () - , unless -- :: (Monad m) => Bool -> m () -> m () - , ap -- :: (Monad m) => m (a -> b) -> m a -> m b - , msum -- :: (MonadPlus m) => [m a] -> m a - , filterM -- :: (Monad m) => (a -> m Bool) -> [a] -> m [a] - , mapAndUnzipM -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) - , zipWithM -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] - , zipWithM_ -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () - , foldM -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a - - , liftM -- :: (Monad m) => (a -> b) -> (m a -> m b) - , liftM2 -- :: (Monad m) => (a -> b -> c) -> (m a -> m b -> m c) - , liftM3 -- :: ... - , liftM4 -- :: ... - , liftM5 -- :: ... - - , Monad((>>=), (>>), return, fail) - , Functor(fmap) - - , mapM -- :: (Monad m) => (a -> m b) -> [a] -> m [b] - , mapM_ -- :: (Monad m) => (a -> m b) -> [a] -> m () - , sequence -- :: (Monad m) => [m a] -> m [a] - , sequence_ -- :: (Monad m) => [m a] -> m () - , (=<<) -- :: (Monad m) => (a -> m b) -> m a -> m b - ) where - -import PrelList -import PrelMaybe -import PrelBase - -infixr 1 =<< -\end{code} - -%********************************************************* -%* * -\subsection{Prelude monad functions} -%* * -%********************************************************* - -\begin{code} -{-# SPECIALISE (=<<) :: (a -> [b]) -> [a] -> [b] #-} -(=<<) :: Monad m => (a -> m b) -> m a -> m b -f =<< x = x >>= f - -sequence :: Monad m => [m a] -> m [a] -{-# INLINE sequence #-} -sequence ms = foldr k (return []) ms - where - k m m' = do { x <- m; xs <- m'; return (x:xs) } - -sequence_ :: Monad m => [m a] -> m () -{-# INLINE sequence_ #-} -sequence_ ms = foldr (>>) (return ()) ms - -mapM :: Monad m => (a -> m b) -> [a] -> m [b] -{-# INLINE mapM #-} -mapM f as = sequence (map f as) - -mapM_ :: Monad m => (a -> m b) -> [a] -> m () -{-# INLINE mapM_ #-} -mapM_ f as = sequence_ (map f as) -\end{code} - -%********************************************************* -%* * -\subsection{Monadic classes: @MonadPlus@} -%* * -%********************************************************* - - -\begin{code} -class Monad m => MonadPlus m where - mzero :: m a - mplus :: m a -> m a -> m a - -instance MonadPlus [] where - mzero = [] - mplus = (++) - -instance MonadPlus Maybe where - mzero = Nothing - - Nothing `mplus` ys = ys - xs `mplus` _ys = xs -\end{code} - - -%********************************************************* -%* * -\subsection{Functions mandated by the Prelude} -%* * -%********************************************************* - -\begin{code} -guard :: (MonadPlus m) => Bool -> m () -guard True = return () -guard False = mzero - --- This subsumes the list-based filter function. - -filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a] -filterM _ [] = return [] -filterM p (x:xs) = do - flg <- p x - ys <- filterM p xs - return (if flg then x:ys else ys) - --- This subsumes the list-based concat function. - -msum :: MonadPlus m => [m a] -> m a -{-# INLINE msum #-} -msum = foldr mplus mzero -\end{code} - - -%********************************************************* -% * -\subsection{Other monad functions} -%* * -%********************************************************* - -\begin{code} -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 = sequence (map f xs) >>= return . unzip - -zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWithM f xs ys = sequence (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 _ a [] = return a -foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs - -unless :: (Monad m) => Bool -> m () -> m () -unless p s = if p then return () else s - -when :: (Monad m) => Bool -> m () -> m () -when p s = if p then s else return () - -ap :: (Monad m) => m (a -> b) -> m a -> m b -ap = liftM2 id - -liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r -liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r -liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r -liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r -liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r - -liftM f m1 = do { x1 <- m1; return (f x1) } -liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } -liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } -liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } -liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } - -\end{code} diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs deleted file mode 100644 index 777f431..0000000 --- a/ghc/lib/std/Numeric.lhs +++ /dev/null @@ -1,372 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: Numeric.lhs,v 1.14 2002/02/01 11:31:27 simonmar Exp $ -% -% (c) The University of Glasgow, 1997-2000 -% - -\section[Numeric]{Numeric interface} - -Odds and ends, mostly functions for reading and showing -\tr{RealFloat}-like kind of values. - - -\begin{code} -module Numeric - - ( fromRat -- :: (RealFloat a) => Rational -> a - , showSigned -- :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS - , readSigned -- :: (Real a) => ReadS a -> ReadS a - - , readInt -- :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a - , readDec -- :: (Integral a) => ReadS a - , readOct -- :: (Integral a) => ReadS a - , readHex -- :: (Integral a) => ReadS a - - , 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 - , readFloat -- :: (RealFloat a) => ReadS a - - , showInt -- :: Integral a => a -> ShowS - , showIntAtBase -- :: Integral a => a -> (a -> Char) -> a -> ShowS - , showHex -- :: Integral a => a -> ShowS - , showOct -- :: Integral a => a -> ShowS - , showBin -- :: Integral a => a -> ShowS - - , floatToDigits -- :: (RealFloat a) => Integer -> a -> ([Int], Int) - , lexDigits -- :: ReadS String - ) where - -import Char - -#ifndef __HUGS__ - -- GHC imports -import Prelude -- For dependencies -import PrelBase ( Char(..), unsafeChr ) -import PrelRead -- Lots of things -import PrelReal ( showSigned ) -import PrelFloat ( fromRat, FFFormat(..), - formatRealFloat, floatToDigits, showFloat - ) -#else - -- Hugs imports -import Array -#endif - -\end{code} - -#ifndef __HUGS__ - -\begin{code} -showInt :: Integral a => a -> ShowS -showInt n cs - | n < 0 = error "Numeric.showInt: can't show negative numbers" - | otherwise = go n cs - where - go n cs - | n < 10 = case unsafeChr (ord '0' + fromIntegral n) of - c@(C# _) -> c:cs - | otherwise = case unsafeChr (ord '0' + fromIntegral r) of - c@(C# _) -> go q (c:cs) - where - (q,r) = n `quotRem` 10 -\end{code} - -Controlling the format and precision of floats. The code that -implements the formatting itself is in @PrelNum@ to avoid -mutual module deps. - -\begin{code} -{-# SPECIALIZE showEFloat :: - Maybe Int -> Float -> ShowS, - Maybe Int -> Double -> ShowS #-} -{-# SPECIALIZE showFFloat :: - Maybe Int -> Float -> ShowS, - Maybe Int -> Double -> ShowS #-} -{-# SPECIALIZE showGFloat :: - Maybe Int -> Float -> ShowS, - Maybe Int -> Double -> ShowS #-} - -showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS -showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS -showGFloat :: (RealFloat a) => Maybe Int -> 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) -\end{code} - -\begin{code} -showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS -showIntAtBase base toChr n r - | n < 0 = error ("NumExts.showIntAtBase: applied to negative number " ++ show n) - | otherwise = - case quotRem n base of { (n', d) -> - let c = toChr d in - c `seq` -- stricter than necessary - let - r' = c : r - in - if n' == 0 then r' else showIntAtBase base toChr n' r' - } - -showHex :: Integral a => a -> ShowS -showHex n r = - showString "0x" $ - showIntAtBase 16 (toChrHex) n r - where - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'a' + fromIntegral (d - 10)) - -showOct :: Integral a => a -> ShowS -showOct n r = - showString "0o" $ - showIntAtBase 8 (toChrOct) n r - where toChrOct d = chr (ord '0' + fromIntegral d) - -showBin :: Integral a => a -> ShowS -showBin n r = - showString "0b" $ - showIntAtBase 2 (toChrOct) n r - where toChrOct d = chr (ord '0' + fromIntegral d) -\end{code} - -#else - -%********************************************************* -%* * - All of this code is for Hugs only - GHC gets it from PrelFloat! -%* * -%********************************************************* - -\begin{code} --- 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 = - if p <= minExp then - (x, p) - else if x >= xMax then - scaleRat b minExp xMin xMax (p+1) (x/b) - else if x < xMin then - scaleRat b minExp xMin xMax (p-1) (x*b) - else - (x, p) - --- Exponentiation with a cache for the most common numbers. -minExpt = 0::Int -maxExpt = 1100::Int -expt :: Integer -> Int -> Integer -expt base n = - if base == 2 && n >= minExpt && n <= maxExpt then - expts!n - else - base^n - -expts :: Array Int Integer -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 :: Integer -> Integer -> 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 :: Integer -> 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 - -showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS -showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS -showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS -showFloat :: (RealFloat a) => a -> ShowS - -showEFloat d x = showString (formatRealFloat FFExponent d x) -showFFloat d x = showString (formatRealFloat FFFixed d x) -showGFloat d x = showString (formatRealFloat FFGeneric d x) -showFloat = showGFloat Nothing - --- These are the format types. This type is not exported. - -data FFFormat = FFExponent | FFFixed | FFGeneric - -formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String -formatRealFloat fmt decs x = s - where base = 10 - s = if isNaN x then - "NaN" - else if isInfinite x then - if x < 0 then "-Infinity" else "Infinity" - else if x < 0 || isNegativeZero x then - '-' : doFmt fmt (floatToDigits (toInteger base) (-x)) - else - doFmt fmt (floatToDigits (toInteger base) x) - doFmt fmt (is, e) = - let ds = map intToDigit is - in case fmt of - FFGeneric -> - doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) - (is, e) - FFExponent -> - case decs of - Nothing -> - case ds of - ['0'] -> "0.0e0" - [d] -> d : ".0e" ++ show (e-1) - d:ds -> d : '.' : ds ++ 'e':show (e-1) - Just dec -> - let dec' = max dec 1 in - case is of - [0] -> '0':'.':take dec' (repeat '0') ++ "e0" - _ -> - let (ei, is') = roundTo base (dec'+1) is - d:ds = map intToDigit - (if ei > 0 then init is' else is') - in d:'.':ds ++ "e" ++ show (e-1+ei) - FFFixed -> - case decs of - Nothing -> - let f 0 s ds = mk0 s ++ "." ++ mk0 ds - f n s "" = f (n-1) (s++"0") "" - f n s (d:ds) = f (n-1) (s++[d]) ds - mk0 "" = "0" - mk0 s = s - in f e "" ds - Just dec -> - let dec' = max dec 0 in - if e >= 0 then - let (ei, is') = roundTo base (dec' + e) is - (ls, rs) = splitAt (e+ei) (map intToDigit is') - in (if null ls then "0" else ls) ++ - (if null rs then "" else '.' : rs) - else - let (ei, is') = roundTo base dec' - (replicate (-e) 0 ++ is) - d : ds = map intToDigit - (if ei > 0 then is' else 0:is') - in d : '.' : ds - -roundTo :: Int -> Int -> [Int] -> (Int, [Int]) -roundTo base d is = case f d is of - (0, is) -> (0, is) - (1, is) -> (1, 1 : is) - where b2 = base `div` 2 - f n [] = (0, replicate n 0) - f 0 (i:_) = (if i >= b2 then 1 else 0, []) - f d (i:is) = - let (c, ds) = f (d-1) is - i' = c + i - in if i' == base then (1, 0:ds) else (0, i':ds) - --- --- Based on "Printing Floating-Point Numbers Quickly and Accurately" --- by R.G. Burger and R. K. Dybvig, in PLDI 96. --- This version uses a much slower logarithm estimator. It should be improved. - --- This function returns a list of digits (Ints in [0..base-1]) and an --- exponent. - -floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) - -floatToDigits _ 0 = ([0], 0) -floatToDigits base x = - let (f0, e0) = decodeFloat x - (minExp0, _) = floatRange x - p = floatDigits x - b = floatRadix x - minExp = minExp0 - p -- the real minimum exponent - -- Haskell requires that f be adjusted so denormalized numbers - -- will have an impossibly low exponent. Adjust for this. - (f, e) = let n = minExp - e0 - in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) - - (r, s, mUp, mDn) = - if e >= 0 then - let be = b^e in - if f == b^(p-1) then - (f*be*b*2, 2*b, be*b, b) - else - (f*be*2, 2, be, be) - else - if e > minExp && f == b^(p-1) then - (f*b*2, b^(-e+1)*2, b, 1) - else - (f*2, b^(-e)*2, 1, 1) - k = - let k0 = - 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)) + - fromIntegral e * log (fromInteger b)) / - log (fromInteger base)) - 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 fromIntegral (reverse rds), k) -\end{code} -#endif diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs deleted file mode 100644 index d714ff9..0000000 --- a/ghc/lib/std/PrelArr.lhs +++ /dev/null @@ -1,609 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelArr.lhs,v 1.30 2001/09/13 15:54:43 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelArr]{Module @PrelArr@} - -Array implementation, @PrelArr@ exports the basic array -types and operations. - -For byte-arrays see @PrelByteArr@. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelArr where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelEnum -import PrelNum -import PrelST -import PrelBase -import PrelList -import PrelShow - -infixl 9 !, // - -default () -\end{code} - - -%********************************************************* -%* * -\subsection{The @Ix@ class} -%* * -%********************************************************* - -\begin{code} -class (Ord a) => Ix a where - range :: (a,a) -> [a] - index, unsafeIndex :: (a,a) -> a -> Int - inRange :: (a,a) -> a -> Bool - rangeSize :: (a,a) -> Int - unsafeRangeSize :: (a,a) -> Int - - -- Must specify one of index, unsafeIndex - index b i | inRange b i = unsafeIndex b i - | otherwise = error "Error in array index" - unsafeIndex b i = index b i - - -- As long as you don't override the default rangeSize, - -- you can specify unsafeRangeSize as follows, to speed up - -- some operations: - -- - -- unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -- - rangeSize b@(_l,h) | inRange b h = unsafeIndex b h + 1 - | otherwise = 0 - unsafeRangeSize b = rangeSize b -\end{code} - -Note that the following is NOT right - rangeSize (l,h) | l <= h = index b h + 1 - | otherwise = 0 - -Because it might be the case that l (a,a) -> a -> String -> b -indexError rng i tp - = error (showString "Ix{" . showString tp . showString "}.index: Index " . - showParen True (showsPrec 0 i) . - showString " out of range " $ - showParen True (showsPrec 0 rng) "") - ----------------------------------------------------------------------- -instance Ix Char where - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = fromEnum i - fromEnum m - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Char" - - inRange (m,n) i = m <= i && i <= n - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance Ix Int where - {-# INLINE range #-} - -- The INLINE stops the build in the RHS from getting inlined, - -- so that callers can fuse with the result of range - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = i - m - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Int" - - {-# INLINE inRange #-} - inRange (I# m,I# n) (I# i) = m <=# i && i <=# n - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance Ix Integer where - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (m,_n) i = fromInteger (i - m) - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Integer" - - inRange (m,n) i = m <= i && i <= n - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance Ix Bool where -- as derived - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (l,_) i = fromEnum i - fromEnum l - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Bool" - - inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance Ix Ordering where -- as derived - {-# INLINE range #-} - range (m,n) = [m..n] - - {-# INLINE unsafeIndex #-} - unsafeIndex (l,_) i = fromEnum i - fromEnum l - - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Ordering" - - inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance Ix () where - {-# INLINE range #-} - range ((), ()) = [()] - {-# INLINE unsafeIndex #-} - unsafeIndex ((), ()) () = 0 - {-# INLINE inRange #-} - inRange ((), ()) () = True - {-# INLINE index #-} - index b i = unsafeIndex b i - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ----------------------------------------------------------------------- -instance (Ix a, Ix b) => Ix (a, b) where -- as derived - {-# SPECIALISE instance Ix (Int,Int) #-} - - {- INLINE range #-} - range ((l1,l2),(u1,u2)) = - [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] - - {- INLINE unsafeIndex #-} - unsafeIndex ((l1,l2),(u1,u2)) (i1,i2) = - unsafeIndex (l1,u1) i1 * unsafeRangeSize (l2,u2) + unsafeIndex (l2,u2) i2 - - {- INLINE inRange #-} - inRange ((l1,l2),(u1,u2)) (i1,i2) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - - -- Default method for index - ----------------------------------------------------------------------- -instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where - {-# SPECIALISE instance Ix (Int,Int,Int) #-} - - range ((l1,l2,l3),(u1,u2,u3)) = - [(i1,i2,i3) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3)] - - unsafeIndex ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1)) - - inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - - -- Default method for index - ----------------------------------------------------------------------- -instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where - range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = - [(i1,i2,i3,i4) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4)] - - unsafeIndex ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1))) - - inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - - -- Default method for index - -instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where - range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = - [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), - i2 <- range (l2,u2), - i3 <- range (l3,u3), - i4 <- range (l4,u4), - i5 <- range (l5,u5)] - - unsafeIndex ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = - unsafeIndex (l5,u5) i5 + unsafeRangeSize (l5,u5) * ( - unsafeIndex (l4,u4) i4 + unsafeRangeSize (l4,u4) * ( - unsafeIndex (l3,u3) i3 + unsafeRangeSize (l3,u3) * ( - unsafeIndex (l2,u2) i2 + unsafeRangeSize (l2,u2) * ( - unsafeIndex (l1,u1) i1)))) - - inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = - inRange (l1,u1) i1 && inRange (l2,u2) i2 && - inRange (l3,u3) i3 && inRange (l4,u4) i4 && - inRange (l5,u5) i5 - - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - - -- Default method for index -\end{code} - - -%********************************************************* -%* * -\subsection{Mutable references} -%* * -%********************************************************* - -\begin{code} -data STRef s a = STRef (MutVar# s a) - -newSTRef :: a -> ST s (STRef s a) -newSTRef init = ST $ \s1# -> - case newMutVar# init s1# of { (# s2#, var# #) -> - (# s2#, STRef var# #) } - -readSTRef :: STRef s a -> ST s a -readSTRef (STRef var#) = ST $ \s1# -> readMutVar# var# s1# - -writeSTRef :: STRef s a -> a -> ST s () -writeSTRef (STRef var#) val = ST $ \s1# -> - case writeMutVar# var# val s1# of { s2# -> - (# s2#, () #) } - --- Just pointer equality on mutable references: -instance Eq (STRef s a) where - STRef v1# == STRef v2# = sameMutVar# v1# v2# -\end{code} - - -%********************************************************* -%* * -\subsection{The @Array@ types} -%* * -%********************************************************* - -\begin{code} -type IPr = (Int, Int) - -data Ix i => Array i e = Array !i !i (Array# e) -data Ix i => STArray s i e = STArray !i !i (MutableArray# s e) - --- Just pointer equality on mutable arrays: -instance Eq (STArray s i e) where - STArray _ _ arr1# == STArray _ _ arr2# = - sameMutableArray# arr1# arr2# -\end{code} - - -%********************************************************* -%* * -\subsection{Operations on immutable arrays} -%* * -%********************************************************* - -\begin{code} -{-# NOINLINE arrEleBottom #-} -arrEleBottom :: a -arrEleBottom = error "(Array.!): undefined array element" - -{-# INLINE array #-} -array :: Ix i => (i,i) -> [(i, e)] -> Array i e -array (l,u) ies = unsafeArray (l,u) [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE unsafeArray #-} -unsafeArray :: Ix i => (i,i) -> [(Int, e)] -> Array i e -unsafeArray (l,u) ies = runST (ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> - foldr (fill marr#) (done l u marr#) ies s2# }}) - -{-# INLINE fill #-} -fill :: MutableArray# s e -> (Int, e) -> STRep s a -> STRep s a -fill marr# (I# i#, e) next s1# = - case writeArray# marr# i# e s1# of { s2# -> - next s2# } - -{-# INLINE done #-} -done :: Ix i => i -> i -> MutableArray# s e -> STRep s (Array i e) -done l u marr# s1# = - case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> - (# s2#, Array l u arr# #) } - --- This is inefficient and I'm not sure why: --- listArray (l,u) es = unsafeArray (l,u) (zip [0 .. rangeSize (l,u) - 1] es) --- The code below is better. It still doesn't enable foldr/build --- transformation on the list of elements; I guess it's impossible --- using mechanisms currently available. - -{-# INLINE listArray #-} -listArray :: Ix i => (i,i) -> [e] -> Array i e -listArray (l,u) es = runST (ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> - let fillFromList i# xs s3# | i# ==# n# = s3# - | otherwise = case xs of - [] -> s3# - y:ys -> case writeArray# marr# i# y s3# of { s4# -> - fillFromList (i# +# 1#) ys s4# } in - case fillFromList 0# es s2# of { s3# -> - done l u marr# s3# }}}) - -{-# INLINE (!) #-} -(!) :: Ix i => Array i e -> i -> e -arr@(Array l u _) ! i = unsafeAt arr (index (l,u) i) - -{-# INLINE unsafeAt #-} -unsafeAt :: Ix i => Array i e -> Int -> e -unsafeAt (Array _ _ arr#) (I# i#) = - case indexArray# arr# i# of (# e #) -> e - -{-# INLINE bounds #-} -bounds :: Ix i => Array i e -> (i,i) -bounds (Array l u _) = (l,u) - -{-# INLINE indices #-} -indices :: Ix i => Array i e -> [i] -indices (Array l u _) = range (l,u) - -{-# INLINE elems #-} -elems :: Ix i => Array i e -> [e] -elems arr@(Array l u _) = - [unsafeAt arr i | i <- [0 .. rangeSize (l,u) - 1]] - -{-# INLINE assocs #-} -assocs :: Ix i => Array i e -> [(i, e)] -assocs arr@(Array l u _) = - [(i, unsafeAt arr (unsafeIndex (l,u) i)) | i <- range (l,u)] - -{-# INLINE accumArray #-} -accumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(i, a)] -> Array i e -accumArray f init (l,u) ies = - unsafeAccumArray f init (l,u) [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE unsafeAccumArray #-} -unsafeAccumArray :: Ix i => (e -> a -> e) -> e -> (i,i) -> [(Int, a)] -> Array i e -unsafeAccumArray f init (l,u) ies = runST (ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# init s1# of { (# s2#, marr# #) -> - foldr (adjust f marr#) (done l u marr#) ies s2# }}) - -{-# INLINE adjust #-} -adjust :: (e -> a -> e) -> MutableArray# s e -> (Int, a) -> STRep s b -> STRep s b -adjust f marr# (I# i#, new) next s1# = - case readArray# marr# i# s1# of { (# s2#, old #) -> - case writeArray# marr# i# (f old new) s2# of { s3# -> - next s3# }} - -{-# INLINE (//) #-} -(//) :: Ix i => Array i e -> [(i, e)] -> Array i e -arr@(Array l u _) // ies = - unsafeReplace arr [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE unsafeReplace #-} -unsafeReplace :: Ix i => Array i e -> [(Int, e)] -> Array i e -unsafeReplace arr@(Array l u _) ies = runST (do - STArray _ _ marr# <- thawSTArray arr - ST (foldr (fill marr#) (done l u marr#) ies)) - -{-# INLINE accum #-} -accum :: Ix i => (e -> a -> e) -> Array i e -> [(i, a)] -> Array i e -accum f arr@(Array l u _) ies = - unsafeAccum f arr [(index (l,u) i, e) | (i, e) <- ies] - -{-# INLINE unsafeAccum #-} -unsafeAccum :: Ix i => (e -> a -> e) -> Array i e -> [(Int, a)] -> Array i e -unsafeAccum f arr@(Array l u _) ies = runST (do - STArray _ _ marr# <- thawSTArray arr - ST (foldr (adjust f marr#) (done l u marr#) ies)) - -{-# INLINE amap #-} -amap :: Ix i => (a -> b) -> Array i a -> Array i b -amap f arr@(Array l u _) = - unsafeArray (l,u) [(i, f (unsafeAt arr i)) | i <- [0 .. rangeSize (l,u) - 1]] - -{-# INLINE ixmap #-} -ixmap :: (Ix i, Ix j) => (i,i) -> (i -> j) -> Array j e -> Array i e -ixmap (l,u) f arr = - unsafeArray (l,u) [(unsafeIndex (l,u) i, arr ! f i) | i <- range (l,u)] - -{-# INLINE eqArray #-} -eqArray :: (Ix i, Eq e) => Array i e -> Array i e -> Bool -eqArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) = - if rangeSize (l1,u1) == 0 then rangeSize (l2,u2) == 0 else - l1 == l2 && u1 == u2 && - and [unsafeAt arr1 i == unsafeAt arr2 i | i <- [0 .. rangeSize (l1,u1) - 1]] - -{-# INLINE cmpArray #-} -cmpArray :: (Ix i, Ord e) => Array i e -> Array i e -> Ordering -cmpArray arr1 arr2 = compare (assocs arr1) (assocs arr2) - -{-# INLINE cmpIntArray #-} -cmpIntArray :: Ord e => Array Int e -> Array Int e -> Ordering -cmpIntArray arr1@(Array l1 u1 _) arr2@(Array l2 u2 _) = - if rangeSize (l1,u1) == 0 then if rangeSize (l2,u2) == 0 then EQ else LT else - if rangeSize (l2,u2) == 0 then GT else - case compare l1 l2 of - EQ -> foldr cmp (compare u1 u2) [0 .. rangeSize (l1, min u1 u2) - 1] - other -> other - where - cmp i rest = case compare (unsafeAt arr1 i) (unsafeAt arr2 i) of - EQ -> rest - other -> other - -{-# RULES "cmpArray/Int" cmpArray = cmpIntArray #-} -\end{code} - - -%********************************************************* -%* * -\subsection{Array instances} -%* * -%********************************************************* - -\begin{code} -instance Ix i => Functor (Array i) where - fmap = amap - -instance (Ix i, Eq e) => Eq (Array i e) where - (==) = eqArray - -instance (Ix i, Ord e) => Ord (Array i e) where - compare = cmpArray - -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 ]) --} -\end{code} - - -%********************************************************* -%* * -\subsection{Operations on mutable arrays} -%* * -%********************************************************* - -Idle ADR question: What's the tradeoff here between flattening these -datatypes into @STArray ix ix (MutableArray# s elt)@ and using -it as is? As I see it, the former uses slightly less heap and -provides faster access to the individual parts of the bounds while the -code used has the benefit of providing a ready-made @(lo, hi)@ pair as -required by many array-related functions. Which wins? Is the -difference significant (probably not). - -Idle AJG answer: When I looked at the outputted code (though it was 2 -years ago) it seems like you often needed the tuple, and we build -it frequently. Now we've got the overloading specialiser things -might be different, though. - -\begin{code} -{-# INLINE newSTArray #-} -newSTArray :: Ix i => (i,i) -> e -> ST s (STArray s i e) -newSTArray (l,u) init = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# init s1# of { (# s2#, marr# #) -> - (# s2#, STArray l u marr# #) }} - -{-# INLINE boundsSTArray #-} -boundsSTArray :: STArray s i e -> (i,i) -boundsSTArray (STArray l u _) = (l,u) - -{-# INLINE readSTArray #-} -readSTArray :: Ix i => STArray s i e -> i -> ST s e -readSTArray marr@(STArray l u _) i = - unsafeReadSTArray marr (index (l,u) i) - -{-# INLINE unsafeReadSTArray #-} -unsafeReadSTArray :: Ix i => STArray s i e -> Int -> ST s e -unsafeReadSTArray (STArray _ _ marr#) (I# i#) = ST $ \s1# -> - readArray# marr# i# s1# - -{-# INLINE writeSTArray #-} -writeSTArray :: Ix i => STArray s i e -> i -> e -> ST s () -writeSTArray marr@(STArray l u _) i e = - unsafeWriteSTArray marr (index (l,u) i) e - -{-# INLINE unsafeWriteSTArray #-} -unsafeWriteSTArray :: Ix i => STArray s i e -> Int -> e -> ST s () -unsafeWriteSTArray (STArray _ _ marr#) (I# i#) e = ST $ \s1# -> - case writeArray# marr# i# e s1# of { s2# -> - (# s2#, () #) } -\end{code} - - -%********************************************************* -%* * -\subsection{Moving between mutable and immutable} -%* * -%********************************************************* - -\begin{code} -freezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) -freezeSTArray (STArray l u marr#) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# arrEleBottom s1# of { (# s2#, marr'# #) -> - let copy i# s3# | i# ==# n# = s3# - | otherwise = - case readArray# marr# i# s3# of { (# s4#, e #) -> - case writeArray# marr'# i# e s4# of { s5# -> - copy (i# +# 1#) s5# }} in - case copy 0# s2# of { s3# -> - case unsafeFreezeArray# marr'# s3# of { (# s4#, arr# #) -> - (# s4#, Array l u arr# #) }}}} - -{-# INLINE unsafeFreezeSTArray #-} -unsafeFreezeSTArray :: Ix i => STArray s i e -> ST s (Array i e) -unsafeFreezeSTArray (STArray l u marr#) = ST $ \s1# -> - case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> - (# s2#, Array l u arr# #) } - -thawSTArray :: Ix i => Array i e -> ST s (STArray s i e) -thawSTArray (Array l u arr#) = ST $ \s1# -> - case rangeSize (l,u) of { I# n# -> - case newArray# n# arrEleBottom s1# of { (# s2#, marr# #) -> - let copy i# s3# | i# ==# n# = s3# - | otherwise = - case indexArray# arr# i# of { (# e #) -> - case writeArray# marr# i# e s3# of { s4# -> - copy (i# +# 1#) s4# }} in - case copy 0# s2# of { s3# -> - (# s3#, STArray l u marr# #) }}} - -{-# INLINE unsafeThawSTArray #-} -unsafeThawSTArray :: Ix i => Array i e -> ST s (STArray s i e) -unsafeThawSTArray (Array l u arr#) = ST $ \s1# -> - case unsafeThawArray# arr# s1# of { (# s2#, marr# #) -> - (# s2#, STArray l u marr# #) } -\end{code} diff --git a/ghc/lib/std/PrelArrExtra.lhs b/ghc/lib/std/PrelArrExtra.lhs deleted file mode 100644 index 85292d8d..0000000 --- a/ghc/lib/std/PrelArrExtra.lhs +++ /dev/null @@ -1,57 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelArrExtra.lhs,v 1.12 2000/12/12 12:19:58 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelArrExtra]{Module @PrelArrExtra@} - -The following functions should be in PrelArr, but need -monly-2-regs -to compile. So as not to compile the whole of PrelArr with --monly-2-regs, the culprits have been moved out into a separate -module. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelArrExtra where - -import PrelArr -import PrelByteArr -import PrelST -import PrelIOBase -import PrelBase -\end{code} - -%********************************************************* -%* * -\subsection{Moving between mutable and immutable} -%* * -%********************************************************* - -\begin{code} -freezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALISE freezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} - --- This coercion of memcpy to the ST monad is safe, because memcpy --- only modifies its destination operand, which is already MutableByteArray. -freezeByteArray (MutableByteArray l u arr) = ST $ \ s -> - let n = sizeofMutableByteArray# arr in - case (newByteArray# n s) of { (# s, newarr #) -> - case ((unsafeCoerce# memcpy) newarr arr n s) of { (# s, () #) -> - case unsafeFreezeByteArray# newarr s of { (# s, frozen #) -> - (# s, ByteArray l u frozen #) }}} - -foreign import "memcpy" unsafe - memcpy :: MutableByteArray# RealWorld -> ByteArray# -> Int# -> IO () - -unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) - -{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) - #-} - -unsafeFreezeByteArray (MutableByteArray l u arr#) = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray l u frozen# #) } -\end{code} diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs deleted file mode 100644 index f883948..0000000 --- a/ghc/lib/std/PrelBase.lhs +++ /dev/null @@ -1,827 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelBase.lhs,v 1.61 2002/02/12 03:52:09 chak Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% -\section[PrelBase]{Module @PrelBase@} - - -The overall structure of the GHC Prelude is a bit tricky. - - a) We want to avoid "orphan modules", i.e. ones with instance - decls that don't belong either to a tycon or a class - defined in the same module - - b) We want to avoid giant modules - -So the rough structure is as follows, in (linearised) dependency order - - -PrelGHC Has no implementation. It defines built-in things, and - by importing it you bring them into scope. - The source file is PrelGHC.hi-boot, which is just - copied to make PrelGHC.hi - - Classes: CCallable, CReturnable - -PrelBase Classes: Eq, Ord, Functor, Monad - Types: list, (), Int, Bool, Ordering, Char, String - -PrelTup Types: tuples, plus instances for PrelBase classes - -PrelShow Class: Show, plus instances for PrelBase/PrelTup types - -PrelEnum Class: Enum, plus instances for PrelBase/PrelTup types - -PrelMaybe Type: Maybe, plus instances for PrelBase classes - -PrelNum Class: Num, plus instances for Int - Type: Integer, plus instances for all classes so far (Eq, Ord, Num, Show) - - Integer is needed here because it is mentioned in the signature - of 'fromInteger' in class Num - -PrelReal Classes: Real, Integral, Fractional, RealFrac - plus instances for Int, Integer - Types: Ratio, Rational - plus intances for classes so far - - Rational is needed here because it is mentioned in the signature - of 'toRational' in class Real - -Ix Classes: Ix, plus instances for Int, Bool, Char, Integer, Ordering, tuples - -PrelArr Types: Array, MutableArray, MutableVar - - Does *not* contain any ByteArray stuff (see PrelByteArr) - Arrays are used by a function in PrelFloat - -PrelFloat Classes: Floating, RealFloat - Types: Float, Double, plus instances of all classes so far - - This module contains everything to do with floating point. - It is a big module (900 lines) - With a bit of luck, many modules can be compiled without ever reading PrelFloat.hi - -PrelByteArr Types: ByteArray, MutableByteArray - - We want this one to be after PrelFloat, because it defines arrays - of unboxed floats. - - -Other Prelude modules are much easier with fewer complex dependencies. - - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "MachDeps.h" - -module PrelBase - ( - module PrelBase, - module PrelGHC, -- Re-export PrelGHC and PrelErr, to avoid lots - module PrelErr -- of people having to import it explicitly - ) - where - -import PrelGHC -import {-# SOURCE #-} PrelErr - -infixr 9 . -infixr 5 ++, : -infix 4 ==, /=, <, <=, >=, > -infixr 3 && -infixr 2 || -infixl 1 >>, >>= -infixr 0 $ - -default () -- Double isn't available yet -\end{code} - - -%********************************************************* -%* * -\subsection{DEBUGGING STUFF} -%* (for use when compiling PrelBase itself doesn't work) -%* * -%********************************************************* - -\begin{code} -{- -data Bool = False | True -data Ordering = LT | EQ | GT -data Char = C# Char# -type String = [Char] -data Int = I# Int# -data () = () -data [] a = MkNil - -not True = False -(&&) True True = True -otherwise = True - -build = error "urk" -foldr = error "urk" - -unpackCString# :: Addr# -> [Char] -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -unpackAppendCString# :: Addr# -> [Char] -> [Char] -unpackCStringUtf8# :: Addr# -> [Char] -unpackCString# a = error "urk" -unpackFoldrCString# a = error "urk" -unpackAppendCString# a = error "urk" -unpackCStringUtf8# a = error "urk" --} -\end{code} - - -%********************************************************* -%* * -\subsection{Standard classes @Eq@, @Ord@} -%* * -%********************************************************* - -\begin{code} -class Eq a where - (==), (/=) :: a -> a -> Bool - - x /= y = not (x == y) - x == y = not (x /= y) - -class (Eq a) => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>), (>=) :: a -> a -> Bool - max, min :: a -> a -> a - - -- An instance of Ord should define either 'compare' or '<='. - -- Using 'compare' can be more efficient for complex types. - - compare x y - | x == y = EQ - | x <= y = LT -- NB: must be '<=' not '<' to validate the - -- above claim about the minimal things that - -- can be defined for an instance of Ord - | otherwise = GT - - x < y = case compare x y of { LT -> True; _other -> False } - x <= y = case compare x y of { GT -> False; _other -> True } - x > y = case compare x y of { GT -> True; _other -> False } - x >= y = case compare x y of { LT -> False; _other -> True } - - -- These two default methods use '<=' rather than 'compare' - -- because the latter is often more expensive - max x y = if x <= y then y else x - min x y = if x <= y then x else y -\end{code} - -%********************************************************* -%* * -\subsection{Monadic classes @Functor@, @Monad@ } -%* * -%********************************************************* - -\begin{code} -class Functor f where - fmap :: (a -> b) -> f a -> f b - -class Monad m where - (>>=) :: m a -> (a -> m b) -> m b - (>>) :: m a -> m b -> m b - return :: a -> m a - fail :: String -> m a - - m >> k = m >>= \_ -> k - fail s = error s -\end{code} - - -%********************************************************* -%* * -\subsection{The list type} -%* * -%********************************************************* - -\begin{code} -data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) - -- to avoid weird names like con2tag_[]# - - -instance (Eq a) => Eq [a] where - {-# SPECIALISE instance Eq [Char] #-} - [] == [] = True - (x:xs) == (y:ys) = x == y && xs == ys - _xs == _ys = False - -instance (Ord a) => Ord [a] where - {-# SPECIALISE instance Ord [Char] #-} - compare [] [] = EQ - compare [] (_:_) = LT - compare (_:_) [] = GT - compare (x:xs) (y:ys) = case compare x y of - EQ -> compare xs ys - other -> other - -instance Functor [] where - fmap = map - -instance Monad [] where - m >>= k = foldr ((++) . k) [] m - m >> k = foldr ((++) . (\ _ -> k)) [] m - return x = [x] - fail _ = [] -\end{code} - -A few list functions that appear here because they are used here. -The rest of the prelude list functions are in PrelList. - ----------------------------------------------- --- foldr/build/augment ----------------------------------------------- - -\begin{code} -foldr :: (a -> b -> b) -> b -> [a] -> b --- foldr _ z [] = z --- foldr f z (x:xs) = f x (foldr f z xs) -{-# INLINE [0] foldr #-} --- Inline only in the final stage, after the foldr/cons rule has had a chance -foldr k z xs = go xs - where - go [] = z - go (y:ys) = y `k` go ys - -build :: forall a. (forall b. (a -> b -> b) -> b -> b) -> [a] -{-# INLINE [1] build #-} - -- The INLINE is important, even though build is tiny, - -- because it prevents [] getting inlined in the version that - -- appears in the interface file. If [] *is* inlined, it - -- won't match with [] appearing in rules in an importing module. - -- - -- The "1" says to inline in phase 1 - -build g = g (:) [] - -augment :: forall a. (forall b. (a->b->b) -> b -> b) -> [a] -> [a] -{-# INLINE [1] augment #-} -augment g xs = g (:) xs - -{-# RULES -"fold/build" forall k z (g::forall b. (a->b->b) -> b -> b) . - foldr k z (build g) = g k z - -"foldr/augment" forall k z xs (g::forall b. (a->b->b) -> b -> b) . - foldr k z (augment g xs) = g k (foldr k z xs) - -"foldr/id" foldr (:) [] = \x->x -"foldr/app" [1] forall xs ys. foldr (:) ys xs = xs ++ ys - -- Only activate this from phase 1, because that's - -- when we disable the rule that expands (++) into foldr - --- The foldr/cons rule looks nice, but it can give disastrously --- bloated code when commpiling --- array (a,b) [(1,2), (2,2), (3,2), ...very long list... ] --- i.e. when there are very very long literal lists --- So I've disabled it for now. We could have special cases --- for short lists, I suppose. --- "foldr/cons" forall k z x xs. foldr k z (x:xs) = k x (foldr k z xs) - -"foldr/single" forall k z x. foldr k z [x] = k x z -"foldr/nil" forall k z. foldr k z [] = z - -"augment/build" forall (g::forall b. (a->b->b) -> b -> b) - (h::forall b. (a->b->b) -> b -> b) . - augment g (build h) = build (\c n -> g c (h c n)) -"augment/nil" forall (g::forall b. (a->b->b) -> b -> b) . - augment g [] = build g - #-} - --- This rule is true, but not (I think) useful: --- augment g (augment h t) = augment (\cn -> g c (h c n)) t -\end{code} - - ----------------------------------------------- --- map ----------------------------------------------- - -\begin{code} -map :: (a -> b) -> [a] -> [b] -map _ [] = [] -map f (x:xs) = f x : map f xs - --- Note eta expanded -mapFB :: (elt -> lst -> lst) -> (a -> elt) -> a -> lst -> lst -{-# INLINE [0] mapFB #-} -mapFB c f x ys = c (f x) ys - --- The rules for map work like this. --- --- Up to (but not including) phase 1, we use the "map" rule to --- rewrite all saturated applications of map with its build/fold --- form, hoping for fusion to happen. --- In phase 1 and 0, we switch off that rule, inline build, and --- switch on the "mapList" rule, which rewrites the foldr/mapFB --- thing back into plain map. --- --- It's important that these two rules aren't both active at once --- (along with build's unfolding) else we'd get an infinite loop --- in the rules. Hence the activation control below. --- --- The "mapFB" rule optimises compositions of map. --- --- This same pattern is followed by many other functions: --- e.g. append, filter, iterate, repeat, etc. - -{-# RULES -"map" [~1] forall f xs. map f xs = build (\c n -> foldr (mapFB c f) n xs) -"mapList" [1] forall f. foldr (mapFB (:) f) [] = map f -"mapFB" forall c f g. mapFB (mapFB c f) g = mapFB c (f.g) - #-} -\end{code} - - ----------------------------------------------- --- append ----------------------------------------------- -\begin{code} -(++) :: [a] -> [a] -> [a] -(++) [] ys = ys -(++) (x:xs) ys = x : xs ++ ys - -{-# RULES -"++" [~1] forall xs ys. xs ++ ys = augment (\c n -> foldr c n xs) ys - #-} - -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Bool@} -%* * -%********************************************************* - -\begin{code} -data Bool = False | True deriving (Eq, Ord) - -- Read in PrelRead, Show in PrelShow - --- Boolean functions - -(&&), (||) :: Bool -> Bool -> Bool -True && x = x -False && _ = False -True || _ = True -False || x = x - -not :: Bool -> Bool -not True = False -not False = True - -otherwise :: Bool -otherwise = True -\end{code} - - -%********************************************************* -%* * -\subsection{The @()@ type} -%* * -%********************************************************* - -The Unit type is here because virtually any program needs it (whereas -some programs may get away without consulting PrelTup). Furthermore, -the renamer currently *always* asks for () to be in scope, so that -ccalls can use () as their default type; so when compiling PrelBase we -need (). (We could arrange suck in () only if -fglasgow-exts, but putting -it here seems more direct.) - -\begin{code} -data () = () - -instance Eq () where - () == () = True - () /= () = False - -instance Ord () where - () <= () = True - () < () = False - () >= () = True - () > () = False - max () () = () - min () () = () - compare () () = EQ -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Ordering@} -%* * -%********************************************************* - -\begin{code} -data Ordering = LT | EQ | GT deriving (Eq, Ord) - -- Read in PrelRead, Show in PrelShow -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Char@ and @String@} -%* * -%********************************************************* - -\begin{code} -type String = [Char] - -data Char = C# Char# - --- We don't use deriving for Eq and Ord, because for Ord the derived --- instance defines only compare, which takes two primops. Then --- '>' uses compare, and therefore takes two primops instead of one. - -instance Eq Char where - (C# c1) == (C# c2) = c1 `eqChar#` c2 - (C# c1) /= (C# c2) = c1 `neChar#` c2 - -instance Ord Char where - (C# c1) > (C# c2) = c1 `gtChar#` c2 - (C# c1) >= (C# c2) = c1 `geChar#` c2 - (C# c1) <= (C# c2) = c1 `leChar#` c2 - (C# c1) < (C# c2) = c1 `ltChar#` c2 - -{-# RULES -"x# `eqChar#` x#" forall x#. x# `eqChar#` x# = True -"x# `neChar#` x#" forall x#. x# `neChar#` x# = False -"x# `gtChar#` x#" forall x#. x# `gtChar#` x# = False -"x# `geChar#` x#" forall x#. x# `geChar#` x# = True -"x# `leChar#` x#" forall x#. x# `leChar#` x# = True -"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False - #-} - -chr :: Int -> Char -chr (I# i#) | int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#) - | otherwise = error "Prelude.chr: bad argument" - -unsafeChr :: Int -> Char -unsafeChr (I# i#) = C# (chr# i#) - -ord :: Char -> Int -ord (C# c#) = I# (ord# c#) -\end{code} - -String equality is used when desugaring pattern-matches against strings. - -\begin{code} -eqString :: String -> String -> Bool -eqString [] [] = True -eqString (c1:cs1) (c2:cs2) = c1 == c2 && cs1 `eqString` cs2 -eqString cs1 cs2 = False - -{-# RULES "eqString" (==) = eqString #-} -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Int@} -%* * -%********************************************************* - -\begin{code} -data Int = I# Int# - -zeroInt, oneInt, twoInt, maxInt, minInt :: Int -zeroInt = I# 0# -oneInt = I# 1# -twoInt = I# 2# - -{- Seems clumsy. Should perhaps put minInt and MaxInt directly into MachDeps.h -} -#if WORD_SIZE_IN_BITS == 31 -minInt = I# (-0x40000000#) -maxInt = I# 0x3FFFFFFF# -#elif WORD_SIZE_IN_BITS == 32 -minInt = I# (-0x80000000#) -maxInt = I# 0x7FFFFFFF# -#else -minInt = I# (-0x8000000000000000#) -maxInt = I# 0x7FFFFFFFFFFFFFFF# -#endif - -instance Eq Int where - (==) = eqInt - (/=) = neInt - -instance Ord Int where - compare = compareInt - (<) = ltInt - (<=) = leInt - (>=) = geInt - (>) = gtInt - -compareInt :: Int -> Int -> Ordering -(I# x#) `compareInt` (I# y#) = compareInt# x# y# - -compareInt# :: Int# -> Int# -> Ordering -compareInt# x# y# - | x# <# y# = LT - | x# ==# y# = EQ - | otherwise = GT -\end{code} - - -%********************************************************* -%* * -\subsection{The function type} -%* * -%********************************************************* - -\begin{code} --- identity function -id :: a -> a -id x = x - --- constant function -const :: a -> b -> a -const x _ = x - --- function composition -{-# INLINE (.) #-} -(.) :: (b -> c) -> (a -> b) -> a -> c -(.) f g x = f (g x) - --- flip f takes its (first) two arguments in the reverse order of f. -flip :: (a -> b -> c) -> b -> a -> c -flip f x y = f y x - --- right-associating infix application operator (useful in continuation- --- passing style) -{-# INLINE ($) #-} -($) :: (a -> b) -> a -> b -f $ x = f x - --- until p f yields the result of applying f until p holds. -until :: (a -> Bool) -> (a -> a) -> a -> a -until p f x | p x = x - | otherwise = until p f (f x) - --- asTypeOf is a type-restricted version of const. It is usually used --- as an infix operator, and its typing forces its first argument --- (which is usually overloaded) to have the same type as the second. -asTypeOf :: a -> a -> a -asTypeOf = const -\end{code} - -%********************************************************* -%* * -\subsection{CCallable instances} -%* * -%********************************************************* - -Defined here to avoid orphans - -\begin{code} -instance CCallable Char -instance CReturnable Char - -instance CCallable Int -instance CReturnable Int - -instance CReturnable () -- Why, exactly? -\end{code} - - -%********************************************************* -%* * -\subsection{Generics} -%* * -%********************************************************* - -\begin{code} -data Unit = Unit -data (:+:) a b = Inl a | Inr b -data (:*:) a b = a :*: b -\end{code} - - -%********************************************************* -%* * -\subsection{Numeric primops} -%* * -%********************************************************* - -\begin{code} -divInt#, modInt# :: Int# -> Int# -> Int# -x# `divInt#` y# - | (x# ># 0#) && (y# <# 0#) = ((x# -# y#) -# 1#) `quotInt#` y# - | (x# <# 0#) && (y# ># 0#) = ((x# -# y#) +# 1#) `quotInt#` y# - | otherwise = x# `quotInt#` y# -x# `modInt#` y# - | (x# ># 0#) && (y# <# 0#) || - (x# <# 0#) && (y# ># 0#) = if r# /=# 0# then r# +# y# else 0# - | otherwise = r# - where - r# = x# `remInt#` y# -\end{code} - -Definitions of the boxed PrimOps; these will be -used in the case of partial applications, etc. - -\begin{code} -{-# INLINE eqInt #-} -{-# INLINE neInt #-} -{-# INLINE gtInt #-} -{-# INLINE geInt #-} -{-# INLINE ltInt #-} -{-# INLINE leInt #-} -{-# INLINE plusInt #-} -{-# INLINE minusInt #-} -{-# INLINE timesInt #-} -{-# INLINE quotInt #-} -{-# INLINE remInt #-} -{-# INLINE negateInt #-} - -plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt, gcdInt :: Int -> Int -> Int -(I# x) `plusInt` (I# y) = I# (x +# y) -(I# x) `minusInt` (I# y) = I# (x -# y) -(I# x) `timesInt` (I# y) = I# (x *# y) -(I# x) `quotInt` (I# y) = I# (x `quotInt#` y) -(I# x) `remInt` (I# y) = I# (x `remInt#` y) -(I# x) `divInt` (I# y) = I# (x `divInt#` y) -(I# x) `modInt` (I# y) = I# (x `modInt#` y) - -{-# RULES -"x# +# 0#" forall x#. x# +# 0# = x# -"0# +# x#" forall x#. 0# +# x# = x# -"x# -# 0#" forall x#. x# -# 0# = x# -"x# -# x#" forall x#. x# -# x# = 0# -"x# *# 0#" forall x#. x# *# 0# = 0# -"0# *# x#" forall x#. 0# *# x# = 0# -"x# *# 1#" forall x#. x# *# 1# = x# -"1# *# x#" forall x#. 1# *# x# = x# - #-} - -gcdInt (I# a) (I# b) = g a b - where g 0# 0# = error "PrelBase.gcdInt: gcd 0 0 is undefined" - g 0# _ = I# absB - g _ 0# = I# absA - g _ _ = I# (gcdInt# absA absB) - - absInt x = if x <# 0# then negateInt# x else x - - absA = absInt a - absB = absInt b - -negateInt :: Int -> Int -negateInt (I# x) = I# (negateInt# x) - -gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool -(I# x) `gtInt` (I# y) = x ># y -(I# x) `geInt` (I# y) = x >=# y -(I# x) `eqInt` (I# y) = x ==# y -(I# x) `neInt` (I# y) = x /=# y -(I# x) `ltInt` (I# y) = x <# y -(I# x) `leInt` (I# y) = x <=# y - -{-# RULES -"x# ># x#" forall x#. x# ># x# = False -"x# >=# x#" forall x#. x# >=# x# = True -"x# ==# x#" forall x#. x# ==# x# = True -"x# /=# x#" forall x#. x# /=# x# = False -"x# <# x#" forall x#. x# <# x# = False -"x# <=# x#" forall x#. x# <=# x# = True - #-} - --- Wrappers for the shift operations. The uncheckedShift# family are --- undefined when the amount being shifted by is greater than the size --- in bits of Int#, so these wrappers perform a check and return --- either zero or -1 appropriately. --- --- Note that these wrappers still produce undefined results when the --- second argument (the shift amount) is negative. - -shiftL#, shiftRL# :: Word# -> Int# -> Word# - -a `shiftL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# - | otherwise = a `uncheckedShiftL#` b - -a `shiftRL#` b | b >=# WORD_SIZE_IN_BITS# = int2Word# 0# - | otherwise = a `uncheckedShiftRL#` b - -iShiftL#, iShiftRA#, iShiftRL# :: Int# -> Int# -> Int# - -a `iShiftL#` b | b >=# WORD_SIZE_IN_BITS# = 0# - | otherwise = a `uncheckedIShiftL#` b - -a `iShiftRA#` b | b >=# WORD_SIZE_IN_BITS# = if a <# 0# then (-1#) else 0# - | otherwise = a `uncheckedIShiftRA#` b - -a `iShiftRL#` b | b >=# WORD_SIZE_IN_BITS# = 0# - | otherwise = a `uncheckedIShiftRL#` b - -#if WORD_SIZE_IN_BITS == 32 -{-# RULES -"narrow32Int#" forall x#. narrow32Int# x# = x# -"narrow32Word#" forall x#. narrow32Word# x# = x# - #-} -#endif - -{-# RULES -"int2Word2Int" forall x#. int2Word# (word2Int# x#) = x# -"word2Int2Word" forall x#. word2Int# (int2Word# x#) = x# - #-} -\end{code} - - -%******************************************************** -%* * -\subsection{Unpacking C strings} -%* * -%******************************************************** - -This code is needed for virtually all programs, since it's used for -unpacking the strings of error messages. - -\begin{code} -unpackCString# :: Addr# -> [Char] -{-# NOINLINE [1] unpackCString# #-} -unpackCString# a = unpackCStringList# a - -unpackCStringList# :: Addr# -> [Char] -unpackCStringList# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackAppendCString# :: Addr# -> [Char] -> [Char] -unpackAppendCString# addr rest - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = rest - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -{-# NOINLINE [0] unpackFoldrCString# #-} --- Don't inline till right at the end; --- usually the unpack-list rule turns it into unpackCStringList -unpackFoldrCString# addr f z - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = z - | otherwise = C# ch `f` unpack (nh +# 1#) - where - ch = indexCharOffAddr# addr nh - -unpackCStringUtf8# :: Addr# -> [Char] -unpackCStringUtf8# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) - | ch `leChar#` '\xDF'# = - C# (chr# ((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : - unpack (nh +# 2#) - | ch `leChar#` '\xEF'# = - C# (chr# ((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6# +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : - unpack (nh +# 3#) - | otherwise = - C# (chr# ((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18# +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12# +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6# +# - (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : - unpack (nh +# 4#) - where - ch = indexCharOffAddr# addr nh - -unpackNBytes# :: Addr# -> Int# -> [Char] -unpackNBytes# _addr 0# = [] -unpackNBytes# addr len# = unpack [] (len# -# 1#) - where - unpack acc i# - | i# <# 0# = acc - | otherwise = - case indexCharOffAddr# addr i# of - ch -> unpack (C# ch : acc) (i# -# 1#) - -{-# RULES -"unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) -"unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCStringList# a -"unpack-append" forall a n . unpackFoldrCString# a (:) n = unpackAppendCString# a n - --- There's a built-in rule (in PrelRules.lhs) for --- unpackFoldr "foo" c (unpackFoldr "baz" c n) = unpackFoldr "foobaz" c n - - #-} -\end{code} diff --git a/ghc/lib/std/PrelBits.lhs b/ghc/lib/std/PrelBits.lhs deleted file mode 100644 index 114ce2e..0000000 --- a/ghc/lib/std/PrelBits.lhs +++ /dev/null @@ -1,81 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1998-2000 -% -\section[Bits]{The @Bits@ interface} - -Defines the @Bits@ class containing bit-based operations. -See library document for details on the semantics of the -individual operations. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} -#include "MachDeps.h" - -module PrelBits where - -#ifdef __GLASGOW_HASKELL__ -import PrelGHC -import PrelBase -import PrelNum -#endif - ---ADR: The fixity for .|. conflicts with that for .|. in Fran. --- Removing all fixities is a fairly safe fix; fixing the "one fixity --- per symbol per program" limitation in Hugs would take a lot longer. -#ifndef __HUGS__ -infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR` -infixl 7 .&. -infixl 6 `xor` -infixl 5 .|. -#endif - -class Num a => Bits a where - (.&.), (.|.), xor :: a -> a -> a - complement :: a -> a - shift :: a -> Int -> a - rotate :: a -> Int -> a - bit :: Int -> a - setBit :: a -> Int -> a - clearBit :: a -> Int -> a - complementBit :: a -> Int -> a - testBit :: a -> Int -> Bool - bitSize :: a -> Int - isSigned :: a -> Bool - - bit i = 1 `shift` i - x `setBit` i = x .|. bit i - x `clearBit` i = x .&. complement (bit i) - x `complementBit` i = x `xor` bit i - x `testBit` i = (x .&. bit i) /= 0 - -shiftL, shiftR :: Bits a => a -> Int -> a -rotateL, rotateR :: Bits a => a -> Int -> a -x `shiftL` i = x `shift` i -x `shiftR` i = x `shift` (-i) -x `rotateL` i = x `rotate` i -x `rotateR` i = x `rotate` (-i) - -instance Bits Int where - (I# x#) .&. (I# y#) = I# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I# x#) .|. (I# y#) = I# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I# x#) `xor` (I# y#) = I# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I# x#) = I# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - (I# x#) `shift` (I# i#) - | i# ==# 0# = I# x# - | i# >=# wsib = 0 - | i# ># 0# = I# (x# `uncheckedIShiftL#` i#) - | i# <=# nwsib = I# (if x# <# 0# then -1# else 0#) - | otherwise = I# (x# `uncheckedIShiftRA#` negateInt# i#) - where - wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} - nwsib = negateInt# wsib - (I# x#) `rotate` (I# i#) = - I# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` - (x'# `uncheckedShiftRL#` (wsib -# i'#)))) - where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS# - bitSize _ = WORD_SIZE_IN_BITS - isSigned _ = True -\end{code} diff --git a/ghc/lib/std/PrelByteArr.lhs b/ghc/lib/std/PrelByteArr.lhs deleted file mode 100644 index 31eff89..0000000 --- a/ghc/lib/std/PrelByteArr.lhs +++ /dev/null @@ -1,184 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelByteArr.lhs,v 1.14 2001/05/18 16:54:05 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelByteArr]{Module @PrelByteArr@} - -Byte-arrays are flat arrays of non-pointers only. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelByteArr where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelNum -import PrelArr -import PrelFloat -import PrelST -import PrelBase -\end{code} - -%********************************************************* -%* * -\subsection{The @Array@ types} -%* * -%********************************************************* - -\begin{code} -data Ix ix => ByteArray ix = ByteArray ix ix ByteArray# -data Ix ix => MutableByteArray s ix = MutableByteArray ix ix (MutableByteArray# s) - -instance CCallable (ByteArray ix) -instance CCallable (MutableByteArray RealWorld ix) - -- Note the RealWorld! You can only ccall with MutableByteArray args - -- which are in the real world. When this was missed out, the result - -- was that a CCallOpId had a free tyvar, and since the compiler doesn't - -- expect that it didn't get zonked or substituted. Bad news. - -instance Eq (MutableByteArray s ix) where - MutableByteArray _ _ arr1# == MutableByteArray _ _ arr2# - = sameMutableByteArray# arr1# arr2# -\end{code} - -%********************************************************* -%* * -\subsection{Operations on mutable arrays} -%* * -%********************************************************* - -\begin{code} -newCharArray, newIntArray, newFloatArray, newDoubleArray - :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) - -{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newIntArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-} -{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-} - -newCharArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newByteArray# (cHAR_SCALE n#) s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newIntArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newWordArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newFloatArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newByteArray# (fLOAT_SCALE n#) s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -newDoubleArray (l,u) = ST $ \ s# -> - case rangeSize (l,u) of { I# n# -> - case (newByteArray# (dOUBLE_SCALE n#) s#) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray l u barr# #) }} - -#include "config.h" - - -- Char arrays really contain only 8-bit bytes for compatibility. -cHAR_SCALE n = 1# *# n -wORD_SCALE n = (case SIZEOF_VOID_P :: Int of I# x -> x *# n) -dOUBLE_SCALE n = (case SIZEOF_DOUBLE :: Int of I# x -> x *# n) -fLOAT_SCALE n = (case SIZEOF_FLOAT :: Int of I# x -> x *# n) - -readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char -readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int -readFloatArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Float -readDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Double - -{-# SPECIALIZE readCharArray :: MutableByteArray s Int -> Int -> ST s Char #-} -{-# SPECIALIZE readIntArray :: MutableByteArray s Int -> Int -> ST s Int #-} ---NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-} -{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-} - -readCharArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readCharArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, C# r# #) }} - -readIntArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readIntArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, I# r# #) }} - -readFloatArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readFloatArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, F# r# #) }} - -readDoubleArray (MutableByteArray l u barr#) n = ST $ \ s# -> - case (index (l,u) n) of { I# n# -> - case readDoubleArray# barr# n# s# of { (# s2#, r# #) -> - (# s2#, D# r# #) }} - ---Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here. -indexCharArray :: Ix ix => ByteArray ix -> ix -> Char -indexIntArray :: Ix ix => ByteArray ix -> ix -> Int -indexFloatArray :: Ix ix => ByteArray ix -> ix -> Float -indexDoubleArray :: Ix ix => ByteArray ix -> ix -> Double - -{-# SPECIALIZE indexCharArray :: ByteArray Int -> Int -> Char #-} -{-# SPECIALIZE indexIntArray :: ByteArray Int -> Int -> Int #-} ---NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-} -{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-} - -indexCharArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexCharArray# barr# n# of { r# -> - (C# r#)}} - -indexIntArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexIntArray# barr# n# of { r# -> - (I# r#)}} - -indexFloatArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexFloatArray# barr# n# of { r# -> - (F# r#)}} - -indexDoubleArray (ByteArray l u barr#) n - = case (index (l,u) n) of { I# n# -> - case indexDoubleArray# barr# n# of { r# -> - (D# r#)}} - -writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () -writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s () -writeFloatArray :: Ix ix => MutableByteArray s ix -> ix -> Float -> ST s () -writeDoubleArray :: Ix ix => MutableByteArray s ix -> ix -> Double -> ST s () - -{-# SPECIALIZE writeCharArray :: MutableByteArray s Int -> Int -> Char -> ST s () #-} -{-# SPECIALIZE writeIntArray :: MutableByteArray s Int -> Int -> Int -> ST s () #-} ---NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-} -{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-} - -writeCharArray (MutableByteArray l u barr#) n (C# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeCharArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeIntArray (MutableByteArray l u barr#) n (I# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeIntArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeFloatArray (MutableByteArray l u barr#) n (F# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeFloatArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} - -writeDoubleArray (MutableByteArray l u barr#) n (D# ele) = ST $ \ s# -> - case index (l,u) n of { I# n# -> - case writeDoubleArray# barr# n# ele s# of { s2# -> - (# s2#, () #) }} -\end{code} diff --git a/ghc/lib/std/PrelCError.lhs b/ghc/lib/std/PrelCError.lhs deleted file mode 100644 index c21e2d1..0000000 --- a/ghc/lib/std/PrelCError.lhs +++ /dev/null @@ -1,612 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelCError.lhs,v 1.12 2001/11/07 08:31:29 sof Exp $ -% -% (c) The FFI task force, 2000 -% - -C-specific Marshalling support: Handling of C "errno" error codes - -\begin{code} -{-# OPTIONS -fno-implicit-prelude -#include "HsStd.h" -#include "errUtils.h" #-} -module PrelCError ( - - -- Haskell representation for "errno" values - -- - Errno(..), -- instance: Eq - eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, - eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, - eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, - eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, - eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, - eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, - eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, - eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, - eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, - eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, - ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, - eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, - eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, - eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV, - -- :: Errno - isValidErrno, -- :: Errno -> Bool - - -- access to the current thread's "errno" value - -- - getErrno, -- :: IO Errno - resetErrno, -- :: IO () - - -- conversion of an "errno" value into IO error - -- - errnoToIOError, -- :: String -- location - -- -> Errno -- errno - -- -> Maybe Handle -- handle - -- -> Maybe String -- filename - -- -> IOError - - -- throw current "errno" value - -- - throwErrno, -- :: String -> IO a - - -- guards for IO operations that may fail - -- - throwErrnoIf, -- :: (a -> Bool) -> String -> IO a -> IO a - throwErrnoIf_, -- :: (a -> Bool) -> String -> IO a -> IO () - throwErrnoIfRetry, -- :: (a -> Bool) -> String -> IO a -> IO a - throwErrnoIfRetry_, -- :: (a -> Bool) -> String -> IO a -> IO () - throwErrnoIfMinus1, -- :: Num a - -- => String -> IO a -> IO a - throwErrnoIfMinus1_, -- :: Num a - -- => String -> IO a -> IO () - throwErrnoIfMinus1Retry, - -- :: Num a - -- => String -> IO a -> IO a - throwErrnoIfMinus1Retry_, - -- :: Num a - -- => String -> IO a -> IO () - throwErrnoIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) - throwErrnoIfNullRetry,-- :: String -> IO (Ptr a) -> IO (Ptr a) - - throwErrnoIfRetryMayBlock, - throwErrnoIfRetryMayBlock_, - throwErrnoIfMinus1RetryMayBlock, - throwErrnoIfMinus1RetryMayBlock_, - throwErrnoIfNullRetryMayBlock -) where - - --- system dependent imports --- ------------------------ - --- GHC allows us to get at the guts inside IO errors/exceptions --- -#if __GLASGOW_HASKELL__ -import PrelIOBase (Exception(..), IOException(..), IOErrorType(..)) -#endif /* __GLASGOW_HASKELL__ */ - - --- regular imports --- --------------- - -#if __GLASGOW_HASKELL__ -import PrelStorable -import PrelMarshalError -import PrelCTypes -import PrelCString -import PrelIOBase -import PrelPtr -import PrelNum -import PrelShow -import PrelMaybe -import PrelBase -#else -import Ptr (Ptr, nullPtr) -import CTypes (CInt) -import CString (peekCString) -import MarshalError (void) - -import IO (IOError, Handle, ioError) -#endif - --- "errno" type --- ------------ - --- import of C function that gives address of errno --- This function exists because errno is a variable on some systems, but on --- Windows it is a macro for a function... --- [yes, global variables and thread safety don't really go hand-in-hand. -- sof] -foreign import "ghcErrno" unsafe _errno :: Ptr CInt - --- Haskell representation for "errno" values --- -newtype Errno = Errno CInt - -instance Eq Errno where - errno1@(Errno no1) == errno2@(Errno no2) - | isValidErrno errno1 && isValidErrno errno2 = no1 == no2 - | otherwise = False - --- common "errno" symbols --- -eOK, e2BIG, eACCES, eADDRINUSE, eADDRNOTAVAIL, eADV, eAFNOSUPPORT, eAGAIN, - eALREADY, eBADF, eBADMSG, eBADRPC, eBUSY, eCHILD, eCOMM, eCONNABORTED, - eCONNREFUSED, eCONNRESET, eDEADLK, eDESTADDRREQ, eDIRTY, eDOM, eDQUOT, - eEXIST, eFAULT, eFBIG, eFTYPE, eHOSTDOWN, eHOSTUNREACH, eIDRM, eILSEQ, - eINPROGRESS, eINTR, eINVAL, eIO, eISCONN, eISDIR, eLOOP, eMFILE, eMLINK, - eMSGSIZE, eMULTIHOP, eNAMETOOLONG, eNETDOWN, eNETRESET, eNETUNREACH, - eNFILE, eNOBUFS, eNODATA, eNODEV, eNOENT, eNOEXEC, eNOLCK, eNOLINK, - eNOMEM, eNOMSG, eNONET, eNOPROTOOPT, eNOSPC, eNOSR, eNOSTR, eNOSYS, - eNOTBLK, eNOTCONN, eNOTDIR, eNOTEMPTY, eNOTSOCK, eNOTTY, eNXIO, - eOPNOTSUPP, ePERM, ePFNOSUPPORT, ePIPE, ePROCLIM, ePROCUNAVAIL, - ePROGMISMATCH, ePROGUNAVAIL, ePROTO, ePROTONOSUPPORT, ePROTOTYPE, - eRANGE, eREMCHG, eREMOTE, eROFS, eRPCMISMATCH, eRREMOTE, eSHUTDOWN, - eSOCKTNOSUPPORT, eSPIPE, eSRCH, eSRMNT, eSTALE, eTIME, eTIMEDOUT, - eTOOMANYREFS, eTXTBSY, eUSERS, eWOULDBLOCK, eXDEV :: Errno --- --- the cCONST_XXX identifiers are cpp symbols whose value is computed by --- configure --- -eOK = Errno 0 -e2BIG = Errno (cCONST_E2BIG) -eACCES = Errno (cCONST_EACCES) -eADDRINUSE = Errno (cCONST_EADDRINUSE) -eADDRNOTAVAIL = Errno (cCONST_EADDRNOTAVAIL) -eADV = Errno (cCONST_EADV) -eAFNOSUPPORT = Errno (cCONST_EAFNOSUPPORT) -eAGAIN = Errno (cCONST_EAGAIN) -eALREADY = Errno (cCONST_EALREADY) -eBADF = Errno (cCONST_EBADF) -eBADMSG = Errno (cCONST_EBADMSG) -eBADRPC = Errno (cCONST_EBADRPC) -eBUSY = Errno (cCONST_EBUSY) -eCHILD = Errno (cCONST_ECHILD) -eCOMM = Errno (cCONST_ECOMM) -eCONNABORTED = Errno (cCONST_ECONNABORTED) -eCONNREFUSED = Errno (cCONST_ECONNREFUSED) -eCONNRESET = Errno (cCONST_ECONNRESET) -eDEADLK = Errno (cCONST_EDEADLK) -eDESTADDRREQ = Errno (cCONST_EDESTADDRREQ) -eDIRTY = Errno (cCONST_EDIRTY) -eDOM = Errno (cCONST_EDOM) -eDQUOT = Errno (cCONST_EDQUOT) -eEXIST = Errno (cCONST_EEXIST) -eFAULT = Errno (cCONST_EFAULT) -eFBIG = Errno (cCONST_EFBIG) -eFTYPE = Errno (cCONST_EFTYPE) -eHOSTDOWN = Errno (cCONST_EHOSTDOWN) -eHOSTUNREACH = Errno (cCONST_EHOSTUNREACH) -eIDRM = Errno (cCONST_EIDRM) -eILSEQ = Errno (cCONST_EILSEQ) -eINPROGRESS = Errno (cCONST_EINPROGRESS) -eINTR = Errno (cCONST_EINTR) -eINVAL = Errno (cCONST_EINVAL) -eIO = Errno (cCONST_EIO) -eISCONN = Errno (cCONST_EISCONN) -eISDIR = Errno (cCONST_EISDIR) -eLOOP = Errno (cCONST_ELOOP) -eMFILE = Errno (cCONST_EMFILE) -eMLINK = Errno (cCONST_EMLINK) -eMSGSIZE = Errno (cCONST_EMSGSIZE) -eMULTIHOP = Errno (cCONST_EMULTIHOP) -eNAMETOOLONG = Errno (cCONST_ENAMETOOLONG) -eNETDOWN = Errno (cCONST_ENETDOWN) -eNETRESET = Errno (cCONST_ENETRESET) -eNETUNREACH = Errno (cCONST_ENETUNREACH) -eNFILE = Errno (cCONST_ENFILE) -eNOBUFS = Errno (cCONST_ENOBUFS) -eNODATA = Errno (cCONST_ENODATA) -eNODEV = Errno (cCONST_ENODEV) -eNOENT = Errno (cCONST_ENOENT) -eNOEXEC = Errno (cCONST_ENOEXEC) -eNOLCK = Errno (cCONST_ENOLCK) -eNOLINK = Errno (cCONST_ENOLINK) -eNOMEM = Errno (cCONST_ENOMEM) -eNOMSG = Errno (cCONST_ENOMSG) -eNONET = Errno (cCONST_ENONET) -eNOPROTOOPT = Errno (cCONST_ENOPROTOOPT) -eNOSPC = Errno (cCONST_ENOSPC) -eNOSR = Errno (cCONST_ENOSR) -eNOSTR = Errno (cCONST_ENOSTR) -eNOSYS = Errno (cCONST_ENOSYS) -eNOTBLK = Errno (cCONST_ENOTBLK) -eNOTCONN = Errno (cCONST_ENOTCONN) -eNOTDIR = Errno (cCONST_ENOTDIR) -eNOTEMPTY = Errno (cCONST_ENOTEMPTY) -eNOTSOCK = Errno (cCONST_ENOTSOCK) -eNOTTY = Errno (cCONST_ENOTTY) -eNXIO = Errno (cCONST_ENXIO) -eOPNOTSUPP = Errno (cCONST_EOPNOTSUPP) -ePERM = Errno (cCONST_EPERM) -ePFNOSUPPORT = Errno (cCONST_EPFNOSUPPORT) -ePIPE = Errno (cCONST_EPIPE) -ePROCLIM = Errno (cCONST_EPROCLIM) -ePROCUNAVAIL = Errno (cCONST_EPROCUNAVAIL) -ePROGMISMATCH = Errno (cCONST_EPROGMISMATCH) -ePROGUNAVAIL = Errno (cCONST_EPROGUNAVAIL) -ePROTO = Errno (cCONST_EPROTO) -ePROTONOSUPPORT = Errno (cCONST_EPROTONOSUPPORT) -ePROTOTYPE = Errno (cCONST_EPROTOTYPE) -eRANGE = Errno (cCONST_ERANGE) -eREMCHG = Errno (cCONST_EREMCHG) -eREMOTE = Errno (cCONST_EREMOTE) -eROFS = Errno (cCONST_EROFS) -eRPCMISMATCH = Errno (cCONST_ERPCMISMATCH) -eRREMOTE = Errno (cCONST_ERREMOTE) -eSHUTDOWN = Errno (cCONST_ESHUTDOWN) -eSOCKTNOSUPPORT = Errno (cCONST_ESOCKTNOSUPPORT) -eSPIPE = Errno (cCONST_ESPIPE) -eSRCH = Errno (cCONST_ESRCH) -eSRMNT = Errno (cCONST_ESRMNT) -eSTALE = Errno (cCONST_ESTALE) -eTIME = Errno (cCONST_ETIME) -eTIMEDOUT = Errno (cCONST_ETIMEDOUT) -eTOOMANYREFS = Errno (cCONST_ETOOMANYREFS) -eTXTBSY = Errno (cCONST_ETXTBSY) -eUSERS = Errno (cCONST_EUSERS) -eWOULDBLOCK = Errno (cCONST_EWOULDBLOCK) -eXDEV = Errno (cCONST_EXDEV) - --- checks whether the given errno value is supported on the current --- architecture --- -isValidErrno :: Errno -> Bool --- --- the configure script sets all invalid "errno"s to -1 --- -isValidErrno (Errno errno) = errno /= -1 - - --- access to the current thread's "errno" value --- -------------------------------------------- - --- yield the current thread's "errno" value --- -getErrno :: IO Errno -getErrno = do e <- peek _errno; return (Errno e) - --- set the current thread's "errno" value to 0 --- -resetErrno :: IO () -resetErrno = poke _errno 0 - - --- throw current "errno" value --- --------------------------- - --- the common case: throw an IO error based on a textual description --- of the error location and the current thread's "errno" value --- -throwErrno :: String -> IO a -throwErrno loc = - do - errno <- getErrno - ioError (errnoToIOError loc errno Nothing Nothing) - - --- guards for IO operations that may fail --- -------------------------------------- - --- guard an IO operation and throw an "errno" based exception of the result --- value of the IO operation meets the given predicate --- -throwErrnoIf :: (a -> Bool) -> String -> IO a -> IO a -throwErrnoIf pred loc f = - do - res <- f - if pred res then throwErrno loc else return res - --- as `throwErrnoIf', but discards the result --- -throwErrnoIf_ :: (a -> Bool) -> String -> IO a -> IO () -throwErrnoIf_ pred loc f = void $ throwErrnoIf pred loc f - --- as `throwErrnoIf', but retries interrupted IO operations (ie, those whose --- flag `EINTR') --- -throwErrnoIfRetry :: (a -> Bool) -> String -> IO a -> IO a -throwErrnoIfRetry pred loc f = - do - res <- f - if pred res - then do - err <- getErrno - if err == eINTR - then throwErrnoIfRetry pred loc f - else throwErrno loc - else return res - --- as `throwErrnoIfRetry', but checks for operations that would block and --- executes an alternative action in that case. - -throwErrnoIfRetryMayBlock :: (a -> Bool) -> String -> IO a -> IO b -> IO a -throwErrnoIfRetryMayBlock pred loc f on_block = - do - res <- f - if pred res - then do - err <- getErrno - if err == eINTR - then throwErrnoIfRetryMayBlock pred loc f on_block - else if err == eWOULDBLOCK || err == eAGAIN - then do on_block; throwErrnoIfRetryMayBlock pred loc f on_block - else throwErrno loc - else return res - --- as `throwErrnoIfRetry', but discards the result --- -throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO () -throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f - --- as `throwErrnoIfRetryMayBlock', but discards the result --- -throwErrnoIfRetryMayBlock_ :: (a -> Bool) -> String -> IO a -> IO b -> IO () -throwErrnoIfRetryMayBlock_ pred loc f on_block - = void $ throwErrnoIfRetryMayBlock pred loc f on_block - --- throws "errno" if a result of "-1" is returned --- -throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a -throwErrnoIfMinus1 = throwErrnoIf (== -1) - --- as `throwErrnoIfMinus1', but discards the result --- -throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO () -throwErrnoIfMinus1_ = throwErrnoIf_ (== -1) - --- throws "errno" if a result of "-1" is returned, but retries in case of an --- interrupted operation --- -throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a -throwErrnoIfMinus1Retry = throwErrnoIfRetry (== -1) - --- as `throwErrnoIfMinus1', but discards the result --- -throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO () -throwErrnoIfMinus1Retry_ = throwErrnoIfRetry_ (== -1) - --- as throwErrnoIfMinus1Retry, but checks for operations that would block --- -throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a -throwErrnoIfMinus1RetryMayBlock = throwErrnoIfRetryMayBlock (== -1) - --- as `throwErrnoIfMinus1RetryMayBlock', but discards the result --- -throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO () -throwErrnoIfMinus1RetryMayBlock_ = throwErrnoIfRetryMayBlock_ (== -1) - --- throws "errno" if a result of a NULL pointer is returned --- -throwErrnoIfNull :: String -> IO (Ptr a) -> IO (Ptr a) -throwErrnoIfNull = throwErrnoIf (== nullPtr) - --- throws "errno" if a result of a NULL pointer is returned, but retries in --- case of an interrupted operation --- -throwErrnoIfNullRetry :: String -> IO (Ptr a) -> IO (Ptr a) -throwErrnoIfNullRetry = throwErrnoIfRetry (== nullPtr) - --- as throwErrnoIfNullRetry, but checks for operations that would block --- -throwErrnoIfNullRetryMayBlock :: String -> IO (Ptr a) -> IO b -> IO (Ptr a) -throwErrnoIfNullRetryMayBlock = throwErrnoIfRetryMayBlock (== nullPtr) - --- conversion of an "errno" value into IO error --- -------------------------------------------- - --- convert a location string, an "errno" value, an optional handle, --- and an optional filename into a matching IO error --- -errnoToIOError :: String -> Errno -> Maybe Handle -> Maybe String -> IOError -errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do - str <- strerror errno >>= peekCString -#if __GLASGOW_HASKELL__ - return (IOException (IOError maybeHdl errType loc str maybeName)) - where - errType - | errno == eOK = OtherError - | errno == e2BIG = ResourceExhausted - | errno == eACCES = PermissionDenied - | errno == eADDRINUSE = ResourceBusy - | errno == eADDRNOTAVAIL = UnsupportedOperation - | errno == eADV = OtherError - | errno == eAFNOSUPPORT = UnsupportedOperation - | errno == eAGAIN = ResourceExhausted - | errno == eALREADY = AlreadyExists - | errno == eBADF = OtherError - | errno == eBADMSG = InappropriateType - | errno == eBADRPC = OtherError - | errno == eBUSY = ResourceBusy - | errno == eCHILD = NoSuchThing - | errno == eCOMM = ResourceVanished - | errno == eCONNABORTED = OtherError - | errno == eCONNREFUSED = NoSuchThing - | errno == eCONNRESET = ResourceVanished - | errno == eDEADLK = ResourceBusy - | errno == eDESTADDRREQ = InvalidArgument - | errno == eDIRTY = UnsatisfiedConstraints - | errno == eDOM = InvalidArgument - | errno == eDQUOT = PermissionDenied - | errno == eEXIST = AlreadyExists - | errno == eFAULT = OtherError - | errno == eFBIG = PermissionDenied - | errno == eFTYPE = InappropriateType - | errno == eHOSTDOWN = NoSuchThing - | errno == eHOSTUNREACH = NoSuchThing - | errno == eIDRM = ResourceVanished - | errno == eILSEQ = InvalidArgument - | errno == eINPROGRESS = AlreadyExists - | errno == eINTR = Interrupted - | errno == eINVAL = InvalidArgument - | errno == eIO = HardwareFault - | errno == eISCONN = AlreadyExists - | errno == eISDIR = InappropriateType - | errno == eLOOP = InvalidArgument - | errno == eMFILE = ResourceExhausted - | errno == eMLINK = ResourceExhausted - | errno == eMSGSIZE = ResourceExhausted - | errno == eMULTIHOP = UnsupportedOperation - | errno == eNAMETOOLONG = InvalidArgument - | errno == eNETDOWN = ResourceVanished - | errno == eNETRESET = ResourceVanished - | errno == eNETUNREACH = NoSuchThing - | errno == eNFILE = ResourceExhausted - | errno == eNOBUFS = ResourceExhausted - | errno == eNODATA = NoSuchThing - | errno == eNODEV = UnsupportedOperation - | errno == eNOENT = NoSuchThing - | errno == eNOEXEC = InvalidArgument - | errno == eNOLCK = ResourceExhausted - | errno == eNOLINK = ResourceVanished - | errno == eNOMEM = ResourceExhausted - | errno == eNOMSG = NoSuchThing - | errno == eNONET = NoSuchThing - | errno == eNOPROTOOPT = UnsupportedOperation - | errno == eNOSPC = ResourceExhausted - | errno == eNOSR = ResourceExhausted - | errno == eNOSTR = InvalidArgument - | errno == eNOSYS = UnsupportedOperation - | errno == eNOTBLK = InvalidArgument - | errno == eNOTCONN = InvalidArgument - | errno == eNOTDIR = InappropriateType - | errno == eNOTEMPTY = UnsatisfiedConstraints - | errno == eNOTSOCK = InvalidArgument - | errno == eNOTTY = IllegalOperation - | errno == eNXIO = NoSuchThing - | errno == eOPNOTSUPP = UnsupportedOperation - | errno == ePERM = PermissionDenied - | errno == ePFNOSUPPORT = UnsupportedOperation - | errno == ePIPE = ResourceVanished - | errno == ePROCLIM = PermissionDenied - | errno == ePROCUNAVAIL = UnsupportedOperation - | errno == ePROGMISMATCH = ProtocolError - | errno == ePROGUNAVAIL = UnsupportedOperation - | errno == ePROTO = ProtocolError - | errno == ePROTONOSUPPORT = ProtocolError - | errno == ePROTOTYPE = ProtocolError - | errno == eRANGE = UnsupportedOperation - | errno == eREMCHG = ResourceVanished - | errno == eREMOTE = IllegalOperation - | errno == eROFS = PermissionDenied - | errno == eRPCMISMATCH = ProtocolError - | errno == eRREMOTE = IllegalOperation - | errno == eSHUTDOWN = IllegalOperation - | errno == eSOCKTNOSUPPORT = UnsupportedOperation - | errno == eSPIPE = UnsupportedOperation - | errno == eSRCH = NoSuchThing - | errno == eSRMNT = UnsatisfiedConstraints - | errno == eSTALE = ResourceVanished - | errno == eTIME = TimeExpired - | errno == eTIMEDOUT = TimeExpired - | errno == eTOOMANYREFS = ResourceExhausted - | errno == eTXTBSY = ResourceBusy - | errno == eUSERS = ResourceExhausted - | errno == eWOULDBLOCK = OtherError - | errno == eXDEV = UnsupportedOperation - | otherwise = OtherError -#else - return (userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName)) -#endif - -foreign import unsafe strerror :: Errno -> IO (Ptr CChar) - --- Dreadfully tedious callouts to wrappers which define the --- actual values for the error codes. -foreign import ccall "prel_error_E2BIG" unsafe cCONST_E2BIG :: CInt -foreign import ccall "prel_error_EACCES" unsafe cCONST_EACCES :: CInt -foreign import ccall "prel_error_EADDRINUSE" unsafe cCONST_EADDRINUSE :: CInt -foreign import ccall "prel_error_EADDRNOTAVAIL" unsafe cCONST_EADDRNOTAVAIL :: CInt -foreign import ccall "prel_error_EADV" unsafe cCONST_EADV :: CInt -foreign import ccall "prel_error_EAFNOSUPPORT" unsafe cCONST_EAFNOSUPPORT :: CInt -foreign import ccall "prel_error_EAGAIN" unsafe cCONST_EAGAIN :: CInt -foreign import ccall "prel_error_EALREADY" unsafe cCONST_EALREADY :: CInt -foreign import ccall "prel_error_EBADF" unsafe cCONST_EBADF :: CInt -foreign import ccall "prel_error_EBADMSG" unsafe cCONST_EBADMSG :: CInt -foreign import ccall "prel_error_EBADRPC" unsafe cCONST_EBADRPC :: CInt -foreign import ccall "prel_error_EBUSY" unsafe cCONST_EBUSY :: CInt -foreign import ccall "prel_error_ECHILD" unsafe cCONST_ECHILD :: CInt -foreign import ccall "prel_error_ECOMM" unsafe cCONST_ECOMM :: CInt -foreign import ccall "prel_error_ECONNABORTED" unsafe cCONST_ECONNABORTED :: CInt -foreign import ccall "prel_error_ECONNREFUSED" unsafe cCONST_ECONNREFUSED :: CInt -foreign import ccall "prel_error_ECONNRESET" unsafe cCONST_ECONNRESET :: CInt -foreign import ccall "prel_error_EDEADLK" unsafe cCONST_EDEADLK :: CInt -foreign import ccall "prel_error_EDESTADDRREQ" unsafe cCONST_EDESTADDRREQ :: CInt -foreign import ccall "prel_error_EDIRTY" unsafe cCONST_EDIRTY :: CInt -foreign import ccall "prel_error_EDOM" unsafe cCONST_EDOM :: CInt -foreign import ccall "prel_error_EDQUOT" unsafe cCONST_EDQUOT :: CInt -foreign import ccall "prel_error_EEXIST" unsafe cCONST_EEXIST :: CInt -foreign import ccall "prel_error_EFAULT" unsafe cCONST_EFAULT :: CInt -foreign import ccall "prel_error_EFBIG" unsafe cCONST_EFBIG :: CInt -foreign import ccall "prel_error_EFTYPE" unsafe cCONST_EFTYPE :: CInt -foreign import ccall "prel_error_EHOSTDOWN" unsafe cCONST_EHOSTDOWN :: CInt -foreign import ccall "prel_error_EHOSTUNREACH" unsafe cCONST_EHOSTUNREACH :: CInt -foreign import ccall "prel_error_EIDRM" unsafe cCONST_EIDRM :: CInt -foreign import ccall "prel_error_EILSEQ" unsafe cCONST_EILSEQ :: CInt -foreign import ccall "prel_error_EINPROGRESS" unsafe cCONST_EINPROGRESS :: CInt -foreign import ccall "prel_error_EINTR" unsafe cCONST_EINTR :: CInt -foreign import ccall "prel_error_EINVAL" unsafe cCONST_EINVAL :: CInt -foreign import ccall "prel_error_EIO" unsafe cCONST_EIO :: CInt -foreign import ccall "prel_error_EISCONN" unsafe cCONST_EISCONN :: CInt -foreign import ccall "prel_error_EISDIR" unsafe cCONST_EISDIR :: CInt -foreign import ccall "prel_error_ELOOP" unsafe cCONST_ELOOP :: CInt -foreign import ccall "prel_error_EMFILE" unsafe cCONST_EMFILE :: CInt -foreign import ccall "prel_error_EMLINK" unsafe cCONST_EMLINK :: CInt -foreign import ccall "prel_error_EMSGSIZE" unsafe cCONST_EMSGSIZE :: CInt -foreign import ccall "prel_error_EMULTIHOP" unsafe cCONST_EMULTIHOP :: CInt -foreign import ccall "prel_error_ENAMETOOLONG" unsafe cCONST_ENAMETOOLONG :: CInt -foreign import ccall "prel_error_ENETDOWN" unsafe cCONST_ENETDOWN :: CInt -foreign import ccall "prel_error_ENETRESET" unsafe cCONST_ENETRESET :: CInt -foreign import ccall "prel_error_ENETUNREACH" unsafe cCONST_ENETUNREACH :: CInt -foreign import ccall "prel_error_ENFILE" unsafe cCONST_ENFILE :: CInt -foreign import ccall "prel_error_ENOBUFS" unsafe cCONST_ENOBUFS :: CInt -foreign import ccall "prel_error_ENODATA" unsafe cCONST_ENODATA :: CInt -foreign import ccall "prel_error_ENODEV" unsafe cCONST_ENODEV :: CInt -foreign import ccall "prel_error_ENOENT" unsafe cCONST_ENOENT :: CInt -foreign import ccall "prel_error_ENOEXEC" unsafe cCONST_ENOEXEC :: CInt -foreign import ccall "prel_error_ENOLCK" unsafe cCONST_ENOLCK :: CInt -foreign import ccall "prel_error_ENOLINK" unsafe cCONST_ENOLINK :: CInt -foreign import ccall "prel_error_ENOMEM" unsafe cCONST_ENOMEM :: CInt -foreign import ccall "prel_error_ENOMSG" unsafe cCONST_ENOMSG :: CInt -foreign import ccall "prel_error_ENONET" unsafe cCONST_ENONET :: CInt -foreign import ccall "prel_error_ENOPROTOOPT" unsafe cCONST_ENOPROTOOPT :: CInt -foreign import ccall "prel_error_ENOSPC" unsafe cCONST_ENOSPC :: CInt -foreign import ccall "prel_error_ENOSR" unsafe cCONST_ENOSR :: CInt -foreign import ccall "prel_error_ENOSTR" unsafe cCONST_ENOSTR :: CInt -foreign import ccall "prel_error_ENOSYS" unsafe cCONST_ENOSYS :: CInt -foreign import ccall "prel_error_ENOTBLK" unsafe cCONST_ENOTBLK :: CInt -foreign import ccall "prel_error_ENOTCONN" unsafe cCONST_ENOTCONN :: CInt -foreign import ccall "prel_error_ENOTDIR" unsafe cCONST_ENOTDIR :: CInt -foreign import ccall "prel_error_ENOTEMPTY" unsafe cCONST_ENOTEMPTY :: CInt -foreign import ccall "prel_error_ENOTSOCK" unsafe cCONST_ENOTSOCK :: CInt -foreign import ccall "prel_error_ENOTTY" unsafe cCONST_ENOTTY :: CInt -foreign import ccall "prel_error_ENXIO" unsafe cCONST_ENXIO :: CInt -foreign import ccall "prel_error_EOPNOTSUPP" unsafe cCONST_EOPNOTSUPP :: CInt -foreign import ccall "prel_error_EPERM" unsafe cCONST_EPERM :: CInt -foreign import ccall "prel_error_EPFNOSUPPORT" unsafe cCONST_EPFNOSUPPORT :: CInt -foreign import ccall "prel_error_EPIPE" unsafe cCONST_EPIPE :: CInt -foreign import ccall "prel_error_EPROCLIM" unsafe cCONST_EPROCLIM :: CInt -foreign import ccall "prel_error_EPROCUNAVAIL" unsafe cCONST_EPROCUNAVAIL :: CInt -foreign import ccall "prel_error_EPROGMISMATCH" unsafe cCONST_EPROGMISMATCH :: CInt -foreign import ccall "prel_error_EPROGUNAVAIL" unsafe cCONST_EPROGUNAVAIL :: CInt -foreign import ccall "prel_error_EPROTO" unsafe cCONST_EPROTO :: CInt -foreign import ccall "prel_error_EPROTONOSUPPORT" unsafe cCONST_EPROTONOSUPPORT :: CInt -foreign import ccall "prel_error_EPROTOTYPE" unsafe cCONST_EPROTOTYPE :: CInt -foreign import ccall "prel_error_ERANGE" unsafe cCONST_ERANGE :: CInt -foreign import ccall "prel_error_EREMCHG" unsafe cCONST_EREMCHG :: CInt -foreign import ccall "prel_error_EREMOTE" unsafe cCONST_EREMOTE :: CInt -foreign import ccall "prel_error_EROFS" unsafe cCONST_EROFS :: CInt -foreign import ccall "prel_error_ERPCMISMATCH" unsafe cCONST_ERPCMISMATCH :: CInt -foreign import ccall "prel_error_ERREMOTE" unsafe cCONST_ERREMOTE :: CInt -foreign import ccall "prel_error_ESHUTDOWN" unsafe cCONST_ESHUTDOWN :: CInt -foreign import ccall "prel_error_ESOCKTNOSUPPORT" unsafe cCONST_ESOCKTNOSUPPORT :: CInt -foreign import ccall "prel_error_ESPIPE" unsafe cCONST_ESPIPE :: CInt -foreign import ccall "prel_error_ESRCH" unsafe cCONST_ESRCH :: CInt -foreign import ccall "prel_error_ESRMNT" unsafe cCONST_ESRMNT :: CInt -foreign import ccall "prel_error_ESTALE" unsafe cCONST_ESTALE :: CInt -foreign import ccall "prel_error_ETIME" unsafe cCONST_ETIME :: CInt -foreign import ccall "prel_error_ETIMEDOUT" unsafe cCONST_ETIMEDOUT :: CInt -foreign import ccall "prel_error_ETOOMANYREFS" unsafe cCONST_ETOOMANYREFS :: CInt -foreign import ccall "prel_error_ETXTBSY" unsafe cCONST_ETXTBSY :: CInt -foreign import ccall "prel_error_EUSERS" unsafe cCONST_EUSERS :: CInt -foreign import ccall "prel_error_EWOULDBLOCK" unsafe cCONST_EWOULDBLOCK :: CInt -foreign import ccall "prel_error_EXDEV" unsafe cCONST_EXDEV :: CInt - -\end{code} diff --git a/ghc/lib/std/PrelCString.lhs b/ghc/lib/std/PrelCString.lhs deleted file mode 100644 index 533803d..0000000 --- a/ghc/lib/std/PrelCString.lhs +++ /dev/null @@ -1,125 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelCString.lhs,v 1.6 2001/11/27 14:49:10 simonmar Exp $ -% -% (c) The FFI task force, 2000 -% - -Utilities for primitive marshaling - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelCString where - -#ifdef __GLASGOW_HASKELL__ -import PrelMarshalArray -import PrelPtr -import PrelStorable -import PrelCTypes -import PrelWord -import PrelList -import PrelReal -import PrelNum -import PrelIOBase -import PrelBase -#endif - ------------------------------------------------------------------------------ --- Strings - --- representation of strings in C --- ------------------------------ - -type CString = Ptr CChar -- conventional NUL terminates strings -type CStringLen = (CString, Int) -- strings with explicit length - - --- exported functions --- ------------------ --- --- * the following routines apply the default conversion when converting the --- C-land character encoding into the Haskell-land character encoding --- --- ** NOTE: The current implementation doesn't handle conversions yet! ** --- --- * the routines using an explicit length tolerate NUL characters in the --- middle of a string --- - --- marshal a NUL terminated C string into a Haskell string --- -peekCString :: CString -> IO String -peekCString cp = do cs <- peekArray0 nUL cp; return (cCharsToChars cs) - --- marshal a C string with explicit length into a Haskell string --- -peekCStringLen :: CStringLen -> IO String -peekCStringLen (cp, len) = do cs <- peekArray len cp; return (cCharsToChars cs) - --- marshal a Haskell string into a NUL terminated C strings --- --- * the Haskell string may *not* contain any NUL characters --- --- * new storage is allocated for the C string and must be explicitly freed --- -newCString :: String -> IO CString -newCString = newArray0 nUL . charsToCChars - --- marshal a Haskell string into a C string (ie, character array) with --- explicit length information --- --- * new storage is allocated for the C string and must be explicitly freed --- -newCStringLen :: String -> IO CStringLen -newCStringLen str = do a <- newArray (charsToCChars str) - return (pairLength str a) - --- marshal a Haskell string into a NUL terminated C strings using temporary --- storage --- --- * the Haskell string may *not* contain any NUL characters --- --- * see the lifetime constraints of `MarshalAlloc.alloca' --- -withCString :: String -> (CString -> IO a) -> IO a -withCString = withArray0 nUL . charsToCChars - --- marshal a Haskell string into a NUL terminated C strings using temporary --- storage --- --- * the Haskell string may *not* contain any NUL characters --- --- * see the lifetime constraints of `MarshalAlloc.alloca' --- -withCStringLen :: String -> (CStringLen -> IO a) -> IO a -withCStringLen str act = withArray (charsToCChars str) $ act . pairLength str - --- auxilliary definitions --- ---------------------- - --- C's end of string character --- -nUL :: CChar -nUL = 0 - --- pair a C string with the length of the given Haskell string --- -pairLength :: String -> CString -> CStringLen -pairLength = flip (,) . length - --- cast [CChar] to [Char] --- -cCharsToChars :: [CChar] -> [Char] -cCharsToChars = map castCCharToChar - --- cast [Char] to [CChar] --- -charsToCChars :: [Char] -> [CChar] -charsToCChars = map castCharToCChar - -castCCharToChar :: CChar -> Char -castCCharToChar ch = unsafeChr (fromIntegral (fromIntegral ch :: Word8)) - -castCharToCChar :: Char -> CChar -castCharToCChar ch = fromIntegral (ord ch) -\end{code} diff --git a/ghc/lib/std/PrelCTypes.lhs b/ghc/lib/std/PrelCTypes.lhs deleted file mode 100644 index cca6eb8..0000000 --- a/ghc/lib/std/PrelCTypes.lhs +++ /dev/null @@ -1,88 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelCTypes.lhs,v 1.5 2002/02/04 09:05:46 chak Exp $ -% -% (c) The FFI task force, 2000 -% - -A mapping of C types to corresponding Haskell types. A cool hack... - -#include "cbits/CTypes.h" - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelCTypes - ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum, - -- Typeable, Storable, Bounded, Real, Integral, Bits - CChar(..), CSChar(..), CUChar(..) - , CShort(..), CUShort(..), CInt(..), CUInt(..) - , CLong(..), CULong(..), CLLong(..), CULLong(..) - - -- Floating types, instances of: Eq, Ord, Num, Read, Show, Enum, - -- Typeable, Storable, Real, Fractional, Floating, RealFrac, - -- RealFloat - , CFloat(..), CDouble(..), CLDouble(..) - ) where -\end{code} - -\begin{code} -import PrelBase -import PrelFloat -import PrelEnum -import PrelReal -import PrelShow -import PrelRead -import PrelNum -import PrelBits ( Bits(..) ) -import PrelInt ( Int8, Int16, Int32, Int64 ) -import PrelWord ( Word8, Word16, Word32, Word64 ) -\end{code} - -\begin{code} -INTEGRAL_TYPE(CChar,tyConCChar,"CChar",HTYPE_CHAR) -INTEGRAL_TYPE(CSChar,tyConCSChar,"CSChar",HTYPE_SIGNED_CHAR) -INTEGRAL_TYPE(CUChar,tyConCUChar,"CUChar",HTYPE_UNSIGNED_CHAR) - -INTEGRAL_TYPE(CShort,tyConCShort,"CShort",HTYPE_SHORT) -INTEGRAL_TYPE(CUShort,tyConCUShort,"CUShort",HTYPE_UNSIGNED_SHORT) - -INTEGRAL_TYPE(CInt,tyConCInt,"CInt",HTYPE_INT) -INTEGRAL_TYPE(CUInt,tyConCUInt,"CUInt",HTYPE_UNSIGNED_INT) - -INTEGRAL_TYPE(CLong,tyConCLong,"CLong",HTYPE_LONG) -INTEGRAL_TYPE(CULong,tyConCULong,"CULong",HTYPE_UNSIGNED_LONG) - -INTEGRAL_TYPE(CLLong,tyConCLLong,"CLLong",HTYPE_LONG_LONG) -INTEGRAL_TYPE(CULLong,tyConCULLong,"CULLong",HTYPE_UNSIGNED_LONG_LONG) - -{-# RULES -"fromIntegral/a->CChar" fromIntegral = \x -> CChar (fromIntegral x) -"fromIntegral/a->CSChar" fromIntegral = \x -> CSChar (fromIntegral x) -"fromIntegral/a->CUChar" fromIntegral = \x -> CUChar (fromIntegral x) -"fromIntegral/a->CShort" fromIntegral = \x -> CShort (fromIntegral x) -"fromIntegral/a->CUShort" fromIntegral = \x -> CUShort (fromIntegral x) -"fromIntegral/a->CInt" fromIntegral = \x -> CInt (fromIntegral x) -"fromIntegral/a->CUInt" fromIntegral = \x -> CUInt (fromIntegral x) -"fromIntegral/a->CLong" fromIntegral = \x -> CLong (fromIntegral x) -"fromIntegral/a->CULong" fromIntegral = \x -> CULong (fromIntegral x) -"fromIntegral/a->CLLong" fromIntegral = \x -> CLLong (fromIntegral x) -"fromIntegral/a->CULLong" fromIntegral = \x -> CULLong (fromIntegral x) - -"fromIntegral/CChar->a" fromIntegral = \(CChar x) -> fromIntegral x -"fromIntegral/CSChar->a" fromIntegral = \(CSChar x) -> fromIntegral x -"fromIntegral/CUChar->a" fromIntegral = \(CUChar x) -> fromIntegral x -"fromIntegral/CShort->a" fromIntegral = \(CShort x) -> fromIntegral x -"fromIntegral/CUShort->a" fromIntegral = \(CUShort x) -> fromIntegral x -"fromIntegral/CInt->a" fromIntegral = \(CInt x) -> fromIntegral x -"fromIntegral/CUInt->a" fromIntegral = \(CUInt x) -> fromIntegral x -"fromIntegral/CLong->a" fromIntegral = \(CLong x) -> fromIntegral x -"fromIntegral/CULong->a" fromIntegral = \(CULong x) -> fromIntegral x -"fromIntegral/CLLong->a" fromIntegral = \(CLLong x) -> fromIntegral x -"fromIntegral/CULLong->a" fromIntegral = \(CULLong x) -> fromIntegral x - #-} - -FLOATING_TYPE(CFloat,tyConCFloat,"CFloat",HTYPE_FLOAT) -FLOATING_TYPE(CDouble,tyConCDouble,"CDouble",HTYPE_DOUBLE) --- HACK: Currently no long double in the FFI, so we simply re-use double -FLOATING_TYPE(CLDouble,tyConCLDouble,"CLDouble",HTYPE_DOUBLE) -\end{code} diff --git a/ghc/lib/std/PrelCTypesISO.lhs b/ghc/lib/std/PrelCTypesISO.lhs deleted file mode 100644 index 99955c8..0000000 --- a/ghc/lib/std/PrelCTypesISO.lhs +++ /dev/null @@ -1,71 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelCTypesISO.lhs,v 1.7 2002/02/04 09:05:46 chak Exp $ -% -% (c) The FFI task force, 2000 -% - -A mapping of C types defined by the ISO C standard to corresponding Haskell -types. Like CTypes, this is a cool hack... - -#include "cbits/CTypes.h" - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelCTypesISO - ( -- Integral types, instances of: Eq, Ord, Num, Read, Show, Enum, - -- Typeable, Storable, Bounded, Real, Integral, Bits - CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) - - -- Numeric types, instances of: Eq, Ord, Num, Read, Show, Enum, - -- Typeable, Storable - , CClock(..), CTime(..), - - -- Instances of: Eq and Storable - , CFile, CFpos, CJmpBuf - ) where -\end{code} - -\begin{code} -import PrelBase -import PrelFloat -import PrelEnum -import PrelReal -import PrelShow -import PrelRead -import PrelNum -import PrelBase ( unsafeCoerce# ) -import PrelBits ( Bits(..) ) -import PrelInt ( Int8, Int16, Int32, Int64 ) -import PrelWord ( Word8, Word16, Word32, Word64 ) -\end{code} - -\begin{code} -INTEGRAL_TYPE(CPtrdiff,tyConCPtrdiff,"CPtrdiff",HTYPE_PTRDIFF_T) -INTEGRAL_TYPE(CSize,tyConCSize,"CSize",HTYPE_SIZE_T) -INTEGRAL_TYPE(CWchar,tyConCWchar,"CWchar",HTYPE_WCHAR_T) -INTEGRAL_TYPE(CSigAtomic,tyConCSigAtomic,"CSigAtomic",HTYPE_SIG_ATOMIC_T) - -{-# RULES -"fromIntegral/a->CPtrdiff" fromIntegral = \x -> CPtrdiff (fromIntegral x) -"fromIntegral/a->CSize" fromIntegral = \x -> CSize (fromIntegral x) -"fromIntegral/a->CWchar" fromIntegral = \x -> CWchar (fromIntegral x) -"fromIntegral/a->CSigAtomic" fromIntegral = \x -> CSigAtomic (fromIntegral x) - -"fromIntegral/CPtrdiff->a" fromIntegral = \(CPtrdiff x) -> fromIntegral x -"fromIntegral/CSize->a" fromIntegral = \(CSize x) -> fromIntegral x -"fromIntegral/CWchar->a" fromIntegral = \(CWchar x) -> fromIntegral x -"fromIntegral/CSigAtomic->a" fromIntegral = \(CSigAtomic x) -> fromIntegral x - #-} - -INTEGRAL_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T) -INTEGRAL_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T) - --- FIXME: Implement and provide instances for Eq and Storable -data CFile = CFile -data CFpos = CFpos -data CJmpBuf = CJmpBuf - --- C99 types which are still missing include: --- intptr_t, uintptr_t, intmax_t, uintmax_t, wint_t, wctrans_t, wctype_t -\end{code} diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs deleted file mode 100644 index e011060..0000000 --- a/ghc/lib/std/PrelConc.lhs +++ /dev/null @@ -1,205 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelConc.lhs,v 1.25 2001/09/14 15:49:56 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelConc]{Module @PrelConc@} - -Basic concurrency stuff - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelConc - ( ThreadId(..) - - -- Forking and suchlike - , myThreadId -- :: IO ThreadId - , killThread -- :: ThreadId -> IO () - , throwTo -- :: ThreadId -> Exception -> IO () - , par -- :: a -> b -> b - , pseq -- :: a -> b -> b - , yield -- :: IO () - - -- Waiting - , threadDelay -- :: Int -> IO () - , threadWaitRead -- :: Int -> IO () - , threadWaitWrite -- :: Int -> IO () - - -- MVars - , MVar -- abstract - , newMVar -- :: a -> IO (MVar a) - , newEmptyMVar -- :: IO (MVar a) - , takeMVar -- :: MVar a -> IO a - , putMVar -- :: MVar a -> a -> IO () - , tryTakeMVar -- :: MVar a -> IO (Maybe a) - , tryPutMVar -- :: MVar a -> a -> IO Bool - , isEmptyMVar -- :: MVar a -> IO Bool - , addMVarFinalizer -- :: MVar a -> IO () -> IO () - - ) where - -import PrelBase -import PrelMaybe -import PrelErr ( parError, seqError ) -import PrelIOBase ( IO(..), MVar(..) ) -import PrelBase ( Int(..) ) -import PrelException ( Exception(..), AsyncException(..) ) - -infixr 0 `par`, `pseq` -\end{code} - -%************************************************************************ -%* * -\subsection{@ThreadId@, @par@, and @fork@} -%* * -%************************************************************************ - -\begin{code} -data ThreadId = ThreadId ThreadId# --- ToDo: data ThreadId = ThreadId (Weak ThreadId#) --- But since ThreadId# is unlifted, the Weak type must use open --- type variables. - ---forkIO has now been hoisted out into the Concurrent library. - -killThread :: ThreadId -> IO () -killThread (ThreadId id) = IO $ \ s -> - case (killThread# id (AsyncException ThreadKilled) s) of s1 -> (# s1, () #) - -throwTo :: ThreadId -> Exception -> IO () -throwTo (ThreadId id) ex = IO $ \ s -> - case (killThread# id ex s) of s1 -> (# s1, () #) - -myThreadId :: IO ThreadId -myThreadId = IO $ \s -> - case (myThreadId# s) of (# s1, id #) -> (# s1, ThreadId id #) - -yield :: IO () -yield = IO $ \s -> - case (yield# s) of s1 -> (# s1, () #) - --- Nota Bene: 'pseq' used to be 'seq' --- but 'seq' is now defined in PrelGHC --- --- "pseq" is defined a bit weirdly (see below) --- --- The reason for the strange "0# -> parError" case is that --- it fools the compiler into thinking that seq is non-strict in --- its second argument (even if it inlines seq at the call site). --- If it thinks seq is strict in "y", then it often evaluates --- "y" before "x", which is totally wrong. --- --- Just before converting from Core to STG there's a bit of magic --- that recognises the seq# and eliminates the duff case. - -{-# INLINE pseq #-} -pseq :: a -> b -> b -pseq x y = case (seq# x) of { 0# -> seqError; _ -> y } - -{-# INLINE par #-} -par :: a -> b -> b -par x y = case (par# x) of { 0# -> parError; _ -> y } -\end{code} - -%************************************************************************ -%* * -\subsection[mvars]{M-Structures} -%* * -%************************************************************************ - -M-Vars are rendezvous points for concurrent threads. They begin -empty, and any attempt to read an empty M-Var blocks. When an M-Var -is written, a single blocked thread may be freed. Reading an M-Var -toggles its state from full back to empty. Therefore, any value -written to an M-Var may only be read once. Multiple reads and writes -are allowed, but there must be at least one read between any two -writes. - -\begin{code} ---Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) - -newEmptyMVar :: IO (MVar a) -newEmptyMVar = IO $ \ s# -> - case newMVar# s# of - (# s2#, svar# #) -> (# s2#, MVar svar# #) - -takeMVar :: MVar a -> IO a -takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s# - -putMVar :: MVar a -> a -> IO () -putMVar (MVar mvar#) x = IO $ \ s# -> - case putMVar# mvar# x s# of - s2# -> (# s2#, () #) - -tryPutMVar :: MVar a -> a -> IO Bool -tryPutMVar (MVar mvar#) x = IO $ \ s# -> - case tryPutMVar# mvar# x s# of - (# s, 0# #) -> (# s, False #) - (# s, _ #) -> (# s, True #) - -newMVar :: a -> IO (MVar a) -newMVar value = - newEmptyMVar >>= \ mvar -> - putMVar mvar value >> - return mvar - --- tryTakeMVar is a non-blocking takeMVar -tryTakeMVar :: MVar a -> IO (Maybe a) -tryTakeMVar (MVar m) = IO $ \ s -> - case tryTakeMVar# m s of - (# s, 0#, _ #) -> (# s, Nothing #) -- MVar is empty - (# s, _, a #) -> (# s, Just a #) -- MVar is full - -{- - Low-level op. for checking whether an MVar is filled-in or not. - Notice that the boolean value returned is just a snapshot of - the state of the MVar. By the time you get to react on its result, - the MVar may have been filled (or emptied) - so be extremely - careful when using this operation. - - Use tryTakeMVar instead if possible. - - If you can re-work your abstractions to avoid having to - depend on isEmptyMVar, then you're encouraged to do so, - i.e., consider yourself warned about the imprecision in - general of isEmptyMVar :-) --} -isEmptyMVar :: MVar a -> IO Bool -isEmptyMVar (MVar mv#) = IO $ \ s# -> - case isEmptyMVar# mv# s# of - (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) - --- Like addForeignPtrFinalizer, but for MVars -addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = - IO $ \s -> case mkWeak# m () finalizer s of { (# s1, w #) -> (# s1, () #) } -\end{code} - - -%************************************************************************ -%* * -\subsection{Thread waiting} -%* * -%************************************************************************ - -@threadDelay@ delays rescheduling of a thread until the indicated -number of microseconds have elapsed. Generally, the microseconds are -counted by the context switch timer, which ticks in virtual time; -however, when there are no runnable threads, we don't accumulate any -virtual time, so we start ticking in real time. (The granularity is -the effective resolution of the context switch timer, so it is -affected by the RTS -C option.) - -@threadWaitRead@ delays rescheduling of a thread until input on the -specified file descriptor is available for reading (just like select). -@threadWaitWrite@ is similar, but for writing on a file descriptor. - -\begin{code} -threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () - -threadDelay (I# ms) = IO $ \s -> case delay# ms s of s -> (# s, () #) -threadWaitRead (I# fd) = IO $ \s -> case waitRead# fd s of s -> (# s, () #) -threadWaitWrite (I# fd) = IO $ \s -> case waitWrite# fd s of s -> (# s, () #) -\end{code} diff --git a/ghc/lib/std/PrelDynamic.lhs b/ghc/lib/std/PrelDynamic.lhs deleted file mode 100644 index aabb377..0000000 --- a/ghc/lib/std/PrelDynamic.lhs +++ /dev/null @@ -1,35 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelDynamic.lhs,v 1.6 2001/01/11 17:25:57 simonmar Exp $ -% -% (c) The University of Glasgow, 1998-2000 -% - -The Dynamic type is used in the Exception type, so we have to have -Dynamic visible here. The rest of the operations on Dynamics are -available in lang/Dynamic.lhs. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#ifndef __HUGS__ -module PrelDynamic where - -import PrelBase -#endif - -data Dynamic = Dynamic TypeRep Obj - -data Obj = Obj - -- dummy type to hold the dynamically typed value. - -data TypeRep - = App TyCon [TypeRep] - | Fun TypeRep TypeRep - deriving ( Eq ) - --- type constructors are -data TyCon = TyCon Int String - -instance Eq TyCon where - (TyCon t1 _) == (TyCon t2 _) = t1 == t2 -\end{code} diff --git a/ghc/lib/std/PrelEnum.lhs b/ghc/lib/std/PrelEnum.lhs deleted file mode 100644 index 5bcf0ac..0000000 --- a/ghc/lib/std/PrelEnum.lhs +++ /dev/null @@ -1,408 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelEnum.lhs,v 1.18 2002/01/29 09:58:19 simonpj Exp $ -% -% (c) The University of Glasgow, 1992-2001 -% - -Instances of Bounded and Enum for various datatypes. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelEnum( - Bounded(..), Enum(..), - boundedEnumFrom, boundedEnumFromThen, - - -- Instances for Bounded and Eum: (), Char, Int - - ) where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelBase -import PrelTup () -- To make sure we look for the .hi file - -default () -- Double isn't available yet -\end{code} - - -%********************************************************* -%* * -\subsection{Class declarations} -%* * -%********************************************************* - -\begin{code} -class Bounded a where - minBound, maxBound :: a - -class Enum a where - succ, pred :: a -> a - toEnum :: Int -> a - fromEnum :: a -> Int - enumFrom :: a -> [a] -- [n..] - enumFromThen :: a -> a -> [a] -- [n,n'..] - enumFromTo :: a -> a -> [a] -- [n..m] - enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] - - succ = toEnum . (`plusInt` oneInt) . fromEnum - pred = toEnum . (`minusInt` oneInt) . fromEnum - enumFrom x = map toEnum [fromEnum x ..] - enumFromThen x y = map toEnum [fromEnum x, fromEnum y ..] - enumFromTo x y = map toEnum [fromEnum x .. fromEnum y] - enumFromThenTo x1 x2 y = map toEnum [fromEnum x1, fromEnum x2 .. fromEnum y] - --- Default methods for bounded enumerations -boundedEnumFrom :: (Enum a, Bounded a) => a -> [a] -boundedEnumFrom n = map toEnum [fromEnum n .. fromEnum (maxBound `asTypeOf` n)] - -boundedEnumFromThen :: (Enum a, Bounded a) => a -> a -> [a] -boundedEnumFromThen n1 n2 - | i_n2 >= i_n1 = map toEnum [i_n1, i_n2 .. fromEnum (maxBound `asTypeOf` n1)] - | otherwise = map toEnum [i_n1, i_n2 .. fromEnum (minBound `asTypeOf` n1)] - where - i_n1 = fromEnum n1 - i_n2 = fromEnum n2 -\end{code} - - -%********************************************************* -%* * -\subsection{Tuples} -%* * -%********************************************************* - -\begin{code} -instance Bounded () where - minBound = () - maxBound = () - -instance Enum () where - succ _ = error "Prelude.Enum.().succ: bad argment" - pred _ = error "Prelude.Enum.().pred: bad argument" - - toEnum x | x == zeroInt = () - | otherwise = error "Prelude.Enum.().toEnum: bad argument" - - fromEnum () = zeroInt - enumFrom () = [()] - enumFromThen () () = [()] - enumFromTo () () = [()] - enumFromThenTo () () () = [()] -\end{code} - -\begin{code} -instance (Bounded a, Bounded b) => Bounded (a,b) where - minBound = (minBound, minBound) - maxBound = (maxBound, maxBound) - -instance (Bounded a, Bounded b, Bounded c) => Bounded (a,b,c) where - minBound = (minBound, minBound, minBound) - maxBound = (maxBound, maxBound, maxBound) - -instance (Bounded a, Bounded b, Bounded c, Bounded d) => Bounded (a,b,c,d) where - minBound = (minBound, minBound, minBound, minBound) - maxBound = (maxBound, maxBound, maxBound, maxBound) -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Bool@} -%* * -%********************************************************* - -\begin{code} -instance Bounded Bool where - minBound = False - maxBound = True - -instance Enum Bool where - succ False = True - succ True = error "Prelude.Enum.Bool.succ: bad argment" - - pred True = False - pred False = error "Prelude.Enum.Bool.pred: bad argment" - - toEnum n | n == zeroInt = False - | n == oneInt = True - | otherwise = error "Prelude.Enum.Bool.toEnum: bad argment" - - fromEnum False = zeroInt - fromEnum True = oneInt - - -- Use defaults for the rest - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen -\end{code} - -%********************************************************* -%* * -\subsection{Type @Ordering@} -%* * -%********************************************************* - -\begin{code} -instance Bounded Ordering where - minBound = LT - maxBound = GT - -instance Enum Ordering where - succ LT = EQ - succ EQ = GT - succ GT = error "Prelude.Enum.Ordering.succ: bad argment" - - pred GT = EQ - pred EQ = LT - pred LT = error "Prelude.Enum.Ordering.pred: bad argment" - - toEnum n | n == zeroInt = LT - | n == oneInt = EQ - | n == twoInt = GT - toEnum _ = error "Prelude.Enum.Ordering.toEnum: bad argment" - - fromEnum LT = zeroInt - fromEnum EQ = oneInt - fromEnum GT = twoInt - - -- Use defaults for the rest - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen -\end{code} - -%********************************************************* -%* * -\subsection{Type @Char@} -%* * -%********************************************************* - -\begin{code} -instance Bounded Char where - minBound = '\0' - maxBound = '\x10FFFF' - -instance Enum Char where - succ (C# c#) - | not (ord# c# ==# 0x10FFFF#) = C# (chr# (ord# c# +# 1#)) - | otherwise = error ("Prelude.Enum.Char.succ: bad argument") - pred (C# c#) - | not (ord# c# ==# 0#) = C# (chr# (ord# c# -# 1#)) - | otherwise = error ("Prelude.Enum.Char.pred: bad argument") - - toEnum = chr - fromEnum = ord - - {-# INLINE enumFrom #-} - enumFrom (C# x) = eftChar (ord# x) 0x10FFFF# - -- Blarg: technically I guess enumFrom isn't strict! - - {-# INLINE enumFromTo #-} - enumFromTo (C# x) (C# y) = eftChar (ord# x) (ord# y) - - {-# INLINE enumFromThen #-} - enumFromThen (C# x1) (C# x2) = efdChar (ord# x1) (ord# x2) - - {-# INLINE enumFromThenTo #-} - enumFromThenTo (C# x1) (C# x2) (C# y) = efdtChar (ord# x1) (ord# x2) (ord# y) - -{-# RULES -"eftChar" [~1] forall x y. eftChar x y = build (\c n -> eftCharFB c n x y) -"efdChar" [~1] forall x1 x2. efdChar x1 x2 = build (\ c n -> efdCharFB c n x1 x2) -"efdtChar" [~1] forall x1 x2 l. efdtChar x1 x2 l = build (\ c n -> efdtCharFB c n x1 x2 l) -"eftCharList" [1] eftCharFB (:) [] = eftChar -"efdCharList" [1] efdCharFB (:) [] = efdChar -"efdtCharList" [1] efdtCharFB (:) [] = efdtChar - #-} - - --- We can do better than for Ints because we don't --- have hassles about arithmetic overflow at maxBound -{-# INLINE [0] eftCharFB #-} -eftCharFB c n x y = go x - where - go x | x ># y = n - | otherwise = C# (chr# x) `c` go (x +# 1#) - -eftChar x y | x ># y = [] - | otherwise = C# (chr# x) : eftChar (x +# 1#) y - - --- For enumFromThenTo we give up on inlining -{-# NOINLINE [0] efdCharFB #-} -efdCharFB c n x1 x2 - | delta >=# 0# = go_up_char_fb c n x1 delta 0x10FFFF# - | otherwise = go_dn_char_fb c n x1 delta 0# - where - delta = x2 -# x1 - -efdChar x1 x2 - | delta >=# 0# = go_up_char_list x1 delta 0x10FFFF# - | otherwise = go_dn_char_list x1 delta 0# - where - delta = x2 -# x1 - -{-# NOINLINE [0] efdtCharFB #-} -efdtCharFB c n x1 x2 lim - | delta >=# 0# = go_up_char_fb c n x1 delta lim - | otherwise = go_dn_char_fb c n x1 delta lim - where - delta = x2 -# x1 - -efdtChar x1 x2 lim - | delta >=# 0# = go_up_char_list x1 delta lim - | otherwise = go_dn_char_list x1 delta lim - where - delta = x2 -# x1 - -go_up_char_fb c n x delta lim - = go_up x - where - go_up x | x ># lim = n - | otherwise = C# (chr# x) `c` go_up (x +# delta) - -go_dn_char_fb c n x delta lim - = go_dn x - where - go_dn x | x <# lim = n - | otherwise = C# (chr# x) `c` go_dn (x +# delta) - -go_up_char_list x delta lim - = go_up x - where - go_up x | x ># lim = [] - | otherwise = C# (chr# x) : go_up (x +# delta) - -go_dn_char_list x delta lim - = go_dn x - where - go_dn x | x <# lim = [] - | otherwise = C# (chr# x) : go_dn (x +# delta) -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Int@} -%* * -%********************************************************* - -Be careful about these instances. - (a) remember that you have to count down as well as up e.g. [13,12..0] - (b) be careful of Int overflow - (c) remember that Int is bounded, so [1..] terminates at maxInt - -Also NB that the Num class isn't available in this module. - -\begin{code} -instance Bounded Int where - minBound = minInt - maxBound = maxInt - -instance Enum Int where - succ x - | x == maxBound = error "Prelude.Enum.succ{Int}: tried to take `succ' of maxBound" - | otherwise = x `plusInt` oneInt - pred x - | x == minBound = error "Prelude.Enum.pred{Int}: tried to take `pred' of minBound" - | otherwise = x `minusInt` oneInt - - toEnum x = x - fromEnum x = x - - {-# INLINE enumFrom #-} - enumFrom (I# x) = eftInt x maxInt# - where I# maxInt# = maxInt - -- Blarg: technically I guess enumFrom isn't strict! - - {-# INLINE enumFromTo #-} - enumFromTo (I# x) (I# y) = eftInt x y - - {-# INLINE enumFromThen #-} - enumFromThen (I# x1) (I# x2) = efdInt x1 x2 - - {-# INLINE enumFromThenTo #-} - enumFromThenTo (I# x1) (I# x2) (I# y) = efdtInt x1 x2 y - -{-# RULES -"eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) -"efdInt" [~1] forall x1 x2. efdInt x1 x2 = build (\ c n -> efdIntFB c n x1 x2) -"efdtInt" [~1] forall x1 x2 l. efdtInt x1 x2 l = build (\ c n -> efdtIntFB c n x1 x2 l) - -"eftIntList" [1] eftIntFB (:) [] = eftInt -"efdIntList" [1] efdIntFB (:) [] = efdInt -"efdtIntList" [1] efdtIntFB (:) [] = efdtInt - #-} - - -{-# INLINE [0] eftIntFB #-} -eftIntFB c n x y | x ># y = n - | otherwise = go x - where - go x = I# x `c` if x ==# y then n else go (x +# 1#) - -- Watch out for y=maxBound; hence ==, not > - -- Be very careful not to have more than one "c" - -- so that when eftInfFB is inlined we can inline - -- whatver is bound to "c" - -eftInt x y | x ># y = [] - | otherwise = go x - where - go x = I# x : if x ==# y then [] else go (x +# 1#) - - --- For enumFromThenTo we give up on inlining; so we don't worry --- about duplicating occurrences of "c" -{-# NOINLINE [0] efdtIntFB #-} -efdtIntFB c n x1 x2 y - | delta >=# 0# = if x1 ># y then n else go_up_int_fb c n x1 delta lim - | otherwise = if x1 <# y then n else go_dn_int_fb c n x1 delta lim - where - delta = x2 -# x1 - lim = y -# delta - -efdtInt x1 x2 y - | delta >=# 0# = if x1 ># y then [] else go_up_int_list x1 delta lim - | otherwise = if x1 <# y then [] else go_dn_int_list x1 delta lim - where - delta = x2 -# x1 - lim = y -# delta - -{-# NOINLINE [0] efdIntFB #-} -efdIntFB c n x1 x2 - | delta >=# 0# = case maxInt of I# y -> go_up_int_fb c n x1 delta (y -# delta) - | otherwise = case minInt of I# y -> go_dn_int_fb c n x1 delta (y -# delta) - where - delta = x2 -# x1 - -efdInt x1 x2 - | delta >=# 0# = case maxInt of I# y -> go_up_int_list x1 delta (y -# delta) - | otherwise = case minInt of I# y -> go_dn_int_list x1 delta (y -# delta) - where - delta = x2 -# x1 - --- In all of these, the (x +# delta) is guaranteed not to overflow - -go_up_int_fb c n x delta lim - = go_up x - where - go_up x | x ># lim = I# x `c` n - | otherwise = I# x `c` go_up (x +# delta) - -go_dn_int_fb c n x delta lim - = go_dn x - where - go_dn x | x <# lim = I# x `c` n - | otherwise = I# x `c` go_dn (x +# delta) - -go_up_int_list x delta lim - = go_up x - where - go_up x | x ># lim = [I# x] - | otherwise = I# x : go_up (x +# delta) - -go_dn_int_list x delta lim - = go_dn x - where - go_dn x | x <# lim = [I# x] - | otherwise = I# x : go_dn (x +# delta) -\end{code} - diff --git a/ghc/lib/std/PrelErr.hi-boot b/ghc/lib/std/PrelErr.hi-boot deleted file mode 100644 index 1181d79..0000000 --- a/ghc/lib/std/PrelErr.hi-boot +++ /dev/null @@ -1,12 +0,0 @@ ---------------------------------------------------------------------------- --- PrelErr.hi-boot --- --- This hand-written interface file is the initial bootstrap version --- for PrelErr.hi. --- It doesn't need to give "error" a type signature, --- because it's wired into the compiler ---------------------------------------------------------------------------- - -__interface "std" PrelErr 1 where -__export PrelErr error parError; - diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs deleted file mode 100644 index 53daf03..0000000 --- a/ghc/lib/std/PrelErr.lhs +++ /dev/null @@ -1,133 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelErr.lhs,v 1.21 2001/07/24 16:09:48 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelErr]{Module @PrelErr@} - -The PrelErr module defines the code for the wired-in error functions, -which have a special type in the compiler (with "open tyvars"). - -We cannot define these functions in a module where they might be used -(e.g., PrelBase), because the magical wired-in type will get confused -with what the typechecker figures out. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} -module PrelErr - ( - irrefutPatError - , noMethodBindingError - , nonExhaustiveGuardsError - , patError - , recSelError - , recConError - , recUpdError -- :: String -> a - - , absentErr, parError -- :: a - , seqError -- :: a - - , errorCString -- :: Addr# -> a -- Arg is a ptr to C string - , error -- :: String -> a - , assertError -- :: String -> Bool -> a -> a - - , undefined -- :: a - ) where - -import PrelBase -import PrelList ( span ) -import PrelException -\end{code} - -%********************************************************* -%* * -\subsection{Error-ish functions} -%* * -%********************************************************* - -\begin{code} --- error stops execution and displays an error message -error :: String -> a -error s = throw (ErrorCall s) - -errorCString :: Addr# -> a -errorCString s = error (unpackCString# s) - --- It is expected that compilers will recognize this and insert error --- messages which are more appropriate to the context in which undefined --- appears. - -undefined :: a -undefined = error "Prelude.undefined" -\end{code} - -%********************************************************* -%* * -\subsection{Compiler generated errors + local utils} -%* * -%********************************************************* - -Used for compiler-generated error message; -encoding saves bytes of string junk. - -\begin{code} -absentErr, parError, seqError :: a - -absentErr = error "Oops! The program has entered an `absent' argument!\n" -parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n" -seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n" - -\end{code} - -\begin{code} -irrefutPatError - , noMethodBindingError - , nonExhaustiveGuardsError - , patError - , recSelError - , recConError - , recUpdError :: String -> a - -noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation")) -irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern")) -nonExhaustiveGuardsError s = throw (PatternMatchFail (untangle s "Non-exhaustive guards in")) -patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in")) -recSelError s = throw (RecSelError (untangle s "Missing field in record selection")) -recConError s = throw (RecConError (untangle s "Missing field in record construction")) -recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated")) - - -assertError :: String -> Bool -> a -> a -assertError str pred v - | pred = v - | otherwise = throw (AssertionFailed (untangle str "Assertion failed")) - -\end{code} - - -(untangle coded message) expects "coded" to be of the form - - "location|details" - -It prints - - location message details - -\begin{code} -untangle :: String -> String -> String -untangle coded message - = location - ++ ": " - ++ message - ++ details - ++ "\n" - where - (location, details) - = case (span not_bar coded) of { (loc, rest) -> - case rest of - ('|':det) -> (loc, ' ' : det) - _ -> (loc, "") - } - not_bar c = c /= '|' -\end{code} diff --git a/ghc/lib/std/PrelException.lhs b/ghc/lib/std/PrelException.lhs deleted file mode 100644 index 21d6b0b..0000000 --- a/ghc/lib/std/PrelException.lhs +++ /dev/null @@ -1,123 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelException.lhs,v 1.24 2000/09/14 14:24:02 simonmar Exp $ -% -% (c) The University of Glasgow, 1998-2000 -% - -Exceptions and exception-handling functions. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#ifndef __HUGS__ -module PrelException - ( module PrelException, - Exception(..), AsyncException(..), - IOException(..), ArithException(..), ArrayException(..), - throw, ioError ) - where - -import PrelBase -import PrelMaybe -import PrelIOBase - -#endif -\end{code} - -%********************************************************* -%* * -\subsection{Primitive catch} -%* * -%********************************************************* - -catchException used to handle the passing around of the state to the -action and the handler. This turned out to be a bad idea - it meant -that we had to wrap both arguments in thunks so they could be entered -as normal (remember IO returns an unboxed pair...). - -Now catch# has type - - catch# :: IO a -> (b -> IO a) -> IO a - -(well almost; the compiler doesn't know about the IO newtype so we -have to work around that in the definition of catchException below). - -\begin{code} -catchException :: IO a -> (Exception -> IO a) -> IO a -#ifdef __HUGS__ -catchException m k = ST (\s -> unST m s `primCatch'` \ err -> unST (k err) s) -#else -catchException (IO m) k = IO $ \s -> catch# m (\ex -> unIO (k ex)) s -#endif - -catch :: IO a -> (Exception -> IO a) -> IO a -catch m k = catchException m handler - where handler err@(IOException _) = k err - handler err@(UserError _) = k err - handler other = throw other -\end{code} - - -%********************************************************* -%* * -\subsection{Try and bracket} -%* * -%********************************************************* - -The construct @try comp@ exposes errors which occur within a -computation, and which are not fully handled. It always succeeds. - -These are the IO-only try/bracket. For the full exception try/bracket -see hslibs/lang/Exception.lhs. - -\begin{code} -try :: IO a -> IO (Either Exception 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 -> ioError 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 -> ioError e -\end{code} - - -%********************************************************* -%* * -\subsection{Controlling asynchronous exception delivery} -%* * -%********************************************************* - -\begin{code} -#ifndef __HUGS__ -block :: IO a -> IO a -block (IO io) = IO $ blockAsyncExceptions# io - -unblock :: IO a -> IO a -unblock (IO io) = IO $ unblockAsyncExceptions# io -#else --- Not implemented yet in Hugs. -block :: IO a -> IO a -block (IO io) = IO io - -unblock :: IO a -> IO a -unblock (IO io) = IO io -#endif -\end{code} - - diff --git a/ghc/lib/std/PrelFloat.lhs b/ghc/lib/std/PrelFloat.lhs deleted file mode 100644 index e2172ba..0000000 --- a/ghc/lib/std/PrelFloat.lhs +++ /dev/null @@ -1,924 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelFloat.lhs,v 1.14 2001/11/20 14:12:48 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelNum]{Module @PrelNum@} - -The types - - Float - Double - -and the classes - - Floating - RealFloat - - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "../../includes/ieee-flpt.h" - -module PrelFloat( module PrelFloat, Float#, Double# ) where - -import PrelBase -import PrelList -import PrelEnum -import PrelShow -import PrelNum -import PrelReal -import PrelArr -import PrelMaybe - -infixr 8 ** -\end{code} - -%********************************************************* -%* * -\subsection{Standard numeric classes} -%* * -%********************************************************* - -\begin{code} -class (Fractional a) => Floating a where - pi :: a - exp, log, sqrt :: a -> a - (**), logBase :: a -> a -> a - sin, cos, tan :: a -> a - asin, acos, atan :: a -> a - sinh, cosh, tanh :: a -> a - asinh, acosh, atanh :: a -> a - - x ** y = exp (log x * y) - logBase x y = log y / log x - sqrt x = x ** 0.5 - tan x = sin x / cos x - tanh x = sinh x / cosh x - -class (RealFrac a, Floating a) => RealFloat a where - floatRadix :: a -> Integer - floatDigits :: a -> Int - floatRange :: a -> (Int,Int) - decodeFloat :: a -> (Integer,Int) - encodeFloat :: Integer -> Int -> a - exponent :: a -> Int - significand :: a -> a - scaleFloat :: Int -> a -> a - isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE - :: a -> Bool - atan2 :: a -> a -> a - - - exponent x = if m == 0 then 0 else n + floatDigits x - where (m,n) = decodeFloat x - - significand x = encodeFloat m (negate (floatDigits x)) - where (m,_) = decodeFloat x - - scaleFloat k x = encodeFloat m (n+k) - where (m,n) = decodeFloat x - - atan2 y x - | x > 0 = atan (y/x) - | x == 0 && y > 0 = pi/2 - | x < 0 && y > 0 = pi + atan (y/x) - |(x <= 0 && y < 0) || - (x < 0 && isNegativeZero y) || - (isNegativeZero x && isNegativeZero y) - = -atan2 (-y) x - | y == 0 && (x < 0 || isNegativeZero x) - = pi -- must be after the previous test on zero y - | x==0 && y==0 = y -- must be after the other double zero tests - | otherwise = x + y -- x or y is a NaN, return a NaN (via +) -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Integer@, @Float@, @Double@} -%* * -%********************************************************* - -\begin{code} -data Float = F# Float# -data Double = D# Double# - -instance CCallable Float -instance CReturnable Float - -instance CCallable Double -instance CReturnable Double -\end{code} - - -%********************************************************* -%* * -\subsection{Type @Float@} -%* * -%********************************************************* - -\begin{code} -instance Eq Float where - (F# x) == (F# y) = x `eqFloat#` y - -instance Ord Float where - (F# x) `compare` (F# y) | x `ltFloat#` y = LT - | x `eqFloat#` y = EQ - | otherwise = GT - - (F# x) < (F# y) = x `ltFloat#` y - (F# x) <= (F# y) = x `leFloat#` y - (F# x) >= (F# y) = x `geFloat#` y - (F# x) > (F# y) = x `gtFloat#` y - -instance Num Float where - (+) x y = plusFloat x y - (-) x y = minusFloat x y - negate x = negateFloat x - (*) x y = timesFloat x y - abs x | x >= 0.0 = x - | otherwise = negateFloat x - signum x | x == 0.0 = 0 - | x > 0.0 = 1 - | otherwise = negate 1 - - {-# INLINE fromInteger #-} - fromInteger n = encodeFloat n 0 - -- It's important that encodeFloat inlines here, and that - -- fromInteger in turn inlines, - -- so that if fromInteger is applied to an (S# i) the right thing happens - -instance Real Float where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x - -instance Fractional Float where - (/) x y = divideFloat x y - fromRational x = fromRat x - recip x = 1.0 / x - -{-# RULES "truncate/Float->Int" truncate = float2Int #-} -instance RealFrac Float where - - {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} - {-# SPECIALIZE round :: Float -> Int #-} - {-# SPECIALIZE ceiling :: Float -> Int #-} - {-# SPECIALIZE floor :: Float -> Int #-} - - {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-} - {-# SPECIALIZE truncate :: Float -> Integer #-} - {-# SPECIALIZE round :: Float -> Integer #-} - {-# SPECIALIZE ceiling :: Float -> Integer #-} - {-# SPECIALIZE floor :: Float -> Integer #-} - - properFraction x - = case (decodeFloat x) of { (m,n) -> - let b = floatRadix x in - if n >= 0 then - (fromInteger m * fromInteger b ^ n, 0.0) - else - case (quotRem m (b^(negate n))) of { (w,r) -> - (fromInteger w, encodeFloat r n) - } - } - - truncate x = case properFraction x of - (n,_) -> n - - round x = case properFraction x of - (n,r) -> let - m = if r < 0.0 then n - 1 else n + 1 - half_down = abs r - 0.5 - in - case (compare half_down 0.0) of - LT -> n - EQ -> if even n then n else m - GT -> m - - ceiling x = case properFraction x of - (n,r) -> if r > 0.0 then n + 1 else n - - floor x = case properFraction x of - (n,r) -> if r < 0.0 then n - 1 else n - -instance Floating Float where - pi = 3.141592653589793238 - exp x = expFloat x - log x = logFloat x - sqrt x = sqrtFloat x - sin x = sinFloat x - cos x = cosFloat x - tan x = tanFloat x - asin x = asinFloat x - acos x = acosFloat x - atan x = atanFloat x - sinh x = sinhFloat x - cosh x = coshFloat x - tanh x = tanhFloat x - (**) x y = powerFloat x y - logBase x y = log y / log x - - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = log ((x+1.0) / sqrt (1.0-x*x)) - -instance RealFloat Float where - floatRadix _ = FLT_RADIX -- from float.h - floatDigits _ = FLT_MANT_DIG -- ditto - floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto - - decodeFloat (F# f#) - = case decodeFloat# f# of - (# exp#, s#, d# #) -> (J# s# d#, I# exp#) - - encodeFloat (S# i) j = int_encodeFloat# i j - encodeFloat (J# s# d#) e = encodeFloat# s# d# e - - exponent x = case decodeFloat x of - (m,n) -> if m == 0 then 0 else n + floatDigits x - - significand x = case decodeFloat x of - (m,_) -> encodeFloat m (negate (floatDigits x)) - - scaleFloat k x = case decodeFloat x of - (m,n) -> encodeFloat m (n+k) - isNaN x = 0 /= isFloatNaN x - isInfinite x = 0 /= isFloatInfinite x - isDenormalized x = 0 /= isFloatDenormalized x - isNegativeZero x = 0 /= isFloatNegativeZero x - isIEEE _ = True - -instance Show Float where - showsPrec x = showSigned showFloat x - showList = showList__ (showsPrec 0) -\end{code} - -%********************************************************* -%* * -\subsection{Type @Double@} -%* * -%********************************************************* - -\begin{code} -instance Eq Double where - (D# x) == (D# y) = x ==## y - -instance Ord Double where - (D# x) `compare` (D# y) | x <## y = LT - | x ==## y = EQ - | otherwise = GT - - (D# x) < (D# y) = x <## y - (D# x) <= (D# y) = x <=## y - (D# x) >= (D# y) = x >=## y - (D# x) > (D# y) = x >## y - -instance Num Double where - (+) x y = plusDouble x y - (-) x y = minusDouble x y - negate x = negateDouble x - (*) x y = timesDouble x y - abs x | x >= 0.0 = x - | otherwise = negateDouble x - signum x | x == 0.0 = 0 - | x > 0.0 = 1 - | otherwise = negate 1 - - {-# INLINE fromInteger #-} - -- See comments with Num Float - fromInteger (S# i#) = case (int2Double# i#) of { d# -> D# d# } - fromInteger (J# s# d#) = encodeDouble# s# d# 0 - - -instance Real Double where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x - -instance Fractional Double where - (/) x y = divideDouble x y - fromRational x = fromRat x - recip x = 1.0 / x - -instance Floating Double where - pi = 3.141592653589793238 - exp x = expDouble x - log x = logDouble x - sqrt x = sqrtDouble x - sin x = sinDouble x - cos x = cosDouble x - tan x = tanDouble x - asin x = asinDouble x - acos x = acosDouble x - atan x = atanDouble x - sinh x = sinhDouble x - cosh x = coshDouble x - tanh x = tanhDouble x - (**) x y = powerDouble x y - logBase x y = log y / log x - - asinh x = log (x + sqrt (1.0+x*x)) - acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) - atanh x = log ((x+1.0) / sqrt (1.0-x*x)) - -{-# RULES "truncate/Double->Int" truncate = double2Int #-} -instance RealFrac Double where - - {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} - {-# SPECIALIZE round :: Double -> Int #-} - {-# SPECIALIZE ceiling :: Double -> Int #-} - {-# SPECIALIZE floor :: Double -> Int #-} - - {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-} - {-# SPECIALIZE truncate :: Double -> Integer #-} - {-# SPECIALIZE round :: Double -> Integer #-} - {-# SPECIALIZE ceiling :: Double -> Integer #-} - {-# SPECIALIZE floor :: Double -> Integer #-} - - properFraction x - = case (decodeFloat x) of { (m,n) -> - let b = floatRadix x in - if n >= 0 then - (fromInteger m * fromInteger b ^ n, 0.0) - else - case (quotRem m (b^(negate n))) of { (w,r) -> - (fromInteger w, encodeFloat r n) - } - } - - truncate x = case properFraction x of - (n,_) -> n - - round x = case properFraction x of - (n,r) -> let - m = if r < 0.0 then n - 1 else n + 1 - half_down = abs r - 0.5 - in - case (compare half_down 0.0) of - LT -> n - EQ -> if even n then n else m - GT -> m - - ceiling x = case properFraction x of - (n,r) -> if r > 0.0 then n + 1 else n - - floor x = case properFraction x of - (n,r) -> if r < 0.0 then n - 1 else n - -instance RealFloat Double where - floatRadix _ = FLT_RADIX -- from float.h - floatDigits _ = DBL_MANT_DIG -- ditto - floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto - - decodeFloat (D# x#) - = case decodeDouble# x# of - (# exp#, s#, d# #) -> (J# s# d#, I# exp#) - - encodeFloat (S# i) j = int_encodeDouble# i j - encodeFloat (J# s# d#) e = encodeDouble# s# d# e - - exponent x = case decodeFloat x of - (m,n) -> if m == 0 then 0 else n + floatDigits x - - significand x = case decodeFloat x of - (m,_) -> encodeFloat m (negate (floatDigits x)) - - scaleFloat k x = case decodeFloat x of - (m,n) -> encodeFloat m (n+k) - - isNaN x = 0 /= isDoubleNaN x - isInfinite x = 0 /= isDoubleInfinite x - isDenormalized x = 0 /= isDoubleDenormalized x - isNegativeZero x = 0 /= isDoubleNegativeZero x - isIEEE _ = True - -instance Show Double where - showsPrec x = showSigned showFloat x - showList = showList__ (showsPrec 0) -\end{code} - -%********************************************************* -%* * -\subsection{@Enum@ instances} -%* * -%********************************************************* - -The @Enum@ instances for Floats and Doubles are slightly unusual. -The @toEnum@ function truncates numbers to Int. The definitions -of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic -series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat -dubious. This example may have either 10 or 11 elements, depending on -how 0.1 is represented. - -NOTE: The instances for Float and Double do not make use of the default -methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being -a `non-lossy' conversion to and from Ints. Instead we make use of the -1.2 default methods (back in the days when Enum had Ord as a superclass) -for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) - -\begin{code} -instance Enum Float where - succ x = x + 1 - pred x = x - 1 - toEnum = int2Float - fromEnum = fromInteger . truncate -- may overflow - enumFrom = numericEnumFrom - enumFromTo = numericEnumFromTo - enumFromThen = numericEnumFromThen - enumFromThenTo = numericEnumFromThenTo - -instance Enum Double where - succ x = x + 1 - pred x = x - 1 - toEnum = int2Double - fromEnum = fromInteger . truncate -- may overflow - enumFrom = numericEnumFrom - enumFromTo = numericEnumFromTo - enumFromThen = numericEnumFromThen - enumFromThenTo = numericEnumFromThenTo -\end{code} - - -%********************************************************* -%* * -\subsection{Printing floating point} -%* * -%********************************************************* - - -\begin{code} -showFloat :: (RealFloat a) => a -> ShowS -showFloat x = showString (formatRealFloat FFGeneric Nothing x) - --- 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 - | isNaN x = "NaN" - | isInfinite x = if x < 0 then "-Infinity" else "Infinity" - | x < 0 || isNegativeZero x = '-':doFmt fmt (floatToDigits (toInteger base) (-x)) - | otherwise = doFmt fmt (floatToDigits (toInteger base) x) - where - base = 10 - - doFmt format (is, e) = - let ds = map intToDigit is in - case format of - FFGeneric -> - doFmt (if e < 0 || e > 7 then FFExponent else FFFixed) - (is,e) - FFExponent -> - case decs of - Nothing -> - let show_e' = show (e-1) in - case ds of - "0" -> "0.0e0" - [d] -> d : ".0e" ++ show_e' - (d:ds') -> d : '.' : ds' ++ "e" ++ show_e' - 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 -> - let - mk0 ls = case ls of { "" -> "0" ; _ -> ls} - in - case decs of - Nothing - | e <= 0 -> "0." ++ replicate (-e) '0' ++ ds - | otherwise -> - let - f 0 s rs = mk0 (reverse s) ++ '.':mk0 rs - f n s "" = f (n-1) ('0':s) "" - f n s (r:rs) = f (n-1) (r:s) rs - 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 - mk0 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 : (if null ds' then "" else '.':ds') - - -roundTo :: Int -> Int -> [Int] -> (Int,[Int]) -roundTo base d is = - case f d is of - x@(0,_) -> x - (1,xs) -> (1, 1:xs) - where - b2 = base `div` 2 - - f n [] = (0, replicate n 0) - f 0 (x:_) = (if x >= b2 then 1 else 0, []) - f n (i:xs) - | i' == base = (1,0:ds) - | otherwise = (0,i':ds) - where - (c,ds) = f (n-1) xs - i' = c + i - --- 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. - --- floatToDigits takes a base and a non-negative RealFloat number, --- and returns a list of digits and an exponent. --- In particular, if x>=0, and --- floatToDigits base x = ([d1,d2,...,dn], e) --- then --- (a) n >= 1 --- (b) x = 0.d1d2...dn * (base**e) --- (c) 0 <= di <= base-1 - -floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) -floatToDigits _ 0 = ([0], 0) -floatToDigits base x = - let - (f0, e0) = decodeFloat x - (minExp0, _) = floatRange x - p = floatDigits x - b = floatRadix x - minExp = minExp0 - p -- the real minimum exponent - -- Haskell requires that f be adjusted so denormalized numbers - -- will have an impossibly low exponent. Adjust for this. - (f, e) = - let n = minExp - e0 in - if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) - (r, s, mUp, mDn) = - if e >= 0 then - let be = b^ e in - if f == b^(p-1) then - (f*be*b*2, 2*b, be*b, b) - else - (f*be*2, 2, be, be) - else - if e > minExp && f == b^(p-1) then - (f*b*2, b^(-e+1)*2, b, 1) - else - (f*2, b^(-e)*2, 1, 1) - k = - let - k0 = - 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)) + - fromInteger (int2Integer e) * log (fromInteger b)) / - log (fromInteger base)) ---WAS: fromInt e * log (fromInteger b)) - - 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 fromIntegral (reverse rds), k) - -\end{code} - - -%********************************************************* -%* * -\subsection{Converting from a Rational to a RealFloat -%* * -%********************************************************* - -[In response to a request for documentation of how fromRational works, -Joe Fasel writes:] A quite reasonable request! This code was added to -the Prelude just before the 1.2 release, when Lennart, working with an -early version of hbi, noticed that (read . show) was not the identity -for floating-point numbers. (There was a one-bit error about half the -time.) The original version of the conversion function was in fact -simply a floating-point divide, as you suggest above. The new version -is, I grant you, somewhat denser. - -Unfortunately, Joe's code doesn't work! Here's an example: - -main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n") - -This program prints - 0.0000000000000000 -instead of - 1.8217369128763981e-300 - -Here's Joe's code: - -\begin{pseudocode} -fromRat :: (RealFloat a) => Rational -> a -fromRat x = x' - where x' = f e - --- If the exponent of the nearest floating-point number to x --- is e, then the significand is the integer nearest xb^(-e), --- where b is the floating-point radix. We start with a good --- guess for e, and if it is correct, the exponent of the --- floating-point number we construct will again be e. If --- not, one more iteration is needed. - - f e = if e' == e then y else f e' - where y = encodeFloat (round (x * (1 % b)^^e)) e - (_,e') = decodeFloat y - b = floatRadix x' - --- We obtain a trial exponent by doing a floating-point --- division of x's numerator by its denominator. The --- result of this division may not itself be the ultimate --- result, because of an accumulation of three rounding --- errors. - - (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' - / fromInteger (denominator x)) -\end{pseudocode} - -Now, here's Lennart's code (which works) - -\begin{code} -{-# SPECIALISE fromRat :: - Rational -> Double, - Rational -> Float #-} -fromRat :: (RealFloat a) => Rational -> a -fromRat x - | x == 0 = encodeFloat 0 0 -- Handle exceptional cases - | x < 0 = - fromRat' (-x) -- first. - | otherwise = 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, maxExpt :: Int -minExpt = 0 -maxExpt = 1100 - -expt :: Integer -> Int -> Integer -expt base n = - if base == 2 && n >= minExpt && n <= maxExpt then - expts!n - else - base^n - -expts :: Array Int Integer -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 :: Integer -> Integer -> Int -integerLogBase b i - | i < b = 0 - | otherwise = doDiv (i `div` (b^l)) l - where - -- Try squaring the base first to cut down the number of divisions. - l = 2 * integerLogBase (b*b) i - - doDiv :: Integer -> Int -> Int - doDiv x y - | x < b = y - | otherwise = doDiv (x `div` b) (y+1) - -\end{code} - - -%********************************************************* -%* * -\subsection{Floating point numeric primops} -%* * -%********************************************************* - -Definitions of the boxed PrimOps; these will be -used in the case of partial applications, etc. - -\begin{code} -plusFloat, minusFloat, timesFloat, divideFloat :: Float -> Float -> Float -plusFloat (F# x) (F# y) = F# (plusFloat# x y) -minusFloat (F# x) (F# y) = F# (minusFloat# x y) -timesFloat (F# x) (F# y) = F# (timesFloat# x y) -divideFloat (F# x) (F# y) = F# (divideFloat# x y) - -{-# RULES -"plusFloat x 0.0" forall x#. plusFloat# x# 0.0# = x# -"plusFloat 0.0 x" forall x#. plusFloat# 0.0# x# = x# -"minusFloat x 0.0" forall x#. minusFloat# x# 0.0# = x# -"minusFloat x x" forall x#. minusFloat# x# x# = 0.0# -"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0# -"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0# -"timesFloat x 1.0" forall x#. timesFloat# x# 1.0# = x# -"timesFloat 1.0 x" forall x#. timesFloat# 1.0# x# = x# -"divideFloat x 1.0" forall x#. divideFloat# x# 1.0# = x# - #-} - -negateFloat :: Float -> Float -negateFloat (F# x) = F# (negateFloat# x) - -gtFloat, geFloat, eqFloat, neFloat, ltFloat, leFloat :: Float -> Float -> Bool -gtFloat (F# x) (F# y) = gtFloat# x y -geFloat (F# x) (F# y) = geFloat# x y -eqFloat (F# x) (F# y) = eqFloat# x y -neFloat (F# x) (F# y) = neFloat# x y -ltFloat (F# x) (F# y) = ltFloat# x y -leFloat (F# x) (F# y) = leFloat# x y - -float2Int :: Float -> Int -float2Int (F# x) = I# (float2Int# x) - -int2Float :: Int -> Float -int2Float (I# x) = F# (int2Float# x) - -expFloat, logFloat, sqrtFloat :: Float -> Float -sinFloat, cosFloat, tanFloat :: Float -> Float -asinFloat, acosFloat, atanFloat :: Float -> Float -sinhFloat, coshFloat, tanhFloat :: Float -> Float -expFloat (F# x) = F# (expFloat# x) -logFloat (F# x) = F# (logFloat# x) -sqrtFloat (F# x) = F# (sqrtFloat# x) -sinFloat (F# x) = F# (sinFloat# x) -cosFloat (F# x) = F# (cosFloat# x) -tanFloat (F# x) = F# (tanFloat# x) -asinFloat (F# x) = F# (asinFloat# x) -acosFloat (F# x) = F# (acosFloat# x) -atanFloat (F# x) = F# (atanFloat# x) -sinhFloat (F# x) = F# (sinhFloat# x) -coshFloat (F# x) = F# (coshFloat# x) -tanhFloat (F# x) = F# (tanhFloat# x) - -powerFloat :: Float -> Float -> Float -powerFloat (F# x) (F# y) = F# (powerFloat# x y) - --- definitions of the boxed PrimOps; these will be --- used in the case of partial applications, etc. - -plusDouble, minusDouble, timesDouble, divideDouble :: Double -> Double -> Double -plusDouble (D# x) (D# y) = D# (x +## y) -minusDouble (D# x) (D# y) = D# (x -## y) -timesDouble (D# x) (D# y) = D# (x *## y) -divideDouble (D# x) (D# y) = D# (x /## y) - -{-# RULES -"plusDouble x 0.0" forall x#. (+##) x# 0.0## = x# -"plusDouble 0.0 x" forall x#. (+##) 0.0## x# = x# -"minusDouble x 0.0" forall x#. (-##) x# 0.0## = x# -"minusDouble x x" forall x#. (-##) x# x# = 0.0## -"timesDouble x 0.0" forall x#. (*##) x# 0.0## = 0.0## -"timesDouble 0.0 x" forall x#. (*##) 0.0## x# = 0.0## -"timesDouble x 1.0" forall x#. (*##) x# 1.0## = x# -"timesDouble 1.0 x" forall x#. (*##) 1.0## x# = x# -"divideDouble x 1.0" forall x#. (/##) x# 1.0## = x# - #-} - -negateDouble :: Double -> Double -negateDouble (D# x) = D# (negateDouble# x) - -gtDouble, geDouble, eqDouble, neDouble, leDouble, ltDouble :: Double -> Double -> Bool -gtDouble (D# x) (D# y) = x >## y -geDouble (D# x) (D# y) = x >=## y -eqDouble (D# x) (D# y) = x ==## y -neDouble (D# x) (D# y) = x /=## y -ltDouble (D# x) (D# y) = x <## y -leDouble (D# x) (D# y) = x <=## y - -double2Int :: Double -> Int -double2Int (D# x) = I# (double2Int# x) - -int2Double :: Int -> Double -int2Double (I# x) = D# (int2Double# x) - -double2Float :: Double -> Float -double2Float (D# x) = F# (double2Float# x) - -float2Double :: Float -> Double -float2Double (F# x) = D# (float2Double# x) - -expDouble, logDouble, sqrtDouble :: Double -> Double -sinDouble, cosDouble, tanDouble :: Double -> Double -asinDouble, acosDouble, atanDouble :: Double -> Double -sinhDouble, coshDouble, tanhDouble :: Double -> Double -expDouble (D# x) = D# (expDouble# x) -logDouble (D# x) = D# (logDouble# x) -sqrtDouble (D# x) = D# (sqrtDouble# x) -sinDouble (D# x) = D# (sinDouble# x) -cosDouble (D# x) = D# (cosDouble# x) -tanDouble (D# x) = D# (tanDouble# x) -asinDouble (D# x) = D# (asinDouble# x) -acosDouble (D# x) = D# (acosDouble# x) -atanDouble (D# x) = D# (atanDouble# x) -sinhDouble (D# x) = D# (sinhDouble# x) -coshDouble (D# x) = D# (coshDouble# x) -tanhDouble (D# x) = D# (tanhDouble# x) - -powerDouble :: Double -> Double -> Double -powerDouble (D# x) (D# y) = D# (x **## y) -\end{code} - -\begin{code} -foreign import ccall "__encodeFloat" unsafe - encodeFloat# :: Int# -> ByteArray# -> Int -> Float -foreign import ccall "__int_encodeFloat" unsafe - int_encodeFloat# :: Int# -> Int -> Float - - -foreign import ccall "isFloatNaN" unsafe isFloatNaN :: Float -> Int -foreign import ccall "isFloatInfinite" unsafe isFloatInfinite :: Float -> Int -foreign import ccall "isFloatDenormalized" unsafe isFloatDenormalized :: Float -> Int -foreign import ccall "isFloatNegativeZero" unsafe isFloatNegativeZero :: Float -> Int - - -foreign import ccall "__encodeDouble" unsafe - encodeDouble# :: Int# -> ByteArray# -> Int -> Double -foreign import ccall "__int_encodeDouble" unsafe - int_encodeDouble# :: Int# -> Int -> Double - -foreign import ccall "isDoubleNaN" unsafe isDoubleNaN :: Double -> Int -foreign import ccall "isDoubleInfinite" unsafe isDoubleInfinite :: Double -> Int -foreign import ccall "isDoubleDenormalized" unsafe isDoubleDenormalized :: Double -> Int -foreign import ccall "isDoubleNegativeZero" unsafe isDoubleNegativeZero :: Double -> Int -\end{code} - -%********************************************************* -%* * -\subsection{Coercion rules} -%* * -%********************************************************* - -\begin{code} -{-# RULES -"fromIntegral/Int->Float" fromIntegral = int2Float -"fromIntegral/Int->Double" fromIntegral = int2Double -"realToFrac/Float->Float" realToFrac = id :: Float -> Float -"realToFrac/Float->Double" realToFrac = float2Double -"realToFrac/Double->Float" realToFrac = double2Float -"realToFrac/Double->Double" realToFrac = id :: Double -> Double - #-} -\end{code} diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs deleted file mode 100644 index 01f135d..0000000 --- a/ghc/lib/std/PrelForeign.lhs +++ /dev/null @@ -1,69 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelForeign.lhs,v 1.20 2001/07/16 00:39:04 sof Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Foreign]{Module @Foreign@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelForeign where - -import PrelIOBase -import PrelNum -- for fromInteger -import PrelBase -import PrelPtr -\end{code} - -%********************************************************* -%* * -\subsection{ForeignPtr} -%* * -%********************************************************* - -\begin{code} -data ForeignPtr a = ForeignPtr ForeignObj# -instance CCallable (ForeignPtr a) - -eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool -eqForeignPtr (ForeignPtr fo1#) (ForeignPtr fo2#) = eqForeignObj# fo1# fo2# - -instance Eq (ForeignPtr a) where - p == q = eqForeignPtr p q - p /= q = not (eqForeignPtr p q) - -newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) -newForeignPtr p finalizer - = do fObj <- mkForeignPtr p - addForeignPtrFinalizer fObj finalizer - return fObj - -addForeignPtrFinalizer :: ForeignPtr a -> IO () -> IO () -addForeignPtrFinalizer (ForeignPtr fo) finalizer = - IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) } - -mkForeignPtr :: Ptr a -> IO (ForeignPtr a) {- not exported -} -mkForeignPtr (Ptr obj) = IO ( \ s# -> - case mkForeignObj# obj s# of - (# s1#, fo# #) -> (# s1#, ForeignPtr fo# #) ) - -touchForeignPtr :: ForeignPtr a -> IO () -touchForeignPtr (ForeignPtr fo) - = IO $ \s -> case touch# fo s of s -> (# s, () #) - -withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b -withForeignPtr fo io - = do r <- io (foreignPtrToPtr fo) - touchForeignPtr fo - return r - -foreignPtrToPtr :: ForeignPtr a -> Ptr a -foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo) - -castForeignPtr (ForeignPtr a) = ForeignPtr a - -\end{code} - - diff --git a/ghc/lib/std/PrelGHC.hi-boot.pp b/ghc/lib/std/PrelGHC.hi-boot.pp deleted file mode 100644 index 1223735..0000000 --- a/ghc/lib/std/PrelGHC.hi-boot.pp +++ /dev/null @@ -1,471 +0,0 @@ ---------------------------------------------------------------------------- --- PrelGHC.hi-boot --- --- This hand-written interface file allows you to bring into scope the --- primitive operations and types that GHC knows about. ---------------------------------------------------------------------------- - -#include "MachDeps.h" - -__interface "std" PrelGHC 1 0 where - -__export PrelGHC - - ZLzmzgZR -- (->) - - CCallable - CReturnable - --- Magical assert thingy - assert - - -- constructor tags - tagToEnumzh - getTagzh - dataToTagzh - - -- I/O primitives - RealWorld - realWorldzh - Statezh - - -- Concurrency primitives - ThreadIdzh - myThreadIdzh - forkzh - yieldzh - killThreadzh - blockAsyncExceptionszh - unblockAsyncExceptionszh - delayzh - waitReadzh - waitWritezh - - -- MVars - MVarzh - sameMVarzh - newMVarzh - takeMVarzh - putMVarzh - tryTakeMVarzh - tryPutMVarzh - isEmptyMVarzh - - -- Seq - seq -- Defined in MkId - - -- Parallel - seqzh - parzh - parGlobalzh - parLocalzh - parAtzh - parAtAbszh - parAtRelzh - parAtForNowzh - - -- Character Type - Charzh - gtCharzh - geCharzh - eqCharzh - neCharzh - ltCharzh - leCharzh - ordzh - chrzh - - -- Int Type - Intzh - zgzh - zgzezh - zezezh - zszezh - zlzh - zlzezh - zpzh - zmzh - ztzh - quotIntzh - remIntzh - gcdIntzh - negateIntzh - uncheckedIShiftLzh - uncheckedIShiftRAzh - uncheckedIShiftRLzh - addIntCzh - subIntCzh - mulIntMayOflozh - - Wordzh - gtWordzh - geWordzh - eqWordzh - neWordzh - ltWordzh - leWordzh - plusWordzh - minusWordzh - timesWordzh - quotWordzh - remWordzh - andzh - orzh - notzh - xorzh - uncheckedShiftLzh - uncheckedShiftRLzh - int2Wordzh - word2Intzh - - narrow8Intzh - narrow16Intzh - narrow32Intzh - narrow8Wordzh - narrow16Wordzh - narrow32Wordzh - -#if WORD_SIZE_IN_BITS < 32 - Int32zh - Word32zh -#endif - -#if WORD_SIZE_IN_BITS < 64 - Int64zh - Word64zh -#endif - - Addrzh - nullAddrzh -- Defined in MkId - plusAddrzh - minusAddrzh - remAddrzh -#if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) - addr2Intzh - int2Addrzh -#endif - gtAddrzh - geAddrzh - eqAddrzh - neAddrzh - ltAddrzh - leAddrzh - - Floatzh - gtFloatzh - geFloatzh - eqFloatzh - neFloatzh - ltFloatzh - leFloatzh - plusFloatzh - minusFloatzh - timesFloatzh - divideFloatzh - negateFloatzh - float2Intzh - int2Floatzh - expFloatzh - logFloatzh - sqrtFloatzh - sinFloatzh - cosFloatzh - tanFloatzh - asinFloatzh - acosFloatzh - atanFloatzh - sinhFloatzh - coshFloatzh - tanhFloatzh - powerFloatzh - decodeFloatzh - - Doublezh - zgzhzh - zgzezhzh - zezezhzh - zszezhzh - zlzhzh - zlzezhzh - zpzhzh - zmzhzh - ztzhzh - zszhzh - negateDoublezh - double2Intzh - int2Doublezh - double2Floatzh - float2Doublezh - expDoublezh - logDoublezh - sqrtDoublezh - sinDoublezh - cosDoublezh - tanDoublezh - asinDoublezh - acosDoublezh - atanDoublezh - sinhDoublezh - coshDoublezh - tanhDoublezh - ztztzhzh - decodeDoublezh - --- Integer is implemented by foreign imports on .NET, so no primops - -#ifndef ILX - cmpIntegerzh - cmpIntegerIntzh - plusIntegerzh - minusIntegerzh - timesIntegerzh - gcdIntegerzh - quotIntegerzh - remIntegerzh - gcdIntegerzh - gcdIntegerIntzh - divExactIntegerzh - quotRemIntegerzh - divModIntegerzh - integer2Intzh - integer2Wordzh - int2Integerzh - word2Integerzh -#if WORD_SIZE_IN_BITS < 32 - integerToInt32zh - integerToWord32zh - int32ToIntegerzh - word32ToIntegerzh -#endif -#if WORD_SIZE_IN_BITS < 64 - int64ToIntegerzh - word64ToIntegerzh -#endif - andIntegerzh - orIntegerzh - xorIntegerzh - complementIntegerzh -#endif - - Arrayzh - ByteArrayzh - MutableArrayzh - MutableByteArrayzh - sameMutableArrayzh - sameMutableByteArrayzh - newArrayzh - newByteArrayzh - newPinnedByteArrayzh - byteArrayContentszh - - indexArrayzh - indexCharArrayzh - indexWideCharArrayzh - indexIntArrayzh - indexWordArrayzh - indexAddrArrayzh - indexFloatArrayzh - indexDoubleArrayzh - indexStablePtrArrayzh - indexInt8Arrayzh - indexInt16Arrayzh - indexInt32Arrayzh - indexInt64Arrayzh - indexWord8Arrayzh - indexWord16Arrayzh - indexWord32Arrayzh - indexWord64Arrayzh - - readArrayzh - readCharArrayzh - readWideCharArrayzh - readIntArrayzh - readWordArrayzh - readAddrArrayzh - readFloatArrayzh - readDoubleArrayzh - readStablePtrArrayzh - readInt8Arrayzh - readInt16Arrayzh - readInt32Arrayzh - readInt64Arrayzh - readWord8Arrayzh - readWord16Arrayzh - readWord32Arrayzh - readWord64Arrayzh - - writeArrayzh - writeCharArrayzh - writeWideCharArrayzh - writeIntArrayzh - writeWordArrayzh - writeAddrArrayzh - writeFloatArrayzh - writeDoubleArrayzh - writeStablePtrArrayzh - writeInt8Arrayzh - writeInt16Arrayzh - writeInt32Arrayzh - writeInt64Arrayzh - writeWord8Arrayzh - writeWord16Arrayzh - writeWord32Arrayzh - writeWord64Arrayzh - - indexCharOffAddrzh - indexWideCharOffAddrzh - indexIntOffAddrzh - indexWordOffAddrzh - indexAddrOffAddrzh - indexFloatOffAddrzh - indexDoubleOffAddrzh - indexStablePtrOffAddrzh - indexInt8OffAddrzh - indexInt16OffAddrzh - indexInt32OffAddrzh - indexInt64OffAddrzh - indexWord8OffAddrzh - indexWord16OffAddrzh - indexWord32OffAddrzh - indexWord64OffAddrzh - - readCharOffAddrzh - readWideCharOffAddrzh - readIntOffAddrzh - readWordOffAddrzh - readAddrOffAddrzh - readFloatOffAddrzh - readDoubleOffAddrzh - readStablePtrOffAddrzh - readInt8OffAddrzh - readInt16OffAddrzh - readInt32OffAddrzh - readInt64OffAddrzh - readWord8OffAddrzh - readWord16OffAddrzh - readWord32OffAddrzh - readWord64OffAddrzh - - writeCharOffAddrzh - writeWideCharOffAddrzh - writeIntOffAddrzh - writeWordOffAddrzh - writeAddrOffAddrzh - writeForeignObjOffAddrzh - writeFloatOffAddrzh - writeDoubleOffAddrzh - writeStablePtrOffAddrzh - writeInt8OffAddrzh - writeInt16OffAddrzh - writeInt32OffAddrzh - writeInt64OffAddrzh - writeWord8OffAddrzh - writeWord16OffAddrzh - writeWord32OffAddrzh - writeWord64OffAddrzh - - eqForeignObjzh - indexCharOffForeignObjzh - indexWideCharOffForeignObjzh - indexIntOffForeignObjzh - indexWordOffForeignObjzh - indexAddrOffForeignObjzh - indexFloatOffForeignObjzh - indexDoubleOffForeignObjzh - indexStablePtrOffForeignObjzh - indexInt8OffForeignObjzh - indexInt16OffForeignObjzh - indexInt32OffForeignObjzh - indexInt64OffForeignObjzh - indexWord8OffForeignObjzh - indexWord16OffForeignObjzh - indexWord32OffForeignObjzh - indexWord64OffForeignObjzh - - unsafeFreezzeArrayzh -- Note zz in the middle - unsafeFreezzeByteArrayzh -- Ditto - - unsafeThawArrayzh - - sizzeofByteArrayzh -- Ditto - sizzeofMutableByteArrayzh -- Ditto - - MutVarzh - newMutVarzh - readMutVarzh - writeMutVarzh - sameMutVarzh - - catchzh - raisezh - - Weakzh - mkWeakzh - deRefWeakzh - finalizzeWeakzh - - ForeignObjzh - mkForeignObjzh - writeForeignObjzh - foreignObjToAddrzh - touchzh - - StablePtrzh - makeStablePtrzh - deRefStablePtrzh - eqStablePtrzh - - StableNamezh - makeStableNamezh - eqStableNamezh - stableNameToIntzh - - newBCOzh - BCOzh - mkApUpd0zh - - unsafeCoercezh -- unsafeCoerce# :: forall a b. a -> b - -- It's defined in ghc/compiler/basicTypes/MkId.lhs - addrToHValuezh -; - --- Export PrelErr.error, so that others do not have to import PrelErr -__export PrelErr error ; - -infixr 0 seq ; - --------------------------------------------------- -instance {CCallable Charzh} = zdfCCallableCharzh; -instance {CCallable Doublezh} = zdfCCallableDoublezh; -instance {CCallable Floatzh} = zdfCCallableFloatzh; -instance {CCallable Intzh} = zdfCCallableIntzh; -instance {CCallable Addrzh} = zdfCCallableAddrzh; -instance {CCallable Int64zh} = zdfCCallableInt64zh; -instance {CCallable Word64zh} = zdfCCallableWord64zh; -instance {CCallable Wordzh} = zdfCCallableWordzh; -instance {CCallable ByteArrayzh} = zdfCCallableByteArrayzh; -instance __forall s => {CCallable (MutableByteArrayzh s)} = zdfCCallableMutableByteArrayzh; -instance {CCallable ForeignObjzh} = zdfCCallableForeignObjzh; -instance __forall s => {CCallable (StablePtrzh s)} = zdfCCallableStablePtrzh; --- CCallable and CReturnable have kind (Type AnyBox) so that --- things like Int# can be instances of CCallable. -1 class CCallable a :: ? ; -1 class CReturnable a :: ? ; - -1 assert :: __forall a => PrelBase.Bool -> a -> a ; - --- These guys do not really exist: --- -1 zdfCCallableCharzh :: {CCallable Charzh} ; -1 zdfCCallableDoublezh :: {CCallable Doublezh} ; -1 zdfCCallableFloatzh :: {CCallable Floatzh} ; -1 zdfCCallableIntzh :: {CCallable Intzh} ; -1 zdfCCallableAddrzh :: {CCallable Addrzh} ; -1 zdfCCallableInt64zh :: {CCallable Int64zh} ; -1 zdfCCallableWord64zh :: {CCallable Word64zh} ; -1 zdfCCallableWordzh :: {CCallable Wordzh} ; -1 zdfCCallableByteArrayzh :: {CCallable ByteArrayzh} ; -1 zdfCCallableMutableByteArrayzh :: __forall s => {CCallable (MutableByteArrayzh s)} ; -1 zdfCCallableForeignObjzh :: {CCallable ForeignObjzh} ; -1 zdfCCallableStablePtrzh :: __forall a => {CCallable (StablePtrzh a)} ; - diff --git a/ghc/lib/std/PrelGHC.ilx.pp b/ghc/lib/std/PrelGHC.ilx.pp deleted file mode 100644 index 3c08b57..0000000 --- a/ghc/lib/std/PrelGHC.ilx.pp +++ /dev/null @@ -1,662 +0,0 @@ -// The ILX implementation of PrelGHC - -// This file isn't really preprocessed, but it's kept as a .pp file -// because .ilx files aren't precious, and may be deleted - -.module 'PrelGHC.i_o' -.module extern 'PrelBase.i_o' -.classunion import [.module 'PrelBase.i_o']PrelBase_Bool {.alternative 'PrelBase_False' () -.alternative 'PrelBase_True' ()} -.assembly extern 'mscorlib' { } - -.namespace GHC { - .class support { - .method public static class [.module 'PrelBase.i_o']PrelBase_Bool mkBool (bool b) { - ldarg b - brtrue Ltrue - newdata class [.module 'PrelBase.i_o']PrelBase_Bool, PrelBase_False() - ret - Ltrue: - newdata class [.module 'PrelBase.i_o']PrelBase_Bool, PrelBase_True() - ret - } - .method public static int32 IntGcdOp (int32,int32) { - ldstr "WARNING: IntGcdOp called (warning! not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 1 - ret - } - .method public static value class PrelGHC_Z2H IntSubCOp(int32 a,int32 b) { - .locals(int32 r, int32 c) - ldstr "WARNING: IntSubCOp called (warning! not yet tested properly)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - //r=a-b - ldarg a ldarg b sub stloc r - //c = ((a^r) & (a^b)) >> 31 - ldloc r ldarg a xor ldarg a ldarg b xor and ldc.i4 31 shr.un stloc c - // - ldloc r ldloc c newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ldstr "a = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg a call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "b = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg b call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "r = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc r call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "c = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc c call void ['mscorlib']System.Console::WriteLine(int32) - ret - } - .method public static value class PrelGHC_Z2H IntAddCOp(int32 a,int32 b) { - .locals(int32 r, int32 c) - ldstr "WARNING: IntAddCOp called (warning! not yet tested properly)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - //r=a+b - ldarg a ldarg b add stloc r - //c = ((a^r) & ~(a^b)) >> 31 - ldloc r ldarg a xor ldarg a ldarg b xor not and ldc.i4 31 shr.un stloc c - // - ldloc r ldloc c newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ldstr "a = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg a call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "b = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg b call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "r = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc r call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "c = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc c call void ['mscorlib']System.Console::WriteLine(int32) - ret - } - - // TODO: check me!!! test me!!!! - .method public static value class PrelGHC_Z2H IntMulCOp(int32 a,int32 b) { - .locals(int64 l, int32 r, int32 c) - - ldstr "WARNING: IntMulCOp called (warning! not yet tested properly)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - - //r=(StgInt64)a * (StgInt64)b - ldarg a conv.i8 - ldarg b conv.i8 - mul stloc l - // r = z.i[R] - // c = z.i[C] - ldloc l ldc.i8 0x80000000 rem conv.i4 stloc r - ldloc l ldc.i8 0x80000000 div conv.i4 stloc c - - ldloc r ldloc c newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ldstr "a = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg a call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "b = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg b call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "r = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc r call void ['mscorlib']System.Console::WriteLine(int32) - ldstr "c = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldloc c call void ['mscorlib']System.Console::WriteLine(int32) - ret - - } - - .method public static - // Return type - !!0 - // Method name - 'catch'( thunk<(func ( /* unit skipped */ ) --> !!0)> f1, thunk<(func (!!1) --> (func ( /* unit skipped */ ) --> !!0))> f2) - { - .locals(!!0 res, !!1 exn) - //LOG ldstr "LOG: Entering catch..." call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - .try { - ldarg f1 - // ldunit - callfunc () ( /* unit skipped */ ) --> !!0 - stloc res - //LOG ldstr "LOG: Leaving catch..." call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - leave retA - } catch [mscorlib]System.Object { - - // exception of type !!1 should be on the stack?? - dup ldstr "LOG: CAUGHT! , Exn = " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.Object) - unbox.any !!1 - stloc exn - leave retE - } - - retA: - ldloc res - ret - - retE: - ldstr "LOG: CAUGHT! Executing handler..." call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg f2 - ldloc exn - tail. callfunc () (!!1) --> !!0 - ret - - } - - - .method public static !!0 'unblockAsyncExceptions'( thunk<(func ( /* unit skipped */ ) --> !!0)> f ) - { - //ldstr "WARNING: unblockAsyncExceptions called (warning! not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg f - // ldunit - tail. callfunc () ( /* unit skipped */ ) --> !!0 - ret - } - - .method public static !!0 'blockAsyncExceptions'( thunk<(func ( /* unit skipped */ ) --> !!0)> f ) - { - //ldstr "WARNING: blockAsyncExceptions called (warning! not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg f - // ldunit - tail. callfunc () ( /* unit skipped */ ) --> !!0 - ret - } - - - - .method public static !!0 'takeMVar' (class PrelGHC_MVarzh mvar) - { - //ldstr "WARNING: takeMVar called (warning! locking not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg mvar ldfld !0 class PrelGHC_MVarzh::contents - //LOG ldstr "LOG: takeMVar returned: " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) dup call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.Object) - //LOG ldstr "LOG: for MVar: " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg mvar ldfld int32 class PrelGHC_MVarzh::id call void ['mscorlib']System.Console::WriteLine(int32) - ret - } - - - .method public static void 'putMVar'(class PrelGHC_MVarzh mvar ,!!0 v) - { - //ldstr "WARNING: putMVar called (warning! locking not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg mvar ldarg v stfld !0 class PrelGHC_MVarzh::contents - - //LOG ldstr "LOG: putMVar put: " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg v call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.Object) - //LOG ldstr "LOG: for MVar: " call void ['mscorlib']System.Console::Write(class ['mscorlib']System.String) ldarg mvar ldfld int32 class PrelGHC_MVarzh::id call void ['mscorlib']System.Console::WriteLine(int32) - ret - } - - // Enter, if (null(Read)) Wait Exit - .method public static value class PrelGHC_Z2H 'tryTakeMVar'(class PrelGHC_MVarzh mvar) - { - ldstr "WARNING: tryTakeMVar called (locking not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 1 - ldarg mvar ldfld !0 class PrelGHC_MVarzh::contents - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - - // Enter, if (null(Read)) Wait Exit - .method public static int32 'tryPutMVar'(class PrelGHC_MVarzh mvar, !!0 v) - { - ldstr "WARNING: tryPutMVar called (locking not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 1 - ret - } - - - - .method public static int32 isEmptyMVar(class PrelGHC_MVarzh mvar) - { - ldstr "WARNING: isEmptyMVar called (locking not yet implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - - - .method public static value class PrelGHC_Z2H IntegerAddOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerAddOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static int32 IntegerCmpIntOp(int32, unsigned int8[], int32) { - ldstr "WARNING: IntegerCmpIntOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - .method public static int32 IntegerCmpOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerCmpOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - .method public static value class PrelGHC_Z2H IntegerSubOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerSubOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H IntegerMulOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerMulOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z4H IntegerQuotRemOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerQuotRemOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull ldc.i4 0 ldnull - newobj void value class PrelGHC_Z4H::.ctor(!0,!1,!2,!3) - ret - } - - .method public static value class PrelGHC_Z4H IntegerDivModOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerDivModOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull ldc.i4 0 ldnull - newobj void value class PrelGHC_Z4H::.ctor(!0,!1,!2,!3) - ret - } - .method public static value class PrelGHC_Z2H IntegerDivExactOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerDivExactOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - .method public static value class PrelGHC_Z2H IntegerQuotOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerQuotOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - .method public static value class PrelGHC_Z2H IntegerAndOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerAndOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H IntegerRemOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerRemOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - - .method public static int32 Integer2IntOp(int32, unsigned int8[]) { - ldstr "WARNING: Integer2IntOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - - .method public static unsigned int32 Integer2WordOp(int32, unsigned int8[]) { - ldstr "WARNING: Integer2WordOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - - .method public static int64 IntegerToInt64Op(int32, unsigned int8[]) { - ldstr "WARNING: IntegerToInt64Op called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i8 0 - ret - } - - .method public static unsigned int64 IntegerToWord64Op(int32, unsigned int8[]) { - ldstr "WARNING: IntegerToWord64Op called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i8 0 - ret - } - - .method public static value class PrelGHC_Z2H Int2IntegerOp(int32) { - ldstr "WARNING: Integer2IntOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H Word2IntegerOp(unsigned int32) { - ldstr "WARNING: Word2IntegerOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H Word64ToIntegerOp(unsigned int64) { - ldstr "WARNING: Word64ToIntegerOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H Int64ToIntegerOp(int64) { - ldstr "WARNING: Int64ToIntegerOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H IntegerOrOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerOrOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static int32 IntegerIntGcdOp(int32, unsigned int8[], int32) { - ldstr "WARNING: IntegerOrOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - .method public static value class PrelGHC_Z2H IntegerXorOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerXorOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H IntegerGcdOp(int32, unsigned int8[], int32, unsigned int8[]) { - ldstr "WARNING: IntegerGcdOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z2H IntegerComplementOp(int32, unsigned int8[]) { - ldstr "WARNING: IntegerComplementOp called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - - .method public static value class PrelGHC_Z3H decodeFloat(float32 f) { - ldstr "WARNING: decodeFloat called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg f conv.r8 call float64 [mscorlib]System.Math::Abs(float64) call float64 [mscorlib]System.Math::Log(float64) conv.i4 - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z3H::.ctor(!0,!1,!2) - ret - } - - .method public static value class PrelGHC_Z3H decodeDouble(float64 f) { - ldstr "WARNING: decodeDouble called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldarg f call float64 [mscorlib]System.Math::Abs(float64) call float64 [mscorlib]System.Math::Log(float64) conv.i4 - ldc.i4 0 ldnull - newobj void value class PrelGHC_Z3H::.ctor(!0,!1,!2) - ret - } - - - .method public static !!0[] newArray(int32 n, !!0 x) { - .locals(int32 i, !!0[] res) - ldarg n - newarr !!0 - stloc res - ldc.i4 0 - stloc i -loop: - ldarg n - ldloc i - beq end - ldloc res - ldloc i - ldarg x - stelem.any !!0 - br loop -end: - ldloc res - ret - } - - - .method public static int32 dataToTag(!!0 x) { - ldstr "WARNING: dataToTag called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldc.i4 0 - ret - } - .method public static !!0 tagToEnum(int32) { - ldstr "WARNING: tagToEnum called (not implemented)" call void ['mscorlib']System.Console::WriteLine(class ['mscorlib']System.String) - ldnull - ret - } - } -} - -//-------------------------------------------- -// Builtin classes - -.class public 'PrelGHC_MVarzh' { - .field public !0 contents - .field public int32 id - .field static public int32 ids - .method public rtspecialname specialname instance void .ctor() { - ldarg 0 - ldsfld int32 class PrelGHC_MVarzh::ids - ldc.i4 1 - add - dup - stsfld int32 class PrelGHC_MVarzh::ids - stfld int32 class PrelGHC_MVarzh::id - - ret - } -} - -.class public 'PrelGHC_StablePtrzh' /* */ { - .field public class [mscorlib]System.Object contents - .method public rtspecialname specialname instance void .ctor(class [mscorlib]System.Object) { - ldarg 0 ldarg 1 stfld class [mscorlib]System.Object class PrelGHC_StablePtrzh::contents - ret - } -} - -.class public 'PrelGHC_StableNamezh' /* */ { - .method public rtspecialname specialname instance void .ctor() { - ret - } -} - -.class public 'PrelGHC_Foreignzh' { - .field public void * contents - .method public rtspecialname specialname instance void .ctor(void *) { - ldarg 0 ldarg 1 stfld void * class PrelGHC_Foreignzh::contents - ret - } -} - -// TODO -.class public 'PrelGHC_Weakzh' { - .field public !0 contents - .field public thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> _finalizer - .method public rtspecialname specialname instance void .ctor(!0 x, thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> f) { - ldarg 0 ldarg x stfld !0 class PrelGHC_Weakzh::contents - ldarg 0 ldarg f stfld thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> class PrelGHC_Weakzh::_finalizer - ret - } - .method public static value class PrelGHC_Z2H class [.module 'PrelBase.i_o']PrelBase_Z0T)>> finalizer(class PrelGHC_Weakzh) { - ldc.i4 1 - ldarg 0 ldfld thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> class PrelGHC_Weakzh::_finalizer - newobj void value class PrelGHC_Z2H class [.module 'PrelBase.i_o']PrelBase_Z0T)>>::.ctor(!0,!1) - ret - } - .method public static value class PrelGHC_Z2H deref(class PrelGHC_Weakzh) { - ldc.i4 1 - ldarg 0 ldfld !0 class PrelGHC_Weakzh::contents - newobj void value class PrelGHC_Z2H::.ctor(!0,!1) - ret - } - .method public static - class PrelGHC_Weakzh - bake(!!0,!!1 obj,thunk<(func () --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> finalizer) { - ldarg obj - ldarg finalizer - newobj void class 'PrelGHC_Weakzh'::.ctor(!0 x, thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)>) - ret - } - -} - -.class public 'PrelGHC_MutVarzh' { - .field public !0 contents - .method public rtspecialname specialname instance void .ctor(!0) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_MutVarzh::contents - ret - } -} - -.class public PrelGHC_ZCTCCallable { -} - -.class public PrelGHC_BCOzh { -} - -.class public PrelGHC_ZCTCReturnable { -} - - -//------------------------------------------------------------ -// Builtin Unboxed Tuple Types - -.class value sealed 'PrelGHC_Z1H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z1H::fld0 - ret - } - .field public !0 fld0 -} - -.class value sealed 'PrelGHC_Z2H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z2H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z2H::fld1 - ret - } - .field public !0 fld0 - .field public !1 fld1 -} - -.class value sealed 'PrelGHC_Z3H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z3H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z3H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z3H::fld2 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 -} - -.class value sealed 'PrelGHC_Z4H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z4H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z4H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z4H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z4H::fld3 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 -} - -.class value sealed 'PrelGHC_Z5H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3,!4) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z5H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z5H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z5H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z5H::fld3 - ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z5H::fld4 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 - .field public !4 fld4 -} - -.class value sealed 'PrelGHC_Z6H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3,!4,!5) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z6H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z6H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z6H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z6H::fld3 - ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z6H::fld4 - ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z6H::fld5 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 - .field public !4 fld4 - .field public !5 fld5 -} - -.class value sealed 'PrelGHC_Z7H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3,!4,!5,!6) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z7H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z7H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z7H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z7H::fld3 - ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z7H::fld4 - ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z7H::fld5 - ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z7H::fld6 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 - .field public !4 fld4 - .field public !5 fld5 - .field public !6 fld6 -} - -.class value sealed 'PrelGHC_Z8H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3,!4,!5,!6,!7) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z8H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z8H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z8H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z8H::fld3 - ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z8H::fld4 - ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z8H::fld5 - ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z8H::fld6 - ldarg 0 ldarg 8 stfld !7 class PrelGHC_Z8H::fld7 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 - .field public !4 fld4 - .field public !5 fld5 - .field public !6 fld6 - .field public !7 fld7 -} - - -// Phew...This is needed by the optimized Haskell library.... -// - TODO: fill in the rest! -.class value sealed 'PrelGHC_Z18H' extends ['mscorlib']System.ValueType { - .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17) { - ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z18H::fld0 - ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z18H::fld1 - ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z18H::fld2 - ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z18H::fld3 - ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z18H::fld4 - ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z18H::fld5 - ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z18H::fld6 - ldarg 0 ldarg 8 stfld !7 class PrelGHC_Z18H::fld7 - ldarg 0 ldarg 9 stfld !8 class PrelGHC_Z18H::fld8 - ldarg 0 ldarg 10 stfld !9 class PrelGHC_Z18H::fld9 - ldarg 0 ldarg 11 stfld !10 class PrelGHC_Z18H::fld10 - ldarg 0 ldarg 12 stfld !11 class PrelGHC_Z18H::fld11 - ldarg 0 ldarg 13 stfld !12 class PrelGHC_Z18H::fld12 - ldarg 0 ldarg 14 stfld !13 class PrelGHC_Z18H::fld13 - ldarg 0 ldarg 15 stfld !14 class PrelGHC_Z18H::fld14 - ldarg 0 ldarg 16 stfld !15 class PrelGHC_Z18H::fld15 - ldarg 0 ldarg 17 stfld !16 class PrelGHC_Z18H::fld16 - ldarg 0 ldarg 18 stfld !17 class PrelGHC_Z18H::fld17 - ret - } - .field public !0 fld0 - .field public !1 fld1 - .field public !2 fld2 - .field public !3 fld3 - .field public !4 fld4 - .field public !5 fld5 - .field public !6 fld6 - .field public !7 fld7 - .field public !8 fld8 - .field public !9 fld9 - .field public !10 fld10 - .field public !11 fld11 - .field public !12 fld12 - .field public !13 fld13 - .field public !14 fld14 - .field public !15 fld15 - .field public !16 fld16 - .field public !17 fld17 - -} - -.classunion '()' extends thunk { - .alternative '()'() -} - diff --git a/ghc/lib/std/PrelHandle.hs b/ghc/lib/std/PrelHandle.hs deleted file mode 100644 index fe360a7..0000000 --- a/ghc/lib/std/PrelHandle.hs +++ /dev/null @@ -1,1226 +0,0 @@ -{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-} - -#undef DEBUG_DUMP -#undef DEBUG - --- ----------------------------------------------------------------------------- --- $Id: PrelHandle.hs,v 1.9 2002/01/28 13:47:05 simonmar Exp $ --- --- (c) The University of Glasgow, 1994-2001 --- --- This module defines the basic operations on I/O "handles". - -module PrelHandle ( - withHandle, withHandle', withHandle_, - wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, - read_off, read_off_ba, - write_off, write_off_ba, - - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, - - stdin, stdout, stderr, - IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, - hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - hFlush, - - hClose, hClose_help, - - HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, - - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, - hSetEcho, hGetEcho, hIsTerminalDevice, - ioeGetFileName, ioeGetErrorString, ioeGetHandle, - -#ifdef DEBUG_DUMP - puts, -#endif - - ) where - -#include "config.h" - -import Monad - -import PrelBits -import PrelPosix -import PrelMarshalUtils -import PrelCString -import PrelCTypes -import PrelCError -import PrelReal - -import PrelArr -import PrelBase -import PrelPtr -import PrelRead ( Read ) -import PrelList -import PrelIOBase -import PrelMaybe ( Maybe(..) ) -import PrelException -import PrelEnum -import PrelNum ( Integer(..), Num(..) ) -import PrelShow -import PrelReal ( toInteger ) - -import PrelConc - --- ----------------------------------------------------------------------------- --- TODO: - --- hWaitForInput blocks (should use a timeout) - --- unbuffered hGetLine is a bit dodgy - --- hSetBuffering: can't change buffering on a stream, --- when the read buffer is non-empty? (no way to flush the buffer) - --- --------------------------------------------------------------------------- --- Are files opened by default in text or binary mode, if the user doesn't --- specify? -dEFAULT_OPEN_IN_BINARY_MODE :: Bool -dEFAULT_OPEN_IN_BINARY_MODE = False - --- Is seeking on text-mode handles allowed, or not? -foreign import ccall "prel_supportsTextMode" unsafe tEXT_MODE_SEEK_ALLOWED :: Bool - --- --------------------------------------------------------------------------- --- Creating a new handle - -newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle -newFileHandle finalizer hc = do - m <- newMVar hc - addMVarFinalizer m (finalizer m) - return (FileHandle m) - --- --------------------------------------------------------------------------- --- Working with Handles - -{- -In the concurrent world, handles are locked during use. This is done -by wrapping an MVar around the handle which acts as a mutex over -operations on the handle. - -To avoid races, we use the following bracketing operations. The idea -is to obtain the lock, do some operation and replace the lock again, -whether the operation succeeded or failed. We also want to handle the -case where the thread receives an exception while processing the IO -operation: in these cases we also want to relinquish the lock. - -There are three versions of @withHandle@: corresponding to the three -possible combinations of: - - - the operation may side-effect the handle - - the operation may return a result - -If the operation generates an error or an exception is raised, the -original handle is always replaced [ this is the case at the moment, -but we might want to revisit this in the future --SDM ]. --} - -{-# INLINE withHandle #-} -withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle fun h@(FileHandle m) act = withHandle' fun h m act -withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act - -withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - (h',v) <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h' - putMVar m h' - return v - -{-# INLINE withHandle_ #-} -withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a -withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act -withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act - -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - v <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h_ - putMVar m h_ - return v - -withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () -withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act -withAllHandles__ fun h@(DuplexHandle r w) act = do - withHandle__' fun h r act - withHandle__' fun h w act - -withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - h' <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h' - putMVar m h' - return () - -augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_ - = IOException (IOError (Just h) iot fun str filepath) - where filepath | Just _ <- fp = fp - | otherwise = Just (haFilePath h_) -augmentIOError other_exception _ _ _ - = other_exception - --- --------------------------------------------------------------------------- --- Wrapper for write operations. - -wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantWritableHandle fun h@(FileHandle m) act - = wantWritableHandle' fun h m act -wantWritableHandle fun h@(DuplexHandle _ m) act - = wantWritableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkWritableHandle - -wantWritableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantWritableHandle' fun h m act - = withHandle_' fun h m (checkWritableHandle act) - -checkWritableHandle act handle_ - = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - ReadHandle -> ioe_notWritable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - new_buf <- - if not (bufferIsWritable buf) - then do b <- flushReadBuffer (haFD handle_) buf - return b{ bufState=WriteBuffer } - else return buf - writeIORef ref new_buf - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for read operations. - -wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantReadableHandle fun h@(FileHandle m) act - = wantReadableHandle' fun h m act -wantReadableHandle fun h@(DuplexHandle m _) act - = wantReadableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkReadableHandle - -wantReadableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantReadableHandle' fun h m act - = withHandle_' fun h m (checkReadableHandle act) - -checkReadableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef ref new_buf{ bufState=ReadBuffer } - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for seek operations. - -wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantSeekableHandle fun h@(DuplexHandle _ _) _act = - ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) -wantSeekableHandle fun h@(FileHandle m) act = - withHandle_' fun h m (checkSeekableHandle act) - -checkSeekableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ - | otherwise -> ioe_notSeekable_notBin - --- ----------------------------------------------------------------------------- --- Handy IOErrors - -ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, - ioe_notSeekable, ioe_notSeekable_notBin :: IO a - -ioe_closedHandle = ioException - (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) -ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) -ioe_notReadable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) -ioe_notWritable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) -ioe_notSeekable = ioException - (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) -ioe_notSeekable_notBin = ioException - (IOError Nothing IllegalOperation "" - "seek operations on text-mode handles are not allowed on this platform" - Nothing) - -ioe_bufsiz :: Int -> IO a -ioe_bufsiz n = ioException - (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) - -- 9 => should be parens'ified. - --- ----------------------------------------------------------------------------- --- Handle Finalizers - --- For a duplex handle, we arrange that the read side points to the write side --- (and hence keeps it alive if the read side is alive). This is done by --- having the haOtherSide field of the read side point to the read side. --- The finalizer is then placed on the write side, and the handle only gets --- finalized once, when both sides are no longer required. - -stdHandleFinalizer :: MVar Handle__ -> IO () -stdHandleFinalizer m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - -handleFinalizer :: MVar Handle__ -> IO () -handleFinalizer m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - let fd = fromIntegral (haFD h_) - unlockFile fd - when (fd /= -1) -#ifdef mingw32_TARGET_OS - (closeFd (haIsStream h_) fd >> return ()) -#else - (c_close fd >> return ()) -#endif - return () - --- --------------------------------------------------------------------------- --- Grimy buffer operations - -#ifdef DEBUG -checkBufferInvariants h_ = do - let ref = haBuffer h_ - Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref - if not ( - size > 0 - && r <= w - && w <= size - && ( r /= w || (r == 0 && w == 0) ) - && ( state /= WriteBuffer || r == 0 ) - && ( state /= WriteBuffer || w < size ) -- write buffer is never full - ) - then error "buffer invariant violation" - else return () -#else -checkBufferInvariants h_ = return () -#endif - -newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer -newEmptyBuffer b state size - = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } - -allocateBuffer :: Int -> BufferState -> IO Buffer -allocateBuffer sz@(I# size) state = IO $ \s -> - case newByteArray# size s of { (# s, b #) -> - (# s, newEmptyBuffer b state sz #) } - -writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int -writeCharIntoBuffer slab (I# off) (C# c) - = IO $ \s -> case writeCharArray# slab off c s of - s -> (# s, I# (off +# 1#) #) - -readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) -readCharFromBuffer slab (I# off) - = IO $ \s -> case readCharArray# slab off s of - (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #) - -getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) -getBuffer fd state = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state - ioref <- newIORef buffer - is_tty <- fdIsTTY fd - - let buffer_mode - | is_tty = LineBuffering - | otherwise = BlockBuffering Nothing - - return (ioref, buffer_mode) - -mkUnBuffer :: IO (IORef Buffer) -mkUnBuffer = do - buffer <- allocateBuffer 1 ReadBuffer - newIORef buffer - --- flushWriteBufferOnly flushes the buffer iff it contains pending write data. -flushWriteBufferOnly :: Handle__ -> IO () -flushWriteBufferOnly h_ = do - let fd = haFD h_ - ref = haBuffer h_ - buf <- readIORef ref - new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd (haIsStream h_) buf - else return buf - writeIORef ref new_buf - --- flushBuffer syncs the file with the buffer, including moving the --- file pointer backwards in the case of a read buffer. -flushBuffer :: Handle__ -> IO () -flushBuffer h_ = do - let ref = haBuffer h_ - buf <- readIORef ref - - flushed_buf <- - case bufState buf of - ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf - - writeIORef ref flushed_buf - --- When flushing a read buffer, we seek backwards by the number of --- characters in the buffer. The file descriptor must therefore be --- seekable: attempting to flush the read buffer on an unseekable --- handle is not allowed. - -flushReadBuffer :: FD -> Buffer -> IO Buffer -flushReadBuffer fd buf - | bufferEmpty buf = return buf - | otherwise = do - let off = negate (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") -# endif - throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR) - return buf{ bufWPtr=0, bufRPtr=0 } - -flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer -flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do - let bytes = w - r -#ifdef DEBUG_DUMP - puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") -#endif - if bytes == 0 - then return (buf{ bufRPtr=0, bufWPtr=0 }) - else do - res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer" - (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r) - (fromIntegral bytes)) - (threadWaitWrite fd) - let res' = fromIntegral res - if res' < bytes - then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' }) - else return buf{ bufRPtr=0, bufWPtr=0 } - -foreign import "prel_PrelHandle_write" unsafe - write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import "prel_PrelHandle_write" unsafe - write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt - -fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line is_stream buf b w size - --- For a line buffer, we just get the first chunk of data to arrive, --- and don't wait for the whole buffer to be full (but we *do* wait --- until some data arrives). This isn't really line buffering, but it --- appears to be what GHC has done for a long time, and I suspect it --- is more useful than line buffering in most cases. - -fillReadBufferLoop fd is_line is_stream buf b w size = do - let bytes = size - w - if bytes == 0 -- buffer full? - then return buf{ bufRPtr=0, bufWPtr=w } - else do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") -#endif - res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer" - (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes)) - (threadWaitRead fd) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") -#endif - if res' == 0 - then if w == 0 - then ioe_EOF - else return buf{ bufRPtr=0, bufWPtr=w } - else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line is_stream buf b (w+res') size - else return buf{ bufRPtr=0, bufWPtr=w+res' } - -foreign import "prel_PrelHandle_read" unsafe - read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import "prel_PrelHandle_read" unsafe - read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt - --- --------------------------------------------------------------------------- --- Standard Handles - --- Three handles are allocated during program initialisation. The first --- two manage input or output from the Haskell program's standard input --- or output channel respectively. The third manages output to the --- standard error channel. These handles are initially open. - -fd_stdin = 0 :: FD -fd_stdout = 1 :: FD -fd_stderr = 2 :: FD - -stdin :: Handle -stdin = unsafePerformIO $ do - -- ToDo: acquire lock - setNonBlockingFD fd_stdin - (buf, bmode) <- getBuffer fd_stdin ReadBuffer - mkStdHandle fd_stdin "" ReadHandle buf bmode - -stdout :: Handle -stdout = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stdout - (buf, bmode) <- getBuffer fd_stdout WriteBuffer - mkStdHandle fd_stdout "" WriteHandle buf bmode - -stderr :: Handle -stderr = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stderr - buf <- mkUnBuffer - mkStdHandle fd_stderr "" WriteHandle buf NoBuffering - --- --------------------------------------------------------------------------- --- Opening and Closing Files - -{- -Computation `openFile file mode' allocates and returns a new, open -handle to manage the file `file'. It manages input if `mode' -is `ReadMode', output if `mode' is `WriteMode' or `AppendMode', -and both input and output if mode is `ReadWriteMode'. - -If the file does not exist and it is opened for output, it should be -created as a new file. If `mode' is `WriteMode' and the file -already exists, then it should be truncated to zero length. The -handle is positioned at the end of the file if `mode' is -`AppendMode', and otherwise at the beginning (in which case its -internal position is 0). - -Implementations should enforce, locally to the Haskell process, -multiple-reader single-writer locking on files, which is to say that -there may either be many handles on the same file which manage input, -or just one handle on the file which manages output. If any open or -semi-closed handle is managing a file for output, no new handle can be -allocated for that file. If any open or semi-closed handle is -managing a file for input, new handles can only be allocated if they -do not manage output. - -Two files are the same if they have the same absolute name. An -implementation is free to impose stricter conditions. --} - -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) - -data IOModeEx - = BinaryMode IOMode - | TextMode IOMode - deriving (Eq, Read, Show) - -addFilePathToIOError fun fp (IOException (IOError h iot _ str _)) - = IOException (IOError h iot fun str (Just fp)) -addFilePathToIOError _ _ other_exception - = other_exception - -openFile :: FilePath -> IOMode -> IO Handle -openFile fp im = - catch - (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE - then BinaryMode im - else TextMode im)) - (\e -> throw (addFilePathToIOError "openFile" fp e)) - -openFileEx :: FilePath -> IOModeEx -> IO Handle -openFileEx fp m = - catch - (openFile' fp m) - (\e -> throw (addFilePathToIOError "openFileEx" fp e)) - - -openFile' filepath ex_mode = - withCString filepath $ \ f -> - - let - (mode, binary) = - case ex_mode of - BinaryMode bmo -> (bmo, True) - TextMode tmo -> (tmo, False) - - oflags1 = case mode of - ReadMode -> read_flags - WriteMode -> write_flags - ReadWriteMode -> rw_flags - AppendMode -> append_flags - - truncate | WriteMode <- mode = True - | otherwise = False - - binary_flags - | binary = o_BINARY -- is '0' if not supported. - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - in do - - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) - - openFd fd Nothing filepath mode binary truncate - -- ASSERT: if we just created the file, then openFd won't fail - -- (so we don't need to worry about removing the newly created file - -- in the event of an error). - - -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY -rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND - --- --------------------------------------------------------------------------- --- openFd - -openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd mb_fd_type filepath mode binary truncate = do - -- turn on non-blocking mode - setNonBlockingFD fd - - let (ha_type, write) = - case mode of - ReadMode -> ( ReadHandle, False ) - WriteMode -> ( WriteHandle, True ) - ReadWriteMode -> ( ReadWriteHandle, True ) - AppendMode -> ( AppendHandle, True ) - - -- open() won't tell us if it was a directory if we only opened for - -- reading, so check again. - fd_type <- - case mb_fd_type of - Just x -> return x - Nothing -> fdType fd - let is_stream = fd_type == Stream - case fd_type of - Directory -> - ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) - - Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary - | otherwise -> mkFileHandle fd is_stream filepath ha_type binary - - -- regular files need to be locked - RegularFile -> do - r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} - when (r == -1) $ - ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing) - - -- truncate the file if necessary - when truncate (fileTruncate filepath) - - mkFileHandle fd is_stream filepath ha_type binary - - -foreign import "lockFile" unsafe - lockFile :: CInt -> CInt -> CInt -> IO CInt - -foreign import "unlockFile" unsafe - unlockFile :: CInt -> IO CInt - -mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode - -> IO Handle -mkStdHandle fd filepath ha_type buf bmode = do - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haIsStream = False, - haBufferMode = bmode, - haFilePath = filepath, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd is_stream filepath ha_type binary = do - (buf, bmode) <- getBuffer fd (initBufferState ha_type) - spares <- newIORef BufferListNil - newFileHandle handleFinalizer - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = bmode, - haFilePath = filepath, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd is_stream filepath binary = do - (w_buf, w_bmode) <- getBuffer fd WriteBuffer - w_spares <- newIORef BufferListNil - let w_handle_ = - Handle__ { haFD = fd, - haType = WriteHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = w_bmode, - haFilePath = filepath, - haBuffer = w_buf, - haBuffers = w_spares, - haOtherSide = Nothing - } - write_side <- newMVar w_handle_ - - (r_buf, r_bmode) <- getBuffer fd ReadBuffer - r_spares <- newIORef BufferListNil - let r_handle_ = - Handle__ { haFD = fd, - haType = ReadHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = r_bmode, - haFilePath = filepath, - haBuffer = r_buf, - haBuffers = r_spares, - haOtherSide = Just write_side - } - read_side <- newMVar r_handle_ - - addMVarFinalizer read_side (handleFinalizer read_side) - return (DuplexHandle read_side write_side) - - -initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer - --- --------------------------------------------------------------------------- --- Closing a handle - --- Computation `hClose hdl' makes handle `hdl' closed. Before the --- computation finishes, any items buffered for output and not already --- sent to the operating system are flushed as for `hFlush'. - --- For a duplex handle, we close&flush the write side, and just close --- the read side. - -hClose :: Handle -> IO () -hClose h@(FileHandle m) = hClose' h m -hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r - -hClose' h m = withHandle__' "hClose" h m $ hClose_help - --- hClose_help is also called by lazyRead (in PrelIO) when EOF is read --- or an IO error occurs on a lazy stream. The semi-closed Handle is --- then closed immediately. We have to be careful with DuplexHandles --- though: we have to leave the closing to the finalizer in that case, --- because the write side may still be in use. -hClose_help handle_ = - case haType handle_ of - ClosedHandle -> return handle_ - _ -> do - let fd = haFD handle_ - c_fd = fromIntegral fd - - flushWriteBufferOnly handle_ - - -- close the file descriptor, but not when this is the read - -- side of a duplex handle, and not when this is one of the - -- std file handles. - case haOtherSide handle_ of - Nothing -> - when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $ - throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_TARGET_OS - (closeFd (haIsStream handle_) c_fd) -#else - (c_close c_fd) -#endif - Just _ -> return () - - -- free the spare buffers - writeIORef (haBuffers handle_) BufferListNil - - -- unlock it - unlockFile c_fd - - -- we must set the fd to -1, because the finalizer is going - -- to run eventually and try to close/unlock it. - return (handle_{ haFD = -1, - haType = ClosedHandle - }) - ------------------------------------------------------------------------------ --- Detecting the size of a file - --- For a handle `hdl' which attached to a physical file, `hFileSize --- hdl' returns the size of `hdl' in terms of the number of items --- which can be read from `hdl'. - -hFileSize :: Handle -> IO Integer -hFileSize handle = - withHandle_ "hFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - r <- fdFileSize (haFD handle_) - if r /= -1 - then return r - else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing) - --- --------------------------------------------------------------------------- --- Detecting the End of Input - --- For a readable handle `hdl', `hIsEOF hdl' returns --- `True' if no further input can be taken from `hdl' or for a --- physical file, if the current I/O position is equal to the length of --- the file. Otherwise, it returns `False'. - -hIsEOF :: Handle -> IO Bool -hIsEOF handle = - catch - (do hLookAhead handle; return False) - (\e -> if isEOFError e then return True else throw e) - -isEOF :: IO Bool -isEOF = hIsEOF stdin - --- --------------------------------------------------------------------------- --- Looking ahead - --- hLookahead returns the next character from the handle without --- removing it from the input buffer, blocking until a character is --- available. - -hLookAhead :: Handle -> IO Char -hLookAhead handle = do - wantReadableHandle "hLookAhead" handle $ \handle_ -> do - let ref = haBuffer handle_ - fd = haFD handle_ - is_line = haBufferMode handle_ == LineBuffering - buf <- readIORef ref - - -- fill up the read buffer if necessary - new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line (haIsStream handle_) buf - else return buf - - writeIORef ref new_buf - - (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) - return c - --- --------------------------------------------------------------------------- --- Buffering Operations - --- Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. See PrelIOBase for definition and --- further explanation of what the type represent. - --- Computation `hSetBuffering hdl mode' sets the mode of buffering for --- handle hdl on subsequent reads and writes. --- --- * If mode is LineBuffering, line-buffering should be enabled if possible. --- --- * If mode is `BlockBuffering size', then block-buffering --- should be enabled if possible. The size of the buffer is n items --- if size is `Just n' and is otherwise implementation-dependent. --- --- * If mode is NoBuffering, then buffering is disabled if possible. - --- If the buffer mode is changed from BlockBuffering or --- LineBuffering to NoBuffering, then any items in the output --- buffer are written to the device, and any items in the input buffer --- are discarded. The default buffering mode when a handle is opened --- is implementation-dependent and may depend on the object which is --- attached to that handle. - -hSetBuffering :: Handle -> BufferMode -> IO () -hSetBuffering handle mode = - withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> do - {- Note: - - we flush the old buffer regardless of whether - the new buffer could fit the contents of the old buffer - or not. - - allow a handle's buffering to change even if IO has - occurred (ANSI C spec. does not allow this, nor did - the previous implementation of IO.hSetBuffering). - - a non-standard extension is to allow the buffering - of semi-closed handles to change [sof 6/98] - -} - flushBuffer handle_ - - let state = initBufferState (haType handle_) - new_buf <- - case mode of - -- we always have a 1-character read buffer for - -- unbuffered handles: it's needed to - -- support hLookAhead. - NoBuffering -> allocateBuffer 1 ReadBuffer - LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n - | otherwise -> allocateBuffer n state - writeIORef (haBuffer handle_) new_buf - - -- for input terminals we need to put the terminal into - -- cooked or raw mode depending on the type of buffering. - is_tty <- fdIsTTY (haFD handle_) - when (is_tty && isReadableHandleType (haType handle_)) $ - case mode of - NoBuffering -> setCooked (haFD handle_) False - _ -> setCooked (haFD handle_) True - - -- throw away spare buffers, they might be the wrong size - writeIORef (haBuffers handle_) BufferListNil - - return (handle_{ haBufferMode = mode }) - --- ----------------------------------------------------------------------------- --- hFlush - --- The action `hFlush hdl' causes any items buffered for output --- in handle `hdl' to be sent immediately to the operating --- system. - -hFlush :: Handle -> IO () -hFlush handle = - wantWritableHandle "hFlush" handle $ \ handle_ -> do - buf <- readIORef (haBuffer handle_) - if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef (haBuffer handle_) flushed_buf - else return () - - --- ----------------------------------------------------------------------------- --- Repositioning Handles - -data HandlePosn = HandlePosn Handle HandlePosition - -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - -instance Show HandlePosn where - showsPrec p (HandlePosn h pos) = - showsPrec p h . showString " at position " . shows pos - - -- HandlePosition is the Haskell equivalent of POSIX' off_t. - -- We represent it as an Integer on the Haskell side, but - -- cheat slightly in that hGetPosn calls upon a C helper - -- that reports the position back via (merely) an Int. -type HandlePosition = Integer - --- Computation `hGetPosn hdl' returns the current I/O position of --- `hdl' as an abstract position. Computation `hSetPosn p' sets the --- position of `hdl' to a previously obtained position `p'. - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#if defined(mingw32_TARGET_OS) - -- urgh, on Windows we have to worry about \n -> \r\n translation, - -- so we can't easily calculate the file position using the - -- current buffer size. Just flush instead. - flushBuffer handle_ -#endif - let fd = fromIntegral (haFD handle_) - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 sEEK_CUR) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return (HandlePosn handle real_posn) - - -hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i - --- --------------------------------------------------------------------------- --- hSeek - -{- -The action `hSeek hdl mode i' sets the position of handle -`hdl' depending on `mode'. If `mode' is - - * AbsoluteSeek - The position of `hdl' is set to `i'. - * RelativeSeek - The position of `hdl' is set to offset `i' from - the current position. - * SeekFromEnd - The position of `hdl' is set to offset `i' from - the end of the file. - -Some handles may not be seekable (see `hIsSeekable'), or only -support a subset of the possible positioning operations (e.g. it may -only be possible to seek to the end of a tape, or to a positive -offset from the beginning or current position). - -It is not possible to set a negative I/O position, or for a physical -file, an I/O position beyond the current end-of-file. - -Note: - - when seeking using `SeekFromEnd', positive offsets (>=0) means - seeking at or past EOF. - - - we possibly deviate from the report on the issue of seeking within - the buffer and whether to flush it or not. The report isn't exactly - clear here. --} - -data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd - deriving (Eq, Ord, Ix, Enum, Read, Show) - -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset = - wantSeekableHandle "hSeek" handle $ \ handle_ -> do -# ifdef DEBUG_DUMP - puts ("hSeek " ++ show (mode,offset) ++ "\n") -# endif - let ref = haBuffer handle_ - buf <- readIORef ref - let r = bufRPtr buf - w = bufWPtr buf - fd = haFD handle_ - - let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence) - - whence :: CInt - whence = case mode of - AbsoluteSeek -> sEEK_SET - RelativeSeek -> sEEK_CUR - SeekFromEnd -> sEEK_END - - if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf - writeIORef ref new_buf - do_seek - else do - - if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef ref buf{ bufRPtr = r + fromIntegral offset } - else do - - new_buf <- flushReadBuffer (haFD handle_) buf - writeIORef ref new_buf - do_seek - --- ----------------------------------------------------------------------------- --- Handle Properties - --- A number of operations return information about the properties of a --- handle. Each of these operations returns `True' if the handle has --- the specified property, and `False' otherwise. - -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - withHandle_ "hIsOpen" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return False - SemiClosedHandle -> return False - _ -> return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - withHandle_ "hIsClosed" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return True - _ -> return False - -{- not defined, nor exported, but mentioned - here for documentation purposes: - - hSemiClosed :: Handle -> IO Bool - hSemiClosed h = do - ho <- hIsOpen h - hc <- hIsClosed h - return (not (ho || hc)) --} - -hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _) = return True -hIsReadable handle = - withHandle_ "hIsReadable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isReadableHandleType htype) - -hIsWritable :: Handle -> IO Bool -hIsWritable (DuplexHandle _ _) = return False -hIsWritable handle = - withHandle_ "hIsWritable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isWritableHandleType htype) - --- Querying how a handle buffers its data: - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = - withHandle_ "hGetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> - -- We're being non-standard here, and allow the buffering - -- of a semi-closed handle to be queried. -- sof 6/98 - return (haBufferMode handle_) -- could be stricter.. - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - withHandle_ "hIsSeekable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> return False - _ -> do t <- fdType (haFD handle_) - return (t == RegularFile - && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) - --- ----------------------------------------------------------------------------- --- Changing echo status - --- Non-standard GHC extension is to allow the echoing status --- of a handles connected to terminals to be reconfigured: - -hSetEcho :: Handle -> Bool -> IO () -hSetEcho handle on = do - isT <- hIsTerminalDevice handle - if not isT - then return () - else - withHandle_ "hSetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> setEcho (haFD handle_) on - -hGetEcho :: Handle -> IO Bool -hGetEcho handle = do - isT <- hIsTerminalDevice handle - if not isT - then return False - else - withHandle_ "hGetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> getEcho (haFD handle_) - -hIsTerminalDevice :: Handle -> IO Bool -hIsTerminalDevice handle = do - withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> fdIsTTY (haFD handle_) - --- ----------------------------------------------------------------------------- --- hSetBinaryMode -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (fromIntegral (haFD handle_)) bin) - return handle_{haIsBin=bin} - -foreign import "prel_setmode" setmode :: CInt -> Bool -> IO CInt - --- ----------------------------------------------------------------------------- --- Miscellaneous - --- These three functions are meant to get things out of an IOError. - -ioeGetFileName :: IOError -> Maybe FilePath -ioeGetErrorString :: IOError -> String -ioeGetHandle :: IOError -> Maybe Handle - -ioeGetHandle (IOException (IOError h _ _ _ _)) = h -ioeGetHandle (UserError _) = Nothing -ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" - -ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot -ioeGetErrorString (UserError str) = str -ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" - -ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn -ioeGetFileName (UserError _) = Nothing -ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" - --- --------------------------------------------------------------------------- --- debugging - -#ifdef DEBUG_DUMP -puts :: String -> IO () -puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s)) - return () -#endif - --- wrappers to platform-specific constants: -foreign import ccall "prel_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int -foreign import ccall "prel_seek_cur" unsafe sEEK_CUR :: CInt -foreign import ccall "prel_seek_set" unsafe sEEK_SET :: CInt -foreign import ccall "prel_seek_end" unsafe sEEK_END :: CInt - - diff --git a/ghc/lib/std/PrelIO.hs b/ghc/lib/std/PrelIO.hs deleted file mode 100644 index 39132b4..0000000 --- a/ghc/lib/std/PrelIO.hs +++ /dev/null @@ -1,676 +0,0 @@ -{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-} - -#undef DEBUG_DUMP - --- ----------------------------------------------------------------------------- --- $Id: PrelIO.hs,v 1.7 2001/12/27 11:26:03 sof Exp $ --- --- (c) The University of Glasgow, 1992-2001 --- --- Module PrelIO - --- This module defines all basic IO operations. --- These are needed for the IO operations exported by Prelude, --- but as it happens they also do everything required by library --- module IO. - -module PrelIO ( - putChar, putStr, putStrLn, print, getChar, getLine, getContents, - interact, readFile, writeFile, appendFile, readLn, readIO, hReady, - hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - hPutStrLn, hPrint, - commitBuffer', -- hack, see below - hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - - -- helpers - memcpy_ba_ba, - memcpy_ba_ptr, - memcpy_ptr_ba, - memcpy_ptr_ptr - ) where - -import PrelBase - -import PrelPosix -import PrelMarshalUtils -import PrelStorable -import PrelCError -import PrelCString -import PrelCTypes -import PrelCTypesISO - -import PrelIOBase -import PrelHandle -- much of the real stuff is in here - -import PrelMaybe -import PrelReal -import PrelNum -import PrelRead -import PrelShow -import PrelMaybe ( Maybe(..) ) -import PrelPtr -import PrelList -import PrelException ( ioError, catch, throw ) -import PrelConc - --- ----------------------------------------------------------------------------- --- Standard IO - -putChar :: Char -> IO () -putChar c = hPutChar stdout c - -putStr :: String -> IO () -putStr s = hPutStr stdout s - -putStrLn :: String -> IO () -putStrLn s = do putStr s - putChar '\n' - -print :: Show a => a -> IO () -print x = putStrLn (show x) - -getChar :: IO Char -getChar = hGetChar stdin - -getLine :: IO String -getLine = hGetLine stdin - -getContents :: IO String -getContents = hGetContents stdin - -interact :: (String -> String) -> IO () -interact f = do s <- getContents - putStr (f s) - -readFile :: FilePath -> IO String -readFile name = openFile name ReadMode >>= hGetContents - -writeFile :: FilePath -> String -> IO () -writeFile name str = do - hdl <- openFile name WriteMode - hPutStr hdl str - hClose hdl - -appendFile :: FilePath -> String -> IO () -appendFile name str = do - hdl <- openFile name AppendMode - hPutStr hdl str - hClose hdl - -readLn :: Read a => IO a -readLn = do l <- getLine - r <- readIO l - return r - - -- raises an exception instead of an error -readIO :: Read a => String -> IO a -readIO s = case (do { (x,t) <- reads s ; - ("","") <- lex t ; - return x }) of -#ifndef NEW_READS_REP - [x] -> return x - [] -> ioError (userError "Prelude.readIO: no parse") - _ -> ioError (userError "Prelude.readIO: ambiguous parse") -#else - Just x -> return x - Nothing -> ioError (userError "Prelude.readIO: no parse") -#endif - --- --------------------------------------------------------------------------- --- Simple input operations - --- Computation "hReady hdl" indicates whether at least --- one item is available for input from handle "hdl". - --- If hWaitForInput finds anything in the Handle's buffer, it --- immediately returns. If not, it tries to read from the underlying --- OS handle. Notice that for buffered Handles connected to terminals --- this means waiting until a complete line is available. - -hReady :: Handle -> IO Bool -hReady h = hWaitForInput h 0 - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hReady" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref - - if not (bufferEmpty buf) - then return True - else do - - r <- throwErrnoIfMinus1Retry "hReady" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_)) - return (r /= 0) - -foreign import "inputReady" unsafe - inputReady :: CInt -> CInt -> Bool -> IO CInt - --- --------------------------------------------------------------------------- --- hGetChar - --- hGetChar reads the next character from a handle, --- blocking until a character is available. - -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \handle_ -> do - - let fd = haFD handle_ - ref = haBuffer handle_ - - buf <- readIORef ref - if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do - - -- buffer is empty. - case haBufferMode handle_ of - LineBuffering -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - hGetcBuffered fd ref new_buf - BlockBuffering _ -> do - new_buf <- fillReadBuffer fd False (haIsStream handle_) buf - hGetcBuffered fd ref new_buf - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- throwErrnoIfMinus1RetryMayBlock "hGetChar" - (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1) - (threadWaitRead fd) - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } - = do (c,r) <- readCharFromBuffer b r - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c - --- --------------------------------------------------------------------------- --- hGetLine - --- If EOF is reached before EOL is encountered, ignore the EOF and --- return the partial line. Next attempt at calling hGetLine on the --- handle will yield an EOF IO exception though. - --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. -hGetLine :: Handle -> IO String -hGetLine h = do - m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) - case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - - -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - - -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' - in do - (eol, off) <- loop raw r - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw r off - if eol - then do if w == off + 1 - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> let str = concat (reverse (xs:xss)) in - if not (null str) - then return str - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf (xs:xss) - - -maybeFillReadBuffer fd is_line is_stream buf - = catch - (do buf <- fillReadBuffer fd is_line is_stream buf - return (Just buf) - ) - (\e -> do if isEOFError e - then return Nothing - else throw e) - - -unpack :: RawBuffer -> Int -> Int -> IO [Char] -unpack buf r 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s - where - unpack acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s - - -hGetLineUnBuffered :: Handle -> IO String -hGetLineUnBuffered h = do - c <- hGetChar h - if c == '\n' then - return "" - else do - l <- getRest - return (c:l) - where - getRest = do - c <- - catch - (hGetChar h) - (\ err -> do - if isEOFError err then - return '\n' - else - ioError err) - if c == '\n' then - return "" - else do - s <- getRest - return (c:s) - --- ----------------------------------------------------------------------------- --- hGetContents - --- hGetContents returns the list of characters corresponding to the --- unread portion of the channel or file managed by the handle, which --- is made semi-closed. - --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. - -hGetContents :: Handle -> IO String -hGetContents handle = - withHandle "hGetContents" handle $ \handle_ -> - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) - --- Note that someone may close the semi-closed handle (or change its --- buffering), so each time these lazy read functions are pulled on, --- they have to check whether the handle has indeed been closed. - -lazyRead :: Handle -> IO String -lazyRead handle = - unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) - -lazyRead' h handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - - -- even a NoBuffering handle can have a char in the buffer... - -- (see hLookAhead) - buf <- readIORef ref - if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do - - case haBufferMode handle_ of - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- throwErrnoIfMinus1RetryMayBlock "lazyRead" - (read_off_ba (fromIntegral fd) (haIsStream handle_) raw 0 1) - (threadWaitRead fd) - if r == 0 - then do handle_ <- hClose_help handle_ - return (handle_, "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) - - LineBuffering -> lazyReadBuffered h handle_ fd ref buf - BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf - --- we never want to block during the read, so we call fillReadBuffer with --- is_line==True, which tells it to "just read what there is". -lazyReadBuffered h handle_ fd ref buf = do - catch - (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf - lazyReadHaveBuffer h handle_ fd ref buf - ) - -- all I/O errors are discarded. Additionally, we close the handle. - (\e -> do handle_ <- hClose_help handle_ - return (handle_, "") - ) - -lazyReadHaveBuffer h handle_ fd ref buf = do - more <- lazyRead h - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more - return (handle_, s) - - -unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc buf r 0 acc = return "" -unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s - where - unpack acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s - --- --------------------------------------------------------------------------- --- hPutChar - --- `hPutChar hdl ch' writes the character `ch' to the file or channel --- managed by `hdl'. Characters may be buffered if buffering is --- enabled for `hdl'. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = - c `seq` do -- must evaluate c before grabbing the handle lock - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - withObject (castCharToCChar c) $ \buf -> - throwErrnoIfMinus1RetryMayBlock_ "hPutChar" - (write_off (fromIntegral fd) (haIsStream handle_) buf 0 1) - (threadWaitWrite fd) - - -hPutcBuffered handle_ is_line c = do - let ref = haBuffer handle_ - buf <- readIORef ref - let w = bufWPtr buf - w' <- writeCharIntoBuffer (bufBuf buf) w c - let new_buf = buf{ bufWPtr = w' } - if bufferFull new_buf || is_line && c == '\n' - then do - flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf - writeIORef ref flushed_buf - else do - writeIORef ref new_buf - - -hPutChars :: Handle -> [Char] -> IO () -hPutChars handle [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs - --- --------------------------------------------------------------------------- --- hPutStr - --- `hPutStr hdl s' writes the string `s' to the file or --- hannel managed by `hdl', buffering the output if needs be. - --- We go to some trouble to avoid keeping the handle locked while we're --- evaluating the string argument to hPutStr, in case doing so triggers another --- I/O operation on the same handle which would lead to deadlock. The classic --- case is --- --- putStr (trace "hello" "world") --- --- so the basic scheme is this: --- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. --- --- Committing may involve simply copying the contents of the new --- buffer into the handle's buffer, flushing one or both buffers, or --- maybe just swapping the buffers over (if the handle's buffer was --- empty). See commitBuffer below. - -hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) - case buffer_mode of - (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care - (LineBuffering, buf) -> do - writeLines handle buf str - (BlockBuffering _, buf) -> do - writeBlocks handle buf str - - -getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) -getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} - = do - case mode of - NoBuffering -> return (mode, error "no buffer!") - _ -> do - bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) - - -writeLines :: Handle -> Buffer -> String -> IO () -writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeLines hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - if (c == '\n') - then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeLines hdl new_buf cs - else - shoveString n' cs - in - shoveString 0 s - -writeBlocks :: Handle -> Buffer -> String -> IO () -writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - shoveString n' cs - in - shoveString 0 s - --- ----------------------------------------------------------------------------- --- commitBuffer handle buf sz count flush release --- --- Write the contents of the buffer 'buf' ('sz' bytes long, containing --- 'count' bytes of data) to handle (handle must be block or line buffered). --- --- Implementation: --- --- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. --- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. --- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. - -commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer - -commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do - wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' hdl raw sz count flush release - --- Explicitly lambda-lift this function to subvert GHC's full laziness --- optimisations, which otherwise tends to float out subexpressions --- past the \handle, which is really a pessimisation in this case because --- that lambda is a one-shot lambda. --- --- Don't forget to export the function, to stop it being inlined too --- (this appears to be better than NOINLINE, because the strictness --- analyser still gets to worker-wrapper it). --- --- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 --- -commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release - handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do - -#ifdef DEBUG_DUMP - puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") -#endif - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_ba_ba old_raw w raw 0 (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd (haIsStream handle_) this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer - - -- release the buffer if necessary - case buf_ret of - Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do - if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret - - -foreign import "prel_PrelIO_memcpy" unsafe - memcpy_ba_ba :: RawBuffer -> Int -> RawBuffer -> Int -> CSize -> IO (Ptr ()) - -foreign import "prel_PrelIO_memcpy" unsafe - memcpy_ba_ptr :: RawBuffer -> Int -> Ptr a -> Int -> CSize -> IO (Ptr ()) - -foreign import "prel_PrelIO_memcpy" unsafe - memcpy_ptr_ba :: Ptr a -> Int -> RawBuffer -> Int -> CSize -> IO (Ptr ()) - -foreign import "prel_PrelIO_memcpy" unsafe - memcpy_ptr_ptr :: Ptr a -> Int -> Ptr a -> Int -> CSize -> IO (Ptr ()) - --- --------------------------------------------------------------------------- --- hPutStrLn - --- Derived action `hPutStrLn hdl str' writes the string `str' to --- the handle `hdl', adding a newline at the end. - -hPutStrLn :: Handle -> String -> IO () -hPutStrLn hndl str = do - hPutStr hndl str - hPutChar hndl '\n' - --- --------------------------------------------------------------------------- --- hPrint - --- Computation `hPrint hdl t' writes the string representation of `t' --- given by the `shows' function to the file or channel managed by `hdl'. - -hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStrLn hdl . show diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs deleted file mode 100644 index 51a16dc..0000000 --- a/ghc/lib/std/PrelIOBase.lhs +++ /dev/null @@ -1,633 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelIOBase.lhs,v 1.47 2002/01/29 17:12:53 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2001 -% - -% Definitions for the @IO@ monad and its friends. Everything is exported -% concretely; the @IO@ module itself exports abstractly. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} -module PrelIOBase where - -import PrelST -import PrelArr -import PrelBase -import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude -import PrelMaybe ( Maybe(..) ) -import PrelShow -import PrelList -import PrelRead -import PrelDynamic - --- --------------------------------------------------------------------------- --- The IO Monad - -{- -The IO Monad is just an instance of the ST monad, where the state is -the real world. We use the exception mechanism (in PrelException) to -implement IO exceptions. - -NOTE: The IO representation is deeply wired in to various parts of the -system. The following list may or may not be exhaustive: - -Compiler - types of various primitives in PrimOp.lhs - -RTS - forceIO (StgMiscClosures.hc) - - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast - (Exceptions.hc) - - raiseAsync (Schedule.c) - -Prelude - PrelIOBase.lhs, and several other places including - PrelException.lhs. - -Libraries - parts of hslibs/lang. - ---SDM --} - -newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) - -unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) -unIO (IO a) = a - -instance Functor IO where - fmap f x = x >>= (return . f) - -instance Monad IO where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - m >> k = m >>= \ _ -> k - return x = returnIO x - - m >>= k = bindIO m k - fail s = failIO s - -failIO :: String -> IO a -failIO s = ioError (userError s) - -liftIO :: IO a -> State# RealWorld -> STret RealWorld a -liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r - -bindIO :: IO a -> (a -> IO b) -> IO b -bindIO (IO m) k = IO ( \ s -> - case m s of - (# new_s, a #) -> unIO (k a) new_s - ) - -returnIO :: a -> IO a -returnIO x = IO (\ s -> (# s, x #)) - --- --------------------------------------------------------------------------- --- Coercions between IO and ST - ---stToIO :: (forall s. ST s a) -> IO a -stToIO :: ST RealWorld a -> IO a -stToIO (ST m) = IO m - -ioToST :: IO a -> ST RealWorld a -ioToST (IO m) = (ST m) - --- --------------------------------------------------------------------------- --- Unsafe IO operations - -{-# NOINLINE unsafePerformIO #-} -unsafePerformIO :: IO a -> a -unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r - -{-# NOINLINE unsafeInterleaveIO #-} -unsafeInterleaveIO :: IO a -> IO a -unsafeInterleaveIO (IO m) - = IO ( \ s -> let - r = case m s of (# _, res #) -> res - in - (# s, r #)) - --- --------------------------------------------------------------------------- --- Handle type - -data MVar a = MVar (MVar# RealWorld a) - --- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module -instance Eq (MVar a) where - (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2# - --- A Handle is represented by (a reference to) a record --- containing the state of the I/O port/device. We record --- the following pieces of info: - --- * type (read,write,closed etc.) --- * the underlying file descriptor --- * buffering mode --- * buffer, and spare buffers --- * user-friendly name (usually the --- FilePath used when IO.openFile was called) - --- Note: when a Handle is garbage collected, we want to flush its buffer --- and close the OS file handle, so as to free up a (precious) resource. - -data Handle - = FileHandle -- A normal handle to a file - !(MVar Handle__) - - | DuplexHandle -- A handle to a read/write stream - !(MVar Handle__) -- The read side - !(MVar Handle__) -- The write side - --- NOTES: --- * A 'FileHandle' is seekable. A 'DuplexHandle' may or may not be --- seekable. - -instance Eq Handle where - (FileHandle h1) == (FileHandle h2) = h1 == h2 - (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2 - _ == _ = False - -type FD = Int -- XXX ToDo: should be CInt - -data Handle__ - = Handle__ { - haFD :: !FD, -- file descriptor - haType :: HandleType, -- type (read/write/append etc.) - haIsBin :: Bool, -- binary mode? - haIsStream :: Bool, -- is this a stream handle? - haBufferMode :: BufferMode, -- buffer contains read/write data? - haFilePath :: FilePath, -- file name, possibly - haBuffer :: !(IORef Buffer), -- the current buffer - haBuffers :: !(IORef BufferList), -- spare buffers - haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a - -- duplex handle. - } - --- --------------------------------------------------------------------------- --- Buffers - --- The buffer is represented by a mutable variable containing a --- record, where the record contains the raw buffer and the start/end --- points of the filled portion. We use a mutable variable so that --- the common operation of writing (or reading) some data from (to) --- the buffer doesn't need to modify, and hence copy, the handle --- itself, it just updates the buffer. - --- There will be some allocation involved in a simple hPutChar in --- order to create the new Buffer structure (below), but this is --- relatively small, and this only has to be done once per write --- operation. - --- The buffer contains its size - we could also get the size by --- calling sizeOfMutableByteArray# on the raw buffer, but that tends --- to be rounded up to the nearest Word. - -type RawBuffer = MutableByteArray# RealWorld - --- INVARIANTS on a Buffer: --- --- * A handle *always* has a buffer, even if it is only 1 character long --- (an unbuffered handle needs a 1 character buffer in order to support --- hLookAhead and hIsEOF). --- * r <= w --- * if r == w, then r == 0 && w == 0 --- * if state == WriteBuffer, then r == 0 --- * a write buffer is never full. If an operation --- fills up the buffer, it will always flush it before --- returning. --- * a read buffer may be full as a result of hLookAhead. In normal --- operation, a read buffer always has at least one character of space. - -data Buffer - = Buffer { - bufBuf :: RawBuffer, - bufRPtr :: !Int, - bufWPtr :: !Int, - bufSize :: !Int, - bufState :: BufferState - } - -data BufferState = ReadBuffer | WriteBuffer deriving (Eq) - --- we keep a few spare buffers around in a handle to avoid allocating --- a new one for each hPutStr. These buffers are *guaranteed* to be the --- same size as the main buffer. -data BufferList - = BufferListNil - | BufferListCons RawBuffer BufferList - - -bufferIsWritable :: Buffer -> Bool -bufferIsWritable Buffer{ bufState=WriteBuffer } = True -bufferIsWritable _other = False - -bufferEmpty :: Buffer -> Bool -bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w - --- only makes sense for a write buffer -bufferFull :: Buffer -> Bool -bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b - --- Internally, we classify handles as being one --- of the following: - -data HandleType - = ClosedHandle - | SemiClosedHandle - | ReadHandle - | WriteHandle - | AppendHandle - | ReadWriteHandle - -isReadableHandleType ReadHandle = True -isReadableHandleType ReadWriteHandle = True -isReadableHandleType _ = False - -isWritableHandleType AppendHandle = True -isWritableHandleType WriteHandle = True -isWritableHandleType ReadWriteHandle = True -isWritableHandleType _ = False - --- File names are specified using @FilePath@, a OS-dependent --- string that (hopefully, I guess) maps to an accessible file/object. - -type FilePath = String - --- --------------------------------------------------------------------------- --- Buffering modes - --- Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. These modes have the following --- effects. For output, items are written out from the internal --- buffer according to the buffer mode: --- --- * line-buffering the entire output buffer is written --- out whenever a newline is output, the output buffer overflows, --- a flush is issued, or the handle is closed. --- --- * block-buffering the entire output buffer is written out whenever --- it overflows, a flush is issued, or the handle --- is closed. --- --- * no-buffering output is written immediately, and never stored --- in the output buffer. --- --- The output buffer is emptied as soon as it has been written out. - --- Similarly, input occurs according to the buffer mode for handle {\em hdl}. - --- * line-buffering when the input buffer for the handle is not empty, --- the next item is obtained from the buffer; --- otherwise, when the input buffer is empty, --- characters up to and including the next newline --- character are read into the buffer. No characters --- are available until the newline character is --- available. --- --- * block-buffering when the input buffer for the handle becomes empty, --- the next block of data is read into this buffer. --- --- * no-buffering the next input item is read and returned. - --- For most implementations, physical files will normally be block-buffered --- and terminals will normally be line-buffered. (the IO interface provides --- operations for changing the default buffering of a handle tho.) - -data BufferMode - = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) - deriving (Eq, Ord, Read, Show) - --- --------------------------------------------------------------------------- --- IORefs - -newtype IORef a = IORef (STRef RealWorld a) deriving Eq - -newIORef :: a -> IO (IORef a) -newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var) - -readIORef :: IORef a -> IO a -readIORef (IORef var) = stToIO (readSTRef var) - -writeIORef :: IORef a -> a -> IO () -writeIORef (IORef var) v = stToIO (writeSTRef var v) - -modifyIORef :: IORef a -> (a -> a) -> IO () -modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x) - --- deprecated, use modifyIORef -updateIORef :: IORef a -> (a -> a) -> IO () -updateIORef = modifyIORef - --- --------------------------------------------------------------------------- --- Show instance for Handles - --- handle types are 'show'n when printing error msgs, so --- we provide a more user-friendly Show instance for it --- than the derived one. - -instance Show HandleType where - showsPrec p t = - case t of - ClosedHandle -> showString "closed" - SemiClosedHandle -> showString "semi-closed" - ReadHandle -> showString "readable" - WriteHandle -> showString "writable" - AppendHandle -> showString "writable (append)" - ReadWriteHandle -> showString "read-writable" - -instance Show Handle where - showsPrec p (FileHandle h) = showHandle p h False - showsPrec p (DuplexHandle _ h) = showHandle p h True - -showHandle p h duplex = - let - -- (Big) SIGH: unfolded defn of takeMVar to avoid - -- an (oh-so) unfortunate module loop with PrelConc. - hdl_ = unsafePerformIO (IO $ \ s# -> - case h of { MVar h# -> - case takeMVar# h# s# of { (# s2# , r #) -> - case putMVar# h# r s2# of { s3# -> - (# s3#, r #) }}}) - - showType | duplex = showString "duplex (read-write)" - | otherwise = showsPrec p (haType hdl_) - in - showChar '{' . - showHdl (haType hdl_) - (showString "loc=" . showString (haFilePath hdl_) . showChar ',' . - showString "type=" . showType . showChar ',' . - showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' . - showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" ) - where - - showHdl :: HandleType -> ShowS -> ShowS - showHdl ht cont = - case ht of - ClosedHandle -> showsPrec p ht . showString "}" - _ -> cont - - showBufMode :: Buffer -> BufferMode -> ShowS - showBufMode buf bmo = - case bmo of - NoBuffering -> showString "none" - LineBuffering -> showString "line" - BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n) - BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def) - where - def :: Int - def = bufSize buf - --- ------------------------------------------------------------------------ --- Exception datatype and operations - -data Exception - = IOException IOException -- IO exceptions - | ArithException ArithException -- Arithmetic exceptions - | ArrayException ArrayException -- Array-related exceptions - | ErrorCall String -- Calls to 'error' - | ExitException ExitCode -- Call to System.exitWith - | NoMethodError String -- A non-existent method was invoked - | PatternMatchFail String -- A pattern match / guard failure - | RecSelError String -- Selecting a non-existent field - | RecConError String -- Field missing in record construction - | RecUpdError String -- Record doesn't contain updated field - | AssertionFailed String -- Assertions - | DynException Dynamic -- Dynamic exceptions - | AsyncException AsyncException -- Externally generated errors - | BlockedOnDeadMVar -- Blocking on a dead MVar - | NonTermination -- Cyclic data dependency or other loop - | Deadlock -- no threads can run (raised in main thread) - | UserError String - -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - deriving (Eq, Ord) - -data AsyncException - = StackOverflow - | HeapOverflow - | ThreadKilled - deriving (Eq, Ord) - -data ArrayException - = IndexOutOfBounds String -- out-of-range array access - | UndefinedElement String -- evaluating an undefined element - deriving (Eq, Ord) - -stackOverflow, heapOverflow :: Exception -- for the RTS -stackOverflow = AsyncException StackOverflow -heapOverflow = AsyncException HeapOverflow - -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - -instance Show AsyncException where - showsPrec _ StackOverflow = showString "stack overflow" - showsPrec _ HeapOverflow = showString "heap overflow" - showsPrec _ ThreadKilled = showString "thread killed" - -instance Show ArrayException where - showsPrec _ (IndexOutOfBounds s) - = showString "array index out of range" - . (if not (null s) then showString ": " . showString s - else id) - showsPrec _ (UndefinedElement s) - = showString "undefined array element" - . (if not (null s) then showString ": " . showString s - else id) - -instance Show Exception where - showsPrec _ (IOException err) = shows err - showsPrec _ (ArithException err) = shows err - showsPrec _ (ArrayException err) = shows err - showsPrec _ (ErrorCall err) = showString err - showsPrec _ (ExitException err) = showString "exit: " . shows err - showsPrec _ (NoMethodError err) = showString err - showsPrec _ (PatternMatchFail err) = showString err - showsPrec _ (RecSelError err) = showString err - showsPrec _ (RecConError err) = showString err - showsPrec _ (RecUpdError err) = showString err - showsPrec _ (AssertionFailed err) = showString err - showsPrec _ (DynException _err) = showString "unknown exception" - showsPrec _ (AsyncException e) = shows e - showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely" - showsPrec _ (NonTermination) = showString "<>" - showsPrec _ (Deadlock) = showString "<>" - showsPrec _ (UserError err) = showString err - -instance Eq Exception where - IOException e1 == IOException e2 = e1 == e2 - ArithException e1 == ArithException e2 = e1 == e2 - ArrayException e1 == ArrayException e2 = e1 == e2 - ErrorCall e1 == ErrorCall e2 = e1 == e2 - ExitException e1 == ExitException e2 = e1 == e2 - NoMethodError e1 == NoMethodError e2 = e1 == e2 - PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2 - RecSelError e1 == RecSelError e2 = e1 == e2 - RecConError e1 == RecConError e2 = e1 == e2 - RecUpdError e1 == RecUpdError e2 = e1 == e2 - AssertionFailed e1 == AssertionFailed e2 = e1 == e2 - DynException _ == DynException _ = False -- incomparable - AsyncException e1 == AsyncException e2 = e1 == e2 - BlockedOnDeadMVar == BlockedOnDeadMVar = True - NonTermination == NonTermination = True - Deadlock == Deadlock = True - UserError e1 == UserError e2 = e1 == e2 - --- ----------------------------------------------------------------------------- --- The ExitCode type - --- The `ExitCode' type defines the exit codes that a program --- can return. `ExitSuccess' indicates successful termination; --- and `ExitFailure code' indicates program failure --- with value `code'. The exact interpretation of `code' --- is operating-system dependent. In particular, some values of --- `code' may be prohibited (e.g. 0 on a POSIX-compliant system). - --- We need it here because it is used in ExitException in the --- Exception datatype (above). - -data ExitCode = ExitSuccess | ExitFailure Int - deriving (Eq, Ord, Read, Show) - --- -------------------------------------------------------------------------- --- Primitive throw - -throw :: Exception -> a -throw exception = raise# exception - -ioError :: Exception -> IO a -ioError err = IO $ \s -> throw err s - -ioException :: IOException -> IO a -ioException err = IO $ \s -> throw (IOException err) s - --- --------------------------------------------------------------------------- --- IOError type - --- A value @IOError@ encode errors occurred in the @IO@ monad. --- An @IOError@ records a more specific error type, a descriptive --- string and maybe the handle that was used when the error was --- flagged. - -type IOError = Exception - -data IOException - = IOError - (Maybe Handle) -- the handle used by the action flagging the - -- the error. - IOErrorType -- what it was. - String -- location. - String -- error type specific information. - (Maybe FilePath) -- filename the error is related to. - -instance Eq IOException where - (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = - e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2 - -data IOErrorType - = AlreadyExists | HardwareFault - | IllegalOperation | InappropriateType - | Interrupted | InvalidArgument - | NoSuchThing | OtherError - | PermissionDenied | ProtocolError - | ResourceBusy | ResourceExhausted - | ResourceVanished | SystemError - | TimeExpired | UnsatisfiedConstraints - | UnsupportedOperation - | EOF - | DynIOError Dynamic -- cheap&cheerful extensible IO error type. - -instance Eq IOErrorType where - x == y = - case x of - DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst? - _ -> getTag# x ==# getTag# y - -instance Show IOErrorType where - showsPrec _ e = - showString $ - case e of - AlreadyExists -> "already exists" - HardwareFault -> "hardware fault" - IllegalOperation -> "illegal operation" - InappropriateType -> "inappropriate type" - Interrupted -> "interrupted" - InvalidArgument -> "invalid argument" - NoSuchThing -> "does not exist" - OtherError -> "failed" - PermissionDenied -> "permission denied" - ProtocolError -> "protocol error" - ResourceBusy -> "resource busy" - ResourceExhausted -> "resource exhausted" - ResourceVanished -> "resource vanished" - SystemError -> "system error" - TimeExpired -> "timeout" - UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise! - UnsupportedOperation -> "unsupported operation" - EOF -> "end of file" - DynIOError{} -> "unknown IO error" - -userError :: String -> IOError -userError str = UserError str - --- --------------------------------------------------------------------------- --- Predicates on IOError - -isAlreadyExistsError :: IOError -> Bool -isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True -isAlreadyExistsError _ = False - -isAlreadyInUseError :: IOError -> Bool -isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True -isAlreadyInUseError _ = False - -isFullError :: IOError -> Bool -isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True -isFullError _ = False - -isEOFError :: IOError -> Bool -isEOFError (IOException (IOError _ EOF _ _ _)) = True -isEOFError _ = False - -isIllegalOperation :: IOError -> Bool -isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True -isIllegalOperation _ = False - -isPermissionError :: IOError -> Bool -isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True -isPermissionError _ = False - -isDoesNotExistError :: IOError -> Bool -isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True -isDoesNotExistError _ = False - -isUserError :: IOError -> Bool -isUserError (UserError _) = True -isUserError _ = False - --- --------------------------------------------------------------------------- --- Showing IOErrors - -instance Show IOException where - showsPrec p (IOError hdl iot loc s fn) = - showsPrec p iot . - (case loc of - "" -> id - _ -> showString "\nAction: " . showString loc) . - (case hdl of - Nothing -> id - Just h -> showString "\nHandle: " . showsPrec p h) . - (case s of - "" -> id - _ -> showString "\nReason: " . showString s) . - (case fn of - Nothing -> id - Just name -> showString "\nFile: " . showString name) -\end{code} diff --git a/ghc/lib/std/PrelInt.lhs b/ghc/lib/std/PrelInt.lhs deleted file mode 100644 index 83f1c63..0000000 --- a/ghc/lib/std/PrelInt.lhs +++ /dev/null @@ -1,783 +0,0 @@ -% -% (c) The University of Glasgow, 1997-2001 -% -\section[PrelInt]{Module @PrelInt@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "MachDeps.h" - -module PrelInt ( - Int8(..), Int16(..), Int32(..), Int64(..)) - where - -import PrelBase -import PrelEnum -import PrelNum -import PrelReal -import PrelRead -import PrelArr -import PrelBits -import PrelWord -import PrelShow - ------------------------------------------------------------------------- --- type Int8 ------------------------------------------------------------------------- - --- Int8 is represented in the same way as Int. Operations may assume --- and must ensure that it holds only values from its logical range. - -data Int8 = I8# Int# deriving (Eq, Ord) - -instance CCallable Int8 -instance CReturnable Int8 - -instance Show Int8 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Int8 where - (I8# x#) + (I8# y#) = I8# (narrow8Int# (x# +# y#)) - (I8# x#) - (I8# y#) = I8# (narrow8Int# (x# -# y#)) - (I8# x#) * (I8# y#) = I8# (narrow8Int# (x# *# y#)) - negate (I8# x#) = I8# (narrow8Int# (negateInt# x#)) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I8# (narrow8Int# i#) - fromInteger (J# s# d#) = I8# (narrow8Int# (integer2Int# s# d#)) - -instance Real Int8 where - toRational x = toInteger x % 1 - -instance Enum Int8 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int8" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int8" - toEnum i@(I# i#) - | i >= fromIntegral (minBound::Int8) && i <= fromIntegral (maxBound::Int8) - = I8# i# - | otherwise = toEnumError "Int8" i (minBound::Int8, maxBound::Int8) - fromEnum (I8# x#) = I# x# - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Int8 where - quot x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (narrow8Int# (x# `quotInt#` y#)) - | otherwise = divZeroError "quot{Int8}" x - rem x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (narrow8Int# (x# `remInt#` y#)) - | otherwise = divZeroError "rem{Int8}" x - div x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (narrow8Int# (x# `divInt#` y#)) - | otherwise = divZeroError "div{Int8}" x - mod x@(I8# x#) y@(I8# y#) - | y /= 0 = I8# (narrow8Int# (x# `modInt#` y#)) - | otherwise = divZeroError "mod{Int8}" x - quotRem x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (narrow8Int# (x# `quotInt#` y#)), - I8# (narrow8Int# (x# `remInt#` y#))) - | otherwise = divZeroError "quotRem{Int8}" x - divMod x@(I8# x#) y@(I8# y#) - | y /= 0 = (I8# (narrow8Int# (x# `divInt#` y#)), - I8# (narrow8Int# (x# `modInt#` y#))) - | otherwise = divZeroError "divMod{Int8}" x - toInteger (I8# x#) = S# x# - -instance Bounded Int8 where - minBound = -0x80 - maxBound = 0x7F - -instance Ix Int8 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Int8 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Int8 where - (I8# x#) .&. (I8# y#) = I8# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I8# x#) .|. (I8# y#) = I8# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I8# x#) `xor` (I8# y#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I8# x#) = I8# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - (I8# x#) `shift` (I# i#) - | i# ==# 0# = I8# x# - | i# >=# 8# = I8# 0# - | i# ># 0# = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#)) - | i# <=# -8# = I8# (if x# <# 0# then -1# else 0#) - | otherwise = I8# (x# `uncheckedIShiftRA#` negateInt# i#) - (I8# x#) `rotate` (I# i#) - | i'# ==# 0# - = I8# x# - | otherwise - = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` - (x'# `uncheckedShiftRL#` (8# -# i'#))))) - where - x'# = narrow8Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) - bitSize _ = 8 - isSigned _ = True - -{-# RULES -"fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8 -"fromIntegral/a->Int8" fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (narrow8Int# x#) -"fromIntegral/Int8->a" fromIntegral = \(I8# x#) -> fromIntegral (I# x#) - #-} - ------------------------------------------------------------------------- --- type Int16 ------------------------------------------------------------------------- - --- Int16 is represented in the same way as Int. Operations may assume --- and must ensure that it holds only values from its logical range. - -data Int16 = I16# Int# deriving (Eq, Ord) - -instance CCallable Int16 -instance CReturnable Int16 - -instance Show Int16 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Int16 where - (I16# x#) + (I16# y#) = I16# (narrow16Int# (x# +# y#)) - (I16# x#) - (I16# y#) = I16# (narrow16Int# (x# -# y#)) - (I16# x#) * (I16# y#) = I16# (narrow16Int# (x# *# y#)) - negate (I16# x#) = I16# (narrow16Int# (negateInt# x#)) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I16# (narrow16Int# i#) - fromInteger (J# s# d#) = I16# (narrow16Int# (integer2Int# s# d#)) - -instance Real Int16 where - toRational x = toInteger x % 1 - -instance Enum Int16 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int16" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int16" - toEnum i@(I# i#) - | i >= fromIntegral (minBound::Int16) && i <= fromIntegral (maxBound::Int16) - = I16# i# - | otherwise = toEnumError "Int16" i (minBound::Int16, maxBound::Int16) - fromEnum (I16# x#) = I# x# - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Int16 where - quot x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (narrow16Int# (x# `quotInt#` y#)) - | otherwise = divZeroError "quot{Int16}" x - rem x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (narrow16Int# (x# `remInt#` y#)) - | otherwise = divZeroError "rem{Int16}" x - div x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (narrow16Int# (x# `divInt#` y#)) - | otherwise = divZeroError "div{Int16}" x - mod x@(I16# x#) y@(I16# y#) - | y /= 0 = I16# (narrow16Int# (x# `modInt#` y#)) - | otherwise = divZeroError "mod{Int16}" x - quotRem x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (narrow16Int# (x# `quotInt#` y#)), - I16# (narrow16Int# (x# `remInt#` y#))) - | otherwise = divZeroError "quotRem{Int16}" x - divMod x@(I16# x#) y@(I16# y#) - | y /= 0 = (I16# (narrow16Int# (x# `divInt#` y#)), - I16# (narrow16Int# (x# `modInt#` y#))) - | otherwise = divZeroError "divMod{Int16}" x - toInteger (I16# x#) = S# x# - -instance Bounded Int16 where - minBound = -0x8000 - maxBound = 0x7FFF - -instance Ix Int16 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Int16 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Int16 where - (I16# x#) .&. (I16# y#) = I16# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I16# x#) .|. (I16# y#) = I16# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I16# x#) `xor` (I16# y#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I16# x#) = I16# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - (I16# x#) `shift` (I# i#) - | i# ==# 0# = I16# x# - | i# >=# 16# = I16# 0# - | i# ># 0# = I16# (narrow16Int# (x# `uncheckedIShiftL#` i#)) - | i# <=# -16# = I16# (if x# <# 0# then -1# else 0#) - | otherwise = I16# (x# `uncheckedIShiftRA#` negateInt# i#) - (I16# x#) `rotate` (I# i#) - | i'# ==# 0# - = I16# x# - | otherwise - = I16# (narrow16Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` - (x'# `uncheckedShiftRL#` (16# -# i'#))))) - where - x'# = narrow16Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) - bitSize _ = 16 - isSigned _ = True - -{-# RULES -"fromIntegral/Word8->Int16" fromIntegral = \(W8# x#) -> I16# (word2Int# x#) -"fromIntegral/Int8->Int16" fromIntegral = \(I8# x#) -> I16# x# -"fromIntegral/Int16->Int16" fromIntegral = id :: Int16 -> Int16 -"fromIntegral/a->Int16" fromIntegral = \x -> case fromIntegral x of I# x# -> I16# (narrow16Int# x#) -"fromIntegral/Int16->a" fromIntegral = \(I16# x#) -> fromIntegral (I# x#) - #-} - ------------------------------------------------------------------------- --- type Int32 ------------------------------------------------------------------------- - -#if WORD_SIZE_IN_BITS < 32 - -data Int32 = I32# Int32# - -instance Eq Int32 where - (I32# x#) == (I32# y#) = x# `eqInt32#` y# - (I32# x#) /= (I32# y#) = x# `neInt32#` y# - -instance Ord Int32 where - (I32# x#) < (I32# y#) = x# `ltInt32#` y# - (I32# x#) <= (I32# y#) = x# `leInt32#` y# - (I32# x#) > (I32# y#) = x# `gtInt32#` y# - (I32# x#) >= (I32# y#) = x# `geInt32#` y# - -instance Show Int32 where - showsPrec p x = showsPrec p (toInteger x) - -instance Num Int32 where - (I32# x#) + (I32# y#) = I32# (x# `plusInt32#` y#) - (I32# x#) - (I32# y#) = I32# (x# `minusInt32#` y#) - (I32# x#) * (I32# y#) = I32# (x# `timesInt32#` y#) - negate (I32# x#) = I32# (negateInt32# x#) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I32# (intToInt32# i#) - fromInteger (J# s# d#) = I32# (integerToInt32# s# d#) - -instance Enum Int32 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int32" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int32" - toEnum (I# i#) = I32# (intToInt32# i#) - fromEnum x@(I32# x#) - | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) - = I# (int32ToInt# x#) - | otherwise = fromEnumError "Int32" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Int32 where - quot x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (x# `quotInt32#` y#) - | otherwise = divZeroError "quot{Int32}" x - rem x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (x# `remInt32#` y#) - | otherwise = divZeroError "rem{Int32}" x - div x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (x# `divInt32#` y#) - | otherwise = divZeroError "div{Int32}" x - mod x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (x# `modInt32#` y#) - | otherwise = divZeroError "mod{Int32}" x - quotRem x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (x# `quotInt32#` y#), I32# (x# `remInt32#` y#)) - | otherwise = divZeroError "quotRem{Int32}" x - divMod x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (x# `divInt32#` y#), I32# (x# `modInt32#` y#)) - | otherwise = divZeroError "divMod{Int32}" x - toInteger x@(I32# x#) - | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) - = S# (int32ToInt# x#) - | otherwise = case int32ToInteger# x# of (# s, d #) -> J# s d - -divInt32#, modInt32# :: Int32# -> Int32# -> Int32# -x# `divInt32#` y# - | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) - = ((x# `minusInt32#` y#) `minusInt32#` intToInt32# 1#) `quotInt32#` y# - | (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) - = ((x# `minusInt32#` y#) `plusInt32#` intToInt32# 1#) `quotInt32#` y# - | otherwise = x# `quotInt32#` y# -x# `modInt32#` y# - | (x# `gtInt32#` intToInt32# 0#) && (y# `ltInt32#` intToInt32# 0#) || - (x# `ltInt32#` intToInt32# 0#) && (y# `gtInt32#` intToInt32# 0#) - = if r# `neInt32#` intToInt32# 0# then r# `plusInt32#` y# else intToInt32# 0# - | otherwise = r# - where - r# = x# `remInt32#` y# - -instance Read Int32 where - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] - -instance Bits Int32 where - (I32# x#) .&. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `and32#` int32ToWord32# y#)) - (I32# x#) .|. (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `or32#` int32ToWord32# y#)) - (I32# x#) `xor` (I32# y#) = I32# (word32ToInt32# (int32ToWord32# x# `xor32#` int32ToWord32# y#)) - complement (I32# x#) = I32# (word32ToInt32# (not32# (int32ToWord32# x#))) - (I32# x#) `shift` (I# i#) - | i# ==# 0# = I32# x# - | i# >=# 32# = I32# 0# - | i# ># 0# = I32# (x# `uncheckedIShiftL32#` i#) - | i# <=# -32# = I32# (if x# <# 0# then -1# else 0#) - | otherwise = I32# (x# `uncheckedIShiftRA32#` negateInt# i#) - (I32# x#) `rotate` (I# i#) - | i'# ==# 0# - = I32# x# - | otherwise - = I32# (word32ToInt32# ((x'# `uncheckedShiftL32#` i'#) `or32#` - (x'# `uncheckedShiftRL32#` (32# -# i'#)))) - where - x'# = int32ToWord32# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) - bitSize _ = 32 - isSigned _ = True - -foreign import "stg_eqInt32" unsafe eqInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_neInt32" unsafe neInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_ltInt32" unsafe ltInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_leInt32" unsafe leInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_gtInt32" unsafe gtInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_geInt32" unsafe geInt32# :: Int32# -> Int32# -> Bool -foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# -foreign import "stg_quotInt32" unsafe quotInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_remInt32" unsafe remInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# -foreign import "stg_int32ToInt" unsafe int32ToInt# :: Int32# -> Int# -foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# -foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# -foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# -foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# -foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# -foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# -foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# -foreign import "stg_uncheckedIShiftL32" unsafe uncheckedIShiftL32# :: Int32# -> Int# -> Int32# -foreign import "stg_uncheckedIShiftRA32" unsafe uncheckedIShiftRA32# :: Int32# -> Int# -> Int32# -foreign import "stg_uncheckedShiftL32" unsafe uncheckedShiftL32# :: Word32# -> Int# -> Word32# -foreign import "stg_uncheckedShiftRL32" unsafe uncheckedShiftRL32# :: Word32# -> Int# -> Word32# - -{-# RULES -"fromIntegral/Int->Int32" fromIntegral = \(I# x#) -> I32# (intToInt32# x#) -"fromIntegral/Word->Int32" fromIntegral = \(W# x#) -> I32# (word32ToInt32# (wordToWord32# x#)) -"fromIntegral/Word32->Int32" fromIntegral = \(W32# x#) -> I32# (word32ToInt32# x#) -"fromIntegral/Int32->Int" fromIntegral = \(I32# x#) -> I# (int32ToInt# x#) -"fromIntegral/Int32->Word" fromIntegral = \(I32# x#) -> W# (int2Word# (int32ToInt# x#)) -"fromIntegral/Int32->Word32" fromIntegral = \(I32# x#) -> W32# (int32ToWord32# x#) -"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 - #-} - -#else - --- Int32 is represented in the same way as Int. -#if WORD_SIZE_IN_BITS > 32 --- Operations may assume and must ensure that it holds only values --- from its logical range. -#endif - -data Int32 = I32# Int# deriving (Eq, Ord) - -instance Show Int32 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Int32 where - (I32# x#) + (I32# y#) = I32# (narrow32Int# (x# +# y#)) - (I32# x#) - (I32# y#) = I32# (narrow32Int# (x# -# y#)) - (I32# x#) * (I32# y#) = I32# (narrow32Int# (x# *# y#)) - negate (I32# x#) = I32# (narrow32Int# (negateInt# x#)) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I32# (narrow32Int# i#) - fromInteger (J# s# d#) = I32# (narrow32Int# (integer2Int# s# d#)) - -instance Enum Int32 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int32" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int32" -#if WORD_SIZE_IN_BITS == 32 - toEnum (I# i#) = I32# i# -#else - toEnum i@(I# i#) - | i >= fromIntegral (minBound::Int32) && i <= fromIntegral (maxBound::Int32) - = I32# i# - | otherwise = toEnumError "Int32" i (minBound::Int32, maxBound::Int32) -#endif - fromEnum (I32# x#) = I# x# - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Int32 where - quot x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (narrow32Int# (x# `quotInt#` y#)) - | otherwise = divZeroError "quot{Int32}" x - rem x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (narrow32Int# (x# `remInt#` y#)) - | otherwise = divZeroError "rem{Int32}" x - div x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (narrow32Int# (x# `divInt#` y#)) - | otherwise = divZeroError "div{Int32}" x - mod x@(I32# x#) y@(I32# y#) - | y /= 0 = I32# (narrow32Int# (x# `modInt#` y#)) - | otherwise = divZeroError "mod{Int32}" x - quotRem x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (narrow32Int# (x# `quotInt#` y#)), - I32# (narrow32Int# (x# `remInt#` y#))) - | otherwise = divZeroError "quotRem{Int32}" x - divMod x@(I32# x#) y@(I32# y#) - | y /= 0 = (I32# (narrow32Int# (x# `divInt#` y#)), - I32# (narrow32Int# (x# `modInt#` y#))) - | otherwise = divZeroError "divMod{Int32}" x - toInteger (I32# x#) = S# x# - -instance Read Int32 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Int32 where - (I32# x#) .&. (I32# y#) = I32# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I32# x#) .|. (I32# y#) = I32# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I32# x#) `xor` (I32# y#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I32# x#) = I32# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - (I32# x#) `shift` (I# i#) - | i# ==# 0# = I32# x# - | i# >=# 32# = I32# 0# - | i# ># 0# = I32# (narrow32Int# (x# `uncheckedIShiftL#` i#)) - | i# <=# -32# = I32# (if x# <# 0# then -1# else 0#) - | otherwise = I32# (x# `uncheckedIShiftRA#` negateInt# i#) - (I32# x#) `rotate` (I# i#) - | i'# ==# 0# - = I32# x# - | otherwise - = I32# (narrow32Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` - (x'# `uncheckedShiftRL#` (32# -# i'#))))) - where - x'# = narrow32Word# (int2Word# x#) - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) - bitSize _ = 32 - isSigned _ = True - -{-# RULES -"fromIntegral/Word8->Int32" fromIntegral = \(W8# x#) -> I32# (word2Int# x#) -"fromIntegral/Word16->Int32" fromIntegral = \(W16# x#) -> I32# (word2Int# x#) -"fromIntegral/Int8->Int32" fromIntegral = \(I8# x#) -> I32# x# -"fromIntegral/Int16->Int32" fromIntegral = \(I16# x#) -> I32# x# -"fromIntegral/Int32->Int32" fromIntegral = id :: Int32 -> Int32 -"fromIntegral/a->Int32" fromIntegral = \x -> case fromIntegral x of I# x# -> I32# (narrow32Int# x#) -"fromIntegral/Int32->a" fromIntegral = \(I32# x#) -> fromIntegral (I# x#) - #-} - -#endif - -instance CCallable Int32 -instance CReturnable Int32 - -instance Real Int32 where - toRational x = toInteger x % 1 - -instance Bounded Int32 where - minBound = -0x80000000 - maxBound = 0x7FFFFFFF - -instance Ix Int32 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - ------------------------------------------------------------------------- --- type Int64 ------------------------------------------------------------------------- - -#if WORD_SIZE_IN_BITS < 64 - -data Int64 = I64# Int64# - -instance Eq Int64 where - (I64# x#) == (I64# y#) = x# `eqInt64#` y# - (I64# x#) /= (I64# y#) = x# `neInt64#` y# - -instance Ord Int64 where - (I64# x#) < (I64# y#) = x# `ltInt64#` y# - (I64# x#) <= (I64# y#) = x# `leInt64#` y# - (I64# x#) > (I64# y#) = x# `gtInt64#` y# - (I64# x#) >= (I64# y#) = x# `geInt64#` y# - -instance Show Int64 where - showsPrec p x = showsPrec p (toInteger x) - -instance Num Int64 where - (I64# x#) + (I64# y#) = I64# (x# `plusInt64#` y#) - (I64# x#) - (I64# y#) = I64# (x# `minusInt64#` y#) - (I64# x#) * (I64# y#) = I64# (x# `timesInt64#` y#) - negate (I64# x#) = I64# (negateInt64# x#) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I64# (intToInt64# i#) - fromInteger (J# s# d#) = I64# (integerToInt64# s# d#) - -instance Enum Int64 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int64" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int64" - toEnum (I# i#) = I64# (intToInt64# i#) - fromEnum x@(I64# x#) - | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) - = I# (int64ToInt# x#) - | otherwise = fromEnumError "Int64" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Int64 where - quot x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `quotInt64#` y#) - | otherwise = divZeroError "quot{Int64}" x - rem x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `remInt64#` y#) - | otherwise = divZeroError "rem{Int64}" x - div x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `divInt64#` y#) - | otherwise = divZeroError "div{Int64}" x - mod x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `modInt64#` y#) - | otherwise = divZeroError "mod{Int64}" x - quotRem x@(I64# x#) y@(I64# y#) - | y /= 0 = (I64# (x# `quotInt64#` y#), I64# (x# `remInt64#` y#)) - | otherwise = divZeroError "quotRem{Int64}" x - divMod x@(I64# x#) y@(I64# y#) - | y /= 0 = (I64# (x# `divInt64#` y#), I64# (x# `modInt64#` y#)) - | otherwise = divZeroError "divMod{Int64}" x - toInteger x@(I64# x#) - | x >= fromIntegral (minBound::Int) && x <= fromIntegral (maxBound::Int) - = S# (int64ToInt# x#) - | otherwise = case int64ToInteger# x# of (# s, d #) -> J# s d - - -divInt64#, modInt64# :: Int64# -> Int64# -> Int64# -x# `divInt64#` y# - | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) - = ((x# `minusInt64#` y#) `minusInt64#` intToInt64# 1#) `quotInt64#` y# - | (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#) - = ((x# `minusInt64#` y#) `plusInt64#` intToInt64# 1#) `quotInt64#` y# - | otherwise = x# `quotInt64#` y# -x# `modInt64#` y# - | (x# `gtInt64#` intToInt64# 0#) && (y# `ltInt64#` intToInt64# 0#) || - (x# `ltInt64#` intToInt64# 0#) && (y# `gtInt64#` intToInt64# 0#) - = if r# `neInt64#` intToInt64# 0# then r# `plusInt64#` y# else intToInt64# 0# - | otherwise = r# - where - r# = x# `remInt64#` y# - -instance Read Int64 where - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] - -instance Bits Int64 where - (I64# x#) .&. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `and64#` int64ToWord64# y#)) - (I64# x#) .|. (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `or64#` int64ToWord64# y#)) - (I64# x#) `xor` (I64# y#) = I64# (word64ToInt64# (int64ToWord64# x# `xor64#` int64ToWord64# y#)) - complement (I64# x#) = I64# (word64ToInt64# (not64# (int64ToWord64# x#))) - (I64# x#) `shift` (I# i#) - | i# ==# 0# = I64# x# - | i# >=# 64# = 0 - | i# ># 0# = I64# (x# `uncheckedIShiftL64#` i#) - | i# <=# -64# = if (I64# x#) < 0 then -1 else 0 - | otherwise = I64# (x# `uncheckedIShiftRA64#` negateInt# i#) - (I64# x#) `rotate` (I# i#) - | i'# ==# 0# - = I64# x# - | otherwise - = I64# (word64ToInt64# ((x'# `uncheckedShiftL64#` i'#) `or64#` - (x'# `uncheckedShiftRL64#` (64# -# i'#)))) - where - x'# = int64ToWord64# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) - bitSize _ = 64 - isSigned _ = True - -foreign import "stg_eqInt64" unsafe eqInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_neInt64" unsafe neInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_ltInt64" unsafe ltInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_leInt64" unsafe leInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_gtInt64" unsafe gtInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_geInt64" unsafe geInt64# :: Int64# -> Int64# -> Bool -foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# -foreign import "stg_quotInt64" unsafe quotInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_remInt64" unsafe remInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# -foreign import "stg_int64ToInt" unsafe int64ToInt# :: Int64# -> Int# -foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# -foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64# -foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64# -foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# -foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# -foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# -foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# -foreign import "stg_uncheckedIShiftL64" unsafe uncheckedIShiftL64# :: Int64# -> Int# -> Int64# -foreign import "stg_uncheckedIShiftRA64" unsafe uncheckedIShiftRA64# :: Int64# -> Int# -> Int64# -foreign import "stg_uncheckedShiftL64" unsafe uncheckedShiftL64# :: Word64# -> Int# -> Word64# -foreign import "stg_uncheckedShiftRL64" unsafe uncheckedShiftRL64# :: Word64# -> Int# -> Word64# - -foreign import "stg_integerToInt64" unsafe integerToInt64# :: Int# -> ByteArray# -> Int64# - -{-# RULES -"fromIntegral/Int->Int64" fromIntegral = \(I# x#) -> I64# (intToInt64# x#) -"fromIntegral/Word->Int64" fromIntegral = \(W# x#) -> I64# (word64ToInt64# (wordToWord64# x#)) -"fromIntegral/Word64->Int64" fromIntegral = \(W64# x#) -> I64# (word64ToInt64# x#) -"fromIntegral/Int64->Int" fromIntegral = \(I64# x#) -> I# (int64ToInt# x#) -"fromIntegral/Int64->Word" fromIntegral = \(I64# x#) -> W# (int2Word# (int64ToInt# x#)) -"fromIntegral/Int64->Word64" fromIntegral = \(I64# x#) -> W64# (int64ToWord64# x#) -"fromIntegral/Int64->Int64" fromIntegral = id :: Int64 -> Int64 - #-} - -#else - --- Int64 is represented in the same way as Int. --- Operations may assume and must ensure that it holds only values --- from its logical range. - -data Int64 = I64# Int# deriving (Eq, Ord) - -instance Show Int64 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Int64 where - (I64# x#) + (I64# y#) = I64# (x# +# y#) - (I64# x#) - (I64# y#) = I64# (x# -# y#) - (I64# x#) * (I64# y#) = I64# (x# *# y#) - negate (I64# x#) = I64# (negateInt# x#) - abs x | x >= 0 = x - | otherwise = negate x - signum x | x > 0 = 1 - signum 0 = 0 - signum _ = -1 - fromInteger (S# i#) = I64# i# - fromInteger (J# s# d#) = I64# (integer2Int# s# d#) - -instance Enum Int64 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Int64" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Int64" - toEnum (I# i#) = I64# i# - fromEnum (I64# x#) = I# x# - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Int64 where - quot x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `quotInt#` y#) - | otherwise = divZeroError "quot{Int64}" x - rem x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `remInt#` y#) - | otherwise = divZeroError "rem{Int64}" x - div x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `divInt#` y#) - | otherwise = divZeroError "div{Int64}" x - mod x@(I64# x#) y@(I64# y#) - | y /= 0 = I64# (x# `modInt#` y#) - | otherwise = divZeroError "mod{Int64}" x - quotRem x@(I64# x#) y@(I64# y#) - | y /= 0 = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#)) - | otherwise = divZeroError "quotRem{Int64}" x - divMod x@(I64# x#) y@(I64# y#) - | y /= 0 = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#)) - | otherwise = divZeroError "divMod{Int64}" x - toInteger (I64# x#) = S# x# - -instance Read Int64 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Int64 where - (I64# x#) .&. (I64# y#) = I64# (word2Int# (int2Word# x# `and#` int2Word# y#)) - (I64# x#) .|. (I64# y#) = I64# (word2Int# (int2Word# x# `or#` int2Word# y#)) - (I64# x#) `xor` (I64# y#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# y#)) - complement (I64# x#) = I64# (word2Int# (int2Word# x# `xor#` int2Word# (-1#))) - (I64# x#) `shift` (I# i#) - | i# ==# 0# = I64# x# - | i# >=# 64# = 0 - | i# ># 0# = I64# (x# `uncheckedIShiftL#` i#) - | i# <=# -64# = if x# <# 0# then -1 else 0 - | otherwise = I64# (x# `uncheckedIShiftRA#` negateInt# i#) - (I64# x#) `rotate` (I# i#) - | i'# ==# 0# - = I64# x# - | otherwise - = I64# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#` - (x'# `uncheckedShiftRL#` (64# -# i'#)))) - where - x'# = int2Word# x# - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) - bitSize _ = 64 - isSigned _ = True - -{-# RULES -"fromIntegral/a->Int64" fromIntegral = \x -> case fromIntegral x of I# x# -> I64# x# -"fromIntegral/Int64->a" fromIntegral = \(I64# x#) -> fromIntegral (I# x#) - #-} - -#endif - -instance CCallable Int64 -instance CReturnable Int64 - -instance Real Int64 where - toRational x = toInteger x % 1 - -instance Bounded Int64 where - minBound = -0x8000000000000000 - maxBound = 0x7FFFFFFFFFFFFFFF - -instance Ix Int64 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 -\end{code} diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs deleted file mode 100644 index 02e0cf0..0000000 --- a/ghc/lib/std/PrelList.lhs +++ /dev/null @@ -1,597 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelList.lhs,v 1.29 2002/01/29 09:58:21 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelList]{Module @PrelList@} - -The List data type and its operations - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelList ( - [] (..), - - map, (++), filter, concat, - head, last, tail, init, null, length, (!!), - foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, - iterate, repeat, replicate, cycle, - take, drop, splitAt, takeWhile, dropWhile, span, break, - reverse, and, or, - any, all, elem, notElem, lookup, - maximum, minimum, concatMap, - zip, zip3, zipWith, zipWith3, unzip, unzip3, -#ifdef USE_REPORT_PRELUDE - -#else - - -- non-standard, but hidden when creating the Prelude - -- export list. - takeUInt_append - -#endif - - ) where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelTup -import PrelMaybe -import PrelBase - -infixl 9 !! -infix 4 `elem`, `notElem` -\end{code} - -%********************************************************* -%* * -\subsection{List-manipulation functions} -%* * -%********************************************************* - -\begin{code} --- head and tail extract the first element and remaining elements, --- respectively, of a list, which must be non-empty. last and init --- are the dual functions working from the end of a finite list, --- rather than the beginning. - -head :: [a] -> a -head (x:_) = x -head [] = badHead - -badHead = errorEmptyList "head" - --- This rule is useful in cases like --- head [y | (x,y) <- ps, x==t] -{-# RULES -"head/build" forall (g::forall b.(Bool->b->b)->b->b) . - head (build g) = g (\x _ -> x) badHead -"head/augment" forall xs (g::forall b. (a->b->b) -> b -> b) . - head (augment g xs) = g (\x _ -> x) (head xs) - #-} - -tail :: [a] -> [a] -tail (_:xs) = xs -tail [] = errorEmptyList "tail" - -last :: [a] -> a -#ifdef USE_REPORT_PRELUDE -last [x] = x -last (_:xs) = last xs -last [] = errorEmptyList "last" -#else --- eliminate repeated cases -last [] = errorEmptyList "last" -last (x:xs) = last' x xs - where last' y [] = y - last' _ (y:ys) = last' y ys -#endif - -init :: [a] -> [a] -#ifdef USE_REPORT_PRELUDE -init [x] = [] -init (x:xs) = x : init xs -init [] = errorEmptyList "init" -#else --- eliminate repeated cases -init [] = errorEmptyList "init" -init (x:xs) = init' x xs - where init' _ [] = [] - init' y (z:zs) = y : init' z zs -#endif - -null :: [a] -> Bool -null [] = True -null (_:_) = False - --- length returns the length of a finite list as an Int; it is an instance --- of the more general genericLength, the result type of which may be --- any kind of number. -length :: [a] -> Int -length l = len l 0# - where - len :: [a] -> Int# -> Int - len [] a# = I# a# - len (_:xs) a# = len xs (a# +# 1#) - --- filter, applied to a predicate and a list, returns the list of those --- elements that satisfy the predicate; i.e., --- filter p xs = [ x | x <- xs, p x] -filter :: (a -> Bool) -> [a] -> [a] -filter _pred [] = [] -filter pred (x:xs) - | pred x = x : filter pred xs - | otherwise = filter pred xs - -{-# NOINLINE [0] filterFB #-} -filterFB c p x r | p x = x `c` r - | otherwise = r - -{-# RULES -"filter" [~1] forall p xs. filter p xs = build (\c n -> foldr (filterFB c p) n xs) -"filterList" [1] forall p. foldr (filterFB (:) p) [] = filter p -"filterFB" forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x) - #-} - --- Note the filterFB rule, which has p and q the "wrong way round" in the RHS. --- filterFB (filterFB c p) q a b --- = if q a then filterFB c p a b else b --- = if q a then (if p a then c a b else b) else b --- = if q a && p a then c a b else b --- = filterFB c (\x -> q x && p x) a b --- I originally wrote (\x -> p x && q x), which is wrong, and actually --- gave rise to a live bug report. SLPJ. - - --- foldl, applied to a binary operator, a starting value (typically the --- left-identity of the operator), and a list, reduces the list using --- the binary operator, from left to right: --- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn --- foldl1 is a variant that has no starting value argument, and thus must --- be applied to non-empty lists. scanl is similar to foldl, but returns --- a list of successive reduced values from the left: --- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] --- Note that last (scanl f z xs) == foldl f z xs. --- scanl1 is similar, again without the starting element: --- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] - --- We write foldl as a non-recursive thing, so that it --- can be inlined, and then (often) strictness-analysed, --- and hence the classic space leak on foldl (+) 0 xs - -foldl :: (a -> b -> a) -> a -> [b] -> a -foldl f z xs = lgo z xs - where - lgo z [] = z - lgo z (x:xs) = lgo (f z x) xs - -foldl1 :: (a -> a -> a) -> [a] -> a -foldl1 f (x:xs) = foldl f x xs -foldl1 _ [] = errorEmptyList "foldl1" - -scanl :: (a -> b -> a) -> a -> [b] -> [a] -scanl f q ls = q : (case ls of - [] -> [] - x:xs -> scanl f (f q x) xs) - -scanl1 :: (a -> a -> a) -> [a] -> [a] -scanl1 f (x:xs) = scanl f x xs -scanl1 _ [] = [] - --- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the --- above functions. - -foldr1 :: (a -> a -> a) -> [a] -> a -foldr1 _ [x] = x -foldr1 f (x:xs) = f x (foldr1 f xs) -foldr1 _ [] = errorEmptyList "foldr1" - -scanr :: (a -> b -> b) -> b -> [a] -> [b] -scanr _ q0 [] = [q0] -scanr f q0 (x:xs) = f x q : qs - where qs@(q:_) = scanr f q0 xs - -scanr1 :: (a -> a -> a) -> [a] -> [a] -scanr1 f [] = [] -scanr1 f [x] = [x] -scanr1 f (x:xs) = f x q : qs - where qs@(q:_) = scanr1 f xs - --- iterate f x returns an infinite list of repeated applications of f to x: --- iterate f x == [x, f x, f (f x), ...] -iterate :: (a -> a) -> a -> [a] -iterate f x = x : iterate f (f x) - -iterateFB c f x = x `c` iterateFB c f (f x) - - -{-# RULES -"iterate" [~1] forall f x. iterate f x = build (\c _n -> iterateFB c f x) -"iterateFB" [1] iterateFB (:) = iterate - #-} - - --- repeat x is an infinite list, with x the value of every element. -repeat :: a -> [a] -{-# INLINE [0] repeat #-} --- The pragma just gives the rules more chance to fire -repeat x = xs where xs = x : xs - -{-# INLINE [0] repeatFB #-} -- ditto -repeatFB c x = xs where xs = x `c` xs - - -{-# RULES -"repeat" [~1] forall x. repeat x = build (\c _n -> repeatFB c x) -"repeatFB" [1] repeatFB (:) = repeat - #-} - --- replicate n x is a list of length n with x the value of every element -replicate :: Int -> a -> [a] -replicate n x = take n (repeat x) - --- cycle ties a finite list into a circular one, or equivalently, --- the infinite repetition of the original list. It is the identity --- on infinite lists. - -cycle :: [a] -> [a] -cycle [] = error "Prelude.cycle: empty list" -cycle xs = xs' where xs' = xs ++ xs' - --- takeWhile, applied to a predicate p and a list xs, returns the longest --- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs --- returns the remaining suffix. Span p xs is equivalent to --- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. - -takeWhile :: (a -> Bool) -> [a] -> [a] -takeWhile _ [] = [] -takeWhile p (x:xs) - | p x = x : takeWhile p xs - | otherwise = [] - -dropWhile :: (a -> Bool) -> [a] -> [a] -dropWhile _ [] = [] -dropWhile p xs@(x:xs') - | p x = dropWhile p xs' - | otherwise = xs - --- take n, applied to a list xs, returns the prefix of xs of length n, --- or xs itself if n > length xs. drop n xs returns the suffix of xs --- after the first n elements, or [] if n > length xs. splitAt n xs --- is equivalent to (take n xs, drop n xs). -#ifdef USE_REPORT_PRELUDE -take :: Int -> [a] -> [a] -take n _ | n <= 0 = [] -take _ [] = [] -take n (x:xs) = x : take (n-1) xs - -drop :: Int -> [a] -> [a] -drop n xs | n <= 0 = xs -drop _ [] = [] -drop n (_:xs) = drop (n-1) xs - -splitAt :: Int -> [a] -> ([a],[a]) -splitAt n xs = (take n xs, drop n xs) - -#else /* hack away */ -take :: Int -> [b] -> [b] -take (I# n#) xs = takeUInt n# xs - --- The general code for take, below, checks n <= maxInt --- No need to check for maxInt overflow when specialised --- at type Int or Int# since the Int must be <= maxInt - -takeUInt :: Int# -> [b] -> [b] -takeUInt n xs - | n >=# 0# = take_unsafe_UInt n xs - | otherwise = [] - -take_unsafe_UInt :: Int# -> [b] -> [b] -take_unsafe_UInt 0# _ = [] -take_unsafe_UInt m ls = - case ls of - [] -> [] - (x:xs) -> x : take_unsafe_UInt (m -# 1#) xs - -takeUInt_append :: Int# -> [b] -> [b] -> [b] -takeUInt_append n xs rs - | n >=# 0# = take_unsafe_UInt_append n xs rs - | otherwise = [] - -take_unsafe_UInt_append :: Int# -> [b] -> [b] -> [b] -take_unsafe_UInt_append 0# _ rs = rs -take_unsafe_UInt_append m ls rs = - case ls of - [] -> rs - (x:xs) -> x : take_unsafe_UInt_append (m -# 1#) xs rs - -drop :: Int -> [b] -> [b] -drop (I# n#) ls - | n# <# 0# = [] - | otherwise = drop# n# ls - where - drop# :: Int# -> [a] -> [a] - drop# 0# xs = xs - drop# _ xs@[] = xs - drop# m# (_:xs) = drop# (m# -# 1#) xs - -splitAt :: Int -> [b] -> ([b], [b]) -splitAt (I# n#) ls - | n# <# 0# = ([], ls) - | otherwise = splitAt# n# ls - where - splitAt# :: Int# -> [a] -> ([a], [a]) - splitAt# 0# xs = ([], xs) - splitAt# _ xs@[] = (xs, xs) - splitAt# m# (x:xs) = (x:xs', xs'') - where - (xs', xs'') = splitAt# (m# -# 1#) xs - -#endif /* USE_REPORT_PRELUDE */ - -span, break :: (a -> Bool) -> [a] -> ([a],[a]) -span _ xs@[] = (xs, xs) -span p xs@(x:xs') - | p x = let (ys,zs) = span p xs' in (x:ys,zs) - | otherwise = ([],xs) - -#ifdef USE_REPORT_PRELUDE -break p = span (not . p) -#else --- HBC version (stolen) -break _ xs@[] = (xs, xs) -break p xs@(x:xs') - | p x = ([],xs) - | otherwise = let (ys,zs) = break p xs' in (x:ys,zs) -#endif - --- reverse xs returns the elements of xs in reverse order. xs must be finite. -reverse :: [a] -> [a] -#ifdef USE_REPORT_PRELUDE -reverse = foldl (flip (:)) [] -#else -reverse l = rev l [] - where - rev [] a = a - rev (x:xs) a = rev xs (x:a) -#endif - --- and returns the conjunction of a Boolean list. For the result to be --- True, the list must be finite; False, however, results from a False --- value at a finite index of a finite or infinite list. or is the --- disjunctive dual of and. -and, or :: [Bool] -> Bool -#ifdef USE_REPORT_PRELUDE -and = foldr (&&) True -or = foldr (||) False -#else -and [] = True -and (x:xs) = x && and xs -or [] = False -or (x:xs) = x || or xs - -{-# RULES -"and/build" forall (g::forall b.(Bool->b->b)->b->b) . - and (build g) = g (&&) True -"or/build" forall (g::forall b.(Bool->b->b)->b->b) . - or (build g) = g (||) False - #-} -#endif - --- Applied to a predicate and a list, any determines if any element --- of the list satisfies the predicate. Similarly, for all. -any, all :: (a -> Bool) -> [a] -> Bool -#ifdef USE_REPORT_PRELUDE -any p = or . map p -all p = and . map p -#else -any _ [] = False -any p (x:xs) = p x || any p xs - -all _ [] = True -all p (x:xs) = p x && all p xs -{-# RULES -"any/build" forall p (g::forall b.(a->b->b)->b->b) . - any p (build g) = g ((||) . p) False -"all/build" forall p (g::forall b.(a->b->b)->b->b) . - all p (build g) = g ((&&) . p) True - #-} -#endif - --- elem is the list membership predicate, usually written in infix form, --- e.g., x `elem` xs. notElem is the negation. -elem, notElem :: (Eq a) => a -> [a] -> Bool -#ifdef USE_REPORT_PRELUDE -elem x = any (== x) -notElem x = all (/= x) -#else -elem _ [] = False -elem x (y:ys) = x==y || elem x ys - -notElem _ [] = True -notElem x (y:ys)= x /= y && notElem x ys -#endif - --- lookup key assocs looks up a key in an association list. -lookup :: (Eq a) => a -> [(a,b)] -> Maybe b -lookup _key [] = Nothing -lookup key ((x,y):xys) - | key == x = Just y - | otherwise = lookup key xys - - --- maximum and minimum return the maximum or minimum value from a list, --- which must be non-empty, finite, and of an ordered type. -{-# SPECIALISE maximum :: [Int] -> Int #-} -{-# SPECIALISE minimum :: [Int] -> Int #-} -maximum, minimum :: (Ord a) => [a] -> a -maximum [] = errorEmptyList "maximum" -maximum xs = foldl1 max xs - -minimum [] = errorEmptyList "minimum" -minimum xs = foldl1 min xs - -concatMap :: (a -> [b]) -> [a] -> [b] -concatMap f = foldr ((++) . f) [] - -concat :: [[a]] -> [a] -concat = foldr (++) [] - -{-# RULES - "concat" forall xs. concat xs = build (\c n -> foldr (\x y -> foldr c y x) n xs) --- We don't bother to turn non-fusible applications of concat back into concat - #-} - -\end{code} - - -\begin{code} --- List index (subscript) operator, 0-origin -(!!) :: [a] -> Int -> a -#ifdef USE_REPORT_PRELUDE -xs !! n | n < 0 = error "Prelude.!!: negative index" -[] !! _ = error "Prelude.!!: index too large" -(x:_) !! 0 = x -(_:xs) !! n = xs !! (n-1) -#else --- HBC version (stolen), then unboxified --- The semantics is not quite the same for error conditions --- in the more efficient version. --- -xs !! (I# n) | n <# 0# = error "Prelude.(!!): negative index\n" - | otherwise = sub xs n - where - sub :: [a] -> Int# -> a - sub [] _ = error "Prelude.(!!): index too large\n" - sub (y:ys) n = if n ==# 0# - then y - else sub ys (n -# 1#) -#endif -\end{code} - - -%********************************************************* -%* * -\subsection{The zip family} -%* * -%********************************************************* - -\begin{code} -foldr2 _k z [] _ys = z -foldr2 _k z _xs [] = z -foldr2 k z (x:xs) (y:ys) = k x y (foldr2 k z xs ys) - -foldr2_left _k z _x _r [] = z -foldr2_left k _z x r (y:ys) = k x y (r ys) - -foldr2_right _k z _y _r [] = z -foldr2_right k _z y r (x:xs) = k x y (r xs) - --- foldr2 k z xs ys = foldr (foldr2_left k z) (\_ -> z) xs ys --- foldr2 k z xs ys = foldr (foldr2_right k z) (\_ -> z) ys xs -{-# RULES -"foldr2/left" forall k z ys (g::forall b.(a->b->b)->b->b) . - foldr2 k z (build g) ys = g (foldr2_left k z) (\_ -> z) ys - -"foldr2/right" forall k z xs (g::forall b.(a->b->b)->b->b) . - foldr2 k z xs (build g) = g (foldr2_right k z) (\_ -> z) xs - #-} -\end{code} - -The foldr2/right rule isn't exactly right, because it changes -the strictness of foldr2 (and thereby zip) - -E.g. main = print (null (zip nonobviousNil (build undefined))) - where nonobviousNil = f 3 - f n = if n == 0 then [] else f (n-1) - -I'm going to leave it though. - - -zip takes two lists and returns a list of corresponding pairs. If one -input list is short, excess elements of the longer list are discarded. -zip3 takes three lists and returns a list of triples. Zips for larger -tuples are in the List module. - -\begin{code} ----------------------------------------------- -zip :: [a] -> [b] -> [(a,b)] -zip (a:as) (b:bs) = (a,b) : zip as bs -zip _ _ = [] - -{-# INLINE [0] zipFB #-} -zipFB c x y r = (x,y) `c` r - -{-# RULES -"zip" [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys) -"zipList" [1] foldr2 (zipFB (:)) [] = zip - #-} -\end{code} - -\begin{code} ----------------------------------------------- -zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] --- Specification --- zip3 = zipWith3 (,,) -zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs -zip3 _ _ _ = [] -\end{code} - - --- The zipWith family generalises the zip family by zipping with the --- function given as the first argument, instead of a tupling function. --- For example, zipWith (+) is applied to two lists to produce the list --- of corresponding sums. - - -\begin{code} ----------------------------------------------- -zipWith :: (a->b->c) -> [a]->[b]->[c] -zipWith f (a:as) (b:bs) = f a b : zipWith f as bs -zipWith _ _ _ = [] - -{-# INLINE [0] zipWithFB #-} -zipWithFB c f x y r = (x `f` y) `c` r - -{-# RULES -"zipWith" [~1] forall f xs ys. zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys) -"zipWithList" [1] forall f. foldr2 (zipWithFB (:) f) [] = zipWith f - #-} -\end{code} - -\begin{code} -zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] -zipWith3 z (a:as) (b:bs) (c:cs) - = z a b c : zipWith3 z as bs cs -zipWith3 _ _ _ _ = [] - --- unzip transforms a list of pairs into a pair of lists. -unzip :: [(a,b)] -> ([a],[b]) -{-# INLINE unzip #-} -unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) - -unzip3 :: [(a,b,c)] -> ([a],[b],[c]) -{-# INLINE unzip3 #-} -unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) - ([],[],[]) -\end{code} - - -%********************************************************* -%* * -\subsection{Error code} -%* * -%********************************************************* - -Common up near identical calls to `error' to reduce the number -constant strings created when compiled: - -\begin{code} -errorEmptyList :: String -> a -errorEmptyList fun = - error (prel_list_str ++ fun ++ ": empty list") - -prel_list_str :: String -prel_list_str = "Prelude." -\end{code} diff --git a/ghc/lib/std/PrelMarshalAlloc.lhs b/ghc/lib/std/PrelMarshalAlloc.lhs deleted file mode 100644 index 055b9a8..0000000 --- a/ghc/lib/std/PrelMarshalAlloc.lhs +++ /dev/null @@ -1,124 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelMarshalAlloc.lhs,v 1.3 2001/08/08 14:36:14 simonmar Exp $ -% -% (c) The FFI task force, 2000 -% - -Marshalling support: basic routines for memory allocation - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelMarshalAlloc ( - malloc, -- :: Storable a => IO (Ptr a) - mallocBytes, -- :: Int -> IO (Ptr a) - - alloca, -- :: Storable a => (Ptr a -> IO b) -> IO b - allocaBytes, -- :: Int -> (Ptr a -> IO b) -> IO b - - reallocBytes, -- :: Ptr a -> Int -> IO (Ptr a) - - free -- :: Ptr a -> IO () -) where - -#ifdef __GLASGOW_HASKELL__ -import PrelException ( bracket ) -import PrelPtr ( Ptr(..), nullPtr ) -import PrelStorable ( Storable(sizeOf) ) -import PrelCTypesISO ( CSize ) -import PrelIOBase -import PrelMaybe -import PrelReal -import PrelNum -import PrelErr -import PrelBase -#endif - - --- exported functions --- ------------------ - --- allocate space for storable type --- -malloc :: Storable a => IO (Ptr a) -malloc = doMalloc undefined - where - doMalloc :: Storable a => a -> IO (Ptr a) - doMalloc dummy = mallocBytes (sizeOf dummy) - --- allocate given number of bytes of storage --- -mallocBytes :: Int -> IO (Ptr a) -mallocBytes size = failWhenNULL "malloc" (_malloc (fromIntegral size)) - --- temporarily allocate space for a storable type --- --- * the pointer passed as an argument to the function must *not* escape from --- this function; in other words, in `alloca f' the allocated storage must --- not be used after `f' returns --- -alloca :: Storable a => (Ptr a -> IO b) -> IO b -alloca = doAlloca undefined - where - doAlloca :: Storable a => a -> (Ptr a -> IO b) -> IO b - doAlloca dummy = allocaBytes (sizeOf dummy) - --- temporarily allocate the given number of bytes of storage --- --- * the pointer passed as an argument to the function must *not* escape from --- this function; in other words, in `allocaBytes n f' the allocated storage --- must not be used after `f' returns --- -#ifdef __GLASGOW_HASKELL__ -allocaBytes :: Int -> (Ptr a -> IO b) -> IO b -allocaBytes (I# size) action = IO $ \ s -> - case newPinnedByteArray# size s of { (# s, mbarr# #) -> - case unsafeFreezeByteArray# mbarr# s of { (# s, barr# #) -> - let addr = Ptr (byteArrayContents# barr#) in - case action addr of { IO action -> - case action s of { (# s, r #) -> - case touch# barr# s of { s -> - (# s, r #) - }}}}} -#else -allocaBytes :: Int -> (Ptr a -> IO b) -> IO b -allocaBytes size = bracket (mallocBytes size) free -#endif - --- adjust a malloc'ed storage area to the given size --- -reallocBytes :: Ptr a -> Int -> IO (Ptr a) -reallocBytes ptr size = - failWhenNULL "realloc" (_realloc ptr (fromIntegral size)) - --- free malloc'ed storage --- -free :: Ptr a -> IO () -free = _free - - --- auxilliary routines --- ------------------- - --- asserts that the pointer returned from the action in the second argument is --- non-null --- -failWhenNULL :: String -> IO (Ptr a) -> IO (Ptr a) -failWhenNULL name f = do - addr <- f - if addr == nullPtr -#ifdef __GLASGOW_HASKELL__ - then ioException (IOError Nothing ResourceExhausted name - "out of memory" Nothing) -#else - then ioError (userError (name++": out of memory")) -#endif - else return addr - --- basic C routines needed for memory allocation --- -foreign import "malloc" unsafe _malloc :: CSize -> IO (Ptr a) -foreign import "realloc" unsafe _realloc :: Ptr a -> CSize -> IO (Ptr a) -foreign import "free" unsafe _free :: Ptr a -> IO () - -\end{code} diff --git a/ghc/lib/std/PrelMarshalArray.lhs b/ghc/lib/std/PrelMarshalArray.lhs deleted file mode 100644 index 695e1fe..0000000 --- a/ghc/lib/std/PrelMarshalArray.lhs +++ /dev/null @@ -1,272 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelMarshalArray.lhs,v 1.10 2002/02/05 16:56:38 sewardj Exp $ -% -% (c) The FFI task force, 2000 -% - -Marshalling support: routines allocating, storing, and retrieving Haskell -lists that are represented as arrays in the foreign language - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelMarshalArray ( - - -- allocation - -- - mallocArray, -- :: Storable a => Int -> IO (Ptr a) - mallocArray0, -- :: Storable a => Int -> IO (Ptr a) - - allocaArray, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b - allocaArray0, -- :: Storable a => Int -> (Ptr a -> IO b) -> IO b - - reallocArray, -- :: Storable a => Ptr a -> Int -> IO (Ptr a) - reallocArray0, -- :: Storable a => Ptr a -> Int -> IO (Ptr a) - - -- marshalling - -- - peekArray, -- :: Storable a => Int -> Ptr a -> IO [a] - peekArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO [a] - - pokeArray, -- :: Storable a => Ptr a -> [a] -> IO () - pokeArray0, -- :: Storable a => a -> Ptr a -> [a] -> IO () - - -- combined allocation and marshalling - -- - newArray, -- :: Storable a => [a] -> IO (Ptr a) - newArray0, -- :: Storable a => a -> [a] -> IO (Ptr a) - - withArray, -- :: Storable a => [a] -> (Ptr a -> IO b) -> IO b - withArray0, -- :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b - - -- copying (argument order: destination, source) - -- - copyArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO () - moveArray, -- :: Storable a => Ptr a -> Ptr a -> Int -> IO () - - -- finding the length - -- - lengthArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO Int - - -- indexing - -- - advancePtr, -- :: Storable a => Ptr a -> Int -> Ptr a - - -- DEPRECATED: Don't use! - destructArray, -- :: Storable a => Int -> Ptr a -> IO () - destructArray0, -- :: (Storable a, Eq a) => a -> Ptr a -> IO () -) where - -import Monad - -#ifdef __GLASGOW_HASKELL__ -import PrelPtr (Ptr, plusPtr) -import PrelStorable (Storable(sizeOf,peekElemOff,pokeElemOff,destruct)) -import PrelMarshalAlloc (mallocBytes, allocaBytes, reallocBytes) -import PrelMarshalUtils (copyBytes, moveBytes) -import PrelIOBase -import PrelNum -import PrelList -import PrelErr -import PrelBase -#endif - --- allocation --- ---------- - --- allocate storage for the given number of elements of a storable type --- -mallocArray :: Storable a => Int -> IO (Ptr a) -mallocArray = doMalloc undefined - where - doMalloc :: Storable a => a -> Int -> IO (Ptr a) - doMalloc dummy size = mallocBytes (size * sizeOf dummy) - --- like `mallocArray', but add an extra element to signal the end of the array --- -mallocArray0 :: Storable a => Int -> IO (Ptr a) -mallocArray0 size = mallocArray (size + 1) - --- temporarily allocate space for the given number of elements --- --- * see `MarshalAlloc.alloca' for the storage lifetime constraints --- -allocaArray :: Storable a => Int -> (Ptr a -> IO b) -> IO b -allocaArray = doAlloca undefined - where - doAlloca :: Storable a => a -> Int -> (Ptr a -> IO b) -> IO b - doAlloca dummy size = allocaBytes (size * sizeOf dummy) - --- like `allocaArray', but add an extra element to signal the end of the array --- -allocaArray0 :: Storable a => Int -> (Ptr a -> IO b) -> IO b -allocaArray0 size = allocaArray (size + 1) - --- adjust the size of an array --- -reallocArray :: Storable a => Ptr a -> Int -> IO (Ptr a) -reallocArray = doRealloc undefined - where - doRealloc :: Storable a => a -> Ptr a -> Int -> IO (Ptr a) - doRealloc dummy ptr size = reallocBytes ptr (size * sizeOf dummy) - --- adjust the size of an array while adding an element for the end marker --- -reallocArray0 :: Storable a => Ptr a -> Int -> IO (Ptr a) -reallocArray0 ptr size = reallocArray ptr (size + 1) - - --- marshalling --- ----------- - --- convert an array of given length into a Haskell list. This version --- traverses the array backwards using an accumulating parameter, --- which uses constant stack space. The previous version using mapM --- needed linear stack space. --- -peekArray :: Storable a => Int -> Ptr a -> IO [a] -peekArray size ptr | size <= 0 = return [] - | otherwise = f (size-1) [] - where - f 0 acc = do e <- peekElemOff ptr 0; return (e:acc) - f n acc = do e <- peekElemOff ptr n; f (n-1) (e:acc) - --- convert an array terminated by the given end marker into a Haskell list --- -peekArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO [a] -peekArray0 marker ptr = loop 0 - where - loop i = do - val <- peekElemOff ptr i - if val == marker then return [] else do - rest <- loop (i+1) - return (val:rest) - --- write the list elements consecutive into memory --- -pokeArray :: Storable a => Ptr a -> [a] -> IO () -pokeArray ptr vals = zipWithM_ (pokeElemOff ptr) [0..] vals - --- write the list elements consecutive into memory and terminate them with the --- given marker element --- -pokeArray0 :: Storable a => a -> Ptr a -> [a] -> IO () -pokeArray0 marker ptr vals = do - pokeArray ptr vals - pokeElemOff ptr (length vals) marker - - --- combined allocation and marshalling --- ----------------------------------- - --- write a list of storable elements into a newly allocated, consecutive --- sequence of storable values --- -newArray :: Storable a => [a] -> IO (Ptr a) -newArray vals = do - ptr <- mallocArray (length vals) - pokeArray ptr vals - return ptr - --- write a list of storable elements into a newly allocated, consecutive --- sequence of storable values, where the end is fixed by the given end marker --- -newArray0 :: Storable a => a -> [a] -> IO (Ptr a) -newArray0 marker vals = do - ptr <- mallocArray0 (length vals) - pokeArray0 marker ptr vals - return ptr - --- temporarily store a list of storable values in memory --- -withArray :: Storable a => [a] -> (Ptr a -> IO b) -> IO b -withArray vals f = - allocaArray len $ \ptr -> do - pokeArray ptr vals - res <- f ptr - destructArray len ptr - return res - where - len = length vals - --- like `withArray', but a terminator indicates where the array ends --- -withArray0 :: Storable a => a -> [a] -> (Ptr a -> IO b) -> IO b -withArray0 marker vals f = - allocaArray0 len $ \ptr -> do - pokeArray0 marker ptr vals - res <- f ptr - destructArray (len+1) ptr - return res - where - len = length vals - - --- destruction --- ----------- - --- destruct each element of an array (in reverse order) --- -destructArray :: Storable a => Int -> Ptr a -> IO () -{-# DEPRECATED destructArray "This function is not standards compliant" #-} -destructArray size ptr = - sequence_ [destruct (ptr `advancePtr` i) - | i <- [size-1, size-2 .. 0]] - --- like `destructArray', but a terminator indicates where the array ends --- -destructArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO () -{-# DEPRECATED destructArray0 "This function is not standards compliant" #-} -destructArray0 marker ptr = do - size <- lengthArray0 marker ptr - sequence_ [destruct (ptr `advancePtr` i) - | i <- [size, size-1 .. 0]] - - --- copying (argument order: destination, source) --- ------- - --- copy the given number of elements from the second array (source) into the --- first array (destination); the copied areas may *not* overlap --- -copyArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () -copyArray = doCopy undefined - where - doCopy :: Storable a => a -> Ptr a -> Ptr a -> Int -> IO () - doCopy dummy dest src size = copyBytes dest src (size * sizeOf dummy) - --- copy the given number of elements from the second array (source) into the --- first array (destination); the copied areas *may* overlap --- -moveArray :: Storable a => Ptr a -> Ptr a -> Int -> IO () -moveArray = doMove undefined - where - doMove :: Storable a => a -> Ptr a -> Ptr a -> Int -> IO () - doMove dummy dest src size = moveBytes dest src (size * sizeOf dummy) - - --- finding the length --- ------------------ - --- return the number of elements in an array, excluding the terminator --- -lengthArray0 :: (Storable a, Eq a) => a -> Ptr a -> IO Int -lengthArray0 marker ptr = loop 0 - where - loop i = do - val <- peekElemOff ptr i - if val == marker then return i else loop (i+1) - - --- indexing --- -------- - --- advance a pointer into an array by the given number of elements --- -advancePtr :: Storable a => Ptr a -> Int -> Ptr a -advancePtr = doAdvance undefined - where - doAdvance :: Storable a => a -> Ptr a -> Int -> Ptr a - doAdvance dummy ptr i = ptr `plusPtr` (i * sizeOf dummy) - -\end{code} diff --git a/ghc/lib/std/PrelMarshalError.lhs b/ghc/lib/std/PrelMarshalError.lhs deleted file mode 100644 index 313ec85..0000000 --- a/ghc/lib/std/PrelMarshalError.lhs +++ /dev/null @@ -1,149 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelMarshalError.lhs,v 1.3 2002/02/04 09:05:46 chak Exp $ -% -% (c) The FFI task force, [2000..2002] -% - -Marshalling support: Handling of common error conditions - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelMarshalError ( - - -- I/O errors - -- ---------- - - IOErrorType, -- abstract data type - - mkIOError, -- :: IOErrorType - -- -> String - -- -> Maybe FilePath - -- -> Maybe Handle - -- -> IOError - - alreadyExistsErrorType, -- :: IOErrorType - doesNotExistErrorType, -- :: IOErrorType - alreadyInUseErrorType, -- :: IOErrorType - fullErrorType, -- :: IOErrorType - eofErrorType, -- :: IOErrorType - illegalOperationType, -- :: IOErrorType - permissionErrorType, -- :: IOErrorType - userErrorType, -- :: IOErrorType - - annotateIOError, -- :: IOError - -- -> String - -- -> Maybe FilePath - -- -> Maybe Handle - -- -> IOError - - -- Result value checks - -- ------------------- - - -- throw an exception on specific return values - -- - throwIf, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO a - throwIf_, -- :: (a -> Bool) -> (a -> String) -> IO a -> IO () - throwIfNeg, -- :: (Ord a, Num a) - -- => (a -> String) -> IO a -> IO a - throwIfNeg_, -- :: (Ord a, Num a) - -- => (a -> String) -> IO a -> IO () - throwIfNull, -- :: String -> IO (Ptr a) -> IO (Ptr a) - - -- discard return value - -- - void -- IO a -> IO () -) where - -import PrelPtr -import PrelIOBase -import PrelMaybe -import PrelNum -import PrelBase - - --- I/O errors --- ---------- - --- construct an IO error --- -mkIOError :: IOErrorType -> String -> Maybe FilePath -> Maybe Handle -> IOError -mkIOError errTy loc path hdl = - IOException $ IOError hdl errTy loc "" path - --- pre-defined error types corresponding to the predicates in the standard --- library `IO' --- -alreadyExistsErrorType, doesNotExistErrorType, alreadyInUseErrorType, - fullErrorType, eofErrorType, illegalOperationType, permissionErrorType, - userErrorType :: IOErrorType -alreadyExistsErrorType = AlreadyExists -doesNotExistErrorType = NoSuchThing -alreadyInUseErrorType = ResourceBusy -fullErrorType = ResourceExhausted -eofErrorType = EOF -illegalOperationType = IllegalOperation -permissionErrorType = PermissionDenied -userErrorType = OtherError - --- add location information and possibly a path and handle to an existing I/O --- error --- --- * if no file path or handle is given, the corresponding value that's in the --- error is left unaltered --- -annotateIOError :: IOError - -> String - -> Maybe FilePath - -> Maybe Handle - -> IOError -annotateIOError (IOException (IOError hdl errTy _ str path)) loc opath ohdl = - IOException (IOError (hdl `mplus` ohdl) errTy loc str (path `mplus` opath)) - where - Nothing `mplus` ys = ys - xs `mplus` _ = xs -annotateIOError exc _ _ _ = - exc - - --- Result value checks --- ------------------- - --- guard an IO operation and throw an exception if the result meets the given --- predicate --- --- * the second argument computes an error message from the result of the IO --- operation --- -throwIf :: (a -> Bool) -> (a -> String) -> IO a -> IO a -throwIf pred msgfct act = - do - res <- act - (if pred res then ioError . userError . msgfct else return) res - --- like `throwIf', but discarding the result --- -throwIf_ :: (a -> Bool) -> (a -> String) -> IO a -> IO () -throwIf_ pred msgfct act = void $ throwIf pred msgfct act - --- guards against negative result values --- -throwIfNeg :: (Ord a, Num a) => (a -> String) -> IO a -> IO a -throwIfNeg = throwIf (< 0) - --- like `throwIfNeg', but discarding the result --- -throwIfNeg_ :: (Ord a, Num a) => (a -> String) -> IO a -> IO () -throwIfNeg_ = throwIf_ (< 0) - --- guards against null pointers --- -throwIfNull :: String -> IO (Ptr a) -> IO (Ptr a) -throwIfNull = throwIf (== nullPtr) . const - --- discard the return value of an IO action --- -void :: IO a -> IO () -void act = act >> return () - -\end{code} diff --git a/ghc/lib/std/PrelMarshalUtils.lhs b/ghc/lib/std/PrelMarshalUtils.lhs deleted file mode 100644 index fd31573..0000000 --- a/ghc/lib/std/PrelMarshalUtils.lhs +++ /dev/null @@ -1,163 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelMarshalUtils.lhs,v 1.3 2001/05/18 16:54:05 simonmar Exp $ -% -% (c) The FFI task force, 2000 -% - -Utilities for primitive marshaling - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelMarshalUtils ( - - -- combined allocation and marshalling - -- - withObject, -- :: Storable a => a -> (Ptr a -> IO b) -> IO b - {- FIXME: should be `with' -} - new, -- :: Storable a => a -> IO (Ptr a) - - -- marshalling of Boolean values (non-zero corresponds to `True') - -- - fromBool, -- :: Num a => Bool -> a - toBool, -- :: Num a => a -> Bool - - -- marshalling of Maybe values - -- - maybeNew, -- :: ( a -> IO (Ptr a)) - -- -> (Maybe a -> IO (Ptr a)) - maybeWith, -- :: ( a -> (Ptr b -> IO c) -> IO c) - -- -> (Maybe a -> (Ptr b -> IO c) -> IO c) - maybePeek, -- :: (Ptr a -> IO b ) - -- -> (Ptr a -> IO (Maybe b)) - - -- marshalling lists of storable objects - -- - withMany, -- :: (a -> (b -> res) -> res) -> [a] -> ([b] -> res) -> res - - -- Haskellish interface to memcpy and memmove - -- (argument order: destination, source) - -- - copyBytes, -- :: Ptr a -> Ptr a -> Int -> IO () - moveBytes -- :: Ptr a -> Ptr a -> Int -> IO () -) where - -#ifdef __GLASGOW_HASKELL__ -import PrelPtr ( Ptr, nullPtr ) -import PrelStorable ( Storable(poke,destruct) ) -import PrelCTypesISO ( CSize ) -import PrelMarshalAlloc ( malloc, alloca ) -import PrelIOBase -import PrelMaybe -import PrelReal ( fromIntegral ) -import PrelNum -import PrelBase -#endif - --- combined allocation and marshalling --- ----------------------------------- - --- allocate storage for a value and marshal it into this storage --- -new :: Storable a => a -> IO (Ptr a) -new val = - do - ptr <- malloc - poke ptr val - return ptr - --- allocate temporary storage for a value and marshal it into this storage --- --- * see the life time constraints imposed by `alloca' --- -{- FIXME: should be called `with' -} -withObject :: Storable a => a -> (Ptr a -> IO b) -> IO b -withObject val f = - alloca $ \ptr -> do - poke ptr val - res <- f ptr - destruct ptr - return res - - --- marshalling of Boolean values (non-zero corresponds to `True') --- ----------------------------- - --- convert a Haskell Boolean to its numeric representation --- -fromBool :: Num a => Bool -> a -fromBool False = 0 -fromBool True = 1 - --- convert a Boolean in numeric representation to a Haskell value --- -toBool :: Num a => a -> Bool -toBool = (/= 0) - - --- marshalling of Maybe values --- --------------------------- - --- allocate storage and marshall a storable value wrapped into a `Maybe' --- --- * the `nullPtr' is used to represent `Nothing' --- -maybeNew :: ( a -> IO (Ptr a)) - -> (Maybe a -> IO (Ptr a)) -maybeNew = maybe (return nullPtr) - --- converts a withXXX combinator into one marshalling a value wrapped into a --- `Maybe' --- -maybeWith :: ( a -> (Ptr b -> IO c) -> IO c) - -> (Maybe a -> (Ptr b -> IO c) -> IO c) -maybeWith = maybe ($ nullPtr) - --- convert a peek combinator into a one returning `Nothing' if applied to a --- `nullPtr' --- -maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b) -maybePeek peek ptr | ptr == nullPtr = return Nothing - | otherwise = do a <- peek ptr; return (Just a) - - --- marshalling lists of storable objects --- ------------------------------------- - --- replicates a withXXX combinator over a list of objects, yielding a list of --- marshalled objects --- -withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object - -> [a] -- storable objects - -> ([b] -> res) -- action on list of marshalled obj.s - -> res -withMany _ [] f = f [] -withMany withFoo (x:xs) f = withFoo x $ \x' -> - withMany withFoo xs (\xs' -> f (x':xs')) - - --- Haskellish interface to memcpy and memmove --- ------------------------------------------ - --- copies the given number of bytes from the second area (source) into the --- first (destination); the copied areas may *not* overlap --- -copyBytes :: Ptr a -> Ptr a -> Int -> IO () -copyBytes dest src size = memcpy dest src (fromIntegral size) - --- copies the given number of elements from the second area (source) into the --- first (destination); the copied areas *may* overlap --- -moveBytes :: Ptr a -> Ptr a -> Int -> IO () -moveBytes dest src size = memmove dest src (fromIntegral size) - - --- auxilliary routines --- ------------------- - --- basic C routines needed for memory copying --- -foreign import unsafe memcpy :: Ptr a -> Ptr a -> CSize -> IO () -foreign import unsafe memmove :: Ptr a -> Ptr a -> CSize -> IO () - -\end{code} diff --git a/ghc/lib/std/PrelMaybe.lhs b/ghc/lib/std/PrelMaybe.lhs deleted file mode 100644 index 42bcd3d..0000000 --- a/ghc/lib/std/PrelMaybe.lhs +++ /dev/null @@ -1,65 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelMaybe.lhs,v 1.6 2000/06/30 13:39:36 simonmar Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% - -\section[PrelMaybe]{Module @PrelMaybe@} - -The @Maybe@ type. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelMaybe where - -import PrelBase -\end{code} - - -%********************************************************* -%* * -\subsection{Standard numeric classes} -%* * -%********************************************************* - -\begin{code} -data Maybe a = Nothing | Just a deriving (Eq, Ord) - -maybe :: b -> (a -> b) -> Maybe a -> b -maybe n _ Nothing = n -maybe _ f (Just x) = f x - -instance Functor Maybe where - fmap _ Nothing = Nothing - fmap f (Just a) = Just (f a) - -instance Monad Maybe where - (Just x) >>= k = k x - Nothing >>= _ = Nothing - - (Just _) >> k = k - Nothing >> _ = Nothing - - return = Just - fail _ = Nothing -\end{code} - - -%********************************************************* -%* * -\subsection{Standard numeric classes} -%* * -%********************************************************* - -\begin{code} -data Either a b = Left a | Right b deriving (Eq, Ord ) - -either :: (a -> c) -> (b -> c) -> Either a b -> c -either f _ (Left x) = f x -either _ g (Right y) = g y -\end{code} - - - - diff --git a/ghc/lib/std/PrelNum.hi-boot b/ghc/lib/std/PrelNum.hi-boot deleted file mode 100644 index 33298fd..0000000 --- a/ghc/lib/std/PrelNum.hi-boot +++ /dev/null @@ -1,14 +0,0 @@ ---------------------------------------------------------------------------- --- PrelNum.hi-boot --- --- This hand-written interface file is the --- initial bootstrap version for PrelNum.hi. --- It's needed for the 'thin-air' Id addr2Integer, when compiling --- PrelBase, and other Prelude files that precede PrelNum ---------------------------------------------------------------------------- - -__interface "std" PrelNum 1 where -__export PrelNum Integer addr2Integer ; - -1 data Integer ; -1 addr2Integer :: PrelGHC.Addrzh -> Integer ; diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs deleted file mode 100644 index 49bf878..0000000 --- a/ghc/lib/std/PrelNum.lhs +++ /dev/null @@ -1,461 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelNum.lhs,v 1.46 2002/01/29 09:58:21 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelNum]{Module @PrelNum@} - -The class - - Num - -and the type - - Integer - - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "MachDeps.h" -#if SIZEOF_HSWORD == 4 -#define LEFTMOST_BIT 2147483648 -#elif SIZEOF_HSWORD == 8 -#define LEFTMOST_BIT 9223372036854775808 -#else -#error Please define LEFTMOST_BIT to be 2^(SIZEOF_HSWORD*8-1) -#endif - -module PrelNum where - -import {-# SOURCE #-} PrelErr -import PrelBase -import PrelList -import PrelEnum -import PrelShow - -infixl 7 * -infixl 6 +, - - -default () -- Double isn't available yet, - -- and we shouldn't be using defaults anyway -\end{code} - -%********************************************************* -%* * -\subsection{Standard numeric class} -%* * -%********************************************************* - -\begin{code} -class (Eq a, Show a) => Num a where - (+), (-), (*) :: a -> a -> a - negate :: a -> a - abs, signum :: a -> a - fromInteger :: Integer -> a - - x - y = x + negate y - negate x = 0 - x - -{-# INLINE subtract #-} -subtract :: (Num a) => a -> a -> a -subtract x y = y - x -\end{code} - - -%********************************************************* -%* * -\subsection{Instances for @Int@} -%* * -%********************************************************* - -\begin{code} -instance Num Int where - (+) = plusInt - (-) = minusInt - negate = negateInt - (*) = timesInt - abs n = if n `geInt` 0 then n else negateInt n - - signum n | n `ltInt` 0 = negateInt 1 - | n `eqInt` 0 = 0 - | otherwise = 1 - - fromInteger = integer2Int -\end{code} - - -\begin{code} --- These can't go in PrelBase with the defn of Int, because --- we don't have pairs defined at that time! - -quotRemInt :: Int -> Int -> (Int, Int) -a@(I# _) `quotRemInt` b@(I# _) = (a `quotInt` b, a `remInt` b) - -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) - -divModInt :: Int -> Int -> (Int, Int) -divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y) - -- Stricter. Sorry if you don't like it. (WDP 94/10) -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ type} -%* * -%********************************************************* - -\begin{code} -data Integer - = S# Int# -- small integers -#ifndef ILX - | J# Int# ByteArray# -- large integers -#else - | J# Void BigInteger -- .NET big ints - -foreign type dotnet "BigInteger" BigInteger -#endif -\end{code} - -Convenient boxed Integer PrimOps. - -\begin{code} -zeroInteger :: Integer -zeroInteger = S# 0# - -int2Integer :: Int -> Integer -{-# INLINE int2Integer #-} -int2Integer (I# i) = S# i - -integer2Int :: Integer -> Int -integer2Int (S# i) = I# i -integer2Int (J# s d) = case (integer2Int# s d) of { n# -> I# n# } - -toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d } -toBig i@(J# _ _) = i -\end{code} - - -%********************************************************* -%* * -\subsection{Dividing @Integers@} -%* * -%********************************************************* - -\begin{code} -quotRemInteger :: Integer -> Integer -> (Integer, Integer) -quotRemInteger a@(S# (-LEFTMOST_BIT#)) b = quotRemInteger (toBig a) b -quotRemInteger (S# i) (S# j) - = case quotRemInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j ) -quotRemInteger i1@(J# _ _) i2@(S# _) = quotRemInteger i1 (toBig i2) -quotRemInteger i1@(S# _) i2@(J# _ _) = quotRemInteger (toBig i1) i2 -quotRemInteger (J# s1 d1) (J# s2 d2) - = case (quotRemInteger# s1 d1 s2 d2) of - (# s3, d3, s4, d4 #) - -> (J# s3 d3, J# s4 d4) - -divModInteger a@(S# (-LEFTMOST_BIT#)) b = divModInteger (toBig a) b -divModInteger (S# i) (S# j) - = case divModInt (I# i) (I# j) of ( I# i, I# j ) -> ( S# i, S# j) -divModInteger i1@(J# _ _) i2@(S# _) = divModInteger i1 (toBig i2) -divModInteger i1@(S# _) i2@(J# _ _) = divModInteger (toBig i1) i2 -divModInteger (J# s1 d1) (J# s2 d2) - = case (divModInteger# s1 d1 s2 d2) of - (# s3, d3, s4, d4 #) - -> (J# s3 d3, J# s4 d4) - -remInteger :: Integer -> Integer -> Integer -remInteger ia 0 - = error "Prelude.Integral.rem{Integer}: divide by 0" -remInteger a@(S# (-LEFTMOST_BIT#)) b = remInteger (toBig a) b -remInteger (S# a) (S# b) = S# (remInt# a b) -{- Special case doesn't work, because a 1-element J# has the range - -(2^32-1) -- 2^32-1, whereas S# has the range -2^31 -- (2^31-1) -remInteger ia@(S# a) (J# sb b) - | sb ==# 1# = S# (remInt# a (word2Int# (integer2Word# sb b))) - | sb ==# -1# = S# (remInt# a (0# -# (word2Int# (integer2Word# sb b)))) - | 0# <# sb = ia - | otherwise = S# (0# -# a) --} -remInteger ia@(S# _) ib@(J# _ _) = remInteger (toBig ia) ib -remInteger (J# sa a) (S# b) - = case int2Integer# b of { (# sb, b #) -> - case remInteger# sa a sb b of { (# sr, r #) -> - S# (integer2Int# sr r) }} -remInteger (J# sa a) (J# sb b) - = case remInteger# sa a sb b of (# sr, r #) -> J# sr r - -quotInteger :: Integer -> Integer -> Integer -quotInteger ia 0 - = error "Prelude.Integral.quot{Integer}: divide by 0" -quotInteger a@(S# (-LEFTMOST_BIT#)) b = quotInteger (toBig a) b -quotInteger (S# a) (S# b) = S# (quotInt# a b) -{- Special case disabled, see remInteger above -quotInteger (S# a) (J# sb b) - | sb ==# 1# = S# (quotInt# a (word2Int# (integer2Word# sb b))) - | sb ==# -1# = S# (quotInt# a (0# -# (word2Int# (integer2Word# sb b)))) - | otherwise = zeroInteger --} -quotInteger ia@(S# _) ib@(J# _ _) = quotInteger (toBig ia) ib -quotInteger (J# sa a) (S# b) - = case int2Integer# b of { (# sb, b #) -> - case quotInteger# sa a sb b of (# sq, q #) -> J# sq q } -quotInteger (J# sa a) (J# sb b) - = case quotInteger# sa a sb b of (# sg, g #) -> J# sg g -\end{code} - - - -\begin{code} -gcdInteger :: Integer -> Integer -> Integer --- SUP: Do we really need the first two cases? -gcdInteger a@(S# (-LEFTMOST_BIT#)) b = gcdInteger (toBig a) b -gcdInteger a b@(S# (-LEFTMOST_BIT#)) = gcdInteger a (toBig b) -gcdInteger (S# a) (S# b) = case gcdInt (I# a) (I# b) of { I# c -> S# c } -gcdInteger ia@(S# 0#) ib@(J# 0# _) = error "PrelNum.gcdInteger: gcd 0 0 is undefined" -gcdInteger ia@(S# a) ib@(J# sb b) - | a ==# 0# = abs ib - | sb ==# 0# = abs ia - | otherwise = S# (gcdIntegerInt# absSb b absA) - where absA = if a <# 0# then negateInt# a else a - absSb = if sb <# 0# then negateInt# sb else sb -gcdInteger ia@(J# _ _) ib@(S# _) = gcdInteger ib ia -gcdInteger (J# 0# _) (J# 0# _) = error "PrelNum.gcdInteger: gcd 0 0 is undefined" -gcdInteger (J# sa a) (J# sb b) - = case gcdInteger# sa a sb b of (# sg, g #) -> J# sg g - -lcmInteger :: Integer -> Integer -> Integer -lcmInteger a 0 - = zeroInteger -lcmInteger 0 b - = zeroInteger -lcmInteger a b - = (divExact aa (gcdInteger aa ab)) * ab - where aa = abs a - ab = abs b - -divExact :: Integer -> Integer -> Integer -divExact a@(S# (-LEFTMOST_BIT#)) b = divExact (toBig a) b -divExact (S# a) (S# b) = S# (quotInt# a b) -divExact (S# a) (J# sb b) - = S# (quotInt# a (integer2Int# sb b)) -divExact (J# sa a) (S# b) - = case int2Integer# b of - (# sb, b #) -> case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d -divExact (J# sa a) (J# sb b) - = case divExactInteger# sa a sb b of (# sd, d #) -> J# sd d -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instances for @Eq@, @Ord@} -%* * -%********************************************************* - -\begin{code} -instance Eq Integer where - (S# i) == (S# j) = i ==# j - (S# i) == (J# s d) = cmpIntegerInt# s d i ==# 0# - (J# s d) == (S# i) = cmpIntegerInt# s d i ==# 0# - (J# s1 d1) == (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ==# 0# - - (S# i) /= (S# j) = i /=# j - (S# i) /= (J# s d) = cmpIntegerInt# s d i /=# 0# - (J# s d) /= (S# i) = cmpIntegerInt# s d i /=# 0# - (J# s1 d1) /= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) /=# 0# - ------------------------------------------------------------------------- -instance Ord Integer where - (S# i) <= (S# j) = i <=# j - (J# s d) <= (S# i) = cmpIntegerInt# s d i <=# 0# - (S# i) <= (J# s d) = cmpIntegerInt# s d i >=# 0# - (J# s1 d1) <= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <=# 0# - - (S# i) > (S# j) = i ># j - (J# s d) > (S# i) = cmpIntegerInt# s d i ># 0# - (S# i) > (J# s d) = cmpIntegerInt# s d i <# 0# - (J# s1 d1) > (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) ># 0# - - (S# i) < (S# j) = i <# j - (J# s d) < (S# i) = cmpIntegerInt# s d i <# 0# - (S# i) < (J# s d) = cmpIntegerInt# s d i ># 0# - (J# s1 d1) < (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) <# 0# - - (S# i) >= (S# j) = i >=# j - (J# s d) >= (S# i) = cmpIntegerInt# s d i >=# 0# - (S# i) >= (J# s d) = cmpIntegerInt# s d i <=# 0# - (J# s1 d1) >= (J# s2 d2) = (cmpInteger# s1 d1 s2 d2) >=# 0# - - compare (S# i) (S# j) - | i ==# j = EQ - | i <=# j = LT - | otherwise = GT - compare (J# s d) (S# i) - = case cmpIntegerInt# s d i of { res# -> - if res# <# 0# then LT else - if res# ># 0# then GT else EQ - } - compare (S# i) (J# s d) - = case cmpIntegerInt# s d i of { res# -> - if res# ># 0# then LT else - if res# <# 0# then GT else EQ - } - compare (J# s1 d1) (J# s2 d2) - = case cmpInteger# s1 d1 s2 d2 of { res# -> - if res# <# 0# then LT else - if res# ># 0# then GT else EQ - } -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instances for @Num@} -%* * -%********************************************************* - -\begin{code} -instance Num Integer where - (+) = plusInteger - (-) = minusInteger - (*) = timesInteger - negate = negateInteger - fromInteger x = x - - -- ORIG: abs n = if n >= 0 then n else -n - abs (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT - abs (S# i) = case abs (I# i) of I# j -> S# j - abs n@(J# s d) = if (s >=# 0#) then n else J# (negateInt# s) d - - signum (S# i) = case signum (I# i) of I# j -> S# j - signum (J# s d) - = let - cmp = cmpIntegerInt# s d 0# - in - if cmp ># 0# then S# 1# - else if cmp ==# 0# then S# 0# - else S# (negateInt# 1#) - -plusInteger i1@(S# i) i2@(S# j) = case addIntC# i j of { (# r, c #) -> - if c ==# 0# then S# r - else toBig i1 + toBig i2 } -plusInteger i1@(J# _ _) i2@(S# _) = i1 + toBig i2 -plusInteger i1@(S# _) i2@(J# _ _) = toBig i1 + i2 -plusInteger (J# s1 d1) (J# s2 d2) = case plusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d - -minusInteger i1@(S# i) i2@(S# j) = case subIntC# i j of { (# r, c #) -> - if c ==# 0# then S# r - else toBig i1 - toBig i2 } -minusInteger i1@(J# _ _) i2@(S# _) = i1 - toBig i2 -minusInteger i1@(S# _) i2@(J# _ _) = toBig i1 - i2 -minusInteger (J# s1 d1) (J# s2 d2) = case minusInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d - -timesInteger i1@(S# i) i2@(S# j) = if mulIntMayOflo# i j ==# 0# - then S# (i *# j) - else toBig i1 * toBig i2 -timesInteger i1@(J# _ _) i2@(S# _) = i1 * toBig i2 -timesInteger i1@(S# _) i2@(J# _ _) = toBig i1 * i2 -timesInteger (J# s1 d1) (J# s2 d2) = case timesInteger# s1 d1 s2 d2 of (# s, d #) -> J# s d - -negateInteger (S# (-LEFTMOST_BIT#)) = LEFTMOST_BIT -negateInteger (S# i) = S# (negateInt# i) -negateInteger (J# s d) = J# (negateInt# s) d -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instance for @Enum@} -%* * -%********************************************************* - -\begin{code} -instance Enum Integer where - succ x = x + 1 - pred x = x - 1 - toEnum n = int2Integer n - fromEnum n = integer2Int n - - {-# INLINE enumFrom #-} - {-# INLINE enumFromThen #-} - {-# INLINE enumFromTo #-} - {-# INLINE enumFromThenTo #-} - enumFrom x = enumDeltaInteger x 1 - enumFromThen x y = enumDeltaInteger x (y-x) - enumFromTo x lim = enumDeltaToInteger x 1 lim - enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim - -{-# RULES -"enumDeltaInteger" [~1] forall x y. enumDeltaInteger x y = build (\c _ -> enumDeltaIntegerFB c x y) -"efdtInteger" [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l) -"enumDeltaInteger" [1] enumDeltaIntegerFB (:) = enumDeltaInteger -"enumDeltaToInteger" [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger - #-} - -enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b -enumDeltaIntegerFB c x d = x `c` enumDeltaIntegerFB c (x+d) d - -enumDeltaInteger :: Integer -> Integer -> [Integer] -enumDeltaInteger x d = x : enumDeltaInteger (x+d) d - -enumDeltaToIntegerFB c n x delta lim - | delta >= 0 = up_fb c n x delta lim - | otherwise = dn_fb c n x delta lim - -enumDeltaToInteger x delta lim - | delta >= 0 = up_list x delta lim - | otherwise = dn_list x delta lim - -up_fb c n x delta lim = go (x::Integer) - where - go x | x > lim = n - | otherwise = x `c` go (x+delta) -dn_fb c n x delta lim = go (x::Integer) - where - go x | x < lim = n - | otherwise = x `c` go (x+delta) - -up_list x delta lim = go (x::Integer) - where - go x | x > lim = [] - | otherwise = x : go (x+delta) -dn_list x delta lim = go (x::Integer) - where - go x | x < lim = [] - | otherwise = x : go (x+delta) - -\end{code} - - -%********************************************************* -%* * -\subsection{The @Integer@ instances for @Show@} -%* * -%********************************************************* - -\begin{code} -instance Show Integer where - showsPrec p n r - | p > 6 && n < 0 = '(' : jtos n (')' : r) - -- Minor point: testing p first gives better code - -- in the not-uncommon case where the p argument - -- is a constant - | otherwise = jtos n r - showList = showList__ (showsPrec 0) - -jtos :: Integer -> String -> String -jtos n cs - | n < 0 = '-' : jtos' (-n) cs - | otherwise = jtos' n cs - where - jtos' :: Integer -> String -> String - jtos' n' cs' - | n' < 10 = case unsafeChr (ord '0' + fromInteger n') of - c@(C# _) -> c:cs' - | otherwise = case unsafeChr (ord '0' + fromInteger r) of - c@(C# _) -> jtos' q (c:cs') - where - (q,r) = n' `quotRemInteger` 10 -\end{code} diff --git a/ghc/lib/std/PrelPArr.hs b/ghc/lib/std/PrelPArr.hs deleted file mode 100644 index ca9ea0e..0000000 --- a/ghc/lib/std/PrelPArr.hs +++ /dev/null @@ -1,644 +0,0 @@ --- $Id: PrelPArr.hs,v 1.2 2002/02/11 08:20:49 chak Exp $ --- --- Copyright (c) [2001..2002] Manuel M T Chakravarty & Gabriele Keller --- --- Basic implementation of Parallel Arrays. --- ---- DESCRIPTION --------------------------------------------------------------- --- --- This module has two functions: (1) It defines the interface to the --- parallel array extension of the Prelude and (2) it provides a vanilla --- implementation of parallel arrays that does not require to flatten the --- array code. The implementation is not very optimised. --- ---- DOCU ---------------------------------------------------------------------- --- --- Language: Haskell 98 plus unboxed values and parallel arrays --- --- The semantic difference between standard Haskell arrays (aka "lazy --- arrays") and parallel arrays (aka "strict arrays") is that the evaluation --- of two different elements of a lazy array is independent, whereas in a --- strict array either non or all elements are evaluated. In other words, --- when a parallel array is evaluated to WHNF, all its elements will be --- evaluated to WHNF. The name parallel array indicates that all array --- elements may, in general, be evaluated to WHNF in parallel without any --- need to resort to speculative evaluation. This parallel evaluation --- semantics is also beneficial in the sequential case, as it facilitates --- loop-based array processing as known from classic array-based languages, --- such as Fortran. --- --- The interface of this module is essentially a variant of the list --- component of the Prelude, but also includes some functions (such as --- permutations) that are not provided for lists. The following list --- operations are not supported on parallel arrays, as they would require the --- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'. --- --- The current implementation is quite simple and entirely based on boxed --- arrays. One disadvantage of boxed arrays is that they require to --- immediately initialise all newly allocated arrays with an error thunk to --- keep the garbage collector happy, even if it is guaranteed that the array --- is fully initialised with different values before passing over the --- user-visible interface boundary. Currently, no effort is made to use --- raw memory copy operations to speed things up. --- ---- TODO ---------------------------------------------------------------------- --- --- * We probably want a standard library `PArray' in addition to the prelude --- extension in the same way as the standard library `List' complements the --- list functions from the prelude. --- --- * Currently, functions that emphasis the constructor-based definition of --- lists (such as, head, last, tail, and init) are not supported. --- --- Is it worthwhile to support the string processing functions lines, --- words, unlines, and unwords? (Currently, they are not implemented.) --- --- It can, however, be argued that it would be worthwhile to include them --- for completeness' sake; maybe only in the standard library `PArray'. --- --- * Prescans are often more useful for array programming than scans. Shall --- we include them into the Prelude or the library? --- --- * Due to the use of the iterator `loop', we could define some fusion rules --- in this module. --- --- * We might want to add bounds checks that can be deactivated. --- - -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelPArr ( - [::], -- abstract - - mapP, -- :: (a -> b) -> [:a:] -> [:b:] - (+:+), -- :: [:a:] -> [:a:] -> [:a:] - filterP, -- :: (a -> Bool) -> [:a:] -> [:a:] - concatP, -- :: [:[:a:]:] -> [:a:] - concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:] --- head, last, tail, init, -- it's not wise to use them on arrays - nullP, -- :: [:a:] -> Bool - lengthP, -- :: [:a:] -> Int - (!:), -- :: [:a:] -> Int -> a - foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a - foldl1P, -- :: (a -> a -> a) -> [:a:] -> a - scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:] - scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] - foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b - foldr1P, -- :: (a -> a -> a) -> [:a:] -> a - scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:] - scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] --- iterate, repeat, -- parallel arrays must be finite - replicateP, -- :: Int -> a -> [:a:] --- cycle, -- parallel arrays must be finite - takeP, -- :: Int -> [:a:] -> [:a:] - dropP, -- :: Int -> [:a:] -> [:a:] - splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:]) - takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] - dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] - spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) - breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) --- lines, words, unlines, unwords, -- is string processing really needed - reverseP, -- :: [:a:] -> [:a:] - andP, -- :: [:Bool:] -> Bool - orP, -- :: [:Bool:] -> Bool - anyP, -- :: (a -> Bool) -> [:a:] -> Bool - allP, -- :: (a -> Bool) -> [:a:] -> Bool - elemP, -- :: (Eq a) => a -> [:a:] -> Bool - notElemP, -- :: (Eq a) => a -> [:a:] -> Bool - lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b - sumP, -- :: (Num a) => [:a:] -> a - productP, -- :: (Num a) => [:a:] -> a - maximumP, -- :: (Ord a) => [:a:] -> a - minimumP, -- :: (Ord a) => [:a:] -> a - zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :] - zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] - zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] - zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] - unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:]) - unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) - - -- overloaded functions - -- - enumFromToP, -- :: Enum a => a -> a -> [:a:] - enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:] - - -- the following functions are not available on lists - -- - toP, -- :: [a] -> [:a:] - fromP, -- :: [:a:] -> [a] - sliceP, -- :: Int -> Int -> [:e:] -> [:e:] - foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e - fold1P, -- :: (e -> e -> e) -> [:e:] -> e - permuteP, -- :: [:Int:] -> [:e:] -> [:e:] - bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] - bpermuteDftP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:] - crossP, -- :: [:a:] -> [:b:] -> [:(a, b):] - indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:] -) where - -import PrelBase -import PrelST (ST(..), STRep, runST) -import PrelList -import PrelShow -import PrelRead - -infixl 9 !: -infixr 5 +:+ -infix 4 `elemP`, `notElemP` - - --- representation of parallel arrays --- --------------------------------- - --- this rather straight forward implementation maps parallel arrays to the --- internal representation used for standard Haskell arrays in GHC's Prelude --- (EXPORTED ABSTRACTLY) --- --- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! --- -data [::] e = PArr Int# (Array# e) - - --- exported operations on parallel arrays --- -------------------------------------- - --- operations corresponding to list operations --- - -mapP :: (a -> b) -> [:a:] -> [:b:] -mapP f = fst . loop (mapEFL f) noAL - -(+:+) :: [:a:] -> [:a:] -> [:a:] -a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1)) - -- we can't use the [:x..y:] form here for tedious - -- reasons to do with the typechecker and the fact that - -- `enumFromToP' is defined in the same module - where - len1 = lengthP a1 - len2 = lengthP a2 - -- - sel i | i < len1 = a1!:i - | otherwise = a2!:(i - len1) - -filterP :: (a -> Bool) -> [:a:] -> [:a:] -filterP p = fst . loop (filterEFL p) noAL - -concatP :: [:[:a:]:] -> [:a:] -concatP xss = foldlP (+:+) [::] xss - -concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:] -concatMapP f = concatP . mapP f - --- head, last, tail, init, -- it's not wise to use them on arrays - -nullP :: [:a:] -> Bool -nullP [::] = True -nullP _ = False - -lengthP :: [:a:] -> Int -lengthP (PArr n# _) = I# n# - -(!:) :: [:a:] -> Int -> a -(!:) = indexPArr - -foldlP :: (a -> b -> a) -> a -> [:b:] -> a -foldlP f z = snd . loop (foldEFL (flip f)) z - -foldl1P :: (a -> a -> a) -> [:a:] -> a -foldl1P f [::] = error "Prelude.foldl1P: empty array" -foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a - -scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:] -scanlP f z = fst . loop (scanEFL (flip f)) z - -scanl1P :: (a -> a -> a) -> [:a:] -> [:a:] -acanl1P f [::] = error "Prelude.scanl1P: empty array" -scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a - -foldrP :: (a -> b -> b) -> b -> [:a:] -> b -foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME - -foldr1P :: (a -> a -> a) -> [:a:] -> a -foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME - -scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:] -scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME - -scanr1P :: (a -> a -> a) -> [:a:] -> [:a:] -scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME - --- iterate, repeat -- parallel arrays must be finite - -replicateP :: Int -> a -> [:a:] -{-# INLINE replicateP #-} -replicateP n e = runST (do - marr# <- newArray n e - mkPArr n marr#) - --- cycle -- parallel arrays must be finite - -takeP :: Int -> [:a:] -> [:a:] -takeP n = sliceP 0 (n - 1) - -dropP :: Int -> [:a:] -> [:a:] -dropP n a = sliceP (n - 1) (lengthP a - 1) a - -splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) -splitAtP n xs = (takeP n xs, dropP n xs) - -takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] -takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME - -dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] -dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME - -spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -spanP = error "Prelude.spanP: not implemented yet" -- FIXME - -breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -breakP p = spanP (not . p) - --- lines, words, unlines, unwords, -- is string processing really needed - -reverseP :: [:a:] -> [:a:] -reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a - -- we can't use the [:x, y..z:] form here for tedious - -- reasons to do with the typechecker and the fact that - -- `enumFromThenToP' is defined in the same module - where - len = lengthP a - -andP :: [:Bool:] -> Bool -andP = foldP (&&) True - -orP :: [:Bool:] -> Bool -orP = foldP (||) True - -anyP :: (a -> Bool) -> [:a:] -> Bool -anyP p = orP . mapP p - -allP :: (a -> Bool) -> [:a:] -> Bool -allP p = andP . mapP p - -elemP :: (Eq a) => a -> [:a:] -> Bool -elemP x = anyP (== x) - -notElemP :: (Eq a) => a -> [:a:] -> Bool -notElemP x = allP (/= x) - -lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b -lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME - -sumP :: (Num a) => [:a:] -> a -sumP = foldP (+) 0 - -productP :: (Num a) => [:a:] -> a -productP = foldP (*) 0 - -maximumP :: (Ord a) => [:a:] -> a -maximumP [::] = error "Prelude.maximumP: empty parallel array" -maximumP xs = fold1P max xs - -minimumP :: (Ord a) => [:a:] -> a -minimumP [::] = error "Prelude.minimumP: empty parallel array" -minimumP xs = fold1P min xs - -zipP :: [:a:] -> [:b:] -> [:(a, b):] -zipP = zipWithP (,) - -zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] -zip3P = zipWith3P (,,) - -zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] -zipWithP f a1 a2 = let - len1 = lengthP a1 - len2 = lengthP a2 - len = len1 `min` len2 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i), i + 1) - -zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] -zipWith3P f a1 a2 a3 = let - len1 = lengthP a1 - len2 = lengthP a2 - len3 = lengthP a3 - len = len1 `min` len2 `min` len3 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) - -unzipP :: [:(a, b):] -> ([:a:], [:b:]) -unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) --- FIXME: these two functions should be optimised using a tupled custom loop -unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) -unzip3P a = (fst $ loop (mapEFL fst3) noAL a, - fst $ loop (mapEFL snd3) noAL a, - fst $ loop (mapEFL trd3) noAL a) - where - fst3 (a, _, _) = a - snd3 (_, b, _) = b - trd3 (_, _, c) = c - --- instances --- - -instance Eq a => Eq [:a:] where - a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) - | otherwise = False - -instance Ord a => Ord [:a:] where - compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of - EQ | lengthP a1 == lengthP a2 -> EQ - | lengthP a1 < lengthP a2 -> LT - | otherwise -> GT - where - combineOrdering EQ EQ = EQ - combineOrdering EQ other = other - combineOrdering other _ = other - -instance Functor [::] where - fmap = mapP - -instance Monad [::] where - m >>= k = foldrP ((+:+) . k ) [::] m - m >> k = foldrP ((+:+) . const k) [::] m - return x = [:x:] - fail _ = [::] - -instance Show a => Show [:a:] where - showsPrec _ = showPArr . fromP - where - showPArr [] s = "[::]" ++ s - showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) - - showPArr' [] s = ":]" ++ s - showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) - -instance Read a => Read [:a:] where - readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] - where - readPArr = readParen False (\r -> do - ("[:",s) <- lex r - readPArr1 s) - readPArr1 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) - - readPArr2 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; - return (x:xs, v) }) - --- overloaded functions --- - --- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of --- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, --- for the moment, we hope that the compiler is sufficiently clever to --- properly fuse the following definition. - -enumFromToP :: Enum a => a -> a -> [:a:] -enumFromToP x y = mapP toEnum (eftInt (fromEnum x) (fromEnum y)) - where - eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1 - -enumFromThenToP :: Enum a => a -> a -> a -> [:a:] -enumFromThenToP x y z = - mapP toEnum (efttInt (fromEnum x) (fromEnum y) (fromEnum z)) - where - efttInt x y z = scanlP (+) x $ - replicateP ((z - x + 1) `div` delta - 1) delta - where - delta = y - x - --- the following functions are not available on lists --- - --- create an array from a list (EXPORTED) --- -toP :: [a] -> [:a:] -toP l = fst $ loop store l (replicateP (length l) ()) - where - store _ (x:xs) = (Just x, xs) - --- convert an array to a list (EXPORTED) --- -fromP :: [:a:] -> [a] -fromP a = [a!:i | i <- [0..lengthP a - 1]] - --- cut a subarray out of an array (EXPORTED) --- -sliceP :: Int -> Int -> [:e:] -> [:e:] -sliceP from to a = - fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a - --- parallel folding (EXPORTED) --- --- * the first argument must be associative; otherwise, the result is undefined --- -foldP :: (e -> e -> e) -> e -> [:e:] -> e -foldP = foldlP - --- parallel folding without explicit neutral (EXPORTED) --- --- * the first argument must be associative; otherwise, the result is undefined --- -fold1P :: (e -> e -> e) -> [:e:] -> e -fold1P = foldl1P - --- permute an array according to the permutation vector in the first argument --- (EXPORTED) --- -permuteP :: [:Int:] -> [:e:] -> [:e:] -permuteP is es = fst $ loop (mapEFL (es!:)) noAL is - --- permute an array according to the back-permutation vector in the first --- argument (EXPORTED) --- --- * the permutation vector must represent a surjective function; otherwise, --- the result is undefined --- -bpermuteP :: [:Int:] -> [:e:] -> [:e:] -bpermuteP is es = error "Prelude.bpermuteP: not implemented yet" -- FIXME - --- permute an array according to the back-permutation vector in the first --- argument, which need not be surjective (EXPORTED) --- --- * any elements in the result that are not covered by the back-permutation --- vector assume the value of the corresponding position of the third --- argument --- -bpermuteDftP :: [:Int:] -> [:e:] -> [:e:] -> [:e:] -bpermuteDftP is es = error "Prelude.bpermuteDftP: not implemented yet"-- FIXME - --- computes the cross combination of two arrays (EXPORTED) --- -crossP :: [:a:] -> [:b:] -> [:(a, b):] -crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len () - where - len1 = lengthP a1 - len2 = lengthP a2 - len = len1 * len2 - -- - combine _ (i, j) = (Just $ (a1!:i, a2!:j), next) - where - next | (i + 1) == len1 = (0 , j + 1) - | otherwise = (i + 1, j) - -{- An alternative implementation - * The one above is certainly better for flattened code, but here where we - are handling boxed arrays, the trade off is less clear. However, I - think, the above one is still better. - -crossP a1 a2 = let - len1 = lengthP a1 - len2 = lengthP a2 - x1 = concatP $ mapP (replicateP len2) a1 - x2 = concatP $ replicateP len1 a2 - in - zipP x1 x2 - -} - --- computes an index array for all elements of the second argument for which --- the predicate yields `True' (EXPORTED) --- -indexOfP :: (a -> Bool) -> [:a:] -> [:Int:] -indexOfP p a = fst $ loop calcIdx 0 a - where - calcIdx e idx | p e = (Just idx, idx + 1) - | otherwise = (Nothing , idx ) - - --- auxiliary functions --- ------------------- - --- internally used mutable boxed arrays --- -data MPArr s e = MPArr Int# (MutableArray# s e) - --- allocate a new mutable array that is pre-initialised with a given value --- -newArray :: Int -> e -> ST s (MPArr s e) -{-# INLINE newArray #-} -newArray (I# n#) e = ST $ \s1# -> - case newArray# n# e s1# of { (# s2#, marr# #) -> - (# s2#, MPArr n# marr# #)} - --- convert a mutable array into the external parallel array representation --- -mkPArr :: Int -> MPArr s e -> ST s [:e:] -{-# INLINE mkPArr #-} -mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# -> - case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> - (# s2#, PArr n# arr# #) } - --- general array iterator --- --- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty & --- Keller, ICFP 2001 --- -loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element - -> acc -- initial acc value - -> [:e:] -- input array - -> ([:e':], acc) -{-# INLINE loop #-} -loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr - --- general array iterator with bounds --- -loopFromTo :: Int -- from index - -> Int -- to index - -> (e -> acc -> (Maybe e', acc)) - -> acc - -> [:e:] - -> ([:e':], acc) -{-# INLINE loopFromTo #-} -loopFromTo from to mf start arr = runST (do - marr <- newArray (to - from + 1) noElem - (n', acc) <- trans from to marr arr mf start - arr <- mkPArr n' marr - return (arr, acc)) - where - noElem = error "PrelPArr.loopFromTo: I do not exist!" - -- unlike standard Haskell arrays, this value represents an - -- internal error - --- actually loop body of `loop' --- --- * for this to be really efficient, it has to be translated with the --- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03 --- this requires an optimisation level of at least -O2 --- -trans :: Int -- index of first elem to process - -> Int -- index of last elem to process - -> MPArr s e' -- destination array - -> [:e:] -- source array - -> (e -> acc -> (Maybe e', acc)) -- mutator - -> acc -- initial accumulator - -> ST s (Int, acc) -- final destination length/final acc -{-# INLINE trans #-} -trans from to marr arr mf start = trans' from 0 start - where - trans' arrOff marrOff acc - | arrOff > to = return (marrOff, acc) - | otherwise = do - let (oe', acc') = mf (arr `indexPArr` arrOff) acc - marrOff' <- case oe' of - Nothing -> return marrOff - Just e' -> do - writeMPArr marr marrOff e' - return $ marrOff + 1 - trans' (arrOff + 1) marrOff' acc' - - --- common patterns for using `loop' --- - --- initial value for the accumulator when the accumulator is not needed --- -noAL :: () -noAL = () - --- `loop' mutator maps a function over array elements --- -mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ())) -{-# INLINE mapEFL #-} -mapEFL f = \e a -> (Just $ f e, ()) - --- `loop' mutator that filter elements according to a predicate --- -filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ())) -{-# INLINE filterEFL #-} -filterEFL p = \e a -> if p e then (Just e, ()) else (Nothing, ()) - --- `loop' mutator for array folding --- -foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc)) -{-# INLINE foldEFL #-} -foldEFL f = \e a -> (Nothing, f e a) - --- `loop' mutator for array scanning --- -scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc)) -{-# INLINE scanEFL #-} -scanEFL f = \e a -> (Just a, f e a) - --- elementary array operations --- - --- unlifted array indexing --- -indexPArr :: [:e:] -> Int -> e -{-# INLINE indexPArr #-} -indexPArr (PArr _ arr#) (I# i#) = - case indexArray# arr# i# of (# e #) -> e - --- encapsulate writing into a mutable array into the `ST' monad --- -writeMPArr :: MPArr s e -> Int -> e -> ST s () -{-# INLINE writeMPArr #-} -writeMPArr (MPArr _ marr#) (I# i#) e = ST $ \s# -> - case writeArray# marr# i# e s# of s'# -> (# s'#, () #) diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs deleted file mode 100644 index 65fed7d..0000000 --- a/ghc/lib/std/PrelPack.lhs +++ /dev/null @@ -1,231 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelPack.lhs,v 1.16 2001/01/11 17:25:57 simonmar Exp $ -% -% (c) The University of Glasgow, 1997-2000 -% - -\section[PrelPack]{Packing/unpacking bytes} - -This module provides a small set of low-level functions for packing -and unpacking a chunk of bytes. Used by code emitted by the compiler -plus the prelude libraries. - -The programmer level view of packed strings is provided by a GHC -system library PackedString. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelPack - ( - -- (**) - emitted by compiler. - - packCString#, -- :: [Char] -> ByteArray# ** - packString, -- :: [Char] -> ByteArray Int - packStringST, -- :: [Char] -> ST s (ByteArray Int) - packNBytesST, -- :: Int -> [Char] -> ST s (ByteArray Int) - - unpackCString, -- :: Ptr a -> [Char] - unpackCStringST, -- :: Ptr a -> ST s [Char] - unpackNBytes, -- :: Ptr a -> Int -> [Char] - unpackNBytesST, -- :: Ptr a -> Int -> ST s [Char] - unpackNBytesAccST, -- :: Ptr a -> Int -> [Char] -> ST s [Char] - unpackNBytesAccST#,-- :: Ptr a -> Int -> [Char] -> ST s [Char] - unpackCString#, -- :: Addr# -> [Char] ** - unpackNBytes#, -- :: Addr# -> Int# -> [Char] ** - unpackNBytesST#, -- :: Addr# -> Int# -> ST s [Char] - - unpackCStringBA, -- :: ByteArray Int -> [Char] - unpackNBytesBA, -- :: ByteArray Int -> Int -> [Char] - unpackCStringBA#, -- :: ByteArray# -> Int# -> [Char] - unpackNBytesBA#, -- :: ByteArray# -> Int# -> [Char] - - - unpackFoldrCString#, -- ** - unpackAppendCString#, -- ** - - new_ps_array, -- Int# -> ST s (MutableByteArray s Int) - write_ps_array, -- MutableByteArray s Int -> Int# -> Char# -> ST s () - freeze_ps_array -- MutableByteArray s Int -> Int# -> ST s (ByteArray Int) - - ) - where - -import PrelBase -import {-# SOURCE #-} PrelErr ( error ) -import PrelList ( length ) -import PrelST -import PrelNum -import PrelByteArr -import PrelPtr - -\end{code} - -%********************************************************* -%* * -\subsection{Unpacking Ptrs} -%* * -%********************************************************* - -Primitives for converting Addrs pointing to external -sequence of bytes into a list of @Char@s: - -\begin{code} -unpackCString :: Ptr a -> [Char] -unpackCString a@(Ptr addr) - | a == nullPtr = [] - | otherwise = unpackCString# addr - -unpackNBytes :: Ptr a -> Int -> [Char] -unpackNBytes (Ptr addr) (I# l) = unpackNBytes# addr l - -unpackCStringST :: Ptr a{- ptr. to NUL terminated string-} -> ST s [Char] -unpackCStringST a@(Ptr addr) - | a == nullPtr = return [] - | otherwise = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = return [] - | otherwise = do - ls <- unpack (nh +# 1#) - return ((C# ch ) : ls) - where - ch = indexCharOffAddr# addr nh - -unpackNBytesST :: Ptr a -> Int -> ST s [Char] -unpackNBytesST (Ptr addr) (I# l) = unpackNBytesAccST# addr l [] - -unpackNBytesAccST :: Ptr a -> Int -> [Char] -> ST s [Char] -unpackNBytesAccST (Ptr addr) (I# l) rest = unpackNBytesAccST# addr l rest - -unpackNBytesST# :: Addr# -> Int# -> ST s [Char] -unpackNBytesST# addr# l# = unpackNBytesAccST# addr# l# [] - -unpackNBytesAccST# :: Addr# -> Int# -> [Char] -> ST s [Char] -unpackNBytesAccST# _addr 0# rest = return rest -unpackNBytesAccST# addr len# rest = unpack rest (len# -# 1#) - where - unpack acc i# - | i# <# 0# = return acc - | otherwise = - case indexCharOffAddr# addr i# of - ch -> unpack (C# ch : acc) (i# -# 1#) - -\end{code} - -%******************************************************** -%* * -\subsection{Unpacking ByteArrays} -%* * -%******************************************************** - -Converting byte arrays into list of chars: - -\begin{code} -unpackCStringBA :: ByteArray Int -> [Char] -unpackCStringBA (ByteArray l@(I# l#) u@(I# u#) bytes) - | l > u = [] - | otherwise = unpackCStringBA# bytes (u# -# l# +# 1#) - -{- - unpack until NUL or end of BA is reached, whatever comes first. --} -unpackCStringBA# :: ByteArray# -> Int# -> [Char] -unpackCStringBA# bytes len - = unpack 0# - where - unpack nh - | nh >=# len || - ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - ch = indexCharArray# bytes nh - -unpackNBytesBA :: ByteArray Int -> Int -> [Char] -unpackNBytesBA (ByteArray l u bytes) i - = unpackNBytesBA# bytes len# - where - len# = case max 0 (min i len) of I# v# -> v# - len | l > u = 0 - | otherwise = u-l+1 - -unpackNBytesBA# :: ByteArray# -> Int# -> [Char] -unpackNBytesBA# _bytes 0# = [] -unpackNBytesBA# bytes len# = unpack [] (len# -# 1#) - where - unpack acc i# - | i# <# 0# = acc - | otherwise = - case indexCharArray# bytes i# of - ch -> unpack (C# ch : acc) (i# -# 1#) - -\end{code} - - -%******************************************************** -%* * -\subsection{Packing Strings} -%* * -%******************************************************** - -Converting a list of chars into a packed @ByteArray@ representation. - -\begin{code} -packCString# :: [Char] -> ByteArray# -packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes } - -packString :: [Char] -> ByteArray Int -packString str = runST (packStringST str) - -packStringST :: [Char] -> ST s (ByteArray Int) -packStringST str = - let len = length str in - packNBytesST len str - -packNBytesST :: Int -> [Char] -> ST s (ByteArray Int) -packNBytesST (I# length#) str = - {- - allocate an array that will hold the string - (not forgetting the NUL byte at the end) - -} - new_ps_array (length# +# 1#) >>= \ ch_array -> - -- fill in packed string from "str" - fill_in ch_array 0# str >> - -- freeze the puppy: - freeze_ps_array ch_array length# - where - fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s () - fill_in arr_in# idx [] = - write_ps_array arr_in# idx (chr# 0#) >> - return () - - fill_in arr_in# idx (C# c : cs) = - write_ps_array arr_in# idx c >> - fill_in arr_in# (idx +# 1#) cs - -\end{code} - -(Very :-) ``Specialised'' versions of some CharArray things... - -\begin{code} -new_ps_array :: Int# -> ST s (MutableByteArray s Int) -write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s () -freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int) - -new_ps_array size = ST $ \ s -> - case (newByteArray# size s) of { (# s2#, barr# #) -> - (# s2#, MutableByteArray bot bot barr# #) } - where - bot = error "new_ps_array" - -write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# -> - case writeCharArray# barr# n ch s# of { s2# -> - (# s2#, () #) } - --- same as unsafeFreezeByteArray -freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# -> - case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) -> - (# s2#, ByteArray 0 (I# len#) frozen# #) } -\end{code} - - diff --git a/ghc/lib/std/PrelPosix.hs b/ghc/lib/std/PrelPosix.hs deleted file mode 100644 index ba72bdb..0000000 --- a/ghc/lib/std/PrelPosix.hs +++ /dev/null @@ -1,331 +0,0 @@ -{-# OPTIONS -fno-implicit-prelude -#include "PrelIOUtils.h" #-} - --- --------------------------------------------------------------------------- --- --- POSIX support layer for the standard libraries --- --- Non-posix compliant in order to support the following features: --- * S_ISSOCK (no sockets in POSIX) - -module PrelPosix where - --- See above comment for non-Posixness reasons. --- #include "PosixSource.h" - -#include "config.h" - -import PrelBase -import PrelNum -import PrelReal -import PrelMaybe -import PrelCString -import PrelPtr -import PrelWord -import PrelInt -import PrelCTypesISO -import PrelCTypes -import PrelCError -import PrelStorable -import PrelMarshalAlloc -import PrelMarshalUtils -import PrelBits -import PrelIOBase -import Monad - - --- --------------------------------------------------------------------------- --- Types - -data CDir = CDir -type CSigset = () - -type CDev = HTYPE_DEV_T -type CIno = HTYPE_INO_T -type CMode = HTYPE_MODE_T -type COff = HTYPE_OFF_T -type CPid = HTYPE_PID_T - -#ifdef mingw32_TARGET_OS -type CSsize = HTYPE_SIZE_T -#else -type CGid = HTYPE_GID_T -type CNlink = HTYPE_NLINK_T -type CSsize = HTYPE_SSIZE_T -type CUid = HTYPE_UID_T -type CCc = HTYPE_CC_T -type CSpeed = HTYPE_SPEED_T -type CTcflag = HTYPE_TCFLAG_T -#endif - --- --------------------------------------------------------------------------- --- stat()-related stuff - -type CStat = () - -fdFileSize :: Int -> IO Integer -fdFileSize fd = - allocaBytes sizeof_stat $ \ p_stat -> do - throwErrnoIfMinus1Retry "fileSize" $ - c_fstat (fromIntegral fd) p_stat - c_mode <- st_mode p_stat :: IO CMode - if not (s_isreg c_mode) - then return (-1) - else do - c_size <- st_size p_stat :: IO COff - return (fromIntegral c_size) - -data FDType = Directory | Stream | RegularFile - deriving (Eq) - --- NOTE: On Win32 platforms, this will only work with file descriptors --- referring to file handles. i.e., it'll fail for socket FDs. -fdType :: Int -> IO FDType -fdType fd = - allocaBytes sizeof_stat $ \ p_stat -> do - throwErrnoIfMinus1Retry "fdType" $ - c_fstat (fromIntegral fd) p_stat - c_mode <- st_mode p_stat :: IO CMode - case () of - _ | s_isdir c_mode -> return Directory - | s_isfifo c_mode -> return Stream - | s_issock c_mode -> return Stream - | s_ischr c_mode -> return Stream - | s_isreg c_mode -> return RegularFile - | s_isblk c_mode -> return RegularFile - | otherwise -> ioException ioe_unknownfiletype - -- we consider character devices to be streams (eg. ttys), - -- whereas block devices are more like regular files because they - -- are seekable. - -ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType" - "unknown file type" Nothing - -foreign import "s_isreg_PrelPosix_wrap" unsafe s_isreg :: CMode -> Bool -foreign import "s_isdir_PrelPosix_wrap" unsafe s_isdir :: CMode -> Bool -foreign import "s_isfifo_PrelPosix_wrap" unsafe s_isfifo :: CMode -> Bool -foreign import "s_ischr_PrelPosix_wrap" unsafe s_ischr :: CMode -> Bool -foreign import "s_isblk_PrelPosix_wrap" unsafe s_isblk :: CMode -> Bool - -#ifndef mingw32_TARGET_OS -foreign import "s_issock_PrelPosix_wrap" unsafe s_issock :: CMode -> Bool - -#else -s_issock :: CMode -> Bool -s_issock cmode = False -#endif - --- It isn't clear whether ftruncate is POSIX or not (I've read several --- manpages and they seem to conflict), so we truncate using open/2. -fileTruncate :: FilePath -> IO () -fileTruncate file = do - let flags = o_WRONLY .|. o_TRUNC - withCString file $ \file_cstr -> do - fd <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "fileTruncate" - (c_open file_cstr (fromIntegral flags) 0o666) - c_close fd - return () - --- --------------------------------------------------------------------------- --- Terminal-related stuff - -fdIsTTY :: Int -> IO Bool -fdIsTTY fd = c_isatty (fromIntegral fd) >>= return.toBool - -#ifndef mingw32_TARGET_OS - -type Termios = () - -setEcho :: Int -> Bool -> IO () -setEcho fd on = do - allocaBytes sizeof_termios $ \p_tios -> do - throwErrnoIfMinus1Retry "setEcho" - (c_tcgetattr (fromIntegral fd) p_tios) - c_lflag <- c_lflag p_tios :: IO CTcflag - let new_c_lflag | on = c_lflag .|. fromIntegral prel_echo - | otherwise = c_lflag .&. complement (fromIntegral prel_echo) - poke_c_lflag p_tios (new_c_lflag :: CTcflag) - tcSetAttr fd prel_tcsanow p_tios - -getEcho :: Int -> IO Bool -getEcho fd = do - allocaBytes sizeof_termios $ \p_tios -> do - throwErrnoIfMinus1Retry "setEcho" - (c_tcgetattr (fromIntegral fd) p_tios) - c_lflag <- c_lflag p_tios :: IO CTcflag - return ((c_lflag .&. fromIntegral prel_echo) /= 0) - -setCooked :: Int -> Bool -> IO () -setCooked fd cooked = - allocaBytes sizeof_termios $ \p_tios -> do - throwErrnoIfMinus1Retry "setCooked" - (c_tcgetattr (fromIntegral fd) p_tios) - - -- turn on/off ICANON - c_lflag <- c_lflag p_tios :: IO CTcflag - let new_c_lflag | cooked = c_lflag .|. (fromIntegral prel_icanon) - | otherwise = c_lflag .&. complement (fromIntegral prel_icanon) - poke_c_lflag p_tios (new_c_lflag :: CTcflag) - - -- set VMIN & VTIME to 1/0 respectively - when cooked $ do - c_cc <- ptr_c_cc p_tios - let vmin = (c_cc `plusPtr` (fromIntegral prel_vmin)) :: Ptr Word8 - vtime = (c_cc `plusPtr` (fromIntegral prel_vtime)) :: Ptr Word8 - poke vmin 1 - poke vtime 0 - - tcSetAttr fd prel_tcsanow p_tios - --- tcsetattr() when invoked by a background process causes the process --- to be sent SIGTTOU regardless of whether the process has TOSTOP set --- in its terminal flags (try it...). This function provides a --- wrapper which temporarily blocks SIGTTOU around the call, making it --- transparent. - -tcSetAttr :: FD -> CInt -> Ptr Termios -> IO () -tcSetAttr fd options p_tios = do - allocaBytes sizeof_sigset_t $ \ p_sigset -> do - allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do - c_sigemptyset p_sigset - c_sigaddset p_sigset prel_sigttou - c_sigprocmask prel_sig_block p_sigset p_old_sigset - throwErrnoIfMinus1Retry_ "tcSetAttr" $ - c_tcsetattr (fromIntegral fd) options p_tios - c_sigprocmask prel_sig_setmask p_old_sigset nullPtr - -foreign import ccall "prel_lflag" c_lflag :: Ptr Termios -> IO CTcflag -foreign import ccall "prel_poke_lflag" poke_c_lflag :: Ptr Termios -> CTcflag -> IO () -foreign import ccall "prel_ptr_c_cc" ptr_c_cc :: Ptr Termios -> IO (Ptr Word8) - -foreign import ccall "prel_echo" unsafe prel_echo :: CInt -foreign import ccall "prel_tcsanow" unsafe prel_tcsanow :: CInt -foreign import ccall "prel_icanon" unsafe prel_icanon :: CInt -foreign import ccall "prel_vmin" unsafe prel_vmin :: CInt -foreign import ccall "prel_vtime" unsafe prel_vtime :: CInt -foreign import ccall "prel_sigttou" unsafe prel_sigttou :: CInt -foreign import ccall "prel_sig_block" unsafe prel_sig_block :: CInt -foreign import ccall "prel_sig_setmask" unsafe prel_sig_setmask :: CInt -foreign import ccall "prel_f_getfl" unsafe prel_f_getfl :: CInt -foreign import ccall "prel_f_setfl" unsafe prel_f_setfl :: CInt -#else - --- bogus defns for win32 -setCooked :: Int -> Bool -> IO () -setCooked fd cooked = return () - -setEcho :: Int -> Bool -> IO () -setEcho fd on = return () - -getEcho :: Int -> IO Bool -getEcho fd = return False - -#endif - --- --------------------------------------------------------------------------- --- Turning on non-blocking for a file descriptor - -#ifndef mingw32_TARGET_OS - -setNonBlockingFD fd = do - flags <- throwErrnoIfMinus1Retry "setNonBlockingFD" - (fcntl_read (fromIntegral fd) prel_f_getfl) - -- An error when setting O_NONBLOCK isn't fatal: on some systems - -- there are certain file handles on which this will fail (eg. /dev/null - -- on FreeBSD) so we throw away the return code from fcntl_write. - fcntl_write (fromIntegral fd) prel_f_setfl (flags .|. o_NONBLOCK) -#else - --- bogus defns for win32 -setNonBlockingFD fd = return () - -#endif - --- ----------------------------------------------------------------------------- --- foreign imports - -foreign import "stat" unsafe - c_stat :: CString -> Ptr CStat -> IO CInt - -foreign import "fstat" unsafe - c_fstat :: CInt -> Ptr CStat -> IO CInt - -foreign import "open" unsafe - c_open :: CString -> CInt -> CMode -> IO CInt - -foreign import ccall "prel_sizeof_stat" unsafe sizeof_stat :: Int -foreign import ccall "prel_st_mtime" unsafe st_mtime :: Ptr CStat -> IO CTime -foreign import ccall "prel_st_size" unsafe st_size :: Ptr CStat -> IO COff -foreign import ccall "prel_st_mode" unsafe st_mode :: Ptr CStat -> IO CMode - -#ifndef mingw32_TARGET_OS -foreign import ccall "prel_sizeof_termios" unsafe sizeof_termios :: Int -foreign import ccall "prel_sizeof_sigset_t" unsafe sizeof_sigset_t :: Int -#endif - --- POSIX flags only: -foreign import ccall "prel_o_rdonly" unsafe o_RDONLY :: CInt -foreign import ccall "prel_o_wronly" unsafe o_WRONLY :: CInt -foreign import ccall "prel_o_rdwr" unsafe o_RDWR :: CInt -foreign import ccall "prel_o_append" unsafe o_APPEND :: CInt -foreign import ccall "prel_o_creat" unsafe o_CREAT :: CInt -foreign import ccall "prel_o_excl" unsafe o_EXCL :: CInt -foreign import ccall "prel_o_trunc" unsafe o_TRUNC :: CInt - - --- non-POSIX flags. -foreign import ccall "prel_o_noctty" unsafe o_NOCTTY :: CInt -foreign import ccall "prel_o_nonblock" unsafe o_NONBLOCK :: CInt -foreign import ccall "prel_o_binary" unsafe o_BINARY :: CInt - - -foreign import "isatty" unsafe - c_isatty :: CInt -> IO CInt - -foreign import "close" unsafe - c_close :: CInt -> IO CInt - -#ifdef mingw32_TARGET_OS -closeFd :: Bool -> CInt -> IO CInt -closeFd isStream fd - | isStream = c_closesocket fd - | otherwise = c_close fd - -foreign import "closesocket" unsafe - c_closesocket :: CInt -> IO CInt -#endif - -foreign import "lseek" unsafe - c_lseek :: CInt -> COff -> CInt -> IO COff - -#ifndef mingw32_TARGET_OS -foreign import "fcntl" unsafe - fcntl_read :: CInt -> CInt -> IO CInt - -foreign import "fcntl" unsafe - fcntl_write :: CInt -> CInt -> CInt -> IO CInt - -foreign import "fork" unsafe - fork :: IO CPid - -foreign import "sigemptyset_PrelPosix_wrap" unsafe - c_sigemptyset :: Ptr CSigset -> IO () - -foreign import "sigaddset" unsafe - c_sigaddset :: Ptr CSigset -> CInt -> IO () - -foreign import "sigprocmask" unsafe - c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO () - -foreign import "tcgetattr" unsafe - c_tcgetattr :: CInt -> Ptr Termios -> IO CInt - -foreign import "tcsetattr" unsafe - c_tcsetattr :: CInt -> CInt -> Ptr Termios -> IO CInt - -foreign import "unlink" unsafe - c_unlink :: CString -> IO CInt - -foreign import "waitpid" unsafe - c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid -#endif diff --git a/ghc/lib/std/PrelPtr.lhs b/ghc/lib/std/PrelPtr.lhs deleted file mode 100644 index ddff34e..0000000 --- a/ghc/lib/std/PrelPtr.lhs +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------ --- $Id: PrelPtr.lhs,v 1.4 2001/10/17 11:26:04 simonpj Exp $ --- --- (c) 2000 --- --- Module PrelPtr - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} -module PrelPtr{-everything-} where - -import PrelBase - ------------------------------------------------------------------------- --- Data pointers. - -data Ptr a = Ptr Addr# deriving (Eq, Ord) - -nullPtr :: Ptr a -nullPtr = Ptr nullAddr# - -castPtr :: Ptr a -> Ptr b -castPtr (Ptr addr) = Ptr addr - -plusPtr :: Ptr a -> Int -> Ptr b -plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d) - -alignPtr :: Ptr a -> Int -> Ptr a -alignPtr addr@(Ptr a) (I# i) - = case remAddr# a i of { - 0# -> addr; - n -> Ptr (plusAddr# a (i -# n)) } - -minusPtr :: Ptr a -> Ptr b -> Int -minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2) - -instance CCallable (Ptr a) -instance CReturnable (Ptr a) - ------------------------------------------------------------------------- --- Function pointers for the default calling convention. - -data FunPtr a = FunPtr Addr# deriving (Eq, Ord) - -nullFunPtr :: FunPtr a -nullFunPtr = FunPtr nullAddr# - -castFunPtr :: FunPtr a -> FunPtr b -castFunPtr (FunPtr addr) = FunPtr addr - -castFunPtrToPtr :: FunPtr a -> Ptr b -castFunPtrToPtr (FunPtr addr) = Ptr addr - -castPtrToFunPtr :: Ptr a -> FunPtr b -castPtrToFunPtr (Ptr addr) = FunPtr addr - -instance CCallable (FunPtr a) -instance CReturnable (FunPtr a) -\end{code} - diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs deleted file mode 100644 index 2b060fc..0000000 --- a/ghc/lib/std/PrelRead.lhs +++ /dev/null @@ -1,607 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelRead.lhs,v 1.22 2001/11/23 16:20:08 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelRead]{Module @PrelRead@} - -Instances of the Read class. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelRead where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelEnum ( Enum(..), maxBound ) -import PrelNum -import PrelReal -import PrelFloat -import PrelList -import PrelMaybe -import PrelShow -- isAlpha etc -import PrelBase -\end{code} - -%********************************************************* -%* * -\subsection{The @Read@ class} -%* * -%********************************************************* - -Note: if you compile this with -DNEW_READS_REP, you'll get -a (simpler) ReadS representation that only allow one valid -parse of a string of characters, instead of a list of -possible ones. - -[changing the ReadS rep has implications for the deriving -machinery for Read, a change that hasn't been made, so you -probably won't want to compile in this new rep. except -when in an experimental mood.] - -\begin{code} - -#ifndef NEW_READS_REP -type ReadS a = String -> [(a,String)] -#else -type ReadS a = String -> Maybe (a,String) -#endif - -class Read a where - readsPrec :: Int -> ReadS a - - readList :: ReadS [a] - readList = readList__ reads -\end{code} - -In this module we treat [(a,String)] as a monad in MonadPlus -But MonadPlus isn't defined yet, so we simply give local -declarations for mzero and guard suitable for this particular -type. It would also be reasonably to move MonadPlus to PrelBase -along with Monad and Functor, but that seems overkill for one -example - -\begin{code} -mzero :: [a] -mzero = [] - -guard :: Bool -> [()] -guard True = [()] -guard False = [] -\end{code} - -%********************************************************* -%* * -\subsection{Utility functions} -%* * -%********************************************************* - -\begin{code} -reads :: (Read a) => ReadS a -reads = readsPrec 0 - -read :: (Read a) => String -> a -read s = - case read_s s of -#ifndef NEW_READS_REP - [x] -> x - [] -> error "Prelude.read: no parse" - _ -> error "Prelude.read: ambiguous parse" -#else - Just x -> x - Nothing -> error "Prelude.read: no parse" -#endif - where - read_s str = do - (x,str1) <- reads str - ("","") <- lex str1 - return x -\end{code} - -\begin{code} -readParen :: Bool -> ReadS a -> ReadS a -readParen b g = if b then mandatory else optional - where optional r = g r ++ mandatory r - mandatory r = do - ("(",s) <- lex r - (x,t) <- optional s - (")",u) <- lex t - return (x,u) - - -readList__ :: ReadS a -> ReadS [a] - -readList__ readx - = readParen False (\r -> do - ("[",s) <- lex r - readl s) - where readl s = - (do { ("]",t) <- lex s ; return ([],t) }) ++ - (do { (x,t) <- readx s ; (xs,u) <- readl2 t ; return (x:xs,u) }) - - readl2 s = - (do { ("]",t) <- lex s ; return ([],t) }) ++ - (do { (",",t) <- lex s ; (x,u) <- readx t ; (xs,v) <- readl2 u ; return (x:xs,v) }) - -\end{code} - - -%********************************************************* -%* * -\subsection{Lexical analysis} -%* * -%********************************************************* - -This lexer is not completely faithful to the Haskell lexical syntax. -Current limitations: - Qualified names are not handled properly - A `--' does not terminate a symbol - Octal and hexidecimal numerics are not recognized as a single token - -\begin{code} -lex :: ReadS String - -lex "" = return ("","") -lex (c:s) | isSpace c = lex (dropWhile isSpace s) -lex ('\'':s) = do - (ch, '\'':t) <- lexLitChar s - guard (ch /= "'") - return ('\'':ch++"'", t) -lex ('"':s) = do - (str,t) <- lexString s - return ('"':str, t) - - where - lexString ('"':s) = return ("\"",s) - lexString s = do - (ch,t) <- lexStrItem s - (str,u) <- lexString t - return (ch++str, u) - - - lexStrItem ('\\':'&':s) = return ("\\&",s) - lexStrItem ('\\':c:s) | isSpace c = do - ('\\':t) <- return (dropWhile isSpace s) - return ("\\&",t) - lexStrItem s = lexLitChar s - -lex (c:s) | isSingle c = return ([c],s) - | isSym c = do - (sym,t) <- return (span isSym s) - return (c:sym,t) - | isAlpha c = do - (nam,t) <- return (span isIdChar s) - return (c:nam, t) - | isDigit c = do -{- Removed, 13/03/2000 by SDM. - Doesn't work, and not required by Haskell report. - let - (pred, s', isDec) = - case s of - ('o':rs) -> (isOctDigit, rs, False) - ('O':rs) -> (isOctDigit, rs, False) - ('x':rs) -> (isHexDigit, rs, False) - ('X':rs) -> (isHexDigit, rs, False) - _ -> (isDigit, s, True) --} - (ds,s) <- return (span isDigit s) - (fe,t) <- lexFracExp s - return (c:ds++fe,t) - | otherwise = mzero -- bad character - where - isSingle c = c `elem` ",;()[]{}_`" - isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" - isIdChar c = isAlphaNum c || c `elem` "_'" - - lexFracExp ('.':c:cs) | isDigit c = do - (ds,t) <- lex0Digits cs - (e,u) <- lexExp t - return ('.':c:ds++e,u) - lexFracExp s = return ("",s) - - lexExp (e:s) | e `elem` "eE" = - (do - (c:t) <- return s - guard (c `elem` "+-") - (ds,u) <- lexDecDigits t - return (e:c:ds,u)) ++ - (do - (ds,t) <- lexDecDigits s - return (e:ds,t)) - - lexExp s = return ("",s) - -lexDigits :: ReadS String -lexDigits = lexDecDigits - -lexDecDigits :: ReadS String -lexDecDigits = nonnull isDigit - -lexOctDigits :: ReadS String -lexOctDigits = nonnull isOctDigit - -lexHexDigits :: ReadS String -lexHexDigits = nonnull isHexDigit - --- 0 or more digits -lex0Digits :: ReadS String -lex0Digits s = return (span isDigit s) - -nonnull :: (Char -> Bool) -> ReadS String -nonnull p s = do - (cs@(_:_),t) <- return (span p s) - return (cs,t) - -lexLitChar :: ReadS String -lexLitChar ('\\':s) = do - (esc,t) <- lexEsc s - return ('\\':esc, t) - where - lexEsc (c:s) | c `elem` escChars = return ([c],s) - lexEsc s@(d:_) | isDigit d = checkSize 10 lexDecDigits s - lexEsc ('o':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s) - lexEsc ('O':d:s) | isOctDigit d = checkSize 8 lexOctDigits (d:s) - lexEsc ('x':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s) - lexEsc ('X':d:s) | isHexDigit d = checkSize 16 lexHexDigits (d:s) - lexEsc ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)] -- cf. cntrl in 2.6 of H. report. - lexEsc s@(c:_) | isUpper c = fromAsciiLab s - lexEsc _ = mzero - - escChars = "abfnrtv\\\"'" - - fromAsciiLab (x:y:z:ls) | isUpper y && (isUpper z || isDigit z) && - [x,y,z] `elem` asciiEscTab = return ([x,y,z], ls) - fromAsciiLab (x:y:ls) | isUpper y && - [x,y] `elem` asciiEscTab = return ([x,y], ls) - fromAsciiLab _ = mzero - - asciiEscTab = "DEL" : asciiTab - - {- - Check that the numerically escaped char literals are - within accepted boundaries. - - Note: this allows char lits with leading zeros, i.e., - \0000000000000000000000000000001. - -} - checkSize base f str = do - (num, res) <- f str - if toAnInteger base num > toInteger (ord maxBound) then - mzero - else - case base of - 8 -> return ('o':num, res) - 16 -> return ('x':num, res) - _ -> return (num, res) - - toAnInteger base = foldl (\ acc n -> acc*base + toInteger (digitToInt n)) 0 - - -lexLitChar (c:s) = return ([c],s) -lexLitChar "" = mzero - -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 " ++ show c) -- sigh -\end{code} - -%********************************************************* -%* * -\subsection{Instances of @Read@} -%* * -%********************************************************* - -\begin{code} -instance Read Char where - readsPrec _ = readParen False - (\r -> do - ('\'':s,t) <- lex r - (c,"\'") <- readLitChar s - return (c,t)) - - readList = readParen False (\r -> do - ('"':s,t) <- lex r - (l,_) <- readl s - return (l,t)) - where readl ('"':s) = return ("",s) - readl ('\\':'&':s) = readl s - readl s = do - (c,t) <- readLitChar s - (cs,u) <- readl t - return (c:cs,u) - -instance Read Bool where - readsPrec _ = readParen False - (\r -> - lex r >>= \ lr -> - (do { ("True", rest) <- return lr ; return (True, rest) }) ++ - (do { ("False", rest) <- return lr ; return (False, rest) })) - - -instance Read Ordering where - readsPrec _ = readParen False - (\r -> - lex r >>= \ lr -> - (do { ("LT", rest) <- return lr ; return (LT, rest) }) ++ - (do { ("EQ", rest) <- return lr ; return (EQ, rest) }) ++ - (do { ("GT", rest) <- return lr ; return (GT, rest) })) - -instance Read a => Read (Maybe a) where - readsPrec _ = readParen False - (\r -> - lex r >>= \ lr -> - (do { ("Nothing", rest) <- return lr ; return (Nothing, rest)}) ++ - (do - ("Just", rest1) <- return lr - (x, rest2) <- reads rest1 - return (Just x, rest2))) - -instance (Read a, Read b) => Read (Either a b) where - readsPrec _ = readParen False - (\r -> - lex r >>= \ lr -> - (do - ("Left", rest1) <- return lr - (x, rest2) <- reads rest1 - return (Left x, rest2)) ++ - (do - ("Right", rest1) <- return lr - (x, rest2) <- reads rest1 - return (Right x, rest2))) - -instance Read Int where - readsPrec _ x = readSigned readDec x - -instance Read Integer where - readsPrec _ x = readSigned readDec x - -instance Read Float where - readsPrec _ x = readSigned readFloat x - -instance Read Double where - readsPrec _ x = readSigned readFloat x - -instance (Integral a, Read a) => Read (Ratio a) where - readsPrec p = readParen (p > ratio_prec) - (\r -> do - (x,s) <- reads r - ("%",t) <- lex s - (y,u) <- reads t - return (x % y,u)) - -instance (Read a) => Read [a] where - readsPrec _ = readList - -instance Read () where - readsPrec _ = readParen False - (\r -> do - ("(",s) <- lex r - (")",t) <- lex s - return ((),t)) - -instance (Read a, Read b) => Read (a,b) where - readsPrec _ = readParen False - (\r -> do - ("(",s) <- lex r - (x,t) <- readsPrec 0 s - (",",u) <- lex t - (y,v) <- readsPrec 0 u - (")",w) <- lex v - return ((x,y), w)) - -instance (Read a, Read b, Read c) => Read (a, b, c) where - readsPrec _ = readParen False - (\a -> do - ("(",b) <- lex a - (x,c) <- readsPrec 0 b - (",",d) <- lex c - (y,e) <- readsPrec 0 d - (",",f) <- lex e - (z,g) <- readsPrec 0 f - (")",h) <- lex g - return ((x,y,z), h)) - -instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where - readsPrec _ = readParen False - (\a -> do - ("(",b) <- lex a - (w,c) <- readsPrec 0 b - (",",d) <- lex c - (x,e) <- readsPrec 0 d - (",",f) <- lex e - (y,g) <- readsPrec 0 f - (",",h) <- lex g - (z,h) <- readsPrec 0 h - (")",i) <- lex h - return ((w,x,y,z), i)) - -instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where - readsPrec _ = readParen False - (\a -> do - ("(",b) <- lex a - (v,c) <- readsPrec 0 b - (",",d) <- lex c - (w,e) <- readsPrec 0 d - (",",f) <- lex e - (x,g) <- readsPrec 0 f - (",",h) <- lex g - (y,i) <- readsPrec 0 h - (",",j) <- lex i - (z,k) <- readsPrec 0 j - (")",l) <- lex k - return ((v,w,x,y,z), l)) -\end{code} - - -%********************************************************* -%* * -\subsection{Reading characters} -%* * -%********************************************************* - -\begin{code} -readLitChar :: ReadS Char - -readLitChar [] = mzero -readLitChar ('\\':s) = readEsc s - where - readEsc ('a':s) = return ('\a',s) - readEsc ('b':s) = return ('\b',s) - readEsc ('f':s) = return ('\f',s) - readEsc ('n':s) = return ('\n',s) - readEsc ('r':s) = return ('\r',s) - readEsc ('t':s) = return ('\t',s) - readEsc ('v':s) = return ('\v',s) - readEsc ('\\':s) = return ('\\',s) - readEsc ('"':s) = return ('"',s) - readEsc ('\'':s) = return ('\'',s) - readEsc ('^':c:s) | c >= '@' && c <= '_' - = return (chr (ord c - ord '@'), s) - readEsc s@(d:_) | isDigit d - = do - (n,t) <- readDec s - return (chr n,t) - readEsc ('o':s) = do - (n,t) <- readOct s - return (chr n,t) - readEsc ('x':s) = do - (n,t) <- readHex s - return (chr n,t) - - readEsc s@(c:_) | isUpper c - = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab - in case [(c,s') | (c, mne) <- table, - ([],s') <- [match mne s]] - of (pr:_) -> return pr - [] -> mzero - readEsc _ = mzero - -readLitChar (c:s) = return (c,s) - -match :: (Eq a) => [a] -> [a] -> ([a],[a]) -match (x:xs) (y:ys) | x == y = match xs ys -match xs ys = (xs,ys) - -\end{code} - - -%********************************************************* -%* * -\subsection{Reading numbers} -%* * -%********************************************************* - -Note: reading numbers at bases different than 10, does not -include lexing common prefixes such as '0x' or '0o' etc. - -\begin{code} -{-# SPECIALISE readDec :: - ReadS Int, - ReadS Integer #-} -readDec :: (Integral a) => ReadS a -readDec = readInt 10 isDigit (\d -> ord d - ord '0') - -{-# SPECIALISE readOct :: - ReadS Int, - ReadS Integer #-} -readOct :: (Integral a) => ReadS a -readOct = readInt 8 isOctDigit (\d -> ord d - ord '0') - -{-# SPECIALISE readHex :: - ReadS Int, - ReadS Integer #-} -readHex :: (Integral a) => ReadS a -readHex = readInt 16 isHexDigit hex - where hex d = ord d - (if isDigit d then ord '0' - else ord (if isUpper d then 'A' else 'a') - 10) - -readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a -readInt radix isDig digToInt s = do - (ds,r) <- nonnull isDig s - return (foldl1 (\n d -> n * radix + d) - (map (fromInteger . toInteger . digToInt) ds), r) - -{-# SPECIALISE readSigned :: - ReadS Int -> ReadS Int, - ReadS Integer -> ReadS Integer, - ReadS Double -> ReadS Double #-} -readSigned :: (Real a) => ReadS a -> ReadS a -readSigned readPos = readParen False read' - where read' r = read'' r ++ - (do - ("-",s) <- lex r - (x,t) <- read'' s - return (-x,t)) - read'' r = do - (str,s) <- lex r - (n,"") <- readPos str - return (n,s) -\end{code} - -The functions readFloat below uses rational arithmetic -to ensure correct conversion between the floating-point radix and -decimal. It is often possible to use a higher-precision floating- -point type to obtain the same results. - -\begin{code} -{-# SPECIALISE readFloat :: - ReadS Double, - ReadS Float #-} -readFloat :: (RealFloat a) => ReadS a -readFloat r = - (do - (x,t) <- readRational r - return (fromRational x,t) ) ++ - (do - ("NaN",t) <- lex r - return (0/0,t) ) ++ - (do - ("Infinity",t) <- lex r - return (1/0,t) ) - -readRational :: ReadS Rational -- NB: doesn't handle leading "-" -readRational r = do - (n,d,s) <- readFix r - (k,t) <- readExp s - return ((n%1)*10^^(k-d), t) - where - readFix r = do - (ds,s) <- lexDecDigits r - (ds',t) <- lexDotDigits s - return (read (ds++ds'), length ds', t) - - readExp (e:s) | e `elem` "eE" = readExp' s - readExp s = return (0,s) - - readExp' ('+':s) = readDec s - readExp' ('-':s) = do - (k,t) <- readDec s - return (-k,t) - readExp' s = readDec s - - lexDotDigits ('.':s) = lex0Digits s - lexDotDigits s = return ("",s) - -readRational__ :: String -> Rational -- we export this one (non-std) - -- NB: *does* handle a leading "-" -readRational__ top_s - = case top_s of - '-' : xs -> - (read_me xs) - xs -> read_me xs - where - read_me s - = case (do { (x,t) <- readRational s ; ("","") <- lex t ; return x }) of -#ifndef NEW_READS_REP - [x] -> x - [] -> error ("readRational__: no parse:" ++ top_s) - _ -> error ("readRational__: ambiguous parse:" ++ top_s) -#else - Just x -> x - Nothing -> error ("readRational__: no parse:" ++ top_s) -#endif - -\end{code} diff --git a/ghc/lib/std/PrelReal.lhs b/ghc/lib/std/PrelReal.lhs deleted file mode 100644 index cd2c1c0..0000000 --- a/ghc/lib/std/PrelReal.lhs +++ /dev/null @@ -1,370 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelReal.lhs,v 1.16 2001/09/26 16:27:04 simonpj Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[PrelReal]{Module @PrelReal@} - -The types - - Ratio, Rational - -and the classes - - Real - Integral - Fractional - RealFrac - - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelReal where - -import {-# SOURCE #-} PrelErr -import PrelBase -import PrelNum -import PrelList -import PrelEnum -import PrelShow - -infixr 8 ^, ^^ -infixl 7 /, `quot`, `rem`, `div`, `mod` - -default () -- Double isn't available yet, - -- and we shouldn't be using defaults anyway -\end{code} - - -%********************************************************* -%* * -\subsection{The @Ratio@ and @Rational@ types} -%* * -%********************************************************* - -\begin{code} -data (Integral a) => Ratio a = !a :% !a deriving (Eq) -type Rational = Ratio Integer -\end{code} - - -\begin{code} -{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-} -(%) :: (Integral a) => a -> a -> Ratio a -numerator, denominator :: (Integral a) => Ratio a -> a -\end{code} - -\tr{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. - -\begin{code} -reduce :: (Integral a) => a -> a -> Ratio a -{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-} -reduce _ 0 = error "Ratio.%: zero denominator" -reduce x y = (x `quot` d) :% (y `quot` d) - where d = gcd x y -\end{code} - -\begin{code} -x % y = reduce (x * signum y) (abs y) - -numerator (x :% _) = x -denominator (_ :% y) = y -\end{code} - - -%********************************************************* -%* * -\subsection{Standard numeric classes} -%* * -%********************************************************* - -\begin{code} -class (Num a, Ord a) => Real a where - toRational :: a -> Rational - -class (Real a, Enum a) => Integral a where - quot, rem, div, mod :: a -> a -> a - quotRem, divMod :: a -> a -> (a,a) - toInteger :: a -> Integer - - n `quot` d = q where (q,_) = quotRem n d - n `rem` d = r where (_,r) = quotRem n d - n `div` d = q where (q,_) = divMod n d - n `mod` d = r where (_,r) = divMod n d - divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr - where qr@(q,r) = quotRem n d - -class (Num a) => Fractional a where - (/) :: a -> a -> a - recip :: a -> a - fromRational :: Rational -> a - - recip x = 1 / x - x / y = x * recip y - -class (Real a, Fractional a) => RealFrac a where - properFraction :: (Integral b) => a -> (b,a) - truncate, round :: (Integral b) => a -> b - ceiling, floor :: (Integral b) => a -> b - - truncate x = m where (m,_) = properFraction x - - round x = let (n,r) = properFraction x - m = if r < 0 then n - 1 else n + 1 - in case signum (abs r - 0.5) of - -1 -> n - 0 -> if even n then n else m - 1 -> m - - ceiling x = if r > 0 then n + 1 else n - where (n,r) = properFraction x - - floor x = if r < 0 then n - 1 else n - where (n,r) = properFraction x -\end{code} - - -These 'numeric' enumerations come straight from the Report - -\begin{code} -numericEnumFrom :: (Fractional a) => a -> [a] -numericEnumFrom = iterate (+1) - -numericEnumFromThen :: (Fractional a) => a -> a -> [a] -numericEnumFromThen n m = iterate (+(m-n)) n - -numericEnumFromTo :: (Ord a, Fractional a) => a -> a -> [a] -numericEnumFromTo n m = takeWhile (<= m + 1/2) (numericEnumFrom n) - -numericEnumFromThenTo :: (Ord a, Fractional a) => a -> a -> a -> [a] -numericEnumFromThenTo e1 e2 e3 = takeWhile pred (numericEnumFromThen e1 e2) - where - mid = (e2 - e1) / 2 - pred | e2 > e1 = (<= e3 + mid) - | otherwise = (>= e3 + mid) -\end{code} - - -%********************************************************* -%* * -\subsection{Instances for @Int@} -%* * -%********************************************************* - -\begin{code} -instance Real Int where - toRational x = toInteger x % 1 - -instance Integral Int where - toInteger i = int2Integer i -- give back a full-blown Integer - - -- Following chks for zero divisor are non-standard (WDP) - a `quot` b = if b /= 0 - then a `quotInt` b - else error "Prelude.Integral.quot{Int}: divide by 0" - a `rem` b = if b /= 0 - then a `remInt` b - else error "Prelude.Integral.rem{Int}: divide by 0" - - x `div` y = x `divInt` y - x `mod` y = x `modInt` y - - a `quotRem` b = a `quotRemInt` b - a `divMod` b = a `divModInt` b -\end{code} - - -%********************************************************* -%* * -\subsection{Instances for @Integer@} -%* * -%********************************************************* - -\begin{code} -instance Real Integer where - toRational x = x % 1 - -instance Integral Integer where - toInteger n = n - - n `quot` d = n `quotInteger` d - n `rem` d = n `remInteger` d - - n `div` d = q where (q,_) = divMod n d - n `mod` d = r where (_,r) = divMod n d - - a `divMod` b = a `divModInteger` b - a `quotRem` b = a `quotRemInteger` b -\end{code} - - -%********************************************************* -%* * -\subsection{Instances for @Ratio@} -%* * -%********************************************************* - -\begin{code} -instance (Integral a) => Ord (Ratio a) where - {-# SPECIALIZE instance Ord Rational #-} - (x:%y) <= (x':%y') = x * y' <= x' * y - (x:%y) < (x':%y') = x * y' < x' * y - -instance (Integral a) => Num (Ratio a) where - {-# SPECIALIZE instance Num Rational #-} - (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') - (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:%_) = signum x :% 1 - fromInteger x = fromInteger x :% 1 - -instance (Integral a) => Fractional (Ratio a) where - {-# SPECIALIZE instance Fractional Rational #-} - (x:%y) / (x':%y') = (x*y') % (y*x') - recip (x:%y) = y % x - fromRational (x:%y) = fromInteger x :% fromInteger y - -instance (Integral a) => Real (Ratio a) where - {-# SPECIALIZE instance Real Rational #-} - toRational (x:%y) = toInteger x :% toInteger y - -instance (Integral a) => RealFrac (Ratio a) where - {-# SPECIALIZE instance RealFrac Rational #-} - properFraction (x:%y) = (fromInteger (toInteger q), r:%y) - where (q,r) = quotRem x y - -instance (Integral a) => Show (Ratio a) where - {-# SPECIALIZE instance Show Rational #-} - showsPrec p (x:%y) = showParen (p > ratio_prec) - (shows x . showString " % " . shows y) - -ratio_prec :: Int -ratio_prec = 7 - -instance (Integral a) => Enum (Ratio a) where - {-# SPECIALIZE instance Enum Rational #-} - succ x = x + 1 - pred x = x - 1 - - toEnum n = fromInteger (int2Integer n) :% 1 - fromEnum = fromInteger . truncate - - enumFrom = numericEnumFrom - enumFromThen = numericEnumFromThen - enumFromTo = numericEnumFromTo - enumFromThenTo = numericEnumFromThenTo -\end{code} - - -%********************************************************* -%* * -\subsection{Coercions} -%* * -%********************************************************* - -\begin{code} -fromIntegral :: (Integral a, Num b) => a -> b -fromIntegral = fromInteger . toInteger - -{-# RULES -"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int - #-} - -realToFrac :: (Real a, Fractional b) => a -> b -realToFrac = fromRational . toRational - -{-# RULES -"realToFrac/Int->Int" realToFrac = id :: Int -> Int - #-} - --- For backward compatibility -{-# DEPRECATED fromInt "use fromIntegral instead" #-} -fromInt :: Num a => Int -> a -fromInt = fromIntegral - --- For backward compatibility -{-# DEPRECATED toInt "use fromIntegral instead" #-} -toInt :: Integral a => a -> Int -toInt = fromIntegral -\end{code} - -%********************************************************* -%* * -\subsection{Overloaded numeric functions} -%* * -%********************************************************* - -\begin{code} -showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS -showSigned showPos p x - | x < 0 = showParen (p > 6) (showChar '-' . showPos (-x)) - | otherwise = showPos x - -even, odd :: (Integral a) => a -> Bool -even n = n `rem` 2 == 0 -odd = not . even - -------------------------------------------------------- -{-# SPECIALISE (^) :: - Integer -> Integer -> Integer, - Integer -> Int -> Integer, - Int -> Int -> Int #-} -(^) :: (Num a, Integral b) => a -> b -> a -_ ^ 0 = 1 -x ^ n | n > 0 = f x (n-1) x - where f _ 0 y = y - f a d y = g a d where - g b i | even i = g (b*b) (i `quot` 2) - | otherwise = f b (i-1) (b*y) -_ ^ _ = error "Prelude.^: negative exponent" - -{-# SPECIALISE (^^) :: - Rational -> Int -> Rational #-} -(^^) :: (Fractional a, Integral b) => a -> b -> a -x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) - - -------------------------------------------------------- -gcd :: (Integral a) => a -> a -> a -gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" -gcd x y = gcd' (abs x) (abs y) - where gcd' a 0 = a - gcd' a b = gcd' b (a `rem` b) - -lcm :: (Integral a) => a -> a -> a -{-# SPECIALISE lcm :: Int -> Int -> Int #-} -lcm _ 0 = 0 -lcm 0 _ = 0 -lcm x y = abs ((x `quot` (gcd x y)) * y) - - -{-# RULES -"gcd/Int->Int->Int" gcd = gcdInt -"gcd/Integer->Integer->Integer" gcd = gcdInteger -"lcm/Integer->Integer->Integer" lcm = lcmInteger - #-} - -integralEnumFrom :: (Integral a, Bounded a) => a -> [a] -integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)] - -integralEnumFromThen :: (Integral a, Bounded a) => a -> a -> [a] -integralEnumFromThen n1 n2 - | i_n2 >= i_n1 = map fromInteger [i_n1, i_n2 .. toInteger (maxBound `asTypeOf` n1)] - | otherwise = map fromInteger [i_n1, i_n2 .. toInteger (minBound `asTypeOf` n1)] - where - i_n1 = toInteger n1 - i_n2 = toInteger n2 - -integralEnumFromTo :: Integral a => a -> a -> [a] -integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m] - -integralEnumFromThenTo :: Integral a => a -> a -> a -> [a] -integralEnumFromThenTo n1 n2 m - = map fromInteger [toInteger n1, toInteger n2 .. toInteger m] -\end{code} diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs deleted file mode 100644 index 8cf8f37..0000000 --- a/ghc/lib/std/PrelST.lhs +++ /dev/null @@ -1,120 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelST.lhs,v 1.21 2001/09/26 15:12:37 simonpj Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% - -\section[PrelST]{The @ST@ monad} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelST where - -import PrelBase -import PrelShow -import PrelNum - -default () -\end{code} - -%********************************************************* -%* * -\subsection{The @ST@ monad} -%* * -%********************************************************* - -The state-transformer monad proper. By default the monad is strict; -too many people got bitten by space leaks when it was lazy. - -\begin{code} -newtype ST s a = ST (STRep s a) -type STRep s a = State# s -> (# State# s, a #) - -instance Functor (ST s) where - fmap f (ST m) = ST $ \ s -> - case (m s) of { (# new_s, r #) -> - (# new_s, f r #) } - -instance Monad (ST s) where - {-# INLINE return #-} - {-# INLINE (>>) #-} - {-# INLINE (>>=) #-} - return x = ST $ \ s -> (# s, x #) - m >> k = m >>= \ _ -> k - - (ST m) >>= k - = ST $ \ s -> - case (m s) of { (# new_s, r #) -> - case (k r) of { ST k2 -> - (k2 new_s) }} - -data STret s a = STret (State# s) a - --- liftST is useful when we want a lifted result from an ST computation. See --- fixST below. -liftST :: ST s a -> State# s -> STret s a -liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r - -{-# NOINLINE unsafeInterleaveST #-} -unsafeInterleaveST :: ST s a -> ST s a -unsafeInterleaveST (ST m) = ST ( \ s -> - let - r = case m s of (# _, res #) -> res - in - (# s, r #) - ) - -instance Show (ST s a) where - showsPrec _ _ = showString "<>" - showList = showList__ (showsPrec 0) -\end{code} - -Definition of runST -~~~~~~~~~~~~~~~~~~~ - -SLPJ 95/04: Why @runST@ must not have an unfolding; consider: -\begin{verbatim} -f x = - runST ( \ s -> let - (a, s') = newArray# 100 [] s - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' ) -\end{verbatim} -If we inline @runST@, we'll get: -\begin{verbatim} -f x = let - (a, s') = newArray# 100 [] realWorld#{-NB-} - (_, s'') = fill_in_array_or_something a x s' - in - freezeArray# a s'' -\end{verbatim} -And now the @newArray#@ binding can be floated to become a CAF, which -is totally and utterly wrong: -\begin{verbatim} -f = let - (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! - in - \ x -> - let (_, s'') = fill_in_array_or_something a x s' in - freezeArray# a s'' -\end{verbatim} -All calls to @f@ will share a {\em single} array! End SLPJ 95/04. - -\begin{code} -{-# INLINE runST #-} --- The INLINE prevents runSTRep getting inlined in *this* module --- so that it is still visible when runST is inlined in an importing --- module. Regrettably delicate. runST is behaving like a wrapper. -runST :: (forall s. ST s a) -> a -runST st = runSTRep (case st of { ST st_rep -> st_rep }) - --- I'm only letting runSTRep be inlined right at the end, in particular *after* full laziness --- That's what the "INLINE [0]" says. --- SLPJ Apr 99 -{-# INLINE [0] runSTRep #-} -runSTRep :: (forall s. STRep s a) -> a -runSTRep st_rep = case st_rep realWorld# of - (# _, r #) -> r -\end{code} diff --git a/ghc/lib/std/PrelShow.lhs b/ghc/lib/std/PrelShow.lhs deleted file mode 100644 index 409ab93..0000000 --- a/ghc/lib/std/PrelShow.lhs +++ /dev/null @@ -1,378 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelShow.lhs,v 1.14 2001/09/18 14:42:33 simonmar Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% - -\section{Module @PrelShow@} - - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelShow - ( - Show(..), ShowS, - - -- Instances for Show: (), [], Bool, Ordering, Int, Char - - -- Show support code - shows, showChar, showString, showParen, showList__, showSpace, - showLitChar, protectEsc, - intToDigit, showSignedInt, - - -- Character operations - isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, - toUpper, toLower, - asciiTab, - - -- String operations - lines, unlines, words, unwords - ) - where - -import {-# SOURCE #-} PrelErr ( error ) -import PrelBase -import PrelTup -import PrelMaybe -import PrelList ( (!!), break, dropWhile -#ifdef USE_REPORT_PRELUDE - , concatMap, foldr1 -#endif - ) -\end{code} - - - -%********************************************************* -%* * -\subsection{The @Show@ class} -%* * -%********************************************************* - -\begin{code} -type ShowS = String -> String - -class Show a where - showsPrec :: Int -> a -> ShowS - show :: a -> String - showList :: [a] -> ShowS - - showsPrec _ x s = show x ++ s - show x = shows x "" - showList ls s = showList__ shows ls s - -showList__ :: (a -> ShowS) -> [a] -> ShowS -showList__ _ [] s = "[]" ++ s -showList__ showx (x:xs) s = '[' : showx x (showl xs) - where - showl [] = ']' : s - showl (y:ys) = ',' : showx y (showl ys) -\end{code} - -%********************************************************* -%* * -\subsection{Simple Instances} -%* * -%********************************************************* - -\begin{code} - -instance Show () where - showsPrec _ () = showString "()" - -instance Show a => Show [a] where - showsPrec _ = showList - -instance Show Bool where - showsPrec _ True = showString "True" - showsPrec _ False = showString "False" - -instance Show Ordering where - showsPrec _ LT = showString "LT" - showsPrec _ EQ = showString "EQ" - showsPrec _ GT = showString "GT" - -instance Show Char where - showsPrec _ '\'' = showString "'\\''" - showsPrec _ c = showChar '\'' . showLitChar c . showChar '\'' - - showList cs = showChar '"' . showl cs - where showl "" s = showChar '"' s - showl ('"':xs) s = showString "\\\"" (showl xs s) - showl (x:xs) s = showLitChar x (showl xs s) - -- Making 's' an explicit parameter makes it clear to GHC - -- that showl has arity 2, which avoids it allocating an extra lambda - -- The sticking point is the recursive call to (showl xs), which - -- it can't figure out would be ok with arity 2. - -instance Show Int where - showsPrec = showSignedInt - -instance Show a => Show (Maybe a) where - showsPrec _p Nothing s = showString "Nothing" s - showsPrec (I# p#) (Just x) s - = (showParen (p# >=# 10#) $ - showString "Just " . - showsPrec (I# 10#) x) s - -instance (Show a, Show b) => Show (Either a b) where - showsPrec (I# p#) e s = - (showParen (p# >=# 10#) $ - case e of - Left a -> showString "Left " . showsPrec (I# 10#) a - Right b -> showString "Right " . showsPrec (I# 10#) b) - s - -\end{code} - - -%********************************************************* -%* * -\subsection{Show instances for the first few tuples -%* * -%********************************************************* - -\begin{code} --- The explicit 's' parameters are important --- Otherwise GHC thinks that "shows x" might take a lot of work to compute --- and generates defns like --- showsPrec _ (x,y) = let sx = shows x; sy = shows y in --- \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s)))) - -instance (Show a, Show b) => Show (a,b) where - showsPrec _ (x,y) s = (showChar '(' . shows x . showChar ',' . - shows y . showChar ')') - s - -instance (Show a, Show b, Show c) => Show (a, b, c) where - showsPrec _ (x,y,z) s = (showChar '(' . shows x . showChar ',' . - shows y . showChar ',' . - shows z . showChar ')') - s - -instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where - showsPrec _ (w,x,y,z) s = (showChar '(' . shows w . showChar ',' . - shows x . showChar ',' . - shows y . showChar ',' . - shows z . showChar ')') - s - -instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where - showsPrec _ (v,w,x,y,z) s = (showChar '(' . shows v . showChar ',' . - shows w . showChar ',' . - shows x . showChar ',' . - shows y . showChar ',' . - shows z . showChar ')') - s -\end{code} - - -%********************************************************* -%* * -\subsection{Support code for @Show@} -%* * -%********************************************************* - -\begin{code} -shows :: (Show a) => a -> ShowS -shows = showsPrec zeroInt - -showChar :: Char -> ShowS -showChar = (:) - -showString :: String -> ShowS -showString = (++) - -showParen :: Bool -> ShowS -> ShowS -showParen b p = if b then showChar '(' . p . showChar ')' else p - -showSpace :: ShowS -showSpace = {-showChar ' '-} \ xs -> ' ' : xs -\end{code} - -Code specific for characters - -\begin{code} -showLitChar :: Char -> ShowS -showLitChar c s | c > '\DEL' = showChar '\\' (protectEsc isDigit (shows (ord c)) s) -showLitChar '\DEL' s = showString "\\DEL" s -showLitChar '\\' s = showString "\\\\" s -showLitChar c s | c >= ' ' = showChar c s -showLitChar '\a' s = showString "\\a" s -showLitChar '\b' s = showString "\\b" s -showLitChar '\f' s = showString "\\f" s -showLitChar '\n' s = showString "\\n" s -showLitChar '\r' s = showString "\\r" s -showLitChar '\t' s = showString "\\t" s -showLitChar '\v' s = showString "\\v" s -showLitChar '\SO' s = protectEsc (== 'H') (showString "\\SO") s -showLitChar c s = showString ('\\' : asciiTab!!ord c) s - -- I've done manual eta-expansion here, becuase otherwise it's - -- impossible to stop (asciiTab!!ord) getting floated out as an MFE - -protectEsc :: (Char -> Bool) -> ShowS -> ShowS -protectEsc p f = f . cont - where cont s@(c:_) | p c = "\\&" ++ s - cont s = s - -intToDigit :: Int -> Char -intToDigit (I# i) - | i >=# 0# && i <=# 9# = unsafeChr (ord '0' `plusInt` I# i) - | i >=# 10# && i <=# 15# = unsafeChr (ord 'a' `minusInt` I# 10# `plusInt` I# i) - | otherwise = error ("Char.intToDigit: not a digit " ++ show (I# i)) - -\end{code} - -Code specific for Ints. - -\begin{code} -showSignedInt :: Int -> Int -> ShowS -showSignedInt (I# p) (I# n) r - | n <# 0# && p ># 6# = '(' : itos n (')' : r) - | otherwise = itos n r - -itos :: Int# -> String -> String -itos n# cs - | n# <# 0# = let - n'# = negateInt# n# - in if n'# <# 0# -- minInt? - then '-' : itos' (negateInt# (n'# `quotInt#` 10#)) - (itos' (negateInt# (n'# `remInt#` 10#)) cs) - else '-' : itos' n'# cs - | otherwise = itos' n# cs - where - itos' :: Int# -> String -> String - itos' n# cs - | n# <# 10# = C# (chr# (ord# '0'# +# n#)) : cs - | otherwise = case chr# (ord# '0'# +# (n# `remInt#` 10#)) of { c# -> - itos' (n# `quotInt#` 10#) (C# c# : cs) } -\end{code} - -%********************************************************* -%* * -\subsection{Character stuff} -%* * -%********************************************************* - -\begin{code} -isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum, - isAsciiUpper, isAsciiLower :: Char -> Bool -isAscii c = c < '\x80' -isLatin1 c = c <= '\xff' -isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' -isPrint c = not (isControl c) - --- isSpace includes non-breaking space --- Done with explicit equalities both for efficiency, and to avoid a tiresome --- recursion with PrelList elem -isSpace c = c == ' ' || - c == '\t' || - c == '\n' || - c == '\r' || - c == '\f' || - c == '\v' || - c == '\xa0' - --- The upper case ISO characters have the multiplication sign dumped --- randomly in the middle of the range. Go figure. -isUpper 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. -isLower c = c >= 'a' && c <= 'z' || - c >= '\xDF' && c <= '\xF6' || - c >= '\xF8' && c <= '\xFF' -isAsciiLower c = c >= 'a' && c <= 'z' -isAsciiUpper c = c >= 'A' && c <= 'Z' - -isAlpha c = isLower c || isUpper 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 c = isAlpha c || isDigit c - --- Case-changing operations - -toUpper, toLower :: Char -> Char -toUpper c@(C# c#) - | isAsciiLower c = C# (chr# (ord# c# -# 32#)) - | isAscii c = c - -- fall-through to the slower stuff. - | isLower c && c /= '\xDF' && c /= '\xFF' - = unsafeChr (ord c `minusInt` ord 'a' `plusInt` ord 'A') - | otherwise - = c - - - -toLower c@(C# c#) - | isAsciiUpper c = C# (chr# (ord# c# +# 32#)) - | isAscii c = c - | isUpper c = unsafeChr (ord c `minusInt` ord 'A' `plusInt` ord 'a') - | otherwise = c - -asciiTab :: [String] -asciiTab = -- Using an array drags in the array module. 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"] -\end{code} - -%********************************************************* -%* * -\subsection{Functions on strings} -%* * -%********************************************************* - -lines breaks a string up into a list of strings at newline characters. -The resulting strings do not contain newlines. Similary, words -breaks a string up into a list of words, which were delimited by -white space. unlines and unwords are the inverse operations. -unlines joins lines with terminating newlines, and unwords joins -words with separating spaces. - -\begin{code} -lines :: String -> [String] -lines "" = [] -lines s = let (l, s') = break (== '\n') s - in l : case s' of - [] -> [] - (_:s'') -> lines s'' - -words :: String -> [String] -words s = case dropWhile {-partain:Char.-}isSpace s of - "" -> [] - s' -> w : words s'' - where (w, s'') = - break {-partain:Char.-}isSpace s' - -unlines :: [String] -> String -#ifdef USE_REPORT_PRELUDE -unlines = concatMap (++ "\n") -#else --- HBC version (stolen) --- here's a more efficient version -unlines [] = [] -unlines (l:ls) = l ++ '\n' : unlines ls -#endif - -unwords :: [String] -> String -#ifdef USE_REPORT_PRELUDE -unwords [] = "" -unwords ws = foldr1 (\w s -> w ++ ' ':s) ws -#else --- HBC version (stolen) --- here's a more efficient version -unwords [] = "" -unwords [w] = w -unwords (w:ws) = w ++ ' ' : unwords ws -#endif - -\end{code} diff --git a/ghc/lib/std/PrelSplit.lhs b/ghc/lib/std/PrelSplit.lhs deleted file mode 100644 index 7fd3d6b..0000000 --- a/ghc/lib/std/PrelSplit.lhs +++ /dev/null @@ -1,9 +0,0 @@ -\begin{code} -module PrelSplit( Splittable( split ) ) where - --- The Splittable class for the linear implicit parameters --- Can't put it in PrelBase, because of the use of (,) - -class Splittable t where - split :: t -> (t,t) -\end{code} diff --git a/ghc/lib/std/PrelStable.lhs b/ghc/lib/std/PrelStable.lhs deleted file mode 100644 index 2d6f8ae..0000000 --- a/ghc/lib/std/PrelStable.lhs +++ /dev/null @@ -1,44 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelStable.lhs,v 1.9 2001/03/25 09:57:26 qrczak Exp $ -% -% (c) The GHC Team, 1992-2000 -% - -\section{Module @PrelStable@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelStable - ( StablePtr(..) - , newStablePtr -- :: a -> IO (StablePtr a) - , deRefStablePtr -- :: StablePtr a -> a - , freeStablePtr -- :: StablePtr a -> IO () - ) where - -import PrelBase -import PrelIOBase - ------------------------------------------------------------------------------ --- Stable Pointers - -data StablePtr a = StablePtr (StablePtr# a) - -instance CCallable (StablePtr a) -instance CReturnable (StablePtr a) - -newStablePtr :: a -> IO (StablePtr a) -newStablePtr a = IO $ \ s -> - case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #) - -deRefStablePtr :: StablePtr a -> IO a -deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s - -foreign import unsafe freeStablePtr :: StablePtr a -> IO () - -instance Eq (StablePtr a) where - (StablePtr sp1) == (StablePtr sp2) = - case eqStablePtr# sp1 sp2 of - 0# -> False - _ -> True -\end{code} diff --git a/ghc/lib/std/PrelStorable.lhs b/ghc/lib/std/PrelStorable.lhs deleted file mode 100644 index 4b59569..0000000 --- a/ghc/lib/std/PrelStorable.lhs +++ /dev/null @@ -1,292 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelStorable.lhs,v 1.12 2002/02/05 16:56:39 sewardj Exp $ -% -% (c) The FFI task force, 2000 -% - -A class for primitive marshaling - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "MachDeps.h" - -module PrelStorable - ( Storable( - sizeOf, -- :: a -> Int - alignment, -- :: a -> Int - peekElemOff, -- :: Ptr a -> Int -> IO a - pokeElemOff, -- :: Ptr a -> Int -> a -> IO () - peekByteOff, -- :: Ptr b -> Int -> IO a - pokeByteOff, -- :: Ptr b -> Int -> a -> IO () - peek, -- :: Ptr a -> IO a - poke, -- :: Ptr a -> a -> IO () - - -- DEPRECATED: Don't use! - destruct) -- :: Ptr a -> IO () - ) where -\end{code} - -\begin{code} -import Monad ( liftM ) - -#ifdef __GLASGOW_HASKELL__ -import PrelStable ( StablePtr ) -import PrelNum -import PrelInt -import PrelWord -import PrelCTypes -import PrelCTypesISO -import PrelStable -import PrelPtr -import PrelFloat -import PrelErr -import PrelIOBase -import PrelBase -#endif -\end{code} - -Primitive marshaling - -Minimal complete definition: sizeOf, alignment, and one definition -in each of the peek/poke families. - -\begin{code} -class Storable a where - - -- sizeOf/alignment *never* use their first argument - sizeOf :: a -> Int - alignment :: a -> Int - - -- replacement for read-/write???OffAddr - peekElemOff :: Ptr a -> Int -> IO a - pokeElemOff :: Ptr a -> Int -> a -> IO () - - -- the same with *byte* offsets - peekByteOff :: Ptr b -> Int -> IO a - pokeByteOff :: Ptr b -> Int -> a -> IO () - - -- ... and with no offsets at all - peek :: Ptr a -> IO a - poke :: Ptr a -> a -> IO () - - -- free memory associated with the object - -- (except the object pointer itself) - destruct :: Ptr a -> IO () - - -- circular default instances - peekElemOff = peekElemOff_ undefined - where peekElemOff_ :: a -> Ptr a -> Int -> IO a - peekElemOff_ undef ptr off = peekByteOff ptr (off * sizeOf undef) - pokeElemOff ptr off val = pokeByteOff ptr (off * sizeOf val) val - - peekByteOff ptr off = peek (ptr `plusPtr` off) - pokeByteOff ptr off = poke (ptr `plusPtr` off) - - peek ptr = peekElemOff ptr 0 - poke ptr = pokeElemOff ptr 0 - - destruct _ = return () -{-# DEPRECATED destruct "This function is not standards compliant" #-} -\end{code} - -System-dependent, but rather obvious instances - -\begin{code} -instance Storable Bool where - sizeOf _ = sizeOf (undefined::CInt) - alignment _ = alignment (undefined::CInt) - peekElemOff p i = liftM (/= (0::CInt)) $ peekElemOff (castPtr p) i - pokeElemOff p i x = pokeElemOff (castPtr p) i (if x then 1 else 0::CInt) - -#define STORABLE(T,size,align,read,write) \ -instance Storable (T) where { \ - sizeOf _ = size; \ - alignment _ = align; \ - peekElemOff = read; \ - pokeElemOff = write } - -STORABLE(Char,SIZEOF_INT32,ALIGNMENT_INT32, - readWideCharOffPtr,writeWideCharOffPtr) - -STORABLE(Int,SIZEOF_HSINT,ALIGNMENT_HSINT, - readIntOffPtr,writeIntOffPtr) - -STORABLE(Word,SIZEOF_HSWORD,ALIGNMENT_HSWORD, - readWordOffPtr,writeWordOffPtr) - -STORABLE((Ptr a),SIZEOF_HSPTR,ALIGNMENT_HSPTR, - readPtrOffPtr,writePtrOffPtr) - -STORABLE((FunPtr a),SIZEOF_HSFUNPTR,ALIGNMENT_HSFUNPTR, - readFunPtrOffPtr,writeFunPtrOffPtr) - -STORABLE((StablePtr a),SIZEOF_HSSTABLEPTR,ALIGNMENT_HSSTABLEPTR, - readStablePtrOffPtr,writeStablePtrOffPtr) - -STORABLE(Float,SIZEOF_HSFLOAT,ALIGNMENT_HSFLOAT, - readFloatOffPtr,writeFloatOffPtr) - -STORABLE(Double,SIZEOF_HSDOUBLE,ALIGNMENT_HSDOUBLE, - readDoubleOffPtr,writeDoubleOffPtr) - -STORABLE(Word8,SIZEOF_WORD8,ALIGNMENT_WORD8, - readWord8OffPtr,writeWord8OffPtr) - -STORABLE(Word16,SIZEOF_WORD16,ALIGNMENT_WORD16, - readWord16OffPtr,writeWord16OffPtr) - -STORABLE(Word32,SIZEOF_WORD32,ALIGNMENT_WORD32, - readWord32OffPtr,writeWord32OffPtr) - -STORABLE(Word64,SIZEOF_WORD64,ALIGNMENT_WORD64, - readWord64OffPtr,writeWord64OffPtr) - -STORABLE(Int8,SIZEOF_INT8,ALIGNMENT_INT8, - readInt8OffPtr,writeInt8OffPtr) - -STORABLE(Int16,SIZEOF_INT16,ALIGNMENT_INT16, - readInt16OffPtr,writeInt16OffPtr) - -STORABLE(Int32,SIZEOF_INT32,ALIGNMENT_INT32, - readInt32OffPtr,writeInt32OffPtr) - -STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64, - readInt64OffPtr,writeInt64OffPtr) - -#define NSTORABLE(T) \ -instance Storable T where { \ - sizeOf (T x) = sizeOf x ; \ - alignment (T x) = alignment x ; \ - peekElemOff a i = liftM T (peekElemOff (castPtr a) i) ; \ - pokeElemOff a i (T x) = pokeElemOff (castPtr a) i x } - -NSTORABLE(CChar) -NSTORABLE(CSChar) -NSTORABLE(CUChar) -NSTORABLE(CShort) -NSTORABLE(CUShort) -NSTORABLE(CInt) -NSTORABLE(CUInt) -NSTORABLE(CLong) -NSTORABLE(CULong) -NSTORABLE(CLLong) -NSTORABLE(CULLong) -NSTORABLE(CFloat) -NSTORABLE(CDouble) -NSTORABLE(CLDouble) -NSTORABLE(CPtrdiff) -NSTORABLE(CSize) -NSTORABLE(CWchar) -NSTORABLE(CSigAtomic) -NSTORABLE(CClock) -NSTORABLE(CTime) -\end{code} - -Helper functions - -\begin{code} -#ifdef __GLASGOW_HASKELL__ - -readWideCharOffPtr :: Ptr Char -> Int -> IO Char -readIntOffPtr :: Ptr Int -> Int -> IO Int -readWordOffPtr :: Ptr Word -> Int -> IO Word -readPtrOffPtr :: Ptr (Ptr a) -> Int -> IO (Ptr a) -readFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> IO (FunPtr a) -readFloatOffPtr :: Ptr Float -> Int -> IO Float -readDoubleOffPtr :: Ptr Double -> Int -> IO Double -readStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> IO (StablePtr a) -readInt8OffPtr :: Ptr Int8 -> Int -> IO Int8 -readInt16OffPtr :: Ptr Int16 -> Int -> IO Int16 -readInt32OffPtr :: Ptr Int32 -> Int -> IO Int32 -readInt64OffPtr :: Ptr Int64 -> Int -> IO Int64 -readWord8OffPtr :: Ptr Word8 -> Int -> IO Word8 -readWord16OffPtr :: Ptr Word16 -> Int -> IO Word16 -readWord32OffPtr :: Ptr Word32 -> Int -> IO Word32 -readWord64OffPtr :: Ptr Word64 -> Int -> IO Word64 - -readWideCharOffPtr (Ptr a) (I# i) - = IO $ \s -> case readWideCharOffAddr# a i s of (# s2, x #) -> (# s2, C# x #) -readIntOffPtr (Ptr a) (I# i) - = IO $ \s -> case readIntOffAddr# a i s of (# s2, x #) -> (# s2, I# x #) -readWordOffPtr (Ptr a) (I# i) - = IO $ \s -> case readWordOffAddr# a i s of (# s2, x #) -> (# s2, W# x #) -readPtrOffPtr (Ptr a) (I# i) - = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, Ptr x #) -readFunPtrOffPtr (Ptr a) (I# i) - = IO $ \s -> case readAddrOffAddr# a i s of (# s2, x #) -> (# s2, FunPtr x #) -readFloatOffPtr (Ptr a) (I# i) - = IO $ \s -> case readFloatOffAddr# a i s of (# s2, x #) -> (# s2, F# x #) -readDoubleOffPtr (Ptr a) (I# i) - = IO $ \s -> case readDoubleOffAddr# a i s of (# s2, x #) -> (# s2, D# x #) -readStablePtrOffPtr (Ptr a) (I# i) - = IO $ \s -> case readStablePtrOffAddr# a i s of (# s2, x #) -> (# s2, StablePtr x #) -readInt8OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt8OffAddr# a i s of (# s2, x #) -> (# s2, I8# x #) -readWord8OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord8OffAddr# a i s of (# s2, x #) -> (# s2, W8# x #) -readInt16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt16OffAddr# a i s of (# s2, x #) -> (# s2, I16# x #) -readWord16OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord16OffAddr# a i s of (# s2, x #) -> (# s2, W16# x #) -readInt32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt32OffAddr# a i s of (# s2, x #) -> (# s2, I32# x #) -readWord32OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord32OffAddr# a i s of (# s2, x #) -> (# s2, W32# x #) -readInt64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readInt64OffAddr# a i s of (# s2, x #) -> (# s2, I64# x #) -readWord64OffPtr (Ptr a) (I# i) - = IO $ \s -> case readWord64OffAddr# a i s of (# s2, x #) -> (# s2, W64# x #) - -writeWideCharOffPtr :: Ptr Char -> Int -> Char -> IO () -writeIntOffPtr :: Ptr Int -> Int -> Int -> IO () -writeWordOffPtr :: Ptr Word -> Int -> Word -> IO () -writePtrOffPtr :: Ptr (Ptr a) -> Int -> Ptr a -> IO () -writeFunPtrOffPtr :: Ptr (FunPtr a) -> Int -> FunPtr a -> IO () -writeFloatOffPtr :: Ptr Float -> Int -> Float -> IO () -writeDoubleOffPtr :: Ptr Double -> Int -> Double -> IO () -writeStablePtrOffPtr :: Ptr (StablePtr a) -> Int -> StablePtr a -> IO () -writeInt8OffPtr :: Ptr Int8 -> Int -> Int8 -> IO () -writeInt16OffPtr :: Ptr Int16 -> Int -> Int16 -> IO () -writeInt32OffPtr :: Ptr Int32 -> Int -> Int32 -> IO () -writeInt64OffPtr :: Ptr Int64 -> Int -> Int64 -> IO () -writeWord8OffPtr :: Ptr Word8 -> Int -> Word8 -> IO () -writeWord16OffPtr :: Ptr Word16 -> Int -> Word16 -> IO () -writeWord32OffPtr :: Ptr Word32 -> Int -> Word32 -> IO () -writeWord64OffPtr :: Ptr Word64 -> Int -> Word64 -> IO () - -writeWideCharOffPtr (Ptr a) (I# i) (C# x) - = IO $ \s -> case writeWideCharOffAddr# a i x s of s2 -> (# s2, () #) -writeIntOffPtr (Ptr a) (I# i) (I# x) - = IO $ \s -> case writeIntOffAddr# a i x s of s2 -> (# s2, () #) -writeWordOffPtr (Ptr a) (I# i) (W# x) - = IO $ \s -> case writeWordOffAddr# a i x s of s2 -> (# s2, () #) -writePtrOffPtr (Ptr a) (I# i) (Ptr x) - = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #) -writeFunPtrOffPtr (Ptr a) (I# i) (FunPtr x) - = IO $ \s -> case writeAddrOffAddr# a i x s of s2 -> (# s2, () #) -writeFloatOffPtr (Ptr a) (I# i) (F# x) - = IO $ \s -> case writeFloatOffAddr# a i x s of s2 -> (# s2, () #) -writeDoubleOffPtr (Ptr a) (I# i) (D# x) - = IO $ \s -> case writeDoubleOffAddr# a i x s of s2 -> (# s2, () #) -writeStablePtrOffPtr (Ptr a) (I# i) (StablePtr x) - = IO $ \s -> case writeStablePtrOffAddr# a i x s of s2 -> (# s2 , () #) -writeInt8OffPtr (Ptr a) (I# i) (I8# x) - = IO $ \s -> case writeInt8OffAddr# a i x s of s2 -> (# s2, () #) -writeWord8OffPtr (Ptr a) (I# i) (W8# x) - = IO $ \s -> case writeWord8OffAddr# a i x s of s2 -> (# s2, () #) -writeInt16OffPtr (Ptr a) (I# i) (I16# x) - = IO $ \s -> case writeInt16OffAddr# a i x s of s2 -> (# s2, () #) -writeWord16OffPtr (Ptr a) (I# i) (W16# x) - = IO $ \s -> case writeWord16OffAddr# a i x s of s2 -> (# s2, () #) -writeInt32OffPtr (Ptr a) (I# i) (I32# x) - = IO $ \s -> case writeInt32OffAddr# a i x s of s2 -> (# s2, () #) -writeWord32OffPtr (Ptr a) (I# i) (W32# x) - = IO $ \s -> case writeWord32OffAddr# a i x s of s2 -> (# s2, () #) -writeInt64OffPtr (Ptr a) (I# i) (I64# x) - = IO $ \s -> case writeInt64OffAddr# a i x s of s2 -> (# s2, () #) -writeWord64OffPtr (Ptr a) (I# i) (W64# x) - = IO $ \s -> case writeWord64OffAddr# a i x s of s2 -> (# s2, () #) - -#endif /* __GLASGOW_HASKELL__ */ -\end{code} diff --git a/ghc/lib/std/PrelTopHandler.hs b/ghc/lib/std/PrelTopHandler.hs deleted file mode 100644 index 9773728..0000000 --- a/ghc/lib/std/PrelTopHandler.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS -#include "PrelIOUtils.h" #-} --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow, 1994-2002 --- --- PrelTopHandler --- --- 'Top-level' IO actions want to catch exceptions (e.g., forkIO and --- PrelMain.mainIO) and report them - topHandler is the exception --- handler they should use for this: - --- make sure we handle errors while reporting the error! --- (e.g. evaluating the string passed to 'error' might generate --- another error, etc.) - --- These functions can't go in PrelMain, because PrelMain isn't --- included in HSstd.o (because PrelMain depends on Main, which --- doesn't exist yet...). --- --- Note: used to be called PrelTopHandler.lhs, so if you're looking --- for CVS info, try 'cvs log'ging it too. -module PrelTopHandler ( - runMain, reportStackOverflow, reportError - ) where - -import IO - -import PrelCString -import PrelPtr -import PrelIOBase -import PrelException - --- runMain is applied to Main.main by TcModule -runMain :: IO a -> IO () -runMain main = catchException (main >> return ()) topHandler - -topHandler :: Exception -> IO () -topHandler err = catchException (real_handler err) topHandler - -real_handler :: Exception -> IO () -real_handler ex = - case ex of - AsyncException StackOverflow -> reportStackOverflow True - - -- only the main thread gets ExitException exceptions - ExitException ExitSuccess -> shutdownHaskellAndExit 0 - ExitException (ExitFailure n) -> shutdownHaskellAndExit n - - Deadlock -> reportError True - "no threads to run: infinite loop or deadlock?" - - ErrorCall s -> reportError True s - other -> reportError True (showsPrec 0 other "\n") - --- NOTE: shutdownHaskellAndExit must be called "safe", because it *can* --- re-enter Haskell land through finalizers. -foreign import ccall "shutdownHaskellAndExit" - shutdownHaskellAndExit :: Int -> IO () - -reportStackOverflow :: Bool -> IO () -reportStackOverflow bombOut = do - (hFlush stdout) `catchException` (\ _ -> return ()) - callStackOverflowHook - if bombOut then - stg_exit 2 - else - return () - -reportError :: Bool -> String -> IO () -reportError bombOut str = do - (hFlush stdout) `catchException` (\ _ -> return ()) - withCStringLen str $ \(cstr,len) -> do - writeErrString errorHdrHook cstr len - if bombOut - then stg_exit 1 - else return () - -#ifndef ILX -foreign label "ErrorHdrHook" errorHdrHook :: Ptr () -#else -foreign import "_ErrorHdrHook" errorHdrHook :: Ptr () -#endif - -foreign import ccall "writeErrString__" unsafe - writeErrString :: Ptr () -> CString -> Int -> IO () - --- SUP: Are the hooks allowed to re-enter Haskell land? If so, remove --- the unsafe below. -foreign import ccall "stackOverflow" unsafe - callStackOverflowHook :: IO () - -foreign import ccall "stg_exit" unsafe - stg_exit :: Int -> IO () - diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs deleted file mode 100644 index 9f79a01..0000000 --- a/ghc/lib/std/PrelTup.lhs +++ /dev/null @@ -1,238 +0,0 @@ -% ----------------------------------------------------------------------------- -% $Id: PrelTup.lhs,v 1.12 2001/08/28 15:11:41 simonmar Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% - -\section[PrelTup]{Module @PrelTup@} - -This modules defines the typle data types. - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelTup where - -import PrelBase - -default () -- Double isn't available yet -\end{code} - - -%********************************************************* -%* * -\subsection{Other tuple types} -%* * -%********************************************************* - -\begin{code} -data (,) a b = (,) a b deriving (Eq, Ord) -data (,,) a b c = (,,) a b c deriving (Eq, Ord) -data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord) -data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord) -data (,,,,,) a b c d e f = (,,,,,) a b c d e f deriving (Eq, Ord) -data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g deriving (Eq, Ord) -data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h deriving (Eq, Ord) -data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i deriving (Eq, Ord) -data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j deriving (Eq, Ord) -data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k deriving (Eq, Ord) -data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l deriving (Eq, Ord) -data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m deriving (Eq, Ord) -data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n deriving (Eq, Ord) -data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o deriving (Eq, Ord) -data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p -data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q - = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q -data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r - = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r -data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s - = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s -data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t - = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t -data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u - = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u -data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v - = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v -data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w - = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w -data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x - = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x -data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y - = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y -data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z - = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z -data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ -{- Manuel says: Including one more declaration gives a segmentation fault. -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ -data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ - = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__ k__ l__ m__ n__ o__ p__ q__ r__ s__ t__ u__ v__ w__ x__ y__ z__ a___ b___ c___ d___ e___ f___ g___ h___ i___ j___ k___ l___ m___ n___ o___ p___ q___ r___ s___ t___ u___ v___ --} -\end{code} - - -%********************************************************* -%* * -\subsection{Standard functions over tuples} -* * -%********************************************************* - -\begin{code} -fst :: (a,b) -> a -fst (x,_) = x - -snd :: (a,b) -> b -snd (_,y) = y - --- curry converts an uncurried function to a curried function; --- uncurry converts a curried function to a function on pairs. -curry :: ((a, b) -> c) -> a -> b -> c -curry f x y = f (x, y) - -uncurry :: (a -> b -> c) -> ((a, b) -> c) -uncurry f p = f (fst p) (snd p) -\end{code} - diff --git a/ghc/lib/std/PrelWeak.lhs b/ghc/lib/std/PrelWeak.lhs deleted file mode 100644 index 1a7e643..0000000 --- a/ghc/lib/std/PrelWeak.lhs +++ /dev/null @@ -1,65 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: PrelWeak.lhs,v 1.16 2001/03/22 03:51:09 hwloidl Exp $ -% -% (c) The University of Glasgow, 1998-2000 -% - -\section[PrelWeak]{Module @PrelWeak@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module PrelWeak where - -import PrelGHC -import PrelBase -import PrelMaybe -import PrelIOBase ( IO(..), unIO ) - -data Weak v = Weak (Weak# v) - -mkWeak :: k -- key - -> v -- value - -> Maybe (IO ()) -- finalizer - -> IO (Weak v) -- weak pointer - -mkWeak key val (Just finalizer) = IO $ \s -> - case mkWeak# key val finalizer s of { (# s1, w #) -> (# s1, Weak w #) } -mkWeak key val Nothing = IO $ \s -> - case mkWeak# key val (unsafeCoerce# 0#) s of { (# s1, w #) -> (# s1, Weak w #) } - -mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k) -mkWeakPtr key finalizer = mkWeak key key finalizer - -addFinalizer :: key -> IO () -> IO () -addFinalizer key finalizer = do - mkWeakPtr key (Just finalizer) -- throw it away - return () - -{- -Instance Eq (Weak v) where - (Weak w1) == (Weak w2) = w1 `sameWeak#` w2 --} - - --- run a batch of finalizers from the garbage collector. We're given --- an array of finalizers and the length of the array, and we just --- call each one in turn. --- --- the IO primitives are inlined by hand here to get the optimal --- code (sigh) --SDM. - -runFinalizerBatch :: Int -> Array# (IO ()) -> IO () -runFinalizerBatch (I# n) arr = - let go m = IO $ \s -> - case m of - 0# -> (# s, () #) - _ -> let m' = m -# 1# in - case indexArray# arr m' of { (# io #) -> - case unIO io s of { (# s, _ #) -> - unIO (go m') s - }} - in - go n - -\end{code} diff --git a/ghc/lib/std/PrelWord.lhs b/ghc/lib/std/PrelWord.lhs deleted file mode 100644 index 811cf3d..0000000 --- a/ghc/lib/std/PrelWord.lhs +++ /dev/null @@ -1,887 +0,0 @@ -% -% (c) The University of Glasgow, 1997-2001 -% -\section[PrelWord]{Module @PrelWord@} - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -#include "MachDeps.h" - -module PrelWord ( - Word(..), Word8(..), Word16(..), Word32(..), Word64(..), - divZeroError, toEnumError, fromEnumError, succError, predError) - where - -import PrelBase -import PrelEnum -import PrelNum -import PrelReal -import PrelRead -import PrelArr -import PrelBits -import PrelShow - ------------------------------------------------------------------------- --- Helper functions ------------------------------------------------------------------------- - -{-# NOINLINE divZeroError #-} -divZeroError :: (Show a) => String -> a -> b -divZeroError meth x = - error $ "Integral." ++ meth ++ ": divide by 0 (" ++ show x ++ " / 0)" - -{-# NOINLINE toEnumError #-} -toEnumError :: (Show a) => String -> Int -> (a,a) -> b -toEnumError inst_ty i bnds = - error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++ - show i ++ - ") is outside of bounds " ++ - show bnds - -{-# NOINLINE fromEnumError #-} -fromEnumError :: (Show a) => String -> a -> b -fromEnumError inst_ty x = - error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++ - show x ++ - ") is outside of Int's bounds " ++ - show (minBound::Int, maxBound::Int) - -{-# NOINLINE succError #-} -succError :: String -> a -succError inst_ty = - error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound" - -{-# NOINLINE predError #-} -predError :: String -> a -predError inst_ty = - error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound" - ------------------------------------------------------------------------- --- type Word ------------------------------------------------------------------------- - --- A Word is an unsigned integral type, with the same size as Int. - -data Word = W# Word# deriving (Eq, Ord) - -instance CCallable Word -instance CReturnable Word - -instance Show Word where - showsPrec p x = showsPrec p (toInteger x) - -instance Num Word where - (W# x#) + (W# y#) = W# (x# `plusWord#` y#) - (W# x#) - (W# y#) = W# (x# `minusWord#` y#) - (W# x#) * (W# y#) = W# (x# `timesWord#` y#) - negate (W# x#) = W# (int2Word# (negateInt# (word2Int# x#))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W# (int2Word# i#) - fromInteger (J# s# d#) = W# (integer2Word# s# d#) - -instance Real Word where - toRational x = toInteger x % 1 - -instance Enum Word where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word" - toEnum i@(I# i#) - | i >= 0 = W# (int2Word# i#) - | otherwise = toEnumError "Word" i (minBound::Word, maxBound::Word) - fromEnum x@(W# x#) - | x <= fromIntegral (maxBound::Int) - = I# (word2Int# x#) - | otherwise = fromEnumError "Word" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Word where - quot x@(W# x#) y@(W# y#) - | y /= 0 = W# (x# `quotWord#` y#) - | otherwise = divZeroError "quot{Word}" x - rem x@(W# x#) y@(W# y#) - | y /= 0 = W# (x# `remWord#` y#) - | otherwise = divZeroError "rem{Word}" x - div x@(W# x#) y@(W# y#) - | y /= 0 = W# (x# `quotWord#` y#) - | otherwise = divZeroError "div{Word}" x - mod x@(W# x#) y@(W# y#) - | y /= 0 = W# (x# `remWord#` y#) - | otherwise = divZeroError "mod{Word}" x - quotRem x@(W# x#) y@(W# y#) - | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word}" x - divMod x@(W# x#) y@(W# y#) - | y /= 0 = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#)) - | otherwise = divZeroError "divMod{Word}" x - toInteger (W# x#) - | i# >=# 0# = S# i# - | otherwise = case word2Integer# x# of (# s, d #) -> J# s d - where - i# = word2Int# x# - -instance Bounded Word where - minBound = 0 -#if WORD_SIZE_IN_BITS == 31 - maxBound = 0x7FFFFFFF -#elif WORD_SIZE_IN_BITS == 32 - maxBound = 0xFFFFFFFF -#else - maxBound = 0xFFFFFFFFFFFFFFFF -#endif - -instance Ix Word where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Word where - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] - -instance Bits Word where - (W# x#) .&. (W# y#) = W# (x# `and#` y#) - (W# x#) .|. (W# y#) = W# (x# `or#` y#) - (W# x#) `xor` (W# y#) = W# (x# `xor#` y#) - complement (W# x#) = W# (x# `xor#` mb#) where W# mb# = maxBound - (W# x#) `shift` (I# i#) - | i# ==# 0# = W# x# - | i# >=# wsib = W# (int2Word# 0#) - | i# ># 0# = W# (x# `uncheckedShiftL#` i#) - | i# <=# nwsib = W# (int2Word# 0#) - | otherwise = W# (x# `uncheckedShiftRL#` negateInt# i#) - where - wsib = WORD_SIZE_IN_BITS# {- work around preprocessor problem (??) -} - nwsib = negateInt# wsib - (W# x#) `rotate` (I# i#) - | i'# ==# 0# = W# x# - | otherwise = W# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (wsib -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# (wsib -# 1#)) - wsib = WORD_SIZE_IN_BITS# - bitSize _ = WORD_SIZE_IN_BITS - isSigned _ = False - -{-# RULES -"fromIntegral/Int->Word" fromIntegral = \(I# x#) -> W# (int2Word# x#) -"fromIntegral/Word->Int" fromIntegral = \(W# x#) -> I# (word2Int# x#) -"fromIntegral/Word->Word" fromIntegral = id :: Word -> Word - #-} - ------------------------------------------------------------------------- --- type Word8 ------------------------------------------------------------------------- - --- Word8 is represented in the same way as Word. Operations may assume --- and must ensure that it holds only values from its logical range. - -data Word8 = W8# Word# deriving (Eq, Ord) - -instance CCallable Word8 -instance CReturnable Word8 - -instance Show Word8 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Word8 where - (W8# x#) + (W8# y#) = W8# (narrow8Word# (x# `plusWord#` y#)) - (W8# x#) - (W8# y#) = W8# (narrow8Word# (x# `minusWord#` y#)) - (W8# x#) * (W8# y#) = W8# (narrow8Word# (x# `timesWord#` y#)) - negate (W8# x#) = W8# (narrow8Word# (int2Word# (negateInt# (word2Int# x#)))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W8# (narrow8Word# (int2Word# i#)) - fromInteger (J# s# d#) = W8# (narrow8Word# (integer2Word# s# d#)) - -instance Real Word8 where - toRational x = toInteger x % 1 - -instance Enum Word8 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word8" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word8" - toEnum i@(I# i#) - | i >= 0 && i <= fromIntegral (maxBound::Word8) - = W8# (int2Word# i#) - | otherwise = toEnumError "Word8" i (minBound::Word8, maxBound::Word8) - fromEnum (W8# x#) = I# (word2Int# x#) - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Word8 where - quot x@(W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `quotWord#` y#) - | otherwise = divZeroError "quot{Word8}" x - rem x@(W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `remWord#` y#) - | otherwise = divZeroError "rem{Word8}" x - div x@(W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `quotWord#` y#) - | otherwise = divZeroError "div{Word8}" x - mod x@(W8# x#) y@(W8# y#) - | y /= 0 = W8# (x# `remWord#` y#) - | otherwise = divZeroError "mod{Word8}" x - quotRem x@(W8# x#) y@(W8# y#) - | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word8}" x - divMod x@(W8# x#) y@(W8# y#) - | y /= 0 = (W8# (x# `quotWord#` y#), W8# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word8}" x - toInteger (W8# x#) = S# (word2Int# x#) - -instance Bounded Word8 where - minBound = 0 - maxBound = 0xFF - -instance Ix Word8 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Word8 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Word8 where - (W8# x#) .&. (W8# y#) = W8# (x# `and#` y#) - (W8# x#) .|. (W8# y#) = W8# (x# `or#` y#) - (W8# x#) `xor` (W8# y#) = W8# (x# `xor#` y#) - complement (W8# x#) = W8# (x# `xor#` mb#) where W8# mb# = maxBound - (W8# x#) `shift` (I# i#) - | i# ==# 0# = W8# x# - | i# >=# 8# || i# <=# -8# = W8# (int2Word# 0#) - | i# ># 0# = W8# (narrow8Word# (x# `uncheckedShiftL#` i#)) - | otherwise = W8# (x# `uncheckedShiftRL#` negateInt# i#) - (W8# x#) `rotate` (I# i#) - | i'# ==# 0# = W8# x# - | otherwise = W8# (narrow8Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (8# -# i'#)))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 7#) - bitSize _ = 8 - isSigned _ = False - -{-# RULES -"fromIntegral/Word8->Word8" fromIntegral = id :: Word8 -> Word8 -"fromIntegral/Word8->Integer" fromIntegral = toInteger :: Word8 -> Integer -"fromIntegral/a->Word8" fromIntegral = \x -> case fromIntegral x of W# x# -> W8# (narrow8Word# x#) -"fromIntegral/Word8->a" fromIntegral = \(W8# x#) -> fromIntegral (W# x#) - #-} - ------------------------------------------------------------------------- --- type Word16 ------------------------------------------------------------------------- - --- Word16 is represented in the same way as Word. Operations may assume --- and must ensure that it holds only values from its logical range. - -data Word16 = W16# Word# deriving (Eq, Ord) - -instance CCallable Word16 -instance CReturnable Word16 - -instance Show Word16 where - showsPrec p x = showsPrec p (fromIntegral x :: Int) - -instance Num Word16 where - (W16# x#) + (W16# y#) = W16# (narrow16Word# (x# `plusWord#` y#)) - (W16# x#) - (W16# y#) = W16# (narrow16Word# (x# `minusWord#` y#)) - (W16# x#) * (W16# y#) = W16# (narrow16Word# (x# `timesWord#` y#)) - negate (W16# x#) = W16# (narrow16Word# (int2Word# (negateInt# (word2Int# x#)))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W16# (narrow16Word# (int2Word# i#)) - fromInteger (J# s# d#) = W16# (narrow16Word# (integer2Word# s# d#)) - -instance Real Word16 where - toRational x = toInteger x % 1 - -instance Enum Word16 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word16" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word16" - toEnum i@(I# i#) - | i >= 0 && i <= fromIntegral (maxBound::Word16) - = W16# (int2Word# i#) - | otherwise = toEnumError "Word16" i (minBound::Word16, maxBound::Word16) - fromEnum (W16# x#) = I# (word2Int# x#) - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen - -instance Integral Word16 where - quot x@(W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `quotWord#` y#) - | otherwise = divZeroError "quot{Word16}" x - rem x@(W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `remWord#` y#) - | otherwise = divZeroError "rem{Word16}" x - div x@(W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `quotWord#` y#) - | otherwise = divZeroError "div{Word16}" x - mod x@(W16# x#) y@(W16# y#) - | y /= 0 = W16# (x# `remWord#` y#) - | otherwise = divZeroError "mod{Word16}" x - quotRem x@(W16# x#) y@(W16# y#) - | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word16}" x - divMod x@(W16# x#) y@(W16# y#) - | y /= 0 = (W16# (x# `quotWord#` y#), W16# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word16}" x - toInteger (W16# x#) = S# (word2Int# x#) - -instance Bounded Word16 where - minBound = 0 - maxBound = 0xFFFF - -instance Ix Word16 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Word16 where - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] - -instance Bits Word16 where - (W16# x#) .&. (W16# y#) = W16# (x# `and#` y#) - (W16# x#) .|. (W16# y#) = W16# (x# `or#` y#) - (W16# x#) `xor` (W16# y#) = W16# (x# `xor#` y#) - complement (W16# x#) = W16# (x# `xor#` mb#) where W16# mb# = maxBound - (W16# x#) `shift` (I# i#) - | i# ==# 0# = W16# x# - | i# >=# 16# || i# <=# -16# = W16# (int2Word# 0#) - | i# ># 0# = W16# (narrow16Word# (x# `uncheckedShiftL#` i#)) - | otherwise = W16# (x# `uncheckedShiftRL#` negateInt# i#) - (W16# x#) `rotate` (I# i#) - | i'# ==# 0# = W16# x# - | otherwise = W16# (narrow16Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (16# -# i'#)))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 15#) - bitSize _ = 16 - isSigned _ = False - -{-# RULES -"fromIntegral/Word8->Word16" fromIntegral = \(W8# x#) -> W16# x# -"fromIntegral/Word16->Word16" fromIntegral = id :: Word16 -> Word16 -"fromIntegral/Word16->Integer" fromIntegral = toInteger :: Word16 -> Integer -"fromIntegral/a->Word16" fromIntegral = \x -> case fromIntegral x of W# x# -> W16# (narrow16Word# x#) -"fromIntegral/Word16->a" fromIntegral = \(W16# x#) -> fromIntegral (W# x#) - #-} - ------------------------------------------------------------------------- --- type Word32 ------------------------------------------------------------------------- - -#if WORD_SIZE_IN_BITS < 32 - -data Word32 = W32# Word32# - -instance Eq Word32 where - (W32# x#) == (W32# y#) = x# `eqWord32#` y# - (W32# x#) /= (W32# y#) = x# `neWord32#` y# - -instance Ord Word32 where - (W32# x#) < (W32# y#) = x# `ltWord32#` y# - (W32# x#) <= (W32# y#) = x# `leWord32#` y# - (W32# x#) > (W32# y#) = x# `gtWord32#` y# - (W32# x#) >= (W32# y#) = x# `geWord32#` y# - -instance Num Word32 where - (W32# x#) + (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `plusInt32#` word32ToInt32# y#)) - (W32# x#) - (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `minusInt32#` word32ToInt32# y#)) - (W32# x#) * (W32# y#) = W32# (int32ToWord32# (word32ToInt32# x# `timesInt32#` word32ToInt32# y#)) - negate (W32# x#) = W32# (int32ToWord32# (negateInt32# (word32ToInt32# x#))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W32# (int32ToWord32# (intToInt32# i#)) - fromInteger (J# s# d#) = W32# (integerToWord32# s# d#) - -instance Enum Word32 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word32" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word32" - toEnum i@(I# i#) - | i >= 0 = W32# (wordToWord32# (int2Word# i#)) - | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) - fromEnum x@(W32# x#) - | x <= fromIntegral (maxBound::Int) - = I# (word2Int# (word32ToWord# x#)) - | otherwise = fromEnumError "Word32" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Word32 where - quot x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord32#` y#) - | otherwise = divZeroError "quot{Word32}" x - rem x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord32#` y#) - | otherwise = divZeroError "rem{Word32}" x - div x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord32#` y#) - | otherwise = divZeroError "div{Word32}" x - mod x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord32#` y#) - | otherwise = divZeroError "mod{Word32}" x - quotRem x@(W32# x#) y@(W32# y#) - | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) - | otherwise = divZeroError "quotRem{Word32}" x - divMod x@(W32# x#) y@(W32# y#) - | y /= 0 = (W32# (x# `quotWord32#` y#), W32# (x# `remWord32#` y#)) - | otherwise = divZeroError "quotRem{Word32}" x - toInteger x@(W32# x#) - | x <= fromIntegral (maxBound::Int) = S# (word2Int# (word32ToWord# x#)) - | otherwise = case word32ToInteger# x# of (# s, d #) -> J# s d - -instance Bits Word32 where - (W32# x#) .&. (W32# y#) = W32# (x# `and32#` y#) - (W32# x#) .|. (W32# y#) = W32# (x# `or32#` y#) - (W32# x#) `xor` (W32# y#) = W32# (x# `xor32#` y#) - complement (W32# x#) = W32# (not32# x#) - (W32# x#) `shift` (I# i#) - | i# ==# 0# = W32# x# - | i# >=# 32# || i# <=# -32# = W32# (int2Word# 0#) - | i# ># 0# = W32# (x# `uncheckedShiftL32#` i#) - | otherwise = W32# (x# `uncheckedShiftRL32#` negateInt# i#) - (W32# x#) `rotate` (I# i#) - | i'# ==# 0# = W32# x# - | otherwise = W32# ((x# `uncheckedShiftL32#` i'#) `or32#` - (x# `uncheckedShiftRL32#` (32# -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) - bitSize _ = 32 - isSigned _ = False - -foreign import "stg_eqWord32" unsafe eqWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_neWord32" unsafe neWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_ltWord32" unsafe ltWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_leWord32" unsafe leWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_gtWord32" unsafe gtWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_geWord32" unsafe geWord32# :: Word32# -> Word32# -> Bool -foreign import "stg_int32ToWord32" unsafe int32ToWord32# :: Int32# -> Word32# -foreign import "stg_word32ToInt32" unsafe word32ToInt32# :: Word32# -> Int32# -foreign import "stg_intToInt32" unsafe intToInt32# :: Int# -> Int32# -foreign import "stg_wordToWord32" unsafe wordToWord32# :: Word# -> Word32# -foreign import "stg_word32ToWord" unsafe word32ToWord# :: Word32# -> Word# -foreign import "stg_plusInt32" unsafe plusInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_minusInt32" unsafe minusInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_timesInt32" unsafe timesInt32# :: Int32# -> Int32# -> Int32# -foreign import "stg_negateInt32" unsafe negateInt32# :: Int32# -> Int32# -foreign import "stg_quotWord32" unsafe quotWord32# :: Word32# -> Word32# -> Word32# -foreign import "stg_remWord32" unsafe remWord32# :: Word32# -> Word32# -> Word32# -foreign import "stg_and32" unsafe and32# :: Word32# -> Word32# -> Word32# -foreign import "stg_or32" unsafe or32# :: Word32# -> Word32# -> Word32# -foreign import "stg_xor32" unsafe xor32# :: Word32# -> Word32# -> Word32# -foreign import "stg_not32" unsafe not32# :: Word32# -> Word32# -foreign import "stg_uncheckedShiftL32" unsafe uncheckedShiftL32# :: Word32# -> Int# -> Word32# -foreign import "stg_uncheckedShiftRL32" unsafe uncheckedShiftRL32# :: Word32# -> Int# -> Word32# - -{-# RULES -"fromIntegral/Int->Word32" fromIntegral = \(I# x#) -> W32# (int32ToWord32# (intToInt32# x#)) -"fromIntegral/Word->Word32" fromIntegral = \(W# x#) -> W32# (wordToWord32# x#) -"fromIntegral/Word32->Int" fromIntegral = \(W32# x#) -> I# (word2Int# (word32ToWord# x#)) -"fromIntegral/Word32->Word" fromIntegral = \(W32# x#) -> W# (word32ToWord# x#) -"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 - #-} - -#else - --- Word32 is represented in the same way as Word. -#if WORD_SIZE_IN_BITS > 32 --- Operations may assume and must ensure that it holds only values --- from its logical range. -#endif - -data Word32 = W32# Word# deriving (Eq, Ord) - -instance Num Word32 where - (W32# x#) + (W32# y#) = W32# (narrow32Word# (x# `plusWord#` y#)) - (W32# x#) - (W32# y#) = W32# (narrow32Word# (x# `minusWord#` y#)) - (W32# x#) * (W32# y#) = W32# (narrow32Word# (x# `timesWord#` y#)) - negate (W32# x#) = W32# (narrow32Word# (int2Word# (negateInt# (word2Int# x#)))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W32# (narrow32Word# (int2Word# i#)) - fromInteger (J# s# d#) = W32# (narrow32Word# (integer2Word# s# d#)) - -instance Enum Word32 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word32" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word32" - toEnum i@(I# i#) - | i >= 0 -#if WORD_SIZE_IN_BITS > 32 - && i <= fromIntegral (maxBound::Word32) -#endif - = W32# (int2Word# i#) - | otherwise = toEnumError "Word32" i (minBound::Word32, maxBound::Word32) -#if WORD_SIZE_IN_BITS == 32 - fromEnum x@(W32# x#) - | x <= fromIntegral (maxBound::Int) - = I# (word2Int# x#) - | otherwise = fromEnumError "Word32" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo -#else - fromEnum (W32# x#) = I# (word2Int# x#) - enumFrom = boundedEnumFrom - enumFromThen = boundedEnumFromThen -#endif - -instance Integral Word32 where - quot x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord#` y#) - | otherwise = divZeroError "quot{Word32}" x - rem x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord#` y#) - | otherwise = divZeroError "rem{Word32}" x - div x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `quotWord#` y#) - | otherwise = divZeroError "div{Word32}" x - mod x@(W32# x#) y@(W32# y#) - | y /= 0 = W32# (x# `remWord#` y#) - | otherwise = divZeroError "mod{Word32}" x - quotRem x@(W32# x#) y@(W32# y#) - | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word32}" x - divMod x@(W32# x#) y@(W32# y#) - | y /= 0 = (W32# (x# `quotWord#` y#), W32# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word32}" x - toInteger (W32# x#) -#if WORD_SIZE_IN_BITS == 32 - | i# >=# 0# = S# i# - | otherwise = case word2Integer# x# of (# s, d #) -> J# s d - where - i# = word2Int# x# -#else - = S# (word2Int# x#) -#endif - -instance Bits Word32 where - (W32# x#) .&. (W32# y#) = W32# (x# `and#` y#) - (W32# x#) .|. (W32# y#) = W32# (x# `or#` y#) - (W32# x#) `xor` (W32# y#) = W32# (x# `xor#` y#) - complement (W32# x#) = W32# (x# `xor#` mb#) where W32# mb# = maxBound - (W32# x#) `shift` (I# i#) - | i# ==# 0# = W32# x# - | i# >=# 32# || i# <=# -32# = W32# (int2Word# 0#) - | i# ># 0# = W32# (narrow32Word# (x# `uncheckedShiftL#` i#)) - | otherwise = W32# (x# `uncheckedShiftRL#` negateInt# i#) - (W32# x#) `rotate` (I# i#) - | i'# ==# 0# = W32# x# - | otherwise = W32# (narrow32Word# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (32# -# i'#)))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 31#) - bitSize _ = 32 - isSigned _ = False - -{-# RULES -"fromIntegral/Word8->Word32" fromIntegral = \(W8# x#) -> W32# x# -"fromIntegral/Word16->Word32" fromIntegral = \(W16# x#) -> W32# x# -"fromIntegral/Word32->Word32" fromIntegral = id :: Word32 -> Word32 -"fromIntegral/Word32->Integer" fromIntegral = toInteger :: Word32 -> Integer -"fromIntegral/a->Word32" fromIntegral = \x -> case fromIntegral x of W# x# -> W32# (narrow32Word# x#) -"fromIntegral/Word32->a" fromIntegral = \(W32# x#) -> fromIntegral (W# x#) - #-} - -#endif - -instance CCallable Word32 -instance CReturnable Word32 - -instance Show Word32 where -#if WORD_SIZE_IN_BITS < 33 - showsPrec p x = showsPrec p (toInteger x) -#else - showsPrec p x = showsPrec p (fromIntegral x :: Int) -#endif - - -instance Real Word32 where - toRational x = toInteger x % 1 - -instance Bounded Word32 where - minBound = 0 - maxBound = 0xFFFFFFFF - -instance Ix Word32 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Word32 where -#if WORD_SIZE_IN_BITS < 33 - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] -#else - readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s] -#endif - ------------------------------------------------------------------------- --- type Word64 ------------------------------------------------------------------------- - -#if WORD_SIZE_IN_BITS < 64 - -data Word64 = W64# Word64# - -instance Eq Word64 where - (W64# x#) == (W64# y#) = x# `eqWord64#` y# - (W64# x#) /= (W64# y#) = x# `neWord64#` y# - -instance Ord Word64 where - (W64# x#) < (W64# y#) = x# `ltWord64#` y# - (W64# x#) <= (W64# y#) = x# `leWord64#` y# - (W64# x#) > (W64# y#) = x# `gtWord64#` y# - (W64# x#) >= (W64# y#) = x# `geWord64#` y# - -instance Num Word64 where - (W64# x#) + (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `plusInt64#` word64ToInt64# y#)) - (W64# x#) - (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `minusInt64#` word64ToInt64# y#)) - (W64# x#) * (W64# y#) = W64# (int64ToWord64# (word64ToInt64# x# `timesInt64#` word64ToInt64# y#)) - negate (W64# x#) = W64# (int64ToWord64# (negateInt64# (word64ToInt64# x#))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W64# (int64ToWord64# (intToInt64# i#)) - fromInteger (J# s# d#) = W64# (integerToWord64# s# d#) - -instance Enum Word64 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word64" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word64" - toEnum i@(I# i#) - | i >= 0 = W64# (wordToWord64# (int2Word# i#)) - | otherwise = toEnumError "Word64" i (minBound::Word64, maxBound::Word64) - fromEnum x@(W64# x#) - | x <= fromIntegral (maxBound::Int) - = I# (word2Int# (word64ToWord# x#)) - | otherwise = fromEnumError "Word64" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Word64 where - quot x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `quotWord64#` y#) - | otherwise = divZeroError "quot{Word64}" x - rem x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `remWord64#` y#) - | otherwise = divZeroError "rem{Word64}" x - div x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `quotWord64#` y#) - | otherwise = divZeroError "div{Word64}" x - mod x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `remWord64#` y#) - | otherwise = divZeroError "mod{Word64}" x - quotRem x@(W64# x#) y@(W64# y#) - | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#)) - | otherwise = divZeroError "quotRem{Word64}" x - divMod x@(W64# x#) y@(W64# y#) - | y /= 0 = (W64# (x# `quotWord64#` y#), W64# (x# `remWord64#` y#)) - | otherwise = divZeroError "quotRem{Word64}" x - toInteger x@(W64# x#) - | x <= 0x7FFFFFFF = S# (word2Int# (word64ToWord# x#)) - | otherwise = case word64ToInteger# x# of (# s, d #) -> J# s d - -instance Bits Word64 where - (W64# x#) .&. (W64# y#) = W64# (x# `and64#` y#) - (W64# x#) .|. (W64# y#) = W64# (x# `or64#` y#) - (W64# x#) `xor` (W64# y#) = W64# (x# `xor64#` y#) - complement (W64# x#) = W64# (not64# x#) - (W64# x#) `shift` (I# i#) - | i# ==# 0# = W64# x# - | i# >=# 64# || i# <=# -64# = 0 - | i# ># 0# = W64# (x# `uncheckedShiftL64#` i#) - | otherwise = W64# (x# `uncheckedShiftRL64#` negateInt# i#) - (W64# x#) `rotate` (I# i#) - | i'# ==# 0# = W64# x# - | otherwise = W64# ((x# `uncheckedShiftL64#` i'#) `or64#` - (x# `uncheckedShiftRL64#` (64# -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) - bitSize _ = 64 - isSigned _ = False - -foreign import "stg_eqWord64" unsafe eqWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_neWord64" unsafe neWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_ltWord64" unsafe ltWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_leWord64" unsafe leWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_gtWord64" unsafe gtWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_geWord64" unsafe geWord64# :: Word64# -> Word64# -> Bool -foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64# -foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64# -foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64# -foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64# -foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word# -foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64# -foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64# -foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64# -foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64# -foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64# -foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64# -foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64# -foreign import "stg_not64" unsafe not64# :: Word64# -> Word64# -foreign import "stg_uncheckedShiftL64" unsafe uncheckedShiftL64# :: Word64# -> Int# -> Word64# -foreign import "stg_uncheckedShiftRL64" unsafe uncheckedShiftRL64# :: Word64# -> Int# -> Word64# - -foreign import "stg_integerToWord64" unsafe integerToWord64# :: Int# -> ByteArray# -> Word64# - - -{-# RULES -"fromIntegral/Int->Word64" fromIntegral = \(I# x#) -> W64# (int64ToWord64# (intToInt64# x#)) -"fromIntegral/Word->Word64" fromIntegral = \(W# x#) -> W64# (wordToWord64# x#) -"fromIntegral/Word64->Int" fromIntegral = \(W64# x#) -> I# (word2Int# (word64ToWord# x#)) -"fromIntegral/Word64->Word" fromIntegral = \(W64# x#) -> W# (word64ToWord# x#) -"fromIntegral/Word64->Word64" fromIntegral = id :: Word64 -> Word64 - #-} - -#else - --- Word64 is represented in the same way as Word. --- Operations may assume and must ensure that it holds only values --- from its logical range. - -data Word64 = W64# Word# deriving (Eq, Ord) - -instance Num Word64 where - (W64# x#) + (W64# y#) = W64# (x# `plusWord#` y#) - (W64# x#) - (W64# y#) = W64# (x# `minusWord#` y#) - (W64# x#) * (W64# y#) = W64# (x# `timesWord#` y#) - negate (W64# x#) = W64# (int2Word# (negateInt# (word2Int# x#))) - abs x = x - signum 0 = 0 - signum _ = 1 - fromInteger (S# i#) = W64# (int2Word# i#) - fromInteger (J# s# d#) = W64# (integer2Word# s# d#) - -instance Enum Word64 where - succ x - | x /= maxBound = x + 1 - | otherwise = succError "Word64" - pred x - | x /= minBound = x - 1 - | otherwise = predError "Word64" - toEnum i@(I# i#) - | i >= 0 = W64# (int2Word# i#) - | otherwise = toEnumError "Word64" i (minBound::Word64, maxBound::Word64) - fromEnum x@(W64# x#) - | x <= fromIntegral (maxBound::Int) - = I# (word2Int# x#) - | otherwise = fromEnumError "Word64" x - enumFrom = integralEnumFrom - enumFromThen = integralEnumFromThen - enumFromTo = integralEnumFromTo - enumFromThenTo = integralEnumFromThenTo - -instance Integral Word64 where - quot x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `quotWord#` y#) - | otherwise = divZeroError "quot{Word64}" x - rem x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `remWord#` y#) - | otherwise = divZeroError "rem{Word64}" x - div x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `quotWord#` y#) - | otherwise = divZeroError "div{Word64}" x - mod x@(W64# x#) y@(W64# y#) - | y /= 0 = W64# (x# `remWord#` y#) - | otherwise = divZeroError "mod{Word64}" x - quotRem x@(W64# x#) y@(W64# y#) - | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word64}" x - divMod x@(W64# x#) y@(W64# y#) - | y /= 0 = (W64# (x# `quotWord#` y#), W64# (x# `remWord#` y#)) - | otherwise = divZeroError "quotRem{Word64}" x - toInteger (W64# x#) - | i# >=# 0# = S# i# - | otherwise = case word2Integer# x# of (# s, d #) -> J# s d - where - i# = word2Int# x# - -instance Bits Word64 where - (W64# x#) .&. (W64# y#) = W64# (x# `and#` y#) - (W64# x#) .|. (W64# y#) = W64# (x# `or#` y#) - (W64# x#) `xor` (W64# y#) = W64# (x# `xor#` y#) - complement (W64# x#) = W64# (x# `xor#` mb#) where W64# mb# = maxBound - (W64# x#) `shift` (I# i#) - | i# ==# 0# = W64# x# - | i# >=# 64# || i# <=# -64# = 0 - | i# ># 0# = W64# (x# `uncheckedShiftL#` i#) - | otherwise = W64# (x# `uncheckedShiftRL#` negateInt# i#) - (W64# x#) `rotate` (I# i#) - | i'# ==# 0# = W64# x# - | otherwise = W64# ((x# `uncheckedShiftL#` i'#) `or#` - (x# `uncheckedShiftRL#` (64# -# i'#))) - where - i'# = word2Int# (int2Word# i# `and#` int2Word# 63#) - bitSize _ = 64 - isSigned _ = False - -{-# RULES -"fromIntegral/a->Word64" fromIntegral = \x -> case fromIntegral x of W# x# -> W64# x# -"fromIntegral/Word64->a" fromIntegral = \(W64# x#) -> fromIntegral (W# x#) - #-} - -#endif - -instance CCallable Word64 -instance CReturnable Word64 - -instance Show Word64 where - showsPrec p x = showsPrec p (toInteger x) - -instance Real Word64 where - toRational x = toInteger x % 1 - -instance Bounded Word64 where - minBound = 0 - maxBound = 0xFFFFFFFFFFFFFFFF - -instance Ix Word64 where - range (m,n) = [m..n] - unsafeIndex b@(m,_) i = fromIntegral (i - m) - inRange (m,n) i = m <= i && i <= n - unsafeRangeSize b@(_l,h) = unsafeIndex b h + 1 - -instance Read Word64 where - readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s] -\end{code} diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs deleted file mode 100644 index 79feaf8..0000000 --- a/ghc/lib/std/Prelude.lhs +++ /dev/null @@ -1,146 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: Prelude.lhs,v 1.27 2001/11/14 11:15:53 simonmar Exp $ -% -% (c) The University of Glasgow, 1992-2000 -% - -\section[Prelude]{Module @Prelude@} - -We add the option -fno-implicit-prelude here to tell the reader that -special names such as () and -> shouldn't be resolved to Prelude.() -and Prelude.-> (as they are normally). -- SDM 8/10/97 - -\begin{code} -{-# OPTIONS -fno-implicit-prelude #-} - -module Prelude ( - - -- Everything corresponding to the Report's PreludeList - module PrelList, - lines, words, unlines, unwords, - sum, product, - - -- Everything corresponding to the Report's PreludeText - ReadS, ShowS, - Read(readsPrec, readList), - Show(showsPrec, showList, show), - reads, shows, read, lex, - showChar, showString, readParen, showParen, - - -- Everything corresponding to the Report's PreludeIO - ioError, userError, catch, - FilePath, IOError, - putChar, - putStr, putStrLn, print, - getChar, - getLine, getContents, interact, - readFile, writeFile, appendFile, readIO, readLn, - - Bool(..), - Maybe(..), - Either(..), - Ordering(..), - Char, String, Int, Integer, Float, Double, IO, - Rational, - []((:), []), - - module PrelTup, - -- Includes tuple types + fst, snd, curry, uncurry - ()(..), -- The unit type - (->), -- functions - - Eq(..), - Ord(..), - Enum(..), - Bounded(..), - Num(..), - Real(..), - Integral(..), - Fractional(..), - Floating(..), - RealFrac(..), - RealFloat(..), - - -- Monad stuff, from PrelBase, and defined here - Monad(..), - Functor(..), - mapM, mapM_, sequence, sequence_, (=<<), - - maybe, either, - (&&), (||), not, otherwise, - subtract, even, odd, gcd, lcm, (^), (^^), - fromIntegral, realToFrac, - --exported by PrelTup: fst, snd, curry, uncurry, - id, const, (.), flip, ($), until, - asTypeOf, error, undefined, - seq, ($!) - - ) where - -import Monad - -import PrelBase -import PrelList -#ifndef USE_REPORT_PRELUDE - hiding ( takeUInt_append ) -#endif -import PrelIO -import PrelIOBase -import PrelException -import PrelRead -import PrelEnum -import PrelNum -import PrelReal -import PrelFloat -import PrelTup -import PrelMaybe -import PrelShow -import PrelErr ( error, undefined ) - -infixr 0 $! -\end{code} - - -%********************************************************* -%* * -\subsection{Miscellaneous functions} -%* * -%********************************************************* - -\begin{code} -($!) :: (a -> b) -> a -> b -f $! x = x `seq` f x -\end{code} - - -%********************************************************* -%* * -\subsection{List sum and product} -%* * -%********************************************************* - -List sum and product are defined here because PrelList is too far -down the compilation chain to "see" the Num class. - -\begin{code} --- sum and product compute the sum or product of a finite list of numbers. -{-# SPECIALISE sum :: [Int] -> Int #-} -{-# SPECIALISE sum :: [Integer] -> Integer #-} -{-# SPECIALISE product :: [Int] -> Int #-} -{-# SPECIALISE product :: [Integer] -> Integer #-} -sum, product :: (Num a) => [a] -> a -#ifdef USE_REPORT_PRELUDE -sum = foldl (+) 0 -product = foldl (*) 1 -#else -sum l = sum' l 0 - where - sum' [] a = a - sum' (x:xs) a = sum' xs (a+x) -product l = prod l 1 - where - prod [] a = a - prod (x:xs) a = prod xs (a*x) -#endif -\end{code} - diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs deleted file mode 100644 index 1f19b20..0000000 --- a/ghc/lib/std/Random.lhs +++ /dev/null @@ -1,307 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: Random.lhs,v 1.25 2001/08/29 10:49:28 simonmar Exp $ -% -% (c) The University of Glasgow, 1995-2000 -% - -\section[Random]{Module @Random@} - -The June 1988 (v31 #6) issue of the Communications of the ACM has an -article by Pierre L'Ecuyer called, "Efficient and Portable Combined -Random Number Generators". Here is the Portable Combined Generator of -L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18. - -Transliterator: Lennart Augustsson - -sof 1/99 - code brought (kicking and screaming) into the new Random -world.. - -\begin{code} -module Random - ( - RandomGen(next, split, genRange) - , StdGen - , mkStdGen - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - ) where - -#ifndef __HUGS__ -import PrelGHC ( RealWorld ) -import PrelShow ( showSignedInt, showSpace ) -import PrelRead ( readDec ) -import PrelIOBase ( unsafePerformIO, stToIO ) -import PrelArr ( STRef, newSTRef, readSTRef, writeSTRef ) -import Time ( getClockTime, ClockTime(..) ) -#else -import PrelPrim ( IORef - , newIORef - , readIORef - , writeIORef - , unsafePerformIO - ) -#endif - -import CPUTime ( getCPUTime ) -import Char ( isSpace, chr, ord ) -\end{code} - -\begin{code} -class RandomGen g where - next :: g -> (Int, g) - split :: g -> (g, g) - genRange :: g -> (Int,Int) - - -- default mathod - genRange g = (minBound,maxBound) - - -data StdGen - = StdGen Int Int - -instance RandomGen StdGen where - next = stdNext - split = stdSplit - -#ifdef __HUGS__ -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 -#else -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showSignedInt p s1 . - showSpace . - showSignedInt p s2 -#endif - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r@[_] -> r - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) -\end{code} - -\begin{code} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s - | s < 0 = mkStdGen (-s) - | otherwise = StdGen (s1+1) (s2+1) - where - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s - | s < 0 = createStdGen (-s) - | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1)) - where - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -\end{code} - -The class definition - see library report for details. - -\begin{code} -class Random a where - -- Minimal complete definition: random and randomR - random :: RandomGen g => g -> (a, g) - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - randoms :: RandomGen g => g -> [a] - randoms g = x : randoms g' where (x,g') = random g - - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g - - randomIO :: IO a - randomIO = getStdRandom random - - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) -\end{code} - -\begin{code} -instance Random Int where - randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g - random g = randomR (minBound,maxBound) g - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g) -> (chr x, g) - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of - (x, g) -> (int2Bool x, g) - where - bool2Int False = 0 - bool2Int True = 1 - - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Double where - randomR ival g = randomIvalDouble ival id g - random g = randomR (0::Double,1) g - --- hah, so you thought you were saving cycles by using Float? -instance Random Float where - random g = randomIvalDouble (0::Double,1) realToFrac g - randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g -\end{code} - - -\begin{code} -#ifdef __HUGS__ -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - return (createStdGen (ct + o)) -#else -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (TOD sec _) <- getClockTime - return (createStdGen (sec * 12345 + ct + o)) -#endif - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - k = h - l + 1 - b = 2147483561 - n = iLogBase b k - - f 0 acc g = (acc, g) - f n acc g = - let - (x,g') = next g - in - f (n-1) (fromIntegral x + acc * b) g' - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble ((l+h)/2) + - fromDouble ((h-l) / realToFrac intRange) * - fromIntegral (x::Int) - in - (scaled_x, rng') - -intRange :: Integer -intRange = toInteger (maxBound::Int) - toInteger (minBound::Int) - -iLogBase :: Integer -> Integer -> Integer -iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) - -stdNext :: StdGen -> (Int, StdGen) -stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) -\end{code} - - -\begin{code} -#ifdef __HUGS__ - -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO (newIORef (createStdGen 0)) - -#else - -global_rng :: STRef RealWorld StdGen -global_rng = unsafePerformIO $ do - rng <- mkStdRNG 0 - stToIO (newSTRef rng) - -setStdGen :: StdGen -> IO () -setStdGen sgen = stToIO (writeSTRef global_rng sgen) - -getStdGen :: IO StdGen -getStdGen = stToIO (readSTRef global_rng) - -#endif - - -newStdGen :: IO StdGen -newStdGen = do - rng <- getStdGen - let (a,b) = split rng - setStdGen a - return b - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = do - rng <- getStdGen - let (v, new_rng) = f rng - setStdGen new_rng - return v -\end{code} diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs deleted file mode 100644 index dd18de3..0000000 --- a/ghc/lib/std/Ratio.lhs +++ /dev/null @@ -1,97 +0,0 @@ -% ------------------------------------------------------------------------------ -% $Id: Ratio.lhs,v 1.7 2000/06/30 13:39:36 simonmar Exp $ -% -% (c) The University of Glasgow, 1994-2000 -% - -\section[Ratio]{Module @Ratio@} - -Standard functions on rational numbers - -\begin{code} -module Ratio - ( Ratio - , Rational - , (%) -- :: (Integral a) => a -> a -> Ratio a - , numerator -- :: (Integral a) => Ratio a -> a - , denominator -- :: (Integral a) => Ratio a -> a - , approxRational -- :: (RealFrac a) => a -> a -> Rational - - -- Ratio instances: - -- (Integral a) => Eq (Ratio a) - -- (Integral a) => Ord (Ratio a) - -- (Integral a) => Num (Ratio a) - -- (Integral a) => Real (Ratio a) - -- (Integral a) => Fractional (Ratio a) - -- (Integral a) => RealFrac (Ratio a) - -- (Integral a) => Enum (Ratio a) - -- (Read a, Integral a) => Read (Ratio a) - -- (Integral a) => Show (Ratio a) - -- - -- Implementation checked wrt. Haskell 98 lib report, 1/99. - - ) where -\end{code} - - -#ifndef __HUGS__ - -\begin{code} -import Prelude -- To generate the dependencies -import PrelReal -- The basic defns for Ratio -\end{code} - -%********************************************************* -%* * -\subsection{approxRational} -%* * -%********************************************************* - -@approxRational@, applied to two real fractional numbers x and epsilon, -returns the simplest rational number within epsilon of x. A rational -number n%d in reduced form is said to be simpler than another n'%d' if -abs n <= abs n' && d <= d'. Any real interval contains a unique -simplest rational; here, for simplicity, we assume a closed rational -interval. If such an interval includes at least one whole number, then -the simplest rational is the absolutely least whole number. Otherwise, -the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d -and abs r' < d', and the simplest rational is q%1 + the reciprocal of -the simplest rational between d'%r' and d%r. - -\begin{code} -approxRational :: (RealFrac a) => a -> a -> Rational -approxRational rat eps = simplest (rat-eps) (rat+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 = toRational x - n = numerator xr - d = denominator xr - nd' = toRational y - n' = numerator nd' - d' = denominator nd' - - 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' - nd'' = simplest' d' r' d r - n'' = numerator nd'' - d'' = denominator nd'' - -\end{code} - -#else - -\begin{code} --- Hugs already has this functionally inside its prelude -\end{code} - -#endif - - - diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs deleted file mode 100644 index 51029da..0000000 --- a/ghc/lib/std/System.lhs +++ /dev/null @@ -1,142 +0,0 @@ --- ----------------------------------------------------------------------------- --- $Id: System.lhs,v 1.37 2001/11/08 16:36:39 simonmar Exp $ --- --- (c) The University of Glasgow, 1994-2000 --- - -\begin{code} -#include "config.h" -module System - ( - ExitCode(ExitSuccess,ExitFailure) - , getArgs -- :: IO [String] - , getProgName -- :: IO String - , getEnv -- :: String -> IO String - , system -- :: String -> IO ExitCode - , exitWith -- :: ExitCode -> IO a - , exitFailure -- :: IO a - ) where - -import Monad -import Prelude -import PrelCError -import PrelCString -import PrelCTypes -import PrelMarshalArray -import PrelMarshalAlloc -import PrelPtr -import PrelStorable -import PrelIOBase - --- --------------------------------------------------------------------------- --- getArgs, getProgName, getEnv - --- Computation `getArgs' returns a list of the program's command --- line arguments (not including the program name). - -getArgs :: IO [String] -getArgs = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - getProgArgv p_argc p_argv - p <- fromIntegral `liftM` peek p_argc - argv <- peek p_argv - peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString - - -foreign import "getProgArgv" unsafe - getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - --- Computation `getProgName' returns the name of the program --- as it was invoked. - -getProgName :: IO String -getProgName = - alloca $ \ p_argc -> - alloca $ \ p_argv -> do - getProgArgv p_argc p_argv - argv <- peek p_argv - unpackProgName argv - --- Computation `getEnv var' returns the value --- of the environment variable {\em var}. - --- This computation may fail with --- NoSuchThing: The environment variable does not exist. - -getEnv :: String -> IO String -getEnv name = - withCString name $ \s -> do - litstring <- _getenv s - if litstring /= nullPtr - then peekCString litstring - else ioException (IOError Nothing NoSuchThing "getEnv" - "no environment variable" (Just name)) - -foreign import ccall "getenv" unsafe _getenv :: CString -> IO (Ptr CChar) - --- --------------------------------------------------------------------------- --- system - --- Computation `system cmd' returns the exit code --- produced when the operating system processes the command {\em cmd}. - --- This computation may fail with --- PermissionDenied --- The process has insufficient privileges to perform the operation. --- ResourceExhausted --- Insufficient resources are available to perform the operation. --- UnsupportedOperation --- The implementation does not support system calls. - -system :: String -> IO ExitCode -system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing) -system cmd = - withCString cmd $ \s -> do - status <- throwErrnoIfMinus1 "system" (primSystem s) - case status of - 0 -> return ExitSuccess - n -> return (ExitFailure n) - -foreign import ccall "systemCmd" unsafe primSystem :: CString -> IO Int - --- --------------------------------------------------------------------------- --- exitWith - --- `exitWith code' terminates the program, returning `code' to the --- program's caller. Before it terminates, any open or semi-closed --- handles are first closed. - -exitWith :: ExitCode -> IO a -exitWith ExitSuccess = throw (ExitException ExitSuccess) -exitWith code@(ExitFailure n) - | n == 0 = ioException (IOError Nothing InvalidArgument "exitWith" "ExitFailure 0" Nothing) - | otherwise = throw (ExitException code) - -exitFailure :: IO a -exitFailure = exitWith (ExitFailure 1) - --- --------------------------------------------------------------------------- --- Local utilities - -unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] -unpackProgName argv = do - s <- peekElemOff argv 0 >>= peekCString - return (basename s) - where - basename :: String -> String - basename f = go f f - where - go acc [] = acc - go acc (x:xs) - | isPathSeparator x = go xs xs - | otherwise = go acc xs - - isPathSeparator :: Char -> Bool - isPathSeparator '/' = True -#ifdef mingw32_TARGET_OS - isPathSeparator '\\' = True -#endif - isPathSeparator _ = False - -\end{code} diff --git a/ghc/lib/std/Time.hsc b/ghc/lib/std/Time.hsc deleted file mode 100644 index 4a9b77e..0000000 --- a/ghc/lib/std/Time.hsc +++ /dev/null @@ -1,640 +0,0 @@ - --- ----------------------------------------------------------------------------- --- $Id: Time.hsc,v 1.22 2001/11/06 11:11:07 simonmar Exp $ --- --- (c) The University of Glasgow, 1995-2001 --- - -{- -Haskell 98 Time of Day Library ------------------------------- - -The Time library provides standard functionality for clock times, -including timezone information (i.e, the functionality of "time.h", -adapted to the Haskell environment), It follows RFC 1129 in its use of -Coordinated Universal Time (UTC). - -2000/06/17 : -RESTRICTIONS: - * min./max. time diff currently is restricted to - [minBound::Int, maxBound::Int] - - * surely other restrictions wrt. min/max bounds - - -NOTES: - * printing times - - `showTime' (used in `instance Show ClockTime') always prints time - converted to the local timezone (even if it is taken from - `(toClockTime . toUTCTime)'), whereas `calendarTimeToString' - honors the tzone & tz fields and prints UTC or whatever timezone - is stored inside CalendarTime. - - Maybe `showTime' should be changed to use UTC, since it would - better correspond to the actual representation of `ClockTime' - (can be done by replacing localtime(3) by gmtime(3)). - - -BUGS: - * add proper handling of microsecs, currently, they're mostly - ignored - - * `formatFOO' case of `%s' is currently broken... - - -TODO: - * check for unusual date cases, like 1970/1/1 00:00h, and conversions - between different timezone's etc. - - * check, what needs to be in the IO monad, the current situation - seems to be a bit inconsistent to me - - * check whether `isDst = -1' works as expected on other arch's - (Solaris anyone?) - - * add functions to parse strings to `CalendarTime' (some day...) - - * implement padding capabilities ("%_", "%-") in `formatFOO' - - * add rfc822 timezone (+0200 is CEST) representation ("%z") in `formatFOO' --} - -module Time - ( - Month(..) - , Day(..) - - , ClockTime(..) -- non-standard, lib. report gives this as abstract - -- instance Eq, Ord - -- instance Show (non-standard) - - , getClockTime - - , TimeDiff(..) - , noTimeDiff -- non-standard (but useful when constructing TimeDiff vals.) - , diffClockTimes - , addToClockTime - - , normalizeTimeDiff -- non-standard - , timeDiffToString -- non-standard - , formatTimeDiff -- non-standard - - , CalendarTime(..) - , toCalendarTime - , toUTCTime - , toClockTime - , calendarTimeToString - , formatCalendarTime - - ) where - -#include "HsStd.h" - -import Ix -import Locale - -import PrelMarshalAlloc -import PrelMarshalUtils -import PrelMarshalError -import PrelStorable -import PrelCString -import PrelCTypesISO -import PrelCTypes -import PrelCError -import PrelInt -import PrelPtr -import PrelIOBase -import PrelShow -import PrelNum -import PrelBase - --- One way to partition and give name to chunks of a year and a week: - -data Month - = January | February | March | April - | May | June | July | August - | September | October | November | December - deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) - -data Day - = Sunday | Monday | Tuesday | Wednesday - | Thursday | Friday | Saturday - deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) - --- @ClockTime@ is an abstract type, used for the internal clock time. --- Clock times may be compared, converted to strings, or converted to an --- external calendar time @CalendarTime@. - -data ClockTime = TOD Integer -- Seconds since 00:00:00 on 1 Jan 1970 - Integer -- Picoseconds with the specified second - deriving (Eq, Ord) - --- When a ClockTime is shown, it is converted to a CalendarTime in the current --- timezone and then printed. FIXME: This is arguably wrong, since we can't --- get the current timezone without being in the IO monad. - -instance Show ClockTime where - showsPrec _ t = showString (calendarTimeToString - (unsafePerformIO (toCalendarTime t))) - showList = showList__ (showsPrec 0) - -{- -@CalendarTime@ is a user-readable and manipulable -representation of the internal $ClockTime$ type. The -numeric fields have the following ranges. - -\begin{verbatim} -Value Range Comments ------ ----- -------- - -year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate] -mon 0 .. 11 [Jan = 0, Dec = 11] -day 1 .. 31 -hour 0 .. 23 -min 0 .. 59 -sec 0 .. 61 [Allows for two leap seconds] -picosec 0 .. (10^12)-1 [This could be over-precise?] -wday 0 .. 6 [Sunday = 0, Saturday = 6] -yday 0 .. 365 [364 in non-Leap years] -tz -43200 .. 43200 [Variation from UTC in seconds] -\end{verbatim} - -The {\em tzname} field is the name of the time zone. The {\em isdst} -field indicates whether Daylight Savings Time would be in effect. --} - -data CalendarTime - = CalendarTime { - ctYear :: Int, - ctMonth :: Month, - ctDay :: Int, - ctHour :: Int, - ctMin :: Int, - ctSec :: Int, - ctPicosec :: Integer, - ctWDay :: Day, - ctYDay :: Int, - ctTZName :: String, - ctTZ :: Int, - ctIsDST :: Bool - } - deriving (Eq,Ord,Read,Show) - --- The @TimeDiff@ type records the difference between two clock times in --- a user-readable way. - -data TimeDiff - = TimeDiff { - tdYear :: Int, - tdMonth :: Int, - tdDay :: Int, - tdHour :: Int, - tdMin :: Int, - tdSec :: Int, - tdPicosec :: Integer -- not standard - } - deriving (Eq,Ord,Read,Show) - -noTimeDiff :: TimeDiff -noTimeDiff = TimeDiff 0 0 0 0 0 0 0 - --- ----------------------------------------------------------------------------- --- getClockTime returns the current time in its internal representation. - -#if HAVE_GETTIMEOFDAY -getClockTime = do - allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do - throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr - sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime - usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime - return (TOD (fromIntegral sec) ((fromIntegral usec) * 1000000)) - -#elif HAVE_FTIME -getClockTime = do - allocaBytes (#const sizeof(struct timeb)) $ \ p_timeb -> do - ftime p_timeb - sec <- (#peek struct timeb,time) p_timeb :: IO CTime - msec <- (#peek struct timeb,millitm) p_timeb :: IO CUShort - return (TOD (fromIntegral sec) (fromIntegral msec * 1000000000)) - -#else /* use POSIX time() */ -getClockTime = do - secs <- time nullPtr -- can't fail, according to POSIX - return (TOD (fromIntegral secs) 0) - -#endif - --- ----------------------------------------------------------------------------- --- addToClockTime d t adds a time difference d and a --- clock time t to yield a new clock time. The difference d --- may be either positive or negative. diffClockTimes t1 t2 returns --- the difference between two clock times t1 and t2 as a TimeDiff. - -addToClockTime :: TimeDiff -> ClockTime -> ClockTime -addToClockTime (TimeDiff year mon day hour min sec psec) - (TOD c_sec c_psec) = - let - sec_diff = toInteger sec + - 60 * toInteger min + - 3600 * toInteger hour + - 24 * 3600 * toInteger day - cal = toUTCTime (TOD (c_sec + sec_diff) (c_psec + psec)) - -- FIXME! ^^^^ - new_mon = fromEnum (ctMonth cal) + r_mon - (month', yr_diff) - | new_mon < 0 = (toEnum (12 + new_mon), (-1)) - | new_mon > 11 = (toEnum (new_mon `mod` 12), 1) - | otherwise = (toEnum new_mon, 0) - - (r_yr, r_mon) = mon `quotRem` 12 - - year' = ctYear cal + year + r_yr + yr_diff - in - toClockTime cal{ctMonth=month', ctYear=year'} - -diffClockTimes :: ClockTime -> ClockTime -> TimeDiff --- diffClockTimes is meant to be the dual to `addToClockTime'. --- If you want to have the TimeDiff properly splitted, use --- `normalizeTimeDiff' on this function's result --- --- CAVEAT: see comment of normalizeTimeDiff -diffClockTimes (TOD sa pa) (TOD sb pb) = - noTimeDiff{ tdSec = fromIntegral (sa - sb) - -- FIXME: can handle just 68 years... - , tdPicosec = pa - pb - } - - -normalizeTimeDiff :: TimeDiff -> TimeDiff --- FIXME: handle psecs properly --- FIXME: ?should be called by formatTimeDiff automagically? --- --- when applied to something coming out of `diffClockTimes', you loose --- the duality to `addToClockTime', since a year does not always have --- 365 days, etc. --- --- apply this function as late as possible to prevent those "rounding" --- errors -normalizeTimeDiff td = - let - rest0 = tdSec td - + 60 * (tdMin td - + 60 * (tdHour td - + 24 * (tdDay td - + 30 * (tdMonth td - + 365 * tdYear td)))) - - (diffYears, rest1) = rest0 `quotRem` (365 * 24 * 3600) - (diffMonths, rest2) = rest1 `quotRem` (30 * 24 * 3600) - (diffDays, rest3) = rest2 `quotRem` (24 * 3600) - (diffHours, rest4) = rest3 `quotRem` 3600 - (diffMins, diffSecs) = rest4 `quotRem` 60 - in - td{ tdYear = diffYears - , tdMonth = diffMonths - , tdDay = diffDays - , tdHour = diffHours - , tdMin = diffMins - , tdSec = diffSecs - } - --- ----------------------------------------------------------------------------- --- How do we deal with timezones on this architecture? - --- The POSIX way to do it is through the global variable tzname[]. --- But that's crap, so we do it The BSD Way if we can: namely use the --- tm_zone and tm_gmtoff fields of struct tm, if they're available. - -zone :: Ptr CTm -> IO (Ptr CChar) -gmtoff :: Ptr CTm -> IO CLong -#if HAVE_TM_ZONE -zone x = (#peek struct tm,tm_zone) x -gmtoff x = (#peek struct tm,tm_gmtoff) x - -#else /* ! HAVE_TM_ZONE */ -# if HAVE_TZNAME || defined(_WIN32) -# if cygwin32_TARGET_OS -# define tzname _tzname -# endif -# ifndef mingw32_TARGET_OS -foreign label tzname :: Ptr (Ptr CChar) -# else -foreign import "ghcTimezone" unsafe timezone :: Ptr CLong -foreign import "ghcTzname" unsafe tzname :: Ptr (Ptr CChar) -# def inline long *ghcTimezone(void) { return &_timezone; } -# def inline char **ghcTzname(void) { return _tzname; } -# endif -zone x = do - dst <- (#peek struct tm,tm_isdst) x - if dst then peekElemOff tzname 1 else peekElemOff tzname 0 -# else /* ! HAVE_TZNAME */ --- We're in trouble. If you should end up here, please report this as a bug. -# error "Don't know how to get at timezone name on your OS." -# endif /* ! HAVE_TZNAME */ - --- Get the offset in secs from UTC, if (struct tm) doesn't supply it. */ -#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) -#define timezone _timezone -#endif - -# if HAVE_ALTZONE -foreign label altzone :: Ptr CTime -foreign label timezone :: Ptr CTime -gmtoff x = do - dst <- (#peek struct tm,tm_isdst) x - tz <- if dst then peek altzone else peek timezone - return (fromIntegral tz) -# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone ) -# else /* ! HAVE_ALTZONE */ --- Assume that DST offset is 1 hour ... -gmtoff x = do - dst <- (#peek struct tm,tm_isdst) x - tz <- peek timezone - if dst then return (fromIntegral tz - 3600) else return tz -# endif /* ! HAVE_ALTZONE */ -#endif /* ! HAVE_TM_ZONE */ - --- ----------------------------------------------------------------------------- --- toCalendarTime t converts t to a local time, modified by --- the current timezone and daylight savings time settings. toUTCTime --- t converts t into UTC time. toClockTime l converts l into the --- corresponding internal ClockTime. The wday, yday, tzname, and isdst fields --- are ignored. - - -toCalendarTime :: ClockTime -> IO CalendarTime -#if HAVE_LOCALTIME_R -toCalendarTime = clockToCalendarTime_reentrant (throwAwayReturnPointer localtime_r) False -#else -toCalendarTime = clockToCalendarTime_static localtime False -#endif - -toUTCTime :: ClockTime -> CalendarTime -#if HAVE_GMTIME_R -toUTCTime = unsafePerformIO . clockToCalendarTime_reentrant (throwAwayReturnPointer gmtime_r) True -#else -toUTCTime = unsafePerformIO . clockToCalendarTime_static gmtime True -#endif - -throwAwayReturnPointer :: (Ptr CTime -> Ptr CTm -> IO (Ptr CTm)) - -> (Ptr CTime -> Ptr CTm -> IO ( )) -throwAwayReturnPointer fun x y = fun x y >> return () - -clockToCalendarTime_static :: (Ptr CTime -> IO (Ptr CTm)) -> Bool -> ClockTime - -> IO CalendarTime -clockToCalendarTime_static fun is_utc (TOD secs psec) = do - withObject (fromIntegral secs :: CTime) $ \ p_timer -> do - p_tm <- fun p_timer -- can't fail, according to POSIX - clockToCalendarTime_aux is_utc p_tm psec - -clockToCalendarTime_reentrant :: (Ptr CTime -> Ptr CTm -> IO ()) -> Bool -> ClockTime - -> IO CalendarTime -clockToCalendarTime_reentrant fun is_utc (TOD secs psec) = do - withObject (fromIntegral secs :: CTime) $ \ p_timer -> do - allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do - fun p_timer p_tm - clockToCalendarTime_aux is_utc p_tm psec - -clockToCalendarTime_aux :: Bool -> Ptr CTm -> Integer -> IO CalendarTime -clockToCalendarTime_aux is_utc p_tm psec = do - sec <- (#peek struct tm,tm_sec ) p_tm :: IO CInt - min <- (#peek struct tm,tm_min ) p_tm :: IO CInt - hour <- (#peek struct tm,tm_hour ) p_tm :: IO CInt - mday <- (#peek struct tm,tm_mday ) p_tm :: IO CInt - mon <- (#peek struct tm,tm_mon ) p_tm :: IO CInt - year <- (#peek struct tm,tm_year ) p_tm :: IO CInt - wday <- (#peek struct tm,tm_wday ) p_tm :: IO CInt - yday <- (#peek struct tm,tm_yday ) p_tm :: IO CInt - isdst <- (#peek struct tm,tm_isdst) p_tm :: IO CInt - zone <- zone p_tm - tz <- gmtoff p_tm - - tzname <- peekCString zone - - let month | mon >= 0 && mon <= 11 = toEnum (fromIntegral mon) - | otherwise = error ("toCalendarTime: illegal month value: " ++ show mon) - - return (CalendarTime - (1900 + fromIntegral year) - month - (fromIntegral mday) - (fromIntegral hour) - (fromIntegral min) - (fromIntegral sec) - psec - (toEnum (fromIntegral wday)) - (fromIntegral yday) - (if is_utc then "UTC" else tzname) - (if is_utc then 0 else fromIntegral tz) - (if is_utc then False else isdst /= 0)) - - -toClockTime :: CalendarTime -> ClockTime -toClockTime (CalendarTime year mon mday hour min sec psec - _wday _yday _tzname tz isdst) = - - -- `isDst' causes the date to be wrong by one hour... - -- FIXME: check, whether this works on other arch's than Linux, too... - -- - -- so we set it to (-1) (means `unknown') and let `mktime' determine - -- the real value... - let isDst = -1 :: CInt in -- if isdst then (1::Int) else 0 - - if psec < 0 || psec > 999999999999 then - error "Time.toClockTime: picoseconds out of range" - else if tz < -43200 || tz > 43200 then - error "Time.toClockTime: timezone offset out of range" - else - unsafePerformIO $ do - allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do - (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt) - (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt) - (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt) - (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt) - (#poke struct tm,tm_mon ) p_tm (fromIntegral (fromEnum mon) :: CInt) - (#poke struct tm,tm_year ) p_tm (fromIntegral year - 1900 :: CInt) - (#poke struct tm,tm_isdst) p_tm isDst - t <- throwIf (== -1) (\_ -> "Time.toClockTime: invalid input") - (mktime p_tm) - -- - -- mktime expects its argument to be in the local timezone, but - -- toUTCTime makes UTC-encoded CalendarTime's ... - -- - -- Since there is no any_tz_struct_tm-to-time_t conversion - -- function, we have to fake one... :-) If not in all, it works in - -- most cases (before, it was the other way round...) - -- - -- Luckily, mktime tells us, what it *thinks* the timezone is, so, - -- to compensate, we add the timezone difference to mktime's - -- result. - -- - gmtoff <- gmtoff p_tm - let res = fromIntegral t - tz + fromIntegral gmtoff - return (TOD (fromIntegral res) psec) - --- ----------------------------------------------------------------------------- --- Converting time values to strings. - -calendarTimeToString :: CalendarTime -> String -calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" - -formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String -formatCalendarTime l fmt (CalendarTime year mon day hour min sec _ - wday yday tzname _ _) = - doFmt fmt - where doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented - doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented - doFmt ('%':c:cs) = decode c ++ doFmt cs - doFmt (c:cs) = c : doFmt cs - doFmt "" = "" - - decode 'A' = fst (wDays l !! fromEnum wday) -- day of the week, full name - decode 'a' = snd (wDays l !! fromEnum wday) -- day of the week, abbrev. - decode 'B' = fst (months l !! fromEnum mon) -- month, full name - decode 'b' = snd (months l !! fromEnum mon) -- month, abbrev - decode 'h' = snd (months l !! fromEnum mon) -- ditto - decode 'C' = show2 (year `quot` 100) -- century - decode 'c' = doFmt (dateTimeFmt l) -- locale's data and time format. - decode 'D' = doFmt "%m/%d/%y" - decode 'd' = show2 day -- day of the month - decode 'e' = show2' day -- ditto, padded - decode 'H' = show2 hour -- hours, 24-hour clock, padded - decode 'I' = show2 (to12 hour) -- hours, 12-hour clock - decode 'j' = show3 yday -- day of the year - decode 'k' = show2' hour -- hours, 24-hour clock, no padding - decode 'l' = show2' (to12 hour) -- hours, 12-hour clock, no padding - decode 'M' = show2 min -- minutes - decode 'm' = show2 (fromEnum mon+1) -- numeric month - decode 'n' = "\n" - decode 'p' = (if hour < 12 then fst else snd) (amPm l) -- am or pm - decode 'R' = doFmt "%H:%M" - decode 'r' = doFmt (time12Fmt l) - decode 'T' = doFmt "%H:%M:%S" - decode 't' = "\t" - decode 'S' = show2 sec -- seconds - decode 's' = show2 sec -- number of secs since Epoch. (ToDo.) - decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) -- week number, starting on Sunday. - decode 'u' = show (let n = fromEnum wday in -- numeric day of the week (1=Monday, 7=Sunday) - if n == 0 then 7 else n) - decode 'V' = -- week number (as per ISO-8601.) - let (week, days) = -- [yep, I've always wanted to be able to display that too.] - (yday + 7 - if fromEnum wday > 0 then - fromEnum wday - 1 else 6) `divMod` 7 - in show2 (if days >= 4 then - week+1 - else if week == 0 then 53 else week) - - decode 'W' = -- week number, weeks starting on monday - show2 ((yday + 7 - if fromEnum wday > 0 then - fromEnum wday - 1 else 6) `div` 7) - decode 'w' = show (fromEnum wday) -- numeric day of the week, weeks starting on Sunday. - decode 'X' = doFmt (timeFmt l) -- locale's preferred way of printing time. - decode 'x' = doFmt (dateFmt l) -- locale's preferred way of printing dates. - decode 'Y' = show year -- year, including century. - decode 'y' = show2 (year `rem` 100) -- year, within century. - decode 'Z' = tzname -- timezone name - decode '%' = "%" - decode c = [c] - - -show2, show2', show3 :: Int -> String -show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] - -show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x - -show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) - -to12 :: Int -> Int -to12 h = let h' = h `mod` 12 in if h' == 0 then 12 else h' - --- Useful extensions for formatting TimeDiffs. - -timeDiffToString :: TimeDiff -> String -timeDiffToString = formatTimeDiff defaultTimeLocale "%c" - -formatTimeDiff :: TimeLocale -> String -> TimeDiff -> String -formatTimeDiff l fmt td@(TimeDiff year month day hour min sec _) - = doFmt fmt - where - doFmt "" = "" - doFmt ('%':'-':cs) = doFmt ('%':cs) -- padding not implemented - doFmt ('%':'_':cs) = doFmt ('%':cs) -- padding not implemented - doFmt ('%':c:cs) = decode c ++ doFmt cs - doFmt (c:cs) = c : doFmt cs - - decode spec = - case spec of - 'B' -> fst (months l !! fromEnum month) - 'b' -> snd (months l !! fromEnum month) - 'h' -> snd (months l !! fromEnum month) - 'c' -> defaultTimeDiffFmt td - 'C' -> show2 (year `quot` 100) - 'D' -> doFmt "%m/%d/%y" - 'd' -> show2 day - 'e' -> show2' day - 'H' -> show2 hour - 'I' -> show2 (to12 hour) - 'k' -> show2' hour - 'l' -> show2' (to12 hour) - 'M' -> show2 min - 'm' -> show2 (fromEnum month + 1) - 'n' -> "\n" - 'p' -> (if hour < 12 then fst else snd) (amPm l) - 'R' -> doFmt "%H:%M" - 'r' -> doFmt (time12Fmt l) - 'T' -> doFmt "%H:%M:%S" - 't' -> "\t" - 'S' -> show2 sec - 's' -> show2 sec -- Implementation-dependent, sez the lib doc.. - 'X' -> doFmt (timeFmt l) - 'x' -> doFmt (dateFmt l) - 'Y' -> show year - 'y' -> show2 (year `rem` 100) - '%' -> "%" - c -> [c] - - defaultTimeDiffFmt (TimeDiff year month day hour min sec _) = - foldr (\ (v,s) rest -> - (if v /= 0 - then show v ++ ' ':(addS v s) - ++ if null rest then "" else ", " - else "") ++ rest - ) - "" - (zip [year, month, day, hour, min, sec] (intervals l)) - - addS v s = if abs v == 1 then fst s else snd s - - --- ----------------------------------------------------------------------------- --- Foreign time interface (POSIX) - -type CTm = () -- struct tm - -#if HAVE_LOCALTIME_R -foreign import unsafe localtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) -#else -foreign import unsafe localtime :: Ptr CTime -> IO (Ptr CTm) -#endif -#if HAVE_GMTIME_R -foreign import unsafe gmtime_r :: Ptr CTime -> Ptr CTm -> IO (Ptr CTm) -#else -foreign import unsafe gmtime :: Ptr CTime -> IO (Ptr CTm) -#endif -foreign import unsafe mktime :: Ptr CTm -> IO CTime -foreign import unsafe time :: Ptr CTime -> IO CTime - -#if HAVE_GETTIMEOFDAY -type CTimeVal = () -foreign import unsafe gettimeofday :: Ptr CTimeVal -> Ptr () -> IO CInt -#endif - -#if HAVE_FTIME -type CTimeB = () -#ifndef mingw32_TARGET_OS -foreign import unsafe ftime :: Ptr CTimeB -> IO CInt -#else -foreign import unsafe ftime :: Ptr CTimeB -> IO () -#endif -#endif diff --git a/ghc/lib/std/cbits/CTypes.h b/ghc/lib/std/cbits/CTypes.h deleted file mode 100644 index 59342e7..0000000 --- a/ghc/lib/std/cbits/CTypes.h +++ /dev/null @@ -1,199 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: CTypes.h,v 1.5 2001/12/20 16:39:29 simonmar Exp $ - * - * Dirty CPP hackery for CTypes/CTypesISO - * - * (c) The FFI task force, 2000 - * -------------------------------------------------------------------------- */ - -#include "MachDeps.h" - -/* As long as there is no automatic derivation of classes for newtypes we resort - to extremely dirty cpp-hackery. :-P Some care has to be taken when the - macros below are modified, otherwise the layout rule will bite you. */ - -/* A hacked version for GHC follows the Haskell 98 version... */ -#ifndef __GLASGOW_HASKELL__ - -#define NUMERIC_TYPE(T,C,S,B) \ -newtype T = T B deriving (Eq, Ord) ; \ -INSTANCE_NUM(T) ; \ -INSTANCE_READ(T) ; \ -INSTANCE_SHOW(T) ; \ -INSTANCE_ENUM(T) ; \ -INSTANCE_TYPEABLE(T,C,S) ; - -#define INTEGRAL_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ -INSTANCE_BOUNDED(T) ; \ -INSTANCE_REAL(T) ; \ -INSTANCE_INTEGRAL(T) ; \ -INSTANCE_BITS(T) - -#define FLOATING_TYPE(T,C,S,B) \ -NUMERIC_TYPE(T,C,S,B) ; \ -INSTANCE_REAL(T) ; \ -INSTANCE_FRACTIONAL(T) ; \ -INSTANCE_FLOATING(T) ; \ -INSTANCE_REALFRAC(T) ; \ -INSTANCE_REALFLOAT(T) - -#define INSTANCE_READ(T) \ -instance Read T where { \ - readsPrec p s = fakeMap (\(x, t) -> (T x, t)) (readsPrec p s) } - -#define INSTANCE_SHOW(T) \ -instance Show T where { \ - showsPrec p (T x) = showsPrec p x } - -#define INSTANCE_NUM(T) \ -instance Num T where { \ - (T i) + (T j) = T (i + j) ; \ - (T i) - (T j) = T (i - j) ; \ - (T i) * (T j) = T (i * j) ; \ - negate (T i) = T (negate i) ; \ - abs (T i) = T (abs i) ; \ - signum (T i) = T (signum i) ; \ - fromInteger x = T (fromInteger x) } - -#define INSTANCE_TYPEABLE(T,C,S) \ -C :: TyCon ; \ -C = mkTyCon S ; \ -instance Typeable T where { \ - typeOf _ = mkAppTy C [] } - -#define INSTANCE_BOUNDED(T) \ -instance Bounded T where { \ - minBound = T minBound ; \ - maxBound = T maxBound } - -#define INSTANCE_ENUM(T) \ -instance Enum T where { \ - succ (T i) = T (succ i) ; \ - pred (T i) = T (pred i) ; \ - toEnum x = T (toEnum x) ; \ - fromEnum (T i) = fromEnum i ; \ - enumFrom (T i) = fakeMap T (enumFrom i) ; \ - enumFromThen (T i) (T j) = fakeMap T (enumFromThen i j) ; \ - enumFromTo (T i) (T j) = fakeMap T (enumFromTo i j) ; \ - enumFromThenTo (T i) (T j) (T k) = fakeMap T (enumFromThenTo i j k) } - -#define INSTANCE_REAL(T) \ -instance Real T where { \ - toRational (T i) = toRational i } - -#define INSTANCE_INTEGRAL(T) \ -instance Integral T where { \ - (T i) `quot` (T j) = T (i `quot` j) ; \ - (T i) `rem` (T j) = T (i `rem` j) ; \ - (T i) `div` (T j) = T (i `div` j) ; \ - (T i) `mod` (T j) = T (i `mod` j) ; \ - (T i) `quotRem` (T j) = let (q,r) = i `quotRem` j in (T q, T r) ; \ - (T i) `divMod` (T j) = let (d,m) = i `divMod` j in (T d, T m) ; \ - toInteger (T i) = toInteger i } - -#define INSTANCE_BITS(T) \ -instance Bits T where { \ - (T x) .&. (T y) = T (x .&. y) ; \ - (T x) .|. (T y) = T (x .|. y) ; \ - (T x) `xor` (T y) = T (x `xor` y) ; \ - complement (T x) = T (complement x) ; \ - shift (T x) n = T (shift x n) ; \ - rotate (T x) n = T (rotate x n) ; \ - bit n = T (bit n) ; \ - setBit (T x) n = T (setBit x n) ; \ - clearBit (T x) n = T (clearBit x n) ; \ - complementBit (T x) n = T (complementBit x n) ; \ - testBit (T x) n = testBit x n ; \ - bitSize (T x) = bitSize x ; \ - isSigned (T x) = isSigned x } - -#define INSTANCE_FRACTIONAL(T) \ -instance Fractional T where { \ - (T x) / (T y) = T (x / y) ; \ - recip (T x) = T (recip x) ; \ - fromRational r = T (fromRational r) } - -#define INSTANCE_FLOATING(T) \ -instance Floating T where { \ - pi = pi ; \ - exp (T x) = T (exp x) ; \ - log (T x) = T (log x) ; \ - sqrt (T x) = T (sqrt x) ; \ - (T x) ** (T y) = T (x ** y) ; \ - (T x) `logBase` (T y) = T (x `logBase` y) ; \ - sin (T x) = T (sin x) ; \ - cos (T x) = T (cos x) ; \ - tan (T x) = T (tan x) ; \ - asin (T x) = T (asin x) ; \ - acos (T x) = T (acos x) ; \ - atan (T x) = T (atan x) ; \ - sinh (T x) = T (sinh x) ; \ - cosh (T x) = T (cosh x) ; \ - tanh (T x) = T (tanh x) ; \ - asinh (T x) = T (asinh x) ; \ - acosh (T x) = T (acosh x) ; \ - atanh (T x) = T (atanh x) } - -#define INSTANCE_REALFRAC(T) \ -instance RealFrac T where { \ - properFraction (T x) = let (m,y) = properFraction x in (m, T y) ; \ - truncate (T x) = truncate x ; \ - round (T x) = round x ; \ - ceiling (T x) = ceiling x ; \ - floor (T x) = floor x } - -#define INSTANCE_REALFLOAT(T) \ -instance RealFloat T where { \ - floatRadix (T x) = floatRadix x ; \ - floatDigits (T x) = floatDigits x ; \ - floatRange (T x) = floatRange x ; \ - decodeFloat (T x) = decodeFloat x ; \ - encodeFloat m n = T (encodeFloat m n) ; \ - exponent (T x) = exponent x ; \ - significand (T x) = T (significand x) ; \ - scaleFloat n (T x) = T (scaleFloat n x) ; \ - isNaN (T x) = isNaN x ; \ - isInfinite (T x) = isInfinite x ; \ - isDenormalized (T x) = isDenormalized x ; \ - isNegativeZero (T x) = isNegativeZero x ; \ - isIEEE (T x) = isIEEE x ; \ - (T x) `atan2` (T y) = T (x `atan2` y) } - -#else /* __GLASGOW_HASKELL__ */ - -/* GHC can derive any class for a newtype, so we make use of that - * here... - */ - -#define NUMERIC_CLASSES Eq,Ord,Num,Enum -#define INTEGRAL_CLASSES Bounded,Real,Integral,Bits -#define FLOATING_CLASSES Real,Fractional,Floating,RealFrac,RealFloat - -#define NUMERIC_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES); \ -INSTANCE_READ(T,B); \ -INSTANCE_SHOW(T,B) - -#define INTEGRAL_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES, INTEGRAL_CLASSES); \ -INSTANCE_READ(T,B); \ -INSTANCE_SHOW(T,B) - -#define FLOATING_TYPE(T,C,S,B) \ -newtype T = T B deriving (NUMERIC_CLASSES, FLOATING_CLASSES); \ -INSTANCE_READ(T,B); \ -INSTANCE_SHOW(T,B) - -#define INSTANCE_READ(T,B) \ -instance Read T where { \ - readsPrec = unsafeCoerce# (readsPrec :: Int -> ReadS B); \ - readList = unsafeCoerce# (readList :: ReadS [B]); } - -#define INSTANCE_SHOW(T,B) \ -instance Show T where { \ - showsPrec = unsafeCoerce# (showsPrec :: Int -> B -> ShowS); \ - show = unsafeCoerce# (show :: B -> String); \ - showList = unsafeCoerce# (showList :: [B] -> ShowS); } - -#endif /* __GLASGOW_HASKELL__ */ diff --git a/ghc/lib/std/cbits/HsStd.h b/ghc/lib/std/cbits/HsStd.h deleted file mode 100644 index 39d6ca2..0000000 --- a/ghc/lib/std/cbits/HsStd.h +++ /dev/null @@ -1,100 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: HsStd.h,v 1.6 2001/12/03 20:59:08 sof Exp $ - * - * Definitions for package `std' which are visible in Haskell land. - * - * ---------------------------------------------------------------------------*/ - -#ifndef HSSTD_H -#define HSSTD_H - -#include "config.h" - -#ifdef HAVE_SYS_TYPES_H -#include -#endif -#ifdef HAVE_UNISTD_H -#include -#endif -#ifdef HAVE_SYS_STAT_H -#include -#endif -#ifdef HAVE_FCNTL_H -# include -#endif -#ifdef HAVE_TERMIOS_H -#include -#endif -#ifdef HAVE_SIGNAL_H -#include -#endif -#ifdef HAVE_ERRNO_H -#include -#endif -#ifdef HAVE_STRING_H -#include -#endif -#if defined(HAVE_GETTIMEOFDAY) -# ifdef HAVE_SYS_TIME_H -# include -# endif -#elif defined(HAVE_GETCLOCK) -# ifdef HAVE_SYS_TIMERS_H -# define POSIX_4D9 1 -# include -# endif -#endif -#if defined(HAVE_TIME_H) -# include -#endif -#ifdef HAVE_SYS_TIMEB_H -#include -#endif -#ifdef HAVE_WINDOWS_H -#include -#endif -#ifdef HAVE_SYS_TIMES_H -#include -#endif -#ifdef HAVE_WINSOCK_H -#include -#endif - -#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS) -# if defined(HAVE_SYS_RESOURCE_H) -# include -# endif -#endif - -#ifdef hpux_TARGET_OS -#include -#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b) -#define HAVE_GETRUSAGE -#endif - -/* For System */ -#ifdef HAVE_SYS_WAIT_H -#include -#endif -#ifdef HAVE_VFORK_H -#include -#endif - -#include "lockFile.h" - -#include "HsFFI.h" - -/* in ghc_errno.c */ -int *ghcErrno(void); - -/* in system.c */ -HsInt systemCmd(HsAddr cmd); - -/* in inputReady.c */ -int inputReady(int fd, int msecs, int isSock); - -/* in progargs.c */ -HsAddr get_prog_argv(void); -HsInt get_prog_argc(); - -#endif diff --git a/ghc/lib/std/cbits/Makefile b/ghc/lib/std/cbits/Makefile deleted file mode 100644 index 3ea2666..0000000 --- a/ghc/lib/std/cbits/Makefile +++ /dev/null @@ -1,23 +0,0 @@ -# $Id: Makefile,v 1.34 2001/12/02 15:47:08 panne Exp $ - -TOP = ../../.. -include $(TOP)/mk/boilerplate.mk - -PACKAGE = std -IS_CBITS_LIB = YES - -SRC_CC_OPTS += -Wall -DCOMPILING_STDLIB -I$(GHC_INCLUDE_DIR) -I$(GHC_RUNTIME_DIR) - -ifeq "$(ILXized)" "YES" -DLLized = YES -C_SRCS += $(FPTOOLS_TOP)/ghc/rts/StgPrimFloat.c -else -EXCLUDED_SRCS += ilxstubs.c -endif - -# ----------------------------------------------------------------------------- -# Installation - -INSTALL_DATAS += HsStd.h lockFile.h - -include $(TOP)/mk/target.mk diff --git a/ghc/lib/std/cbits/PrelIOUtils.c b/ghc/lib/std/cbits/PrelIOUtils.c deleted file mode 100644 index edbd898..0000000 --- a/ghc/lib/std/cbits/PrelIOUtils.c +++ /dev/null @@ -1,310 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994- - * - * IO / Handle support. - */ -#include "HsStd.h" -#include "PrelIOUtils.h" -#include -#include -#include - -#ifndef offsetof -#define offsetof(t, f) ((size_t) &((t *)0)->f) -#endif - -#ifdef _WIN32 -#include -#include -#endif - -HsBool prel_supportsTextMode() -{ -#if defined(mingw32_TARGET_OS) - return HS_BOOL_FALSE; -#else - return HS_BOOL_TRUE; -#endif -} - -HsInt prel_bufsiz() -{ - return BUFSIZ; -} - -HsInt prel_seek_cur() -{ - return SEEK_CUR; -} - -int prel_o_binary() -{ -#ifdef HAVE_O_BINARY - return O_BINARY; -#else - return 0; -#endif -} - -int prel_o_rdonly() -{ -#ifdef O_RDONLY - return O_RDONLY; -#else - return 0; -#endif -} - -int prel_o_wronly() -{ -#ifdef O_WRONLY - return O_WRONLY; -#else - return 0; -#endif -} - -int prel_o_rdwr() -{ -#ifdef O_RDWR - return O_RDWR; -#else - return 0; -#endif -} - -int prel_o_append() -{ -#ifdef O_APPEND - return O_APPEND; -#else - return 0; -#endif -} - -int prel_o_creat() -{ -#ifdef O_CREAT - return O_CREAT; -#else - return 0; -#endif -} - -int prel_o_excl() -{ -#ifdef O_EXCL - return O_EXCL; -#else - return 0; -#endif -} - -int prel_o_trunc() -{ -#ifdef O_TRUNC - return O_TRUNC; -#else - return 0; -#endif -} - -int prel_o_noctty() -{ -#ifdef O_NOCTTY - return O_NOCTTY; -#else - return 0; -#endif -} - -int prel_o_nonblock() -{ -#ifdef O_NONBLOCK - return O_NONBLOCK; -#else - return 0; -#endif -} - -HsInt prel_seek_set() -{ - return SEEK_SET; -} - -HsInt prel_seek_end() -{ - return SEEK_END; -} - -HsInt prel_setmode(HsInt fd, HsBool toBin) -{ -#ifdef _WIN32 - return setmode(fd,(toBin == HS_BOOL_TRUE) ? _O_BINARY : _O_TEXT); -#else - return 0; -#endif -} - -HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz) -{ -#ifdef _WIN32 - if (isSock) { - return send(fd,ptr + off, sz, 0); - } -#endif - return write(fd,ptr + off, sz); -} - -HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz) -{ -#ifdef _WIN32 - if (isSock) { - return recv(fd,ptr + off, sz, 0); - } -#endif - return read(fd,ptr + off, sz); - -} - -void *prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, HsInt src_off, size_t sz) -{ - return memcpy(dst+dst_off, src+src_off, sz); -} - - -int s_isreg_PrelPosix_wrap(int m) { return S_ISREG(m); } -int s_isdir_PrelPosix_wrap(int m) { return S_ISDIR(m); } -int s_isfifo_PrelPosix_wrap(int m) { return S_ISFIFO(m); } -int s_isblk_PrelPosix_wrap(int m) { return S_ISBLK(m); } -int s_ischr_PrelPosix_wrap(int m) { return S_ISCHR(m); } -#ifndef mingw32_TARGET_OS -int s_issock_PrelPosix_wrap(int m) { return S_ISSOCK(m); } -void sigemptyset_PrelPosix_wrap(sigset_t *set) { sigemptyset(set); } -#endif - -HsInt prel_sizeof_stat() -{ - return sizeof(struct stat); -} - -time_t prel_st_mtime(struct stat* st) { return st->st_mtime; } -off_t prel_st_size(struct stat* st) { return st->st_size; } -mode_t prel_st_mode(struct stat* st) { return st->st_mode; } - -#if HAVE_TERMIOS_H -tcflag_t prel_lflag(struct termios* ts) { return ts->c_lflag; } -void prel_poke_lflag(struct termios* ts, tcflag_t t) { ts->c_lflag = t; } -unsigned char* prel_ptr_c_cc(struct termios* ts) { return ((unsigned char*)(ts + offsetof(struct termios, c_cc))); } -#endif - -HsInt prel_sizeof_termios() -{ -#ifndef mingw32_TARGET_OS - return sizeof(struct termios); -#else - return 0; -#endif -} - -HsInt prel_sizeof_sigset_t() -{ -#ifndef mingw32_TARGET_OS - return sizeof(sigset_t); -#else - return 0; -#endif -} - -int prel_echo() -{ -#ifdef ECHO - return ECHO; -#else - return 0; -#endif - -} -int prel_tcsanow() -{ -#ifdef TCSANOW - return TCSANOW; -#else - return 0; -#endif - -} - -int prel_icanon() -{ -#ifdef ICANON - return ICANON; -#else - return 0; -#endif -} - -int prel_vmin() -{ -#ifdef VMIN - return VMIN; -#else - return 0; -#endif -} - -int prel_vtime() -{ -#ifdef VTIME - return VTIME; -#else - return 0; -#endif -} - -int prel_sigttou() -{ -#ifdef SIGTTOU - return SIGTTOU; -#else - return 0; -#endif -} - -int prel_sig_block() -{ -#ifdef SIG_BLOCK - return SIG_BLOCK; -#else - return 0; -#endif -} - -int prel_sig_setmask() -{ -#ifdef SIG_SETMASK - return SIG_SETMASK; -#else - return 0; -#endif -} - -int prel_f_getfl() -{ -#ifdef F_GETFL - return F_GETFL; -#else - return 0; -#endif -} - -int prel_f_setfl() -{ -#ifdef F_SETFL - return F_SETFL; -#else - return 0; -#endif -} - - diff --git a/ghc/lib/std/cbits/PrelIOUtils.h b/ghc/lib/std/cbits/PrelIOUtils.h deleted file mode 100644 index 04d79aa..0000000 --- a/ghc/lib/std/cbits/PrelIOUtils.h +++ /dev/null @@ -1,74 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994- - * - * IO / Handle support. - */ -#ifndef __PRELIOUTILS_H__ -#define __PRELIOUTILS_H__ - -/* PrelIOUtils.c */ -extern HsBool prel_supportsTextMode(); -extern HsInt prel_bufsiz(); -extern HsInt prel_seek_cur(); -extern HsInt prel_seek_set(); -extern HsInt prel_seek_end(); - -extern HsInt prel_sizeof_stat(); -extern time_t prel_st_mtime(struct stat* st); -extern off_t prel_st_size(struct stat* st); -extern mode_t prel_st_mode(struct stat* st); - -extern HsInt prel_sizeof_termios(); -extern HsInt prel_sizeof_sigset_t(); - -#if HAVE_TERMIOS_H -extern tcflag_t prel_lflag(struct termios* ts); -extern void prel_poke_lflag(struct termios* ts, tcflag_t t); -extern unsigned char* prel_ptr_c_cc(struct termios* ts); -#endif - -extern int prel_o_binary(); -extern int prel_o_rdonly(); -extern int prel_o_wronly(); -extern int prel_o_rdwr(); -extern int prel_o_append(); -extern int prel_o_creat(); -extern int prel_o_excl(); -extern int prel_o_trunc(); -extern int prel_o_noctty(); -extern int prel_o_nonblock(); - -extern int prel_echo(); -extern int prel_tcsanow(); -extern int prel_icanon(); -extern int prel_vmin(); -extern int prel_vtime(); -extern int prel_sigttou(); -extern int prel_sig_block(); -extern int prel_sig_setmask(); -extern int prel_f_getfl(); -extern int prel_f_setfl(); - -extern HsInt prel_setmode(HsInt fd, HsBool isBin); - -extern HsInt prel_PrelHandle_write(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); -extern HsInt prel_PrelHandle_read(HsInt fd, HsBool isSock, HsAddr ptr, HsInt off, int sz); - -extern void* prel_PrelIO_memcpy(char *dst, HsInt dst_off, const char *src, HsInt src_off, size_t sz); - -/* writeError.c */ -extern void writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len); - -extern int s_isreg_PrelPosix_wrap(int); -extern int s_isdir_PrelPosix_wrap(int); -extern int s_isfifo_PrelPosix_wrap(int); -extern int s_isblk_PrelPosix_wrap(int); -extern int s_ischr_PrelPosix_wrap(int); -#ifndef mingw32_TARGET_OS -extern int s_issock_PrelPosix_wrap(int); -extern void sigemptyset_PrelPosix_wrap(sigset_t *set); -#endif - - -#endif /* __PRELIOUTILS_H__ */ - diff --git a/ghc/lib/std/cbits/dirUtils.c b/ghc/lib/std/cbits/dirUtils.c deleted file mode 100644 index 4277797..0000000 --- a/ghc/lib/std/cbits/dirUtils.c +++ /dev/null @@ -1,126 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994- - * - * Directory Runtime Support - */ -#include "dirUtils.h" - -#if defined(mingw32_TARGET_OS) -#include -#endif - -#ifdef HAVE_STDLIB_H -# include -#endif -#ifdef HAVE_STDDEF_H -# include -#endif -#ifdef HAVE_ERRNO_H -# include -#endif - -HsInt -prel_mkdir(HsAddr pathName, HsInt mode) -{ -#if defined(mingw32_TARGET_OS) - return mkdir(pathName); -#else - return mkdir(pathName,mode); -#endif -} - -HsInt -prel_lstat(HsAddr fname, HsAddr st) -{ -#ifdef HAVE_LSTAT - return lstat((const char*)fname, (struct stat*)st); -#else - return stat((const char*)fname, (struct stat*)st); -#endif -} - -HsInt prel_s_ISDIR(mode_t m) {return S_ISDIR(m);} -HsInt prel_s_ISREG(mode_t m) {return S_ISREG(m);} - -HsInt prel_path_max() { return PATH_MAX; } -mode_t prel_R_OK() { return R_OK; } -mode_t prel_W_OK() { return W_OK; } -mode_t prel_X_OK() { return X_OK; } - -mode_t prel_S_IRUSR() { return S_IRUSR; } -mode_t prel_S_IWUSR() { return S_IWUSR; } -mode_t prel_S_IXUSR() { return S_IXUSR; } - -HsAddr prel_d_name(struct dirent* d) -{ -#ifndef mingw32_TARGET_OS - return (HsAddr)(&d->d_name); -#else - return (HsAddr)(d->d_name); -#endif -} - -HsInt prel_end_of_dir() -{ -#ifndef mingw32_TARGET_OS - return 0; -#else - return ENOENT; -#endif -} - -/* - * read an entry from the directory stream; opt for the - * re-entrant friendly way of doing this, if available. - */ -HsInt -prel_readdir(HsAddr dirPtr, HsAddr pDirEnt) -{ - struct dirent **pDirE = (struct dirent**)pDirEnt; -#if HAVE_READDIR_R - struct dirent* p; - int res; - static unsigned int nm_max = -1; - - if (pDirE == NULL) { - return -1; - } - if (nm_max == -1) { -#ifdef NAME_MAX - nm_max = NAME_MAX + 1; -#else - nm_max = pathconf(".", _PC_NAME_MAX); - if (nm_max == -1) { nm_max = 255; } - nm_max++; -#endif - } - p = (struct dirent*)malloc(sizeof(struct dirent) + nm_max); - if (p == NULL) return -1; - res = readdir_r((DIR*)dirPtr, p, pDirE); - if (res != 0) { - *pDirE = NULL; - free(p); - } - return res; -#else - - if (pDirE == NULL) { - return -1; - } - - *pDirE = readdir((DIR*)dirPtr); - if (*pDirE == NULL) { - return -1; - } else { - return 0; - } -#endif -} - -void -prel_free_dirent(HsAddr dEnt) -{ -#if HAVE_READDIR_R - free(dEnt); -#endif -} diff --git a/ghc/lib/std/cbits/dirUtils.h b/ghc/lib/std/cbits/dirUtils.h deleted file mode 100644 index 4d24f3c..0000000 --- a/ghc/lib/std/cbits/dirUtils.h +++ /dev/null @@ -1,41 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994- - * - * Directory Runtime Support - prototypes. - */ -#ifndef __DIRUTILS_H__ -#define __DIRUTILS_H__ -#include "HsStd.h" - -#include -#include -#include -#include -#include - -extern HsInt prel_mkdir(HsAddr pathName, HsInt mode); -extern HsInt prel_lstat(HsAddr fname, HsAddr st); - -extern HsInt prel_s_ISDIR(mode_t m); -extern HsInt prel_s_ISREG(mode_t m); - -extern HsInt prel_sz_stat(); -extern HsInt prel_path_max(); -extern mode_t prel_R_OK(); -extern mode_t prel_W_OK(); -extern mode_t prel_X_OK(); - -extern mode_t prel_S_IRUSR(); -extern mode_t prel_S_IWUSR(); -extern mode_t prel_S_IXUSR(); - -extern time_t prel_st_mtime(struct stat* st); -extern mode_t prel_st_mode(struct stat* st); - -extern HsAddr prel_d_name(struct dirent* d); - -extern HsInt prel_end_of_dir(); - -extern HsInt prel_readdir(HsAddr dirPtr, HsAddr pDirEnt); -extern void prel_free_dirent(HsAddr dEnt); -#endif /* __DIRUTILS_H__ */ diff --git a/ghc/lib/std/cbits/errUtils.h b/ghc/lib/std/cbits/errUtils.h deleted file mode 100644 index f8403a1..0000000 --- a/ghc/lib/std/cbits/errUtils.h +++ /dev/null @@ -1,112 +0,0 @@ -/* - * (c) The University of Glasgow, 2000-2001 - * - * GHC Error Number Conversion - prototypes. - */ -#ifndef __ERRUTILS_H__ -#define __ERRUTILS_H__ - -#include "HsStd.h" - -#define ErrCodeProto(x) extern HsInt prel_error_##x() - -ErrCodeProto(E2BIG); -ErrCodeProto(EACCES); -ErrCodeProto(EADDRINUSE); -ErrCodeProto(EADDRNOTAVAIL); -ErrCodeProto(EADV); -ErrCodeProto(EAFNOSUPPORT); -ErrCodeProto(EAGAIN); -ErrCodeProto(EALREADY); -ErrCodeProto(EBADF); -ErrCodeProto(EBADMSG); -ErrCodeProto(EBADRPC); -ErrCodeProto(EBUSY); -ErrCodeProto(ECHILD); -ErrCodeProto(ECOMM); -ErrCodeProto(ECONNABORTED); -ErrCodeProto(ECONNREFUSED); -ErrCodeProto(ECONNRESET); -ErrCodeProto(EDEADLK); -ErrCodeProto(EDESTADDRREQ); -ErrCodeProto(EDIRTY); -ErrCodeProto(EDOM); -ErrCodeProto(EDQUOT); -ErrCodeProto(EEXIST); -ErrCodeProto(EFAULT); -ErrCodeProto(EFBIG); -ErrCodeProto(EFTYPE); -ErrCodeProto(EHOSTDOWN); -ErrCodeProto(EHOSTUNREACH); -ErrCodeProto(EIDRM); -ErrCodeProto(EILSEQ); -ErrCodeProto(EINPROGRESS); -ErrCodeProto(EINTR); -ErrCodeProto(EINVAL); -ErrCodeProto(EIO); -ErrCodeProto(EISCONN); -ErrCodeProto(EISDIR); -ErrCodeProto(ELOOP); -ErrCodeProto(EMFILE); -ErrCodeProto(EMLINK); -ErrCodeProto(EMSGSIZE); -ErrCodeProto(EMULTIHOP); -ErrCodeProto(ENAMETOOLONG); -ErrCodeProto(ENETDOWN); -ErrCodeProto(ENETRESET); -ErrCodeProto(ENETUNREACH); -ErrCodeProto(ENFILE); -ErrCodeProto(ENOBUFS); -ErrCodeProto(ENODATA); -ErrCodeProto(ENODEV); -ErrCodeProto(ENOENT); -ErrCodeProto(ENOEXEC); -ErrCodeProto(ENOLCK); -ErrCodeProto(ENOLINK); -ErrCodeProto(ENOMEM); -ErrCodeProto(ENOMSG); -ErrCodeProto(ENONET); -ErrCodeProto(ENOPROTOOPT); -ErrCodeProto(ENOSPC); -ErrCodeProto(ENOSR); -ErrCodeProto(ENOSTR); -ErrCodeProto(ENOSYS); -ErrCodeProto(ENOTBLK); -ErrCodeProto(ENOTCONN); -ErrCodeProto(ENOTDIR); -ErrCodeProto(ENOTEMPTY); -ErrCodeProto(ENOTSOCK); -ErrCodeProto(ENOTTY); -ErrCodeProto(ENXIO); -ErrCodeProto(EOPNOTSUPP); -ErrCodeProto(EPERM); -ErrCodeProto(EPFNOSUPPORT); -ErrCodeProto(EPIPE); -ErrCodeProto(EPROCLIM); -ErrCodeProto(EPROCUNAVAIL); -ErrCodeProto(EPROGMISMATCH); -ErrCodeProto(EPROGUNAVAIL); -ErrCodeProto(EPROTO); -ErrCodeProto(EPROTONOSUPPORT); -ErrCodeProto(EPROTOTYPE); -ErrCodeProto(ERANGE); -ErrCodeProto(EREMCHG); -ErrCodeProto(EREMOTE); -ErrCodeProto(EROFS); -ErrCodeProto(ERPCMISMATCH); -ErrCodeProto(ERREMOTE); -ErrCodeProto(ESHUTDOWN); -ErrCodeProto(ESOCKTNOSUPPORT); -ErrCodeProto(ESPIPE); -ErrCodeProto(ESRCH); -ErrCodeProto(ESRMNT); -ErrCodeProto(ESTALE); -ErrCodeProto(ETIME); -ErrCodeProto(ETIMEDOUT); -ErrCodeProto(ETOOMANYREFS); -ErrCodeProto(ETXTBSY); -ErrCodeProto(EUSERS); -ErrCodeProto(EWOULDBLOCK); -ErrCodeProto(EXDEV); - -#endif /* __ERRUTILS_H__ */ diff --git a/ghc/lib/std/cbits/errno.c b/ghc/lib/std/cbits/errno.c deleted file mode 100644 index 133793c..0000000 --- a/ghc/lib/std/cbits/errno.c +++ /dev/null @@ -1,610 +0,0 @@ -/* - * (c) The University of Glasgow, 2000-2001 - * - * $Id: errno.c,v 1.7 2001/11/07 08:32:34 sof Exp $ - * - * GHC Error Number Conversion - */ - -#include "HsStd.h" -#include "errUtils.h" - -/* Raw errno */ -/* Covers up the fact that on Windows this is a function */ - -int *ghcErrno(void) { - return &errno; -} - -/* Wrappers for the individual error codes - boring */ -#define ErrCode(x) HsInt prel_error_##x() { return x; } -#define ErrCode2(x,y) HsInt prel_error_##x() { return y; } - -#ifdef E2BIG -ErrCode(E2BIG) -#else -ErrCode2(E2BIG,-1) -#endif - -#ifdef EACCES -ErrCode(EACCES) -#else -ErrCode2(EACCES,-1) -#endif - -#ifdef EADDRINUSE -ErrCode(EADDRINUSE) -#else -ErrCode2(EADDRINUSE,-1) -#endif - -#ifdef EADDRNOTAVAIL -ErrCode(EADDRNOTAVAIL) -#else -ErrCode2(EADDRNOTAVAIL,-1) -#endif - -#ifdef EADV -ErrCode(EADV) -#else -ErrCode2(EADV,-1) -#endif - -#ifdef EAFNOSUPPORT -ErrCode(EAFNOSUPPORT) -#else -ErrCode2(EAFNOSUPPORT,-1) -#endif - -#ifdef EAGAIN -ErrCode(EAGAIN) -#else -ErrCode2(EAGAIN,-1) -#endif - -#ifdef EALREADY -ErrCode(EALREADY) -#else -ErrCode2(EALREADY,-1) -#endif - -#ifdef EBADF -ErrCode(EBADF) -#else -ErrCode2(EBADF,-1) -#endif - -#ifdef EBADMSG -ErrCode(EBADMSG) -#else -ErrCode2(EBADMSG,-1) -#endif - -#ifdef EBADRPC -ErrCode(EBADRPC) -#else -ErrCode2(EBADRPC,-1) -#endif - -#ifdef EBUSY -ErrCode(EBUSY) -#else -ErrCode2(EBUSY,-1) -#endif - -#ifdef ECHILD -ErrCode(ECHILD) -#else -ErrCode2(ECHILD,-1) -#endif - -#ifdef ECOMM -ErrCode(ECOMM) -#else -ErrCode2(ECOMM,-1) -#endif - -#ifdef ECONNABORTED -ErrCode(ECONNABORTED) -#else -ErrCode2(ECONNABORTED,-1) -#endif - -#ifdef ECONNREFUSED -ErrCode(ECONNREFUSED) -#else -ErrCode2(ECONNREFUSED,-1) -#endif - -#ifdef ECONNRESET -ErrCode(ECONNRESET) -#else -ErrCode2(ECONNRESET,-1) -#endif - -#ifdef EDEADLK -ErrCode(EDEADLK) -#else -ErrCode2(EDEADLK,-1) -#endif - -#ifdef EDESTADDRREQ -ErrCode(EDESTADDRREQ) -#else -ErrCode2(EDESTADDRREQ,-1) -#endif - -#ifdef EDIRTY -ErrCode(EDIRTY) -#else -ErrCode2(EDIRTY,-1) -#endif - -#ifdef EDOM -ErrCode(EDOM) -#else -ErrCode2(EDOM,-1) -#endif - -#ifdef EDQUOT -ErrCode(EDQUOT) -#else -ErrCode2(EDQUOT,-1) -#endif - -#ifdef EEXIST -ErrCode(EEXIST) -#else -ErrCode2(EEXIST,-1) -#endif - -#ifdef EFAULT -ErrCode(EFAULT) -#else -ErrCode2(EFAULT,-1) -#endif - -#ifdef EFBIG -ErrCode(EFBIG) -#else -ErrCode2(EFBIG,-1) -#endif - -#ifdef EFTYPE -ErrCode(EFTYPE) -#else -ErrCode2(EFTYPE,-1) -#endif - -#ifdef EHOSTDOWN -ErrCode(EHOSTDOWN) -#else -ErrCode2(EHOSTDOWN,-1) -#endif - -#ifdef EHOSTUNREACH -ErrCode(EHOSTUNREACH) -#else -ErrCode2(EHOSTUNREACH,-1) -#endif - -#ifdef EIDRM -ErrCode(EIDRM) -#else -ErrCode2(EIDRM,-1) -#endif - -#ifdef EILSEQ -ErrCode(EILSEQ) -#else -ErrCode2(EILSEQ,-1) -#endif - -#ifdef EINPROGRESS -ErrCode(EINPROGRESS) -#else -ErrCode2(EINPROGRESS,-1) -#endif - -#ifdef EINTR -ErrCode(EINTR) -#else -ErrCode2(EINTR,-1) -#endif - -#ifdef EINVAL -ErrCode(EINVAL) -#else -ErrCode2(EINVAL,-1) -#endif - -#ifdef EIO -ErrCode(EIO) -#else -ErrCode2(EIO,-1) -#endif - -#ifdef EISCONN -ErrCode(EISCONN) -#else -ErrCode2(EISCONN,-1) -#endif - -#ifdef EISDIR -ErrCode(EISDIR) -#else -ErrCode2(EISDIR,-1) -#endif - -#ifdef ELOOP -ErrCode(ELOOP) -#else -ErrCode2(ELOOP,-1) -#endif - -#ifdef EMFILE -ErrCode(EMFILE) -#else -ErrCode2(EMFILE,-1) -#endif - -#ifdef EMLINK -ErrCode(EMLINK) -#else -ErrCode2(EMLINK,-1) -#endif - -#ifdef EMSGSIZE -ErrCode(EMSGSIZE) -#else -ErrCode2(EMSGSIZE,-1) -#endif - -#ifdef EMULTIHOP -ErrCode(EMULTIHOP) -#else -ErrCode2(EMULTIHOP,-1) -#endif - -#ifdef ENAMETOOLONG -ErrCode(ENAMETOOLONG) -#else -ErrCode2(ENAMETOOLONG,-1) -#endif - -#ifdef ENETDOWN -ErrCode(ENETDOWN) -#else -ErrCode2(ENETDOWN,-1) -#endif - -#ifdef ENETRESET -ErrCode(ENETRESET) -#else -ErrCode2(ENETRESET,-1) -#endif - -#ifdef ENETUNREACH -ErrCode(ENETUNREACH) -#else -ErrCode2(ENETUNREACH,-1) -#endif - -#ifdef ENFILE -ErrCode(ENFILE) -#else -ErrCode2(ENFILE,-1) -#endif - -#ifdef ENOBUFS -ErrCode(ENOBUFS) -#else -ErrCode2(ENOBUFS,-1) -#endif - -#ifdef ENODATA -ErrCode(ENODATA) -#else -ErrCode2(ENODATA,-1) -#endif - -#ifdef ENODEV -ErrCode(ENODEV) -#else -ErrCode2(ENODEV,-1) -#endif - -#ifdef ENOENT -ErrCode(ENOENT) -#else -ErrCode2(ENOENT,-1) -#endif - -#ifdef ENOEXEC -ErrCode(ENOEXEC) -#else -ErrCode2(ENOEXEC,-1) -#endif - -#ifdef ENOLCK -ErrCode(ENOLCK) -#else -ErrCode2(ENOLCK,-1) -#endif - -#ifdef ENOLINK -ErrCode(ENOLINK) -#else -ErrCode2(ENOLINK,-1) -#endif - -#ifdef ENOMEM -ErrCode(ENOMEM) -#else -ErrCode2(ENOMEM,-1) -#endif - -#ifdef ENOMSG -ErrCode(ENOMSG) -#else -ErrCode2(ENOMSG,-1) -#endif - -#ifdef ENONET -ErrCode(ENONET) -#else -ErrCode2(ENONET,-1) -#endif - -#ifdef ENOPROTOOPT -ErrCode(ENOPROTOOPT) -#else -ErrCode2(ENOPROTOOPT,-1) -#endif - -#ifdef ENOSPC -ErrCode(ENOSPC) -#else -ErrCode2(ENOSPC,-1) -#endif - -#ifdef ENOSR -ErrCode(ENOSR) -#else -ErrCode2(ENOSR,-1) -#endif - -#ifdef ENOSTR -ErrCode(ENOSTR) -#else -ErrCode2(ENOSTR,-1) -#endif - -#ifdef ENOSYS -ErrCode(ENOSYS) -#else -ErrCode2(ENOSYS,-1) -#endif - -#ifdef ENOTBLK -ErrCode(ENOTBLK) -#else -ErrCode2(ENOTBLK,-1) -#endif - -#ifdef ENOTCONN -ErrCode(ENOTCONN) -#else -ErrCode2(ENOTCONN,-1) -#endif - -#ifdef ENOTDIR -ErrCode(ENOTDIR) -#else -ErrCode2(ENOTDIR,-1) -#endif - -#ifdef ENOTEMPTY -ErrCode(ENOTEMPTY) -#else -ErrCode2(ENOTEMPTY,-1) -#endif - -#ifdef ENOTSOCK -ErrCode(ENOTSOCK) -#else -ErrCode2(ENOTSOCK,-1) -#endif - -#ifdef ENOTTY -ErrCode(ENOTTY) -#else -ErrCode2(ENOTTY,-1) -#endif - -#ifdef ENXIO -ErrCode(ENXIO) -#else -ErrCode2(ENXIO,-1) -#endif - -#ifdef EOPNOTSUPP -ErrCode(EOPNOTSUPP) -#else -ErrCode2(EOPNOTSUPP,-1) -#endif - -#ifdef EPERM -ErrCode(EPERM) -#else -ErrCode2(EPERM,-1) -#endif - -#ifdef EPFNOSUPPORT -ErrCode(EPFNOSUPPORT) -#else -ErrCode2(EPFNOSUPPORT,-1) -#endif - -#ifdef EPIPE -ErrCode(EPIPE) -#else -ErrCode2(EPIPE,-1) -#endif - -#ifdef EPROCLIM -ErrCode(EPROCLIM) -#else -ErrCode2(EPROCLIM,-1) -#endif - -#ifdef EPROCUNAVAIL -ErrCode(EPROCUNAVAIL) -#else -ErrCode2(EPROCUNAVAIL,-1) -#endif - -#ifdef EPROGMISMATCH -ErrCode(EPROGMISMATCH) -#else -ErrCode2(EPROGMISMATCH,-1) -#endif - -#ifdef EPROGUNAVAIL -ErrCode(EPROGUNAVAIL) -#else -ErrCode2(EPROGUNAVAIL,-1) -#endif - -#ifdef EPROTO -ErrCode(EPROTO) -#else -ErrCode2(EPROTO,-1) -#endif - -#ifdef EPROTONOSUPPORT -ErrCode(EPROTONOSUPPORT) -#else -ErrCode2(EPROTONOSUPPORT,-1) -#endif - -#ifdef EPROTOTYPE -ErrCode(EPROTOTYPE) -#else -ErrCode2(EPROTOTYPE,-1) -#endif - -#ifdef ERANGE -ErrCode(ERANGE) -#else -ErrCode2(ERANGE,-1) -#endif - -#ifdef EREMCHG -ErrCode(EREMCHG) -#else -ErrCode2(EREMCHG,-1) -#endif - -#ifdef EREMOTE -ErrCode(EREMOTE) -#else -ErrCode2(EREMOTE,-1) -#endif - -#ifdef EROFS -ErrCode(EROFS) -#else -ErrCode2(EROFS,-1) -#endif - -#ifdef ERPCMISMATCH -ErrCode(ERPCMISMATCH) -#else -ErrCode2(ERPCMISMATCH,-1) -#endif - -#ifdef ERREMOTE -ErrCode(ERREMOTE) -#else -ErrCode2(ERREMOTE,-1) -#endif - -#ifdef ESHUTDOWN -ErrCode(ESHUTDOWN) -#else -ErrCode2(ESHUTDOWN,-1) -#endif - -#ifdef ESOCKTNOSUPPORT -ErrCode(ESOCKTNOSUPPORT) -#else -ErrCode2(ESOCKTNOSUPPORT,-1) -#endif - -#ifdef ESPIPE -ErrCode(ESPIPE) -#else -ErrCode2(ESPIPE,-1) -#endif - -#ifdef ESRCH -ErrCode(ESRCH) -#else -ErrCode2(ESRCH,-1) -#endif - -#ifdef ESRMNT -ErrCode(ESRMNT) -#else -ErrCode2(ESRMNT,-1) -#endif - -#ifdef ESTALE -ErrCode(ESTALE) -#else -ErrCode2(ESTALE,-1) -#endif - -#ifdef ETIME -ErrCode(ETIME) -#else -ErrCode2(ETIME,-1) -#endif - -#ifdef ETIMEDOUT -ErrCode(ETIMEDOUT) -#else -ErrCode2(ETIMEDOUT,-1) -#endif - -#ifdef ETOOMANYREFS -ErrCode(ETOOMANYREFS) -#else -ErrCode2(ETOOMANYREFS,-1) -#endif - -#ifdef ETXTBSY -ErrCode(ETXTBSY) -#else -ErrCode2(ETXTBSY,-1) -#endif - -#ifdef EUSERS -ErrCode(EUSERS) -#else -ErrCode2(EUSERS,-1) -#endif - -#ifdef EWOULDBLOCK -ErrCode(EWOULDBLOCK) -#else -ErrCode2(EWOULDBLOCK,-1) -#endif - -#ifdef EXDEV -ErrCode(EXDEV) -#else -ErrCode2(EXDEV,-1) -#endif - diff --git a/ghc/lib/std/cbits/ghc_errno.h b/ghc/lib/std/cbits/ghc_errno.h deleted file mode 100644 index 89da593..0000000 --- a/ghc/lib/std/cbits/ghc_errno.h +++ /dev/null @@ -1,15 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: ghc_errno.h,v 1.1 2001/01/27 07:46:27 qrczak Exp $ - * - * (c) The GHC Team 2001 - * - * Haskell-usable version of errno - * - * ---------------------------------------------------------------------------*/ - -#ifndef GHCERRNO_H -#define GHCERRNO_H - -int *ghcErrno(void); - -#endif diff --git a/ghc/lib/std/cbits/ilxstubs.c b/ghc/lib/std/cbits/ilxstubs.c deleted file mode 100644 index 1f45e3a..0000000 --- a/ghc/lib/std/cbits/ilxstubs.c +++ /dev/null @@ -1,113 +0,0 @@ -/* - * (c) The GHC Team 2001 - * - * $Id: ilxstubs.c,v 1.5 2001/08/17 11:13:04 rrt Exp $ - * - * ILX stubs for external function calls - */ - -/* - All foreign imports from the C standard library are stubbed out here, - so that they are all in the same DLL (HSstd_cbits), and the ILX code - generator doesn't have to be told or guess which DLL they are in. - Calls to the Win32 API are annotated with the DLL they come from. - - The general rule is that all foreign imports are assumed to be in - _cbits.dll unless a DLL is explicitly given. -*/ - - -#include "Stg.h" -#include "HsStd.h" -#include -#include -#include -#include - -/* From the RTS */ - - /* StgPrimFloat Add to mini-RTS, which is put in a DLL */ - - /* Need to be implemented in ILX RTS */ -/*../PrelStable.lhs:37:foreign import unsafe freeStablePtr :: StablePtr a -> IO () -../PrelTopHandler.lhs:49:foreign import ccall "shutdownHaskellAndExit" -../PrelTopHandler.lhs:77:foreign import ccall "stackOverflow" unsafe -../PrelTopHandler.lhs:80:foreign import ccall "stg_exit" unsafe */ - -void -stg_exit(I_ n) -{ - fprintf(stderr, "doing stg_exit(%d)\n", n); - exit(n); -} - -/* The code is in includes/Stable.h [sic] */ -void -freeStablePtr(StgStablePtr sp) -{ - fprintf(stderr, "Freeing stable ptr %p (NOT!)\n", sp); -} - -void -shutdownHaskellAndExit(int n) -{ - stg_exit(n); -} - -void -stackOverflow(void) -{ -} - -void * -_ErrorHdrHook(void) -{ - return &ErrorHdrHook; -} - -void -ErrorHdrHook(long fd) -{ - const char msg[] = "\nFail: "; - write(fd, msg, sizeof(msg)-1); -} - - - -/* Import directly from correct DLL */ - - /*../CPUTime.hsc:107:foreign import "GetCurrentProcess" unsafe getCurrentProcess :: IO (Ptr HANDLE) - ../CPUTime.hsc:108:foreign import "GetProcessTimes" unsafe getProcessTimes :: Ptr HANDLE -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> Ptr FILETIME -> IO CInt */ - -int s_mkdir(const char *s) { return mkdir(s); } -int s_chmod(const char *s, mode_t m) { return chmod(s, m); } -int s_access(const char *s, int m) { return access(s, m); } -char *s_getcwd(char *s, size_t n) { return getcwd(s, n); } -int s_rmdir(const char *s) { return rmdir(s); } -int s_chdir(const char *s) { return chdir(s); } -int s_unlink(const char *s) { return unlink(s); } -int s_rename(const char *s1, const char *s2) { return rename(s1, s2); } -DIR *s_opendir(const char *s) { return opendir(s); } -struct dirent *s_readdir(DIR *d) { return readdir(d); } -int s_closedir(DIR *d) { return closedir(d); } -int s_stat(const char *s, struct stat *buf) { return stat(s, buf); } -int s_fstat(int f, struct stat* buf) { return fstat(f, buf); } -int s_open(const char *s, int f) { return open(s, f); } -int s_close(int f) { return close(f); } -int s_write(int f, const void *buf, size_t n) { return write(f, buf, n); } -int s_read(int f, void *buf, size_t n) { return read(f, buf, n); } -int s_lseek(int f, off_t off, int w) { return lseek(f, off, w); } -int s_isatty(int f) { return isatty(f); } -void *s_memcpy(void *d, const void *s, size_t n) { return memcpy(d, s, n); } -void *s_memmove(void *d, const void *s, size_t n) { return memmove(d, s, n); } -char *s_strerror(int e) { return strerror(e); } -int s_setmode(int a, int b) { return setmode(a,b); } -void *s_malloc(size_t n) { return malloc(n); } -void *s_realloc(void *p, size_t n) { return realloc(p, n); } -void s_free(void *p) { free(p); } -char *s_getenv(const char *s) { return getenv(s); } -struct tm *s_localtime(const time_t *p) { return localtime(p); } -struct tm *s_gmtime(const time_t *p) { return gmtime(p); } -time_t s_mktime(struct tm *p) { return mktime(p); } -time_t s_time(time_t *p) { return time(p); } -void s_ftime(struct timeb *p) { ftime(p); } diff --git a/ghc/lib/std/cbits/inputReady.c b/ghc/lib/std/cbits/inputReady.c deleted file mode 100644 index 0a1a0ee..0000000 --- a/ghc/lib/std/cbits/inputReady.c +++ /dev/null @@ -1,67 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * hWaitForInput Runtime Support - */ - -/* select and supporting types is not Posix */ -/* #include "PosixSource.h" */ -#include "HsStd.h" - -/* - * inputReady(fd) checks to see whether input is available on the file - * descriptor 'fd'. Input meaning 'can I safely read at least a - * *character* from this file object without blocking?' - */ -int -inputReady(int fd, int msecs, int isSock) -{ - if -#ifndef mingw32_TARGET_OS - ( 1 ) { -#else - ( isSock ) { -#endif - int maxfd, ready; - fd_set rfd; - struct timeval tv; - - FD_ZERO(&rfd); - FD_SET(fd, &rfd); - - /* select() will consider the descriptor set in the range of 0 to - * (maxfd-1) - */ - maxfd = fd + 1; - tv.tv_sec = msecs / 1000; - tv.tv_usec = msecs % 1000; - - while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) { - if (errno != EINTR ) { - return -1; - } - } - - /* 1 => Input ready, 0 => not ready, -1 => error */ - return (ready); - } -#ifdef mingw32_TARGET_OS - else { - DWORD rc; - HANDLE hFile = (HANDLE)_get_osfhandle(fd); - - rc = MsgWaitForMultipleObjects( 1, - &hFile, - FALSE, /* wait all */ - msecs, /*millisecs*/ - QS_ALLEVENTS); - - /* 1 => Input ready, 0 => not ready, -1 => error */ - switch (rc) { - case WAIT_TIMEOUT: return 0; - case WAIT_OBJECT_0: return 1; - default: return -1; - } - } -#endif -} diff --git a/ghc/lib/std/cbits/lockFile.c b/ghc/lib/std/cbits/lockFile.c deleted file mode 100644 index f6a9aea..0000000 --- a/ghc/lib/std/cbits/lockFile.c +++ /dev/null @@ -1,128 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: lockFile.c,v 1.2 2001/05/21 11:02:15 simonmar Exp $ - * - * stdin/stout/stderr Runtime Support - */ - -#include "HsStd.h" - -#ifndef FD_SETSIZE -#define FD_SETSIZE 256 -#endif - -typedef struct { - dev_t device; - ino_t inode; - int fd; -} Lock; - -static Lock readLock[FD_SETSIZE]; -static Lock writeLock[FD_SETSIZE]; - -static int readLocks = 0; -static int writeLocks = 0; - -int -lockFile(int fd, int for_writing, int exclusive) -{ - struct stat sb; - int i; - - while (fstat(fd, &sb) < 0) { - if (errno != EINTR) { -#ifndef _WIN32 - return -1; -#else - /* fstat()ing socket fd's seems to fail with CRT's fstat(), - so let's just silently return and hope for the best.. - */ - return 0; -#endif - } - } - - if (for_writing) { - /* opening a file for writing, check to see whether - we don't have any read locks on it already.. */ - for (i = 0; i < readLocks; i++) { - if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) { -#ifndef __MINGW32__ - return -1; -#else - break; -#endif - } - } - /* If we're determined that there is only a single - writer to the file, check to see whether the file - hasn't already been opened for writing.. - */ - if (exclusive) { - for (i = 0; i < writeLocks; i++) { - if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) { -#ifndef __MINGW32__ - return -1; -#else - break; -#endif - } - } - } - /* OK, everything is cool lock-wise, record it and leave. */ - i = writeLocks++; - writeLock[i].device = sb.st_dev; - writeLock[i].inode = sb.st_ino; - writeLock[i].fd = fd; - return 0; - } else { - /* For reading, it's simpler - just check to see - that there's no-one writing to the underlying file. */ - for (i = 0; i < writeLocks; i++) { - if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) { -#ifndef __MINGW32__ - return -1; -#else - break; -#endif - } - } - /* Fit in new entry, reusing an existing table entry, if possible. */ - for (i = 0; i < readLocks; i++) { - if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) { - return 0; - } - } - i = readLocks++; - readLock[i].device = sb.st_dev; - readLock[i].inode = sb.st_ino; - readLock[i].fd = fd; - return 0; - } - -} - -int -unlockFile(int fd) -{ - int i; - - for (i = 0; i < readLocks; i++) - if (readLock[i].fd == fd) { - while (++i < readLocks) - readLock[i - 1] = readLock[i]; - readLocks--; - return 0; - } - - for (i = 0; i < writeLocks; i++) - if (writeLock[i].fd == fd) { - while (++i < writeLocks) - writeLock[i - 1] = writeLock[i]; - writeLocks--; - return 0; - } - /* Signal that we did not find an entry */ - return 1; -} diff --git a/ghc/lib/std/cbits/lockFile.h b/ghc/lib/std/cbits/lockFile.h deleted file mode 100644 index e1d26b2..0000000 --- a/ghc/lib/std/cbits/lockFile.h +++ /dev/null @@ -1,10 +0,0 @@ -/* - * (c) The University of Glasgow 2001 - * - * $Id: lockFile.h,v 1.1 2001/05/18 16:54:06 simonmar Exp $ - * - * lockFile header - */ - -int lockFile(int fd, int for_writing, int exclusive); -int unlockFile(int fd); diff --git a/ghc/lib/std/cbits/longlong.c b/ghc/lib/std/cbits/longlong.c deleted file mode 100644 index a373786..0000000 --- a/ghc/lib/std/cbits/longlong.c +++ /dev/null @@ -1,126 +0,0 @@ -/* ----------------------------------------------------------------------------- - * $Id: longlong.c,v 1.5 2001/12/07 11:34:48 sewardj Exp $ - * - * (c) The GHC Team, 1998-1999 - * - * Primitive operations over (64-bit) long longs - * (only used on 32-bit platforms.) - * - * ---------------------------------------------------------------------------*/ - - -/* -Miscellaneous primitive operations on StgInt64 and StgWord64s. -N.B. These are not primops! - -Instead of going the normal (boring) route of making the list -of primitive operations even longer to cope with operations -over 64-bit entities, we implement them instead 'out-of-line'. - -The primitive ops get their own routine (in C) that implements -the operation, requiring the caller to _ccall_ out. This has -performance implications of course, but we currently don't -expect intensive use of either Int64 or Word64 types. - -The exceptions to the rule are primops that cast to and from -64-bit entities (these are defined in PrimOps.h) -*/ - -#include "Rts.h" - -#ifdef SUPPORT_LONG_LONGS - -/* Relational operators */ - -StgBool stg_gtWord64 (StgWord64 a, StgWord64 b) {return a > b;} -StgBool stg_geWord64 (StgWord64 a, StgWord64 b) {return a >= b;} -StgBool stg_eqWord64 (StgWord64 a, StgWord64 b) {return a == b;} -StgBool stg_neWord64 (StgWord64 a, StgWord64 b) {return a != b;} -StgBool stg_ltWord64 (StgWord64 a, StgWord64 b) {return a < b;} -StgBool stg_leWord64 (StgWord64 a, StgWord64 b) {return a <= b;} - -StgBool stg_gtInt64 (StgInt64 a, StgInt64 b) {return a > b;} -StgBool stg_geInt64 (StgInt64 a, StgInt64 b) {return a >= b;} -StgBool stg_eqInt64 (StgInt64 a, StgInt64 b) {return a == b;} -StgBool stg_neInt64 (StgInt64 a, StgInt64 b) {return a != b;} -StgBool stg_ltInt64 (StgInt64 a, StgInt64 b) {return a < b;} -StgBool stg_leInt64 (StgInt64 a, StgInt64 b) {return a <= b;} - -/* Arithmetic operators */ - -StgWord64 stg_remWord64 (StgWord64 a, StgWord64 b) {return a % b;} -StgWord64 stg_quotWord64 (StgWord64 a, StgWord64 b) {return a / b;} -StgInt64 stg_remInt64 (StgInt64 a, StgInt64 b) {return a % b;} -StgInt64 stg_quotInt64 (StgInt64 a, StgInt64 b) {return a / b;} -StgInt64 stg_negateInt64 (StgInt64 a) {return -a;} -StgInt64 stg_plusInt64 (StgInt64 a, StgInt64 b) {return a + b;} -StgInt64 stg_minusInt64 (StgInt64 a, StgInt64 b) {return a - b;} -StgInt64 stg_timesInt64 (StgInt64 a, StgInt64 b) {return a * b;} - -/* Logical operators: */ - -StgWord64 stg_and64 (StgWord64 a, StgWord64 b) {return a & b;} -StgWord64 stg_or64 (StgWord64 a, StgWord64 b) {return a | b;} -StgWord64 stg_xor64 (StgWord64 a, StgWord64 b) {return a ^ b;} -StgWord64 stg_not64 (StgWord64 a) {return ~a;} - -StgWord64 stg_uncheckedShiftL64 (StgWord64 a, StgInt b) {return a << b;} -StgWord64 stg_uncheckedShiftRL64 (StgWord64 a, StgInt b) {return a >> b;} -/* Right shifting of signed quantities is not portable in C, so - the behaviour you'll get from using these primops depends - on the whatever your C compiler is doing. ToDo: fix. -- sof 8/98 -*/ -StgInt64 stg_uncheckedIShiftL64 (StgInt64 a, StgInt b) {return a << b;} -StgInt64 stg_uncheckedIShiftRA64 (StgInt64 a, StgInt b) {return a >> b;} -StgInt64 stg_uncheckedIShiftRL64 (StgInt64 a, StgInt b) - {return (StgInt64) ((StgWord64) a >> b);} - -/* Casting between longs and longer longs. - (the primops that cast from long longs to Integers - expressed as macros, since these may cause some heap allocation). -*/ - -StgInt64 stg_intToInt64 (StgInt i) {return (StgInt64) i;} -StgInt stg_int64ToInt (StgInt64 i) {return (StgInt) i;} -StgWord64 stg_int64ToWord64 (StgInt64 i) {return (StgWord64) i;} -StgWord64 stg_wordToWord64 (StgWord w) {return (StgWord64) w;} -StgWord stg_word64ToWord (StgWord64 w) {return (StgWord) w;} -StgInt64 stg_word64ToInt64 (StgWord64 w) {return (StgInt64) w;} - -StgWord64 stg_integerToWord64 (I_ sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - I_ s; - StgWord64 res; - d = (mp_limb_t *)da; - s = sa; - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -d[0]; break; - default: - res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -StgInt64 stg_integerToInt64 (StgInt sa, StgByteArray /* Really: mp_limb_t* */ da) -{ - mp_limb_t* d; - I_ s; - StgInt64 res; - d = (mp_limb_t *)da; - s = (sa); - switch (s) { - case 0: res = 0; break; - case 1: res = d[0]; break; - case -1: res = -d[0]; break; - default: - res = d[0] + ((StgWord64) d[1] << (BITS_IN (mp_limb_t))); - if (s < 0) res = -res; - } - return res; -} - -#endif /* SUPPORT_LONG_LONGS */ diff --git a/ghc/lib/std/cbits/system.c b/ghc/lib/std/cbits/system.c deleted file mode 100644 index 62f1360..0000000 --- a/ghc/lib/std/cbits/system.c +++ /dev/null @@ -1,72 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998 - * - * $Id: system.c,v 1.19 2001/09/17 17:23:32 sewardj Exp $ - * - * system Runtime Support - */ - -/* The itimer stuff in this module is non-posix */ -/* #include "PosixSource.h" */ - -#include "HsStd.h" - -#if defined(mingw32_TARGET_OS) -#include -#include -#endif - -HsInt -systemCmd(HsAddr cmd) -{ - /* -------------------- WINDOWS VERSION --------------------- */ -#if defined(mingw32_TARGET_OS) - return system(cmd); -#else - /* -------------------- UNIX VERSION --------------------- */ - int pid; - int wstat; - - switch(pid = fork()) { - case -1: - if (errno != EINTR) { - return -1; - } - case 0: - { -#ifdef HAVE_SETITIMER - /* Reset the itimers in the child, so it doesn't get plagued - * by SIGVTALRM interrupts. - */ - struct timeval tv_null = { 0, 0 }; - struct itimerval itv; - itv.it_interval = tv_null; - itv.it_value = tv_null; - setitimer(ITIMER_REAL, &itv, NULL); - setitimer(ITIMER_VIRTUAL, &itv, NULL); - setitimer(ITIMER_PROF, &itv, NULL); -#endif - - /* the child */ - execl("/bin/sh", "sh", "-c", cmd, NULL); - _exit(127); - } - } - - while (waitpid(pid, &wstat, 0) < 0) { - if (errno != EINTR) { - return -1; - } - } - - if (WIFEXITED(wstat)) - return WEXITSTATUS(wstat); - else if (WIFSIGNALED(wstat)) { - errno = EINTR; - } - else { - /* This should never happen */ - } - return -1; -#endif -} diff --git a/ghc/lib/std/cbits/writeError.c b/ghc/lib/std/cbits/writeError.c deleted file mode 100644 index e5d2d0e..0000000 --- a/ghc/lib/std/cbits/writeError.c +++ /dev/null @@ -1,49 +0,0 @@ -/* - * (c) The GRASP/AQUA Project, Glasgow University, 1998 - * - * $Id: writeError.c,v 1.9 2001/11/07 18:26:27 sof Exp $ - * - * hPutStr Runtime Support - */ - -/* -Writing out error messages. This is done outside Haskell -(i.e., no use of the IO implementation is made), since it -might be in an unstable state (e.g., hClose stderr >> error "foo") - -(A secondary reason is that ``error'' is used by the IO -implementation in one or two places.) - -*/ - -#include "Rts.h" -#include "RtsUtils.h" -#include "HsStd.h" - -#include "PrelIOUtils.h" - -void -writeErrString__(HsAddr msg_hdr, HsAddr msg, HsInt len) -{ - int count = 0; - char* p = (char*)msg; - char nl = '\n'; - -#ifndef DLLized - resetNonBlockingFd(2); -#endif - - /* Print error msg header */ - if (msg_hdr) { - ((void (*)(int))msg_hdr)(2/*stderr*/); - } - - while ( (count = write(2,p,len)) < len) { - if (errno != EINTR ) { - return; - } - len -= count; - p += count; - } - write(2, &nl, 1); -} diff --git a/ghc/mk/paths.mk b/ghc/mk/paths.mk index 4453b0c..0ead044 100644 --- a/ghc/mk/paths.mk +++ b/ghc/mk/paths.mk @@ -1,64 +1,73 @@ # ----------------------------------------------------------------------------- -# $Id: paths.mk,v 1.38 2001/09/10 12:57:59 simonmar Exp $ +# $Id: paths.mk,v 1.39 2002/02/12 15:17:22 simonmar Exp $ # # ghc project specific make variables # -#----------------------------------------------------------------------------- -# HsTags - -ifdef UseInstalledUtils -HSTAGS = hstags -else -HSTAGS = $(HSTAGS_DIR)/hstags -HSTAGS_DIR = $(GHC_UTILS_DIR)/hstags -endif +PROJECT_DIR := ghc #----------------------------------------------------------------------------- -# Extra things ``only for'' for the ghc project -# These are all build-time things - -GHC_INCLUDE_DIR := $(TOP)/includes -GHC_COMPILER_DIR := $(TOP)/compiler -GHC_RUNTIME_DIR := $(TOP)/rts -GHC_LIB_DIR := $(TOP)/lib - -# --------------------------------------------------- -# -- These variables are defined primarily so they can -# -- be spat into Config.hs by ghc/compiler/Makefile +# Useful directories # -# -- See comments in ghc/compiler/main/SysTools.lhs - - -PROJECT_DIR := ghc -GHC_DRIVER_DIR := $(PROJECT_DIR)/driver -GHC_UTILS_DIR := $(PROJECT_DIR)/utils +# xxx_DIR_REL a directory relative to $(GHC_TOP) +# xxx_DIR a directory (including $(GHC_TOP)) + +GHC_INCLUDE_DIR_REL = includes +GHC_COMPILER_DIR_REL = compiler +GHC_RUNTIME_DIR_REL = rts +GHC_UTILS_DIR_REL = utils +GHC_DRIVER_DIR_REL = driver + +GHC_UNLIT_DIR_REL = $(GHC_UTILS_DIR_REL)/unlit +GHC_HSTAGS_DIR_REL = $(GHC_UTILS_DIR_REL)/hstags +GHC_TOUCHY_DIR_REL = $(GHC_UTILS_DIR_REL)/touchy +GHC_PKG_DIR_REL = $(GHC_UTILS_DIR_REL)/ghc-pkg +GHC_GENPRIMOP_DIR_REL = $(GHC_UTILS_DIR_REL)/genprimopcode +GHC_MANGLER_DIR_REL = $(GHC_DRIVER_DIR_REL)/mangler +GHC_SPLIT_DIR_REL = $(GHC_DRIVER_DIR_REL)/split +GHC_SYSMAN_DIR_REL = $(GHC_RUNTIME_DIR_REL)/parallel + +GHC_INCLUDE_DIR = $(GHC_TOP)/$(GHC_INCLUDE_DIR_REL) +GHC_COMPILER_DIR = $(GHC_TOP)/$(GHC_COMPILER_DIR_REL) +GHC_RUNTIME_DIR = $(GHC_TOP)/$(GHC_RUNTIME_DIR_REL) +GHC_UTILS_DIR = $(GHC_TOP)/$(GHC_UTILS_DIR_REL) +GHC_DRIVER_DIR = $(GHC_TOP)/$(GHC_DRIVER_DIR_REL) +GHC_PKG_DIR = $(GHC_TOP)/$(GHC_PKG_DIR_REL) +GHC_GENPRIMOP_DIR = $(GHC_TOP)/$(GHC_GENPRIMOP_DIR_REL) + +GHC_LIB_DIR = $(FPTOOLS_TOP)/libraries -GHC_TOUCHY_DIR = $(GHC_UTILS_DIR)/touchy - -GHC_UNLIT_DIR = $(GHC_UTILS_DIR)/unlit -GHC_UNLIT = unlit$(EXE_SUFFIX) - -GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler -GHC_MANGLER = ghc-asm +# ----------------------------------------------------------------------------- +# Names of programs in the GHC tree +# +# xxx_PGM the name of an executable, without the path -GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split -GHC_SPLIT = ghc-split +GHC_UNLIT_PGM = unlit$(EXE_SUFFIX) +GHC_HSTAGS_PGM = hstags +GHC_TOUCHY_PGM = touchy$(EXE_SUFFIX) +GHC_MANGLER_PGM = ghc-asm +GHC_SPLIT_PGM = ghc-split +GHC_SYSMAN_PGM = SysMan +GHC_PKG_INPLACE_PGM = ghc-pkg-inplace +GHC_GENPRIMOP_PGM = genprimopcode -GHC_SYSMAN = $(GHC_RUNTIME_DIR)/parallel/SysMan -GHC_SYSMAN_DIR = $(GHC_RUNTIME_DIR)/parallel +# ----------------------------------------------------------------------------- +# Auxilliary programs used by GHC +# +# xxx the pathname to an executable (some using $(TOP)) ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" - GHC_CP = "xcopy /y" GHC_PERL = perl -GHC_TOUCHY = touchy$(EXE_SUFFIX) - else - GHC_CP = $(CP) GHC_PERL = $(PERL) -GHC_TOUCHY = touch - endif +GHC_UNLIT = $(GHC_UNLIT_DIR)/$(GHC_UNLIT_PGM) +GHC_HSTAGS = $(GHC_HSTAGS_DIR)/$(GHC_HSTAGS_PGM) +GHC_MANGLER = $(GHC_MANGLER_DIR)/$(GHC_MANGLER_PGM) +GHC_SPLIT = $(GHC_SPLIT_DIR)/$(GHC_SPLIT_PGM) +GHC_SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM) +GHC_PKG_INPLACE = $(GHC_PKG_DIR)/$(GHC_PKG_INPLACE_PGM) +GHC_GENPRIMOP = $(GHC_GENPRIMOP_DIR)/$(GHC_GENPRIMOP_PGM) diff --git a/ghc/mk/version.mk b/ghc/mk/version.mk index db9af2e..26aceed 100644 --- a/ghc/mk/version.mk +++ b/ghc/mk/version.mk @@ -57,4 +57,4 @@ ProjectPatchLevel = 0 # ghc/compiler/main/Config.hs, which is automatically generated by # ghc/compiler/Makefile. -HscIfaceFileVersion=5 +HscIfaceFileVersion=6 diff --git a/ghc/rts/Linker.c b/ghc/rts/Linker.c index 4eeaf51..1d4711e 100644 --- a/ghc/rts/Linker.c +++ b/ghc/rts/Linker.c @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Linker.c,v 1.82 2002/02/04 16:30:20 sewardj Exp $ + * $Id: Linker.c,v 1.83 2002/02/12 15:17:22 simonmar Exp $ * * (c) The GHC Team, 2000, 2001 * @@ -161,7 +161,7 @@ typedef struct _RtsSymbolVal { Maybe_ForeignObj \ Maybe_Stable_Names \ Sym(StgReturn) \ - Sym(__stginit_PrelGHC) \ + Sym(__stginit_GHCziPrim) \ Sym(init_stack) \ SymX(__stg_chk_0) \ SymX(__stg_chk_1) \ diff --git a/ghc/rts/Makefile b/ghc/rts/Makefile index ac9d823..1be4e41 100644 --- a/ghc/rts/Makefile +++ b/ghc/rts/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.65 2002/02/12 05:01:26 sof Exp $ +# $Id: Makefile,v 1.66 2002/02/12 15:17:22 simonmar Exp $ # # This is the Makefile for the runtime-system stuff. # This stuff is written in C (and cannot be written in Haskell). @@ -29,12 +29,20 @@ include $(TOP)/mk/boilerplate.mk HC=$(GHC_INPLACE) -PACKAGE = rts WAYS=$(GhcLibWays) +PACKAGE = rts + +# Tells the build system not to add various Haskellish options to $(SRC_HC_OPTS) +NON_HS_PKG = YES + # grab sources from these subdirectories ALL_DIRS = hooks parallel +ifeq "$(HaveLibGmp)" "YES" +PKG_CPP_OPTS += -DHAVE_LIBGMP +endif + ifneq "$(DLLized)" "YES" EXCLUDED_SRCS += RtsDllMain.c else @@ -49,7 +57,7 @@ HC_OBJS = $(patsubst %.hc,%.$(way_)o, $(HC_SRCS)) CLEAN_FILES += $(HC_OBJS) -# Override the default $(LIBOBJS) (the default provides for building Haskell libs) +# Override the default $(LIBOBJS) (defaults to $(HS_OBJS)) LIBOBJS = $(C_OBJS) $(HC_OBJS) SplitObjs=NO diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index 4479953..c5a0bef 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.18 2002/02/05 15:42:04 simonpj Exp $ + * $Id: Prelude.h,v 1.19 2002/02/12 15:17:22 simonmar Exp $ * * (c) The GHC Team, 1998-2001 * @@ -14,95 +14,95 @@ * modules these names are defined in. */ -extern DLL_IMPORT const StgClosure PrelBase_True_closure; -extern DLL_IMPORT const StgClosure PrelBase_False_closure; -extern DLL_IMPORT const StgClosure PrelPack_unpackCString_closure; -extern DLL_IMPORT const StgClosure PrelWeak_runFinalizzerBatch_closure; +extern DLL_IMPORT const StgClosure GHCziBase_True_closure; +extern DLL_IMPORT const StgClosure GHCziBase_False_closure; +extern DLL_IMPORT const StgClosure GHCziPack_unpackCString_closure; +extern DLL_IMPORT const StgClosure GHCziWeak_runFinalizzerBatch_closure; extern const StgClosure Main_zdmain_closure; -extern DLL_IMPORT const StgClosure PrelIOBase_stackOverflow_closure; -extern DLL_IMPORT const StgClosure PrelIOBase_heapOverflow_closure; -extern DLL_IMPORT const StgClosure PrelIOBase_BlockedOnDeadMVar_closure; -extern DLL_IMPORT const StgClosure PrelIOBase_NonTermination_closure; -extern DLL_IMPORT const StgClosure PrelIOBase_Deadlock_closure; +extern DLL_IMPORT const StgClosure GHCziIOBase_stackOverflow_closure; +extern DLL_IMPORT const StgClosure GHCziIOBase_heapOverflow_closure; +extern DLL_IMPORT const StgClosure GHCziIOBase_BlockedOnDeadMVar_closure; +extern DLL_IMPORT const StgClosure GHCziIOBase_NonTermination_closure; +extern DLL_IMPORT const StgClosure GHCziIOBase_Deadlock_closure; -extern DLL_IMPORT const StgInfoTable PrelBase_Czh_static_info; -extern DLL_IMPORT const StgInfoTable PrelBase_Izh_static_info; -extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_static_info; -extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziBase_Czh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziBase_Izh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziFloat_Fzh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziFloat_Dzh_static_info; extern DLL_IMPORT const StgInfoTable Addr_Azh_static_info; -extern DLL_IMPORT const StgInfoTable PrelPtr_Ptr_static_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I8zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I16zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I32zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I64zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelWord_Wzh_static_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W8zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W16zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W32zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W64zh_static_info; -extern DLL_IMPORT const StgInfoTable PrelBase_Czh_con_info; -extern DLL_IMPORT const StgInfoTable PrelBase_Izh_con_info; -extern DLL_IMPORT const StgInfoTable PrelFloat_Fzh_con_info; -extern DLL_IMPORT const StgInfoTable PrelFloat_Dzh_con_info; -extern DLL_IMPORT const StgInfoTable PrelPtr_Ptr_con_info; +extern DLL_IMPORT const StgInfoTable GHCziPtr_Ptr_static_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I8zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I16zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I32zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I64zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_Wzh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W8zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W16zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W32zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W64zh_static_info; +extern DLL_IMPORT const StgInfoTable GHCziBase_Czh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziBase_Izh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziFloat_Fzh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziFloat_Dzh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziPtr_Ptr_con_info; extern DLL_IMPORT const StgInfoTable Addr_Azh_con_info; -extern DLL_IMPORT const StgInfoTable PrelWord_Wzh_con_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I8zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I16zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I32zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelInt_I64zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W8zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W16zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W32zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelWord_W64zh_con_info; -extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_static_info; -extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_Wzh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I8zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I16zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I32zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziInt_I64zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W8zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W16zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W32zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziWord_W64zh_con_info; +extern DLL_IMPORT const StgInfoTable GHCziStable_StablePtr_static_info; +extern DLL_IMPORT const StgInfoTable GHCziStable_StablePtr_con_info; -#define True_closure (&PrelBase_True_closure) -#define False_closure (&PrelBase_False_closure) -#define unpackCString_closure (&PrelPack_unpackCString_closure) -#define runFinalizerBatch_closure (&PrelWeak_runFinalizzerBatch_closure) +#define True_closure (&GHCziBase_True_closure) +#define False_closure (&GHCziBase_False_closure) +#define unpackCString_closure (&GHCziPack_unpackCString_closure) +#define runFinalizerBatch_closure (&GHCziWeak_runFinalizzerBatch_closure) #define mainIO_closure (&Main_zdmain_closure) -#define stackOverflow_closure (&PrelIOBase_stackOverflow_closure) -#define heapOverflow_closure (&PrelIOBase_heapOverflow_closure) -#define BlockedOnDeadMVar_closure (&PrelIOBase_BlockedOnDeadMVar_closure) -#define NonTermination_closure (&PrelIOBase_NonTermination_closure) -#define Deadlock_closure (&PrelIOBase_Deadlock_closure) +#define stackOverflow_closure (&GHCziIOBase_stackOverflow_closure) +#define heapOverflow_closure (&GHCziIOBase_heapOverflow_closure) +#define BlockedOnDeadMVar_closure (&GHCziIOBase_BlockedOnDeadMVar_closure) +#define NonTermination_closure (&GHCziIOBase_NonTermination_closure) +#define Deadlock_closure (&GHCziIOBase_NonTermination_closure) -#define Czh_static_info (&PrelBase_Czh_static_info) -#define Fzh_static_info (&PrelFloat_Fzh_static_info) -#define Dzh_static_info (&PrelFloat_Dzh_static_info) +#define Czh_static_info (&GHCziBase_Czh_static_info) +#define Fzh_static_info (&GHCziFloat_Fzh_static_info) +#define Dzh_static_info (&GHCziFloat_Dzh_static_info) #define Azh_static_info (&Addr_Azh_static_info) -#define Izh_static_info (&PrelBase_Izh_static_info) -#define I8zh_static_info (&PrelInt_I8zh_static_info) -#define I16zh_static_info (&PrelInt_I16zh_static_info) -#define I32zh_static_info (&PrelInt_I32zh_static_info) -#define I64zh_static_info (&PrelInt_I64zh_static_info) -#define Wzh_static_info (&PrelWord_Wzh_static_info) -#define W8zh_static_info (&PrelWord_W8zh_static_info) -#define W16zh_static_info (&PrelWord_W16zh_static_info) -#define W32zh_static_info (&PrelWord_W32zh_static_info) -#define W64zh_static_info (&PrelWord_W64zh_static_info) -#define Ptr_static_info (&PrelPtr_Ptr_static_info) -#define Czh_con_info (&PrelBase_Czh_con_info) -#define Izh_con_info (&PrelBase_Izh_con_info) -#define Fzh_con_info (&PrelFloat_Fzh_con_info) -#define Dzh_con_info (&PrelFloat_Dzh_con_info) +#define Izh_static_info (&GHCziBase_Izh_static_info) +#define I8zh_static_info (&GHCziInt_I8zh_static_info) +#define I16zh_static_info (&GHCziInt_I16zh_static_info) +#define I32zh_static_info (&GHCziInt_I32zh_static_info) +#define I64zh_static_info (&GHCziInt_I64zh_static_info) +#define Wzh_static_info (&GHCziWord_Wzh_static_info) +#define W8zh_static_info (&GHCziWord_W8zh_static_info) +#define W16zh_static_info (&GHCziWord_W16zh_static_info) +#define W32zh_static_info (&GHCziWord_W32zh_static_info) +#define W64zh_static_info (&GHCziWord_W64zh_static_info) +#define Ptr_static_info (&GHCziPtr_Ptr_static_info) +#define Czh_con_info (&GHCziBase_Czh_con_info) +#define Izh_con_info (&GHCziBase_Izh_con_info) +#define Fzh_con_info (&GHCziFloat_Fzh_con_info) +#define Dzh_con_info (&GHCziFloat_Dzh_con_info) #define Azh_con_info (&Addr_Azh_con_info) -#define Wzh_con_info (&PrelWord_Wzh_con_info) -#define W8zh_con_info (&PrelWord_W8zh_con_info) -#define W16zh_con_info (&PrelWord_W16zh_con_info) -#define W32zh_con_info (&PrelWord_W32zh_con_info) -#define W64zh_con_info (&PrelWord_W64zh_con_info) -#define I8zh_con_info (&PrelInt_I8zh_con_info) -#define I16zh_con_info (&PrelInt_I16zh_con_info) -#define I32zh_con_info (&PrelInt_I32zh_con_info) -#define I64zh_con_info (&PrelInt_I64zh_con_info) -#define I64zh_con_info (&PrelInt_I64zh_con_info) -#define Ptr_con_info (&PrelPtr_Ptr_con_info) -#define StablePtr_static_info (&PrelStable_StablePtr_static_info) -#define StablePtr_con_info (&PrelStable_StablePtr_con_info) +#define Wzh_con_info (&GHCziWord_Wzh_con_info) +#define W8zh_con_info (&GHCziWord_W8zh_con_info) +#define W16zh_con_info (&GHCziWord_W16zh_con_info) +#define W32zh_con_info (&GHCziWord_W32zh_con_info) +#define W64zh_con_info (&GHCziWord_W64zh_con_info) +#define I8zh_con_info (&GHCziInt_I8zh_con_info) +#define I16zh_con_info (&GHCziInt_I16zh_con_info) +#define I32zh_con_info (&GHCziInt_I32zh_con_info) +#define I64zh_con_info (&GHCziInt_I64zh_con_info) +#define I64zh_con_info (&GHCziInt_I64zh_con_info) +#define Ptr_con_info (&GHCziPtr_Ptr_con_info) +#define StablePtr_static_info (&GHCziStable_StablePtr_static_info) +#define StablePtr_con_info (&GHCziStable_StablePtr_con_info) #endif /* PRELUDE_H */ diff --git a/ghc/rts/StgMiscClosures.hc b/ghc/rts/StgMiscClosures.hc index 67fd674..266b6fd 100644 --- a/ghc/rts/StgMiscClosures.hc +++ b/ghc/rts/StgMiscClosures.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgMiscClosures.hc,v 1.72 2002/01/22 13:54:23 simonmar Exp $ + * $Id: StgMiscClosures.hc,v 1.73 2002/02/12 15:17:22 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -923,8 +923,8 @@ static INFO_TBL_CONST StgInfoTable izh_static_info; #define Char_hash_static_info czh_static_info #define Int_hash_static_info izh_static_info #else -#define Char_hash_static_info PrelBase_Czh_static_info -#define Int_hash_static_info PrelBase_Izh_static_info +#define Char_hash_static_info GHCziBase_Czh_static_info +#define Int_hash_static_info GHCziBase_Izh_static_info #endif #define CHARLIKE_HDR(n) \ diff --git a/ghc/rts/StgStartup.h b/ghc/rts/StgStartup.h index f983e22..55f57e6 100644 --- a/ghc/rts/StgStartup.h +++ b/ghc/rts/StgStartup.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgStartup.h,v 1.5 2001/09/04 18:29:21 ken Exp $ + * $Id: StgStartup.h,v 1.6 2002/02/12 15:17:23 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -14,4 +14,4 @@ EXTFUN(stg_enterStackTop); EXTFUN(stg_init_ret); EXTFUN(stg_init); -EXTFUN(__stginit_PrelGHC); +EXTFUN(__stginit_GHCziPrim); diff --git a/ghc/rts/StgStartup.hc b/ghc/rts/StgStartup.hc index 5920e5e..0121e81 100644 --- a/ghc/rts/StgStartup.hc +++ b/ghc/rts/StgStartup.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: StgStartup.hc,v 1.17 2001/11/22 14:25:12 simonmar Exp $ + * $Id: StgStartup.hc,v 1.18 2002/02/12 15:17:23 simonmar Exp $ * * (c) The GHC Team, 1998-1999 * @@ -133,10 +133,6 @@ STGFUN(stg_enterStackTop) /* ----------------------------------------------------------------------------- Special STG entry points for module registration. - - This stuff is problematic for Hugs, because it introduces a - dependency between the RTS and the program (ie. __stginit_PrelMain). So - we currently disable module initialisation for Hugs. -------------------------------------------------------------------------- */ extern F_ *init_stack; @@ -160,7 +156,7 @@ STGFUN(stg_init) FE_ } -/* PrelGHC doesn't really exist... */ +/* GHC.Prim doesn't really exist... */ -START_MOD_INIT(__stginit_PrelGHC); +START_MOD_INIT(__stginit_GHCziPrim); END_MOD_INIT(); diff --git a/ghc/rts/rts.conf.in b/ghc/rts/rts.conf.in new file mode 100644 index 0000000..c28dd2c --- /dev/null +++ b/ghc/rts/rts.conf.in @@ -0,0 +1,121 @@ +#include "config.h" + +Package { + name = "rts", /* The RTS is just another package! */ + import_dirs = [], + source_dirs = [], + +#ifdef INSTALLING + library_dirs = [ "$libdir" +# ifdef mingw32_TARGET_OS + /* force the dist-provided gcc-lib/ into scope. */ + , "$libdir/gcc-lib" +# endif +#else /* !INSTALLING */ + library_dirs = [ "$libdir/ghc/rts" +# ifdef HAVE_LIBGMP + , "$libdir/ghc/rts/gmp" +# endif + ], +#endif + + hs_libraries = [ "HSrts" ], + extra_libraries = [ "gmp" + , "m" /* for ldexp() */ +#ifdef mingw32_TARGET_OS + ,"winmm" /* for the threadDelay timer */ + ,"wsock32" /* for the linker */ +#endif +#ifdef USING_LIBBFD + ,"bfd", "iberty" /* for debugging */ +#endif +#ifdef THREADED_RTS + ,"pthread" +#endif + ], + +#ifdef INSTALLING + include_dirs = [ "$libdir/include" +# ifdef mingw32_TARGET_OS + , "$libdir/include/mingw" +# endif + ], +#else /* !INSTALLING */ + include_dirs = [ "$libdir/ghc/includes" ], +#endif + + c_includes = [ "Stg.h" ], + package_deps = [], + extra_ghc_opts = [], + extra_cc_opts = [], + /* the RTS forward-references to a bunch of stuff in the prelude, + so we force it to be included with special options to ld. */ + extra_ld_opts = + [ +#ifdef LEADING_UNDERSCORE + "-u", "_GHCziBase_Izh_static_info" + , "-u", "_GHCziBase_Czh_static_info" + , "-u", "_GHCziFloat_Fzh_static_info" + , "-u", "_GHCziFloat_Dzh_static_info" + , "-u", "_GHCziPtr_Ptr_static_info" + , "-u", "_GHCziWord_Wzh_static_info" + , "-u", "_GHCziInt_I8zh_static_info" + , "-u", "_GHCziInt_I16zh_static_info" + , "-u", "_GHCziInt_I32zh_static_info" + , "-u", "_GHCziInt_I64zh_static_info" + , "-u", "_GHCziWord_W8zh_static_info" + , "-u", "_GHCziWord_W16zh_static_info" + , "-u", "_GHCziWord_W32zh_static_info" + , "-u", "_GHCziWord_W64zh_static_info" + , "-u", "_GHCziStable_StablePtr_static_info" + , "-u", "_GHCziBase_Izh_con_info" + , "-u", "_GHCziBase_Czh_con_info" + , "-u", "_GHCziFloat_Fzh_con_info" + , "-u", "_GHCziFloat_Dzh_con_info" + , "-u", "_GHCziPtr_Ptr_con_info" + , "-u", "_GHCziStable_StablePtr_con_info" + , "-u", "_GHCziBase_False_closure" + , "-u", "_GHCziBase_True_closure" + , "-u", "_GHCziPack_unpackCString_closure" + , "-u", "_GHCziIOBase_stackOverflow_closure" + , "-u", "_GHCziIOBase_heapOverflow_closure" + , "-u", "_GHCziIOBase_NonTermination_closure" + , "-u", "_GHCziIOBase_BlockedOnDeadMVar_closure" + , "-u", "_GHCziIOBase_Deadlock_closure" + , "-u", "_GHCziWeak_runFinalizzerBatch_closure" + , "-u", "___stginit_Prelude" +#else + "-u", "GHCziBase_Izh_static_info" + , "-u", "GHCziBase_Czh_static_info" + , "-u", "GHCziFloat_Fzh_static_info" + , "-u", "GHCziFloat_Dzh_static_info" + , "-u", "GHCziPtr_Ptr_static_info" + , "-u", "GHCziWord_Wzh_static_info" + , "-u", "GHCziInt_I8zh_static_info" + , "-u", "GHCziInt_I16zh_static_info" + , "-u", "GHCziInt_I32zh_static_info" + , "-u", "GHCziInt_I64zh_static_info" + , "-u", "GHCziWord_W8zh_static_info" + , "-u", "GHCziWord_W16zh_static_info" + , "-u", "GHCziWord_W32zh_static_info" + , "-u", "GHCziWord_W64zh_static_info" + , "-u", "GHCziStable_StablePtr_static_info" + , "-u", "GHCziBase_Izh_con_info" + , "-u", "GHCziBase_Czh_con_info" + , "-u", "GHCziFloat_Fzh_con_info" + , "-u", "GHCziFloat_Dzh_con_info" + , "-u", "GHCziPtr_Ptr_con_info" + , "-u", "GHCziStable_StablePtr_con_info" + , "-u", "GHCziBase_False_closure" + , "-u", "GHCziBase_True_closure" + , "-u", "GHCziPack_unpackCString_closure" + , "-u", "GHCziIOBase_stackOverflow_closure" + , "-u", "GHCziIOBase_heapOverflow_closure" + , "-u", "GHCziIOBase_NonTermination_closure" + , "-u", "GHCziIOBase_BlockedOnDeadMVar_closure" + , "-u", "GHCziIOBase_Deadlock_closure" + , "-u", "GHCziWeak_runFinalizzerBatch_closure" + , "-u", "__stginit_Prelude" +#endif + ] +} diff --git a/ghc/tests/lib/should_run/Makefile b/ghc/tests/lib/should_run/Makefile new file mode 100644 index 0000000..1e435b0 --- /dev/null +++ b/ghc/tests/lib/should_run/Makefile @@ -0,0 +1,48 @@ +#----------------------------------------------------------------------------- +# $Id: Makefile,v 1.28 2002/02/12 15:17:23 simonmar Exp $ + +TOP = ../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/should_run.mk + +SRC_HC_OPTS += -dcore-lint + +packedstring001_HC_OPTS = -package lang +exceptions001_HC_OPTS = -package lang -fno-warn-missing-methods +stableptr001_HC_OPTS = -package lang +stableptr003_HC_OPTS = -package lang +stableptr004_HC_OPTS = -package lang +list001_HC_OPTS = -package lang +uri001_HC_OPTS = -package net +time001_HC_OPTS = -package lang +io001_HC_OPTS = -package lang +io002_HC_OPTS = -package lang +addr001_HC_OPTS = -package lang + +enum01_HC_OPTS = -cpp -package lang -H12m +enum02_HC_OPTS = -cpp -package lang -H12m +enum03_HC_OPTS = -cpp -package lang -H12m + +stableptr001_RUNTEST_OPTS = +RTS -K4m +stableptr004_RUNTEST_OPTS = +RTS -K4m +dynamic001_HC_OPTS = -package lang +dynamic002_HC_OPTS = -package lang + +ioexts001_HC_OPTS = -package lang -O +ioexts001_RUNTEST_OPTS = +RTS -K16m +ioexts002_HC_OPTS = -package lang + +memo001_HC_OPTS = -package lang -package util +# stress the garbage collector a bit, to make sure weak pointers are being +# finalized properly, and stable names are GC'd etc. +memo001_RUNTEST_OPTS = +RTS -A10k -G1 + +memo002_HC_OPTS = -package lang -package util +memo002_RUNTEST_OPTS = 20 + +weak001_HC_OPTS = -package lang -fglasgow-exts + +SRC_MKDEPENDHS_OPTS += -package lang + +include $(TOP)/mk/target.mk + diff --git a/ghc/tests/lib/should_run/uri001.hs b/ghc/tests/lib/should_run/uri001.hs new file mode 100644 index 0000000..7515f15 --- /dev/null +++ b/ghc/tests/lib/should_run/uri001.hs @@ -0,0 +1,55 @@ +module Main where + +import Network.URI +import Data.Maybe + +main = sequence_ (map do_test tests) + +base = fromJust (parseURI "http://a/b/c/d;p?q") + +do_test test = case parseURI test of + Nothing -> error ("no parse: " ++ test) + Just uri -> putStr (show (fromJust (uri `relativeTo` base)) ++ "\n") + +tests = + [ "g:h", + "g", + "./g", + "g/", + "/g", + "//g", + "?y", + "g?y", + "#s", + "g#s", + "g?y#s", + ";x", + "g;x", + "g;x?y#s", + ".", + "./", + "..", + "../", + "../g", + "../..", + "../../", + "../../g", + -- "../../../g" -- should fail + -- "../../../../g" -- should fail + "/./g", + "/../g", + "g.", + ".g", + "g..", + "..g", + "./../g", + "./g/.", + "g/./h", + "g/../h", + "g;x=1/./y", + "g;x=1/../y", + "g?y/./x", + "g?y/../x", + "g#s/./x", + "g#s/../x" + ] diff --git a/ghc/utils/genprimopcode/Main.hs b/ghc/utils/genprimopcode/Main.hs index 2e79230..5be75a6 100644 --- a/ghc/utils/genprimopcode/Main.hs +++ b/ghc/utils/genprimopcode/Main.hs @@ -249,15 +249,15 @@ gen_latex_doc (Info defaults entries) latex_encode (c:cs) = c:(latex_encode cs) gen_wrappers (Info defaults entries) - = "module PrelPrimopWrappers where\n" - ++ "import qualified PrelGHC\n" + = "module GHC.PrimopWrappers where\n" + ++ "import qualified GHC.Prim\n" ++ unlines (map f (filter (not.dodgy) (filter is_primop entries))) where f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)] src_name = wrap (name spec) in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++ src_name ++ " " ++ unwords args - ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args + ++ " = (GHC.Prim." ++ name spec ++ ") " ++ unwords args wrap nm | isLower (head nm) = nm | otherwise = "(" ++ nm ++ ")" diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index 4464ebd..64cd807 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.20 2002/02/03 17:06:12 sof Exp $ +-- $Id: Main.hs,v 1.21 2002/02/12 15:17:24 simonmar Exp $ -- -- Package management tool ----------------------------------------------------------------------------- @@ -238,9 +238,12 @@ validatePackageConfig pkg pkgs auto_ghci_libs updatePkg = do | otherwise = pkgs return (existing_pkgs ++ [pkg]) -checkDir d = do - there <- doesDirectoryExist d - when (not there) +checkDir d + | "$libdir" `isPrefixOf` d = return () + -- can't check this, because we don't know what $libdir is + | otherwise = do + there <- doesDirectoryExist d + when (not there) (die ("`" ++ d ++ "' doesn't exist or isn't a directory")) checkDep :: [PackageConfig] -> String -> IO () @@ -251,11 +254,15 @@ checkDep pkgs n checkHSLib :: [String] -> Bool -> String -> IO () checkHSLib dirs auto_ghci_libs lib = do let batch_lib_file = "lib" ++ lib ++ ".a" - bs <- mapM (\d -> doesFileExist (d ++ '/':batch_lib_file)) dirs + bs <- mapM (doesLibExistIn batch_lib_file) dirs case [ dir | (exists,dir) <- zip bs dirs, exists ] of [] -> die ("cannot find `" ++ batch_lib_file ++ "' on library path") (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs +doesLibExistIn lib d + | "$libdir" `isPrefixOf` d = return True + | otherwise = doesFileExist (d ++ '/':lib) + checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build = do let ghci_lib_file = lib ++ ".o" diff --git a/ghc/utils/ghc-pkg/Makefile b/ghc/utils/ghc-pkg/Makefile index 39e0d98..e741d75 100644 --- a/ghc/utils/ghc-pkg/Makefile +++ b/ghc/utils/ghc-pkg/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.13 2001/10/23 16:31:37 rrt Exp $ +# $Id: Makefile,v 1.14 2002/02/12 15:17:24 simonmar Exp $ TOP=../.. include $(TOP)/mk/boilerplate.mk @@ -7,6 +7,11 @@ include $(TOP)/mk/boilerplate.mk # hack for ghci-inplace script, see below INSTALLING=1 +# ghc-pkg is needed to boot in ghc/rts and library dirs +ifneq "$(BootingFromHc)" "YES" +boot :: all +endif + # ----------------------------------------------------------------------------- # ghc-pkg.bin diff --git a/ghc/utils/hsc2hs/Main.hs b/ghc/utils/hsc2hs/Main.hs index 92aad1f..030471a 100644 --- a/ghc/utils/hsc2hs/Main.hs +++ b/ghc/utils/hsc2hs/Main.hs @@ -1,5 +1,5 @@ ------------------------------------------------------------------------ --- $Id: Main.hs,v 1.35 2002/01/17 08:37:57 sof Exp $ +-- $Id: Main.hs,v 1.36 2002/02/12 15:17:24 simonmar Exp $ -- -- Program for converting .hsc files to .hs files, by converting the -- file into a C program which is run to generate the Haskell source. @@ -445,7 +445,8 @@ output flags name toks = do let cProgName = outDir++outBase++"_hsc_make.c" oProgName = outDir++outBase++"_hsc_make.o" progName = outDir++outBase++"_hsc_make" ++ progNameSuffix - outHName = outDir++outBase++"_hsc.h" + outHFile = outBase++"_hsc.h" + outHName = outDir++outHFile outCName = outDir++outBase++"_hsc.c" let execProgName @@ -524,8 +525,10 @@ output flags name toks = do "#endif\n" when needsC $ writeFile outCName $ - "#include \""++outHName++"\"\n"++ + "#include \""++outHFile++"\"\n"++ concatMap outTokenC specials + -- NB. outHFile not outHName; works better when processed + -- by gcc or mkdependC. onlyOne :: String -> IO a onlyOne what = do diff --git a/glafp-utils/mk/target.mk b/glafp-utils/mk/target.mk index df719ac..d4cb7e3 100644 --- a/glafp-utils/mk/target.mk +++ b/glafp-utils/mk/target.mk @@ -1,7 +1,9 @@ # ----------------------------------------------------------------------------- -# $Id: target.mk,v 1.1 2000/04/27 10:44:02 simonmar Exp $ +# $Id: target.mk,v 1.2 2002/02/12 15:17:24 simonmar Exp $ # # (c) The GHC Team 2000 # -include $(FPTOOLS_TOP)/mk/target.mk +TOP:=$(TOP)/.. +include $(TOP)/mk/target.mk +TOP:=$(GLAFP_UTILS_TOP) diff --git a/mk/config.mk.in b/mk/config.mk.in index 27d8845..a4f8f70 100644 --- a/mk/config.mk.in +++ b/mk/config.mk.in @@ -99,9 +99,9 @@ BootingFromUnregisterisedHc = @BootingFromUnregisterisedHc@ # build the libs first if we're bootstrapping from .hc files ifeq "$(BootingFromHc)" "YES" -AllProjects = glafp-utils hslibs ghc green-card happy hdirect hood nofib +AllProjects = glafp-utils libraries hslibs ghc green-card happy hdirect hood nofib else -AllProjects = glafp-utils ghc hslibs green-card happy hdirect hood nofib +AllProjects = glafp-utils ghc libraries hslibs green-card happy hdirect hood nofib endif # @@ -236,10 +236,10 @@ else GhcLibWays=p endif -# Option flags to pass to GHC when it's compiling prelude modules -# *and* standard library modules (std) *and* modules in hslibs -# Typically these are things like -O or -dcore-lint -# The ones that are *essential* are wired into ghc/lib/Makefile +# Option flags to pass to GHC when it's compiling modules in +# fptools/libraries. Typically these are things like -O or +# -dcore-lint or -H32m. The ones that are *essential* are wired into +# the build system. # # -O is pretty desirable, otherwise no inlining of prelude # things (incl "+") happens when compiling with this compiler @@ -310,21 +310,10 @@ GhcRtsThreaded=@ThreadedRts@ ################################################################################ # -# hslibs project +# libraries project # ################################################################################ -# Build HsLibs for which compiler? - -# If $(HsLibsFor) == hugs or ghc, we assume we're building for the -# compiler/interpreter in the same source tree. - -# HsLibsFor = ghc | hugs | nhc | hbc -HsLibsFor = ghc - -# hslibs for GHC also uses the following variables (defined above): -# GhcLibWays, GhcLibHcOpts, GhcLibToolsHcOpts, DLLized, StripLibraries - # Build the Haskell Readline bindings? # GhcLibsWithReadline=@HaveReadlineHeaders@ diff --git a/mk/package.mk b/mk/package.mk new file mode 100644 index 0000000..da8712f --- /dev/null +++ b/mk/package.mk @@ -0,0 +1,122 @@ +# ----------------------------------------------------------------------------- +# $Id: package.mk,v 1.1 2002/02/12 15:17:35 simonmar Exp $ + +ifneq "$(PACKAGE)" "" + +# ----------------------------------------------------------------------------- +# Build the package configuration file and tell the compiler about it. + +ifeq "$(way)" "" + +$(PACKAGE).conf.inplace : $(PACKAGE).conf.in + $(CPP) $(RAWCPP_FLAGS) -I$(GHC_INCLUDE_DIR) -x c $(PACKAGE_CPP_OPTS) $< \ + | sed 's/^#.*$$//g' >$@ + +$(PACKAGE).conf.installed : $(PACKAGE).conf.in + $(CPP) $(RAWCPP_FLAGS) -I$(GHC_INCLUDE_DIR) -DINSTALLED -x c $(PACKAGE_CPP_OPTS) $< \ + | sed 's/^#.*$$//g' >$@ + +boot all :: $(PACKAGE).conf.inplace $(PACKAGE).conf.installed + -$(GHC_PKG_INPLACE) --remove-package $(PACKAGE) + $(GHC_PKG_INPLACE) --add-package <$(PACKAGE).conf.inplace + -$(GHC_PKG_INPLACE) -f $(GHC_DRIVER_DIR)/package.conf --remove-package $(PACKAGE) + $(GHC_PKG_INPLACE) -f $(GHC_DRIVER_DIR)/package.conf --add-package <$(PACKAGE).conf.installed + +CLEAN_FILES += $(PACKAGE).conf.installed $(PACKAGE).conf.inplace + +endif # $(way) == "" + +# ----------------------------------------------------------------------------- +# Building the static library libHS.a + +HC = $(GHC_INPLACE) + +SRC_HSC2HS_OPTS += -I. + +ifeq "$(NON_HS_PACKAGE)" "" +SRC_HC_OPTS += -package-name $(PACKAGE) +SRC_HC_OPTS += $(GhcLibHcOpts) +SRC_HC_OPTS += $(patsubst %, -package %, $(PACKAGE_DEPS)) +endif + +LIBRARY = libHS$(PACKAGE)$(_way).a + +WAYS = $(GhcLibWays) + +all :: $(LIBRARY) + +# POSSIBLE alternative version using --make: +# +# lib : $(HS_SRCS) +# $(GHC_INPLACE) $(HC_OPTS) --make $(HS_SRCS) +# +# $(LIBNAME) : lib +# $(RM) $@ +# $(AR) $(AR_OPTS) $@ $(HS_OBJS) +# $(RANLIB) $@ +# +# %.o : %.hs +# $(GHC_INPLACE) $(HC_OPTS) --make $< +# %.o : %.lhs +# $(GHC_INPLACE) $(HC_OPTS) --make $< + +#-------------------------------------------------------------- +# Building dynamically-linkable libraries for GHCi +# +# Build $(GHCI_LIBRARY) from $(OBJS) +# +# Why? GHCi can only link .o files (at the moment), not .a files +# so we have to build libFoo.o as well as libFoo.a +# +# Furthermore, GHCi currently never loads +# profiling libraries (or other non-std ways) +# +# Inputs: +# $(GHCI_LIBRARY) +# +# Outputs: +# Rule to build $(GHCI_LIBRARY) + +ifeq "$(way)" "" +ifeq "$(GhcWithInterpreter)" "YES" + +GHCI_LIBRARY = HS$(PACKAGE)$(_cbits)$(_way).o + +INSTALL_LIBS += $(GHCI_LIBRARY) +CLEAN_FILES += $(GHCI_LIBRARY) + +all :: $(GHCI_LIBRARY) + +ifneq "$(DONT_WANT_STD_GHCI_LIB_RULE)" "YES" +# If you don't want to build GHCI_LIBRARY the 'standard' way, +# set DONT_WANT_STD_GHCI_LIB_RULE to YES. The Prelude and +# hslibs/Win32 uses this 'feature', which will go away soon +# when we can use a "fixed" ld. +# +$(GHCI_LIBRARY) : $(OBJS) + $(LD) -r $(LD_X) -o $@ $(OBJS) + +endif # DONT_WANT_STD_GHCI_LIB_RULE +endif # GhcWithInterpreter +endif # way + +# ----------------------------------------------------------------------------- +# Installation; need to install .hi files as well as libraries +# +# The interface files are put inside the $(libdir), since they +# might (potentially) be platform specific.. +# +# override is used here because for binary distributions, datadir is +# set on the command line. sigh. +# + +override datadir:=$(libdir)/imports/$(PACKAGE) + +# ----------------------------------------------------------------------------- +# Dependencies + +MKDEPENDHS = $(GHC_INPLACE) +SRC_MKDEPENDC_OPTS += $(patsubst %,-I%,$(ALL_DIRS)) -I$(GHC_INCLUDE_DIR) + +endif # $(PACKAGE) /= "" + diff --git a/mk/paths.mk b/mk/paths.mk index 5b3c637..49e34ff 100644 --- a/mk/paths.mk +++ b/mk/paths.mk @@ -191,6 +191,9 @@ SCRIPT_OBJS = $(addsuffix .prl,$(basename $(SCRIPT_SRCS))) OBJS = $(HS_OBJS) $(C_OBJS) $(SCRIPT_OBJS) +# The default is for $(LIBOBJS) to be the same as $(OBJS) +LIBOBJS = $(OBJS) + # # Note that as long as you use the standard variables for setting # which C & Haskell programs you want to work on, you don't have diff --git a/mk/target.mk b/mk/target.mk index 26ee2c7..cf73e23 100644 --- a/mk/target.mk +++ b/mk/target.mk @@ -40,6 +40,11 @@ PRE_SRCS := $(ALL_SRCS) ################################################################## +# Include package building machinery + +include $(TOP)/mk/package.mk + +################################################################## # FPtools standard targets # # depend: @@ -242,74 +247,6 @@ $(C_PROG) :: $(C_OBJS) $(CC) -o $@ $(CC_OPTS) $(LD_OPTS) $(C_OBJS) $(LIBS) endif - -#---------------------------------------- -# Building HsLibs libraries. -# -# Inputs: -# $(PACKAGE) is the name of the library to build -# $(IS_CBITS_LIB) should be "YES" for a "cbits" library -# -# Outputs: -# $(LIBRARY) the name of the library.a -# $(GHIC_LIBRARY) the name of the library.o (for GHCi) -# $(LIBOBJS) objects to put in library -# $(STUBOBJS) more objects to put in library -# -# $(LIBOBJS) is set to $(HS_OBJS) or $(C_OBJS) depending -# on whether or not it's a "cbits" library. But you can -# override this by setting $(LIBOBJS) yourself - -ifneq "$(PACKAGE)" "" - -# add syslib dependencies and current package name - -# HACK!!! The conditional below is needed because we pass $(HC_OPTS) -# directly to mkdependC and sometimes the C compiler in ghc/rts. Todo. -ifneq "$(PACKAGE)" "rts" -SRC_HC_OPTS += -package-name $(PACKAGE) -endif - -SRC_HC_OPTS += $(patsubst %, -package %, $(PACKAGE_DEPS)) - -ifeq "$(IS_CBITS_LIB)" "YES" -_cbits := _cbits -STUBOBJS += $(HSC_C_OBJS) -# Add _hsc.c files to the cbits library -C_SRCS += $(wildcard ../*_hsc.c) -# Make .hsc.h include files from the directory above visible -# (and the cbits/ library too). -SRC_CC_OPTS += -I.. -I. -SRC_HSC2HS_OPTS += -I.. -I. -endif - -ifneq "$(way)" "i" -LIBRARY = libHS$(PACKAGE)$(_cbits)$(_way).a -GHCI_LIBRARY = HS$(PACKAGE)$(_cbits)$(_way).o -else -LIBRARY = $(PACKAGE).dll -endif - -ifneq "$(IS_CBITS_LIB)" "YES" -WAYS=$(GhcLibWays) -endif - -ifeq "$(LIBOBJS)" "" - ifeq "$(IS_CBITS_LIB)" "YES" - LIBOBJS = $(C_OBJS) - else - LIBOBJS = $(HS_OBJS) - endif -endif - -ifeq "$(IS_CBITS_LIB)" "YES" -override datadir:=$(libdir)/include -else -SRC_CC_OPTS += -Icbits -endif - -endif # PACKAGE - #---------------------------------------- # Libraries/archives # @@ -420,52 +357,10 @@ SRC_HC_POST_OPTS += \ endif # SplitObjs endif # StripLibraries -$(LIBRARY) :: $(STUBOBJS) $(LIBOBJS) +$(LIBRARY) : $(STUBOBJS) $(LIBOBJS) $(BUILD_LIB) endif # LIBRARY = "" -#-------------------------------------------------------------- -# Build dynamically-linkable libraries for GHCi -# -# Build $(GHCI_LIBRARY) from $(LIBOBJS)+$(STUBOBJS) -# -# Why? GHCi can only link .o files (at the moment), not .a files -# so we have to build libFoo.o as well as libFoo.a -# -# Furthermore, GHCi currently never loads -# profiling libraries (or other non-std ways) -# -# Inputs: -# $(GHCI_LIBRARY) -# -# Outputs: -# Rule to build $(GHCI_LIBRARY) - - -ifneq "$(GHCI_LIBRARY)" "" -ifeq "$(way)" "" -ifeq "$(GhcWithInterpreter)" "YES" - - -INSTALL_LIBS += $(GHCI_LIBRARY) -CLEAN_FILES += $(GHCI_LIBRARY) - -all :: $(GHCI_LIBRARY) - -ifneq "$(DONT_WANT_STD_GHCI_LIB_RULE)" "YES" -# If you don't want to build GHCI_LIBRARY the 'standard' way, -# set DONT_WANT_STD_GHCI_LIB_RULE to YES. The Prelude and -# hslibs/Win32 uses this 'feature'. -# -$(GHCI_LIBRARY) :: $(LIBOBJS) - $(LD) -r $(LD_X) -o $@ $(LIBOBJS) $(STUBOBJS) - -endif # DONT_WANT_STD_GHCI_LIB_RULE -endif # GhcWithInterpreter -endif # way -endif # GHCI_LIBRARY != "" - - #---------------------------------------- # Building Win32 DLLs # @@ -777,6 +672,7 @@ install-dirs :: #install:: install-dirs # Install libraries automatically +# ToDo: this is a bit magical, maybe do this for packages only? --SDM ifneq "$(LIBRARY)" "" INSTALL_LIBS += $(LIBRARY) ifeq "$(DLLized)" "YES" @@ -1165,7 +1061,7 @@ endif # Recursive stuff # # This was once at the top of the file, allegedly because it was -# needed for some targets, e.g. when building DLLs in hslibs. But +# needed for some targets, e.g. when building DLLs in libraries. But # since this reason is a little short on information, and I'm having # trouble with subdirectory builds happening before the current # directory when building hslibs (bad interaction with including -- 1.7.10.4