#-----------------------------------------------------------------------------
-# $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=.
# 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
# -----------------------------------------------------------------------------
-# $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 = ..
@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)
--- /dev/null
+__interface DataCon 1 0 where
+__export DataCon DataCon dataConRepType isExistentialDataCon ;
+1 data DataCon ;
+1 dataConRepType :: DataCon -> TypeRep.Type ;
+1 isExistentialDataCon :: DataCon -> GHCziBase.Bool ;
--- /dev/null
+__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 ;
+
--- /dev/null
+__interface MkId 1 0 where
+__export MkId mkDataConId mkDataConWrapId ;
+1 mkDataConId :: Name.Name -> DataCon.DataCon -> Var.Id ;
+1 mkDataConWrapId :: DataCon.DataCon -> Var.Id ;
+
--- /dev/null
+__interface Name 1 0 where
+__export Name Name;
+1 data Name ;
import FastString ( FastString, uniqueOfFS )
import GlaExts
import ST
-import PrelBase ( Char(..), chr, ord )
+import Char ( chr, ord )
import FastTypes
import Outputable
--- /dev/null
+__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 ;
+
--- /dev/null
+__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 ;
--- /dev/null
+__interface CgExpr 1 0 where
+__export CgExpr cgExpr;
+1 cgExpr :: StgSyn.StgExpr -> CgMonad.Code ;
--- /dev/null
+__interface CgUsages 1 0 where
+__export CgUsages getSpRelOffset;
+1 getSpRelOffset :: AbsCSyn.VirtualSpOffset -> CgMonad.FCode AbsCSyn.RegRelative ;
--- /dev/null
+__interface ClosureInfo 1 0 where
+__export ClosureInfo ClosureInfo LambdaFormInfo;
+1 data LambdaFormInfo;
+1 data ClosureInfo;
import BasicTypes ( Fixity, defaultFixity )
import Interpreter ( HValue )
import HscMain ( hscStmt )
-import PrelGHC ( unsafeCoerce# )
-
+import GlaExts ( unsafeCoerce# )
import Foreign
import CForeign
import Exception ( Exception, try )
--- /dev/null
+__interface CoreSyn 1 0 where
+__export CoreSyn CoreExpr ;
+
+-- Needed by Var.lhs
+1 type CoreExpr = Expr Var.Var;
+1 data Expr b ;
--- /dev/null
+__interface Subst 2 0 where
+__export Subst Subst substTyWith ;
+1 data Subst;
+1 substTyWith :: [Var.TyVar] -> [TypeRep.Type] -> TypeRep.Type -> TypeRep.Type ;
+
--- /dev/null
+__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 ;
--- /dev/null
+__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 ;
-- 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}
%************************************************************************
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}
%************************************************************************
-}
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
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}
%************************************************************************
-> 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 _
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
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.
-- 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
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)
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=[]}, ())
| 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
import DataCon ( DataCon )
import VarSet ( VarSet )
import PrimOp ( PrimOp )
-import Foreign ( Addr )
-
+import Ptr
\end{code}
%************************************************************************
-- 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
| 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
| 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)
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}
%************************************************************************
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,
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))
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
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}
%************************************************************************
{-# 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
--
import Char
import Monad
-import PrelGHC ( unsafeCoerce# )
+import GlaExts ( unsafeCoerce# )
+
import Foreign ( nullPtr )
import CString ( peekCString )
checkPerms :: String -> IO Bool
checkPerms name =
- handle (\_ -> return False) $ do
+ DriverUtil.handle (\_ -> return False) $ do
#ifdef mingw32_TARGET_OS
doesFileExist name
#else
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 )
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
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}
--- /dev/null
+__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 ;
+
-----------------------------------------------------------------------------
--- $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
--
-- 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
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
-- 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
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)
; 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
| 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
-- 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
--- /dev/null
+__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 ;
import Bits
import Word
-
-#if __GLASGOW_HASKELL__ >= 404
-import GlaExts ( fromInt )
-#endif
\end{code}
Generating code for info tables (arrays of data).
-- 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
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
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) =
--- /dev/null
+__interface StixPrim 1 0 where
+__export StixPrim amodeToStix;
+1 amodeToStix :: AbsCSyn.CAddrMode -> Stix.StixExpr ;
\begin{code}
import Bits ( Bits((.&.)) )
import Int ( Int32 )
-import PrelBase ( Char#, Char(..) )
+import GlaExts ( Char#, Char(..) )
\end{code}
Bit masks
numClassName, -- mentioned, numeric
enumClassName, -- derivable
monadClassName,
- monadPlusClassName,
functorClassName,
showClassName, -- derivable
realClassName, -- numeric
\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"
-- 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
-- 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
fractionalClassKey = mkPreludeClassUnique 6
integralClassKey = mkPreludeClassUnique 7
monadClassKey = mkPreludeClassUnique 8
-monadPlusClassKey = mkPreludeClassUnique 9
functorClassKey = mkPreludeClassUnique 10
numClassKey = mkPreludeClassUnique 11
ordClassKey = mkPreludeClassUnique 12
realFloatClassKey = mkPreludeClassUnique 15
realFracClassKey = mkPreludeClassUnique 16
showClassKey = mkPreludeClassUnique 17
-
+
cCallableClassKey = mkPreludeClassUnique 18
cReturnableClassKey = mkPreludeClassUnique 19
--- /dev/null
+__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) ;
--- /dev/null
+__interface RnHiFiles 1 0 where
+__export RnHiFiles loadInterface;
+1 loadInterface :: __forall [d] => Outputable.SDoc -> Module.ModuleName -> Module.WhereFrom -> RnMonad.RnM d HscTypes.ModIface;
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_`
--- /dev/null
+__interface TcEnv 1 0 where
+__export TcEnv TcEnv;
+1 data TcEnv ;
--- /dev/null
+__interface TcExpr 1 0 where
+__export TcExpr tcExpr ;
+1 tcExpr ::
+ RnHsSyn.RenamedHsExpr
+ -> TcType.TcType
+ -> TcMonad.TcM (TcHsSyn.TcExpr, Inst.LIE) ;
--- /dev/null
+__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) ;
+
--- /dev/null
+__interface TcType 1 0 where
+__export TcType TyVarDetails;
+1 data TyVarDetails ;
--- /dev/null
+-- 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 ;
+
+
--- /dev/null
+__interface Generics 1 0 where
+__export Generics mkTyConGenInfo ;
+
+2 mkTyConGenInfo :: TyCon.TyCon -> [Name.Name] -> DataziMaybe.Maybe (BasicTypes.EP Var.Id) ;
--- /dev/null
+__interface PprType 1 0 where
+__export PprType pprType pprPred ;
+1 pprType :: TypeRep.Type -> Outputable.SDoc ;
+1 pprPred :: Type.PredType -> Outputable.SDoc ;
+
--- /dev/null
+__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 ;
--- /dev/null
+__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 ;
+
#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
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 )
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
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]
-- 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)
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)
-- 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) $
-- _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) $
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. -}
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 (
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 _ _ _)
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"
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}
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}
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)
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 */
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}
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
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}
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}
-#-----------------------------------------------------------------------------
+# -----------------------------------------------------------------------------=
+# $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
+++ /dev/null
-#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<dir> 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
+++ /dev/null
-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)
+++ /dev/null
-# -----------------------------------------------------------------------------
-# $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
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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
+++ /dev/null
-// 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
-
-}
+++ /dev/null
--- -----------------------------------------------------------------------------
--- $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
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-%
-% (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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
-
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-#################################################################################
-#
-# 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
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
-
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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<h, but the range
-is nevertheless empty. Consider
- ((1,2),(2,1))
-Here l<h, but the second index ranges from 2..1 and
-hence is empty
-
-%*********************************************************
-%* *
-\subsection{Instances of @Ix@}
-%* *
-%*********************************************************
-
-\begin{code}
--- abstract these errors from the relevant index functions so that
--- the guts of the function will be small enough to inline.
-
-{-# NOINLINE indexError #-}
-indexError :: Show a => (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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-%
-% (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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
-
+++ /dev/null
----------------------------------------------------------------------------
--- 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;
-
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
-
-
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
-
-
+++ /dev/null
----------------------------------------------------------------------------
--- 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)} ;
-
+++ /dev/null
-// 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<int32,int32> 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<int32, int32 >::.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<int32,int32> 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<int32, int32 >::.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<int32,int32> 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<int32, int32 >::.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'<any,any>( 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'<any>( 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'<any>( 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'<any> (class PrelGHC_MVarzh<!!0> 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<!!0>::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<!!0>::id call void ['mscorlib']System.Console::WriteLine(int32)
- ret
- }
-
-
- .method public static void 'putMVar'<any>(class PrelGHC_MVarzh<!!0> 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<!!0>::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<!!0>::id call void ['mscorlib']System.Console::WriteLine(int32)
- ret
- }
-
- // Enter, if (null(Read)) Wait Exit
- .method public static value class PrelGHC_Z2H<int32, !!0> 'tryTakeMVar'<any>(class PrelGHC_MVarzh<!!0> 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<!!0>::contents
- newobj void value class PrelGHC_Z2H<int32,!!0>::.ctor(!0,!1)
- ret
- }
-
-
- // Enter, if (null(Read)) Wait Exit
- .method public static int32 'tryPutMVar'<any>(class PrelGHC_MVarzh<!!0> 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<any>(class PrelGHC_MVarzh<!!0> 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<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.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<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z4H<int32, unsigned int8[],int32, unsigned int8[]> 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<int32, unsigned int8[],int32, unsigned int8[]>::.ctor(!0,!1,!2,!3)
- ret
- }
-
- .method public static value class PrelGHC_Z4H<int32, unsigned int8[],int32, unsigned int8[]> 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<int32, unsigned int8[],int32, unsigned int8[]>::.ctor(!0,!1,!2,!3)
- ret
- }
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.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<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.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<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z2H<int32, unsigned int8[]> 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<int32, unsigned int8[]>::.ctor(!0,!1)
- ret
- }
-
- .method public static value class PrelGHC_Z3H<int32,int32, unsigned int8[]> 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<int32,int32, unsigned int8[]>::.ctor(!0,!1,!2)
- ret
- }
-
- .method public static value class PrelGHC_Z3H<int32,int32, unsigned int8[]> 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<int32,int32, unsigned int8[]>::.ctor(!0,!1,!2)
- ret
- }
-
-
- .method public static !!0[] newArray<any>(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<any>(!!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<any>(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'<any> {
- .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<!0>::id
-
- ret
- }
-}
-
-.class public 'PrelGHC_StablePtrzh' /* <any> */ {
- .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' /* <any> */ {
- .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'<any> {
- .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<!0>::contents
- ldarg 0 ldarg f stfld thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> class PrelGHC_Weakzh<!0>::_finalizer
- ret
- }
- .method public static value class PrelGHC_Z2H<int32,thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)>> finalizer<any>(class PrelGHC_Weakzh<!!0>) {
- ldc.i4 1
- ldarg 0 ldfld thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> class PrelGHC_Weakzh<!!0>::_finalizer
- newobj void value class PrelGHC_Z2H<int32,thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)>>::.ctor(!0,!1)
- ret
- }
- .method public static value class PrelGHC_Z2H<int32,!!0> deref<any>(class PrelGHC_Weakzh<!!0>) {
- ldc.i4 1
- ldarg 0 ldfld !0 class PrelGHC_Weakzh<!!0>::contents
- newobj void value class PrelGHC_Z2H<int32,!!0>::.ctor(!0,!1)
- ret
- }
- .method public static
- class PrelGHC_Weakzh<!!1>
- bake<any,any>(!!0,!!1 obj,thunk<(func () --> class [.module 'PrelBase.i_o']PrelBase_Z0T)> finalizer) {
- ldarg obj
- ldarg finalizer
- newobj void class 'PrelGHC_Weakzh'<!!1>::.ctor(!0 x, thunk<(func ( /* unit skipped */ ) --> class [.module 'PrelBase.i_o']PrelBase_Z0T)>)
- ret
- }
-
-}
-
-.class public 'PrelGHC_MutVarzh'<any> {
- .field public !0 contents
- .method public rtspecialname specialname instance void .ctor(!0) {
- ldarg 0 ldarg 1 stfld !0 class PrelGHC_MutVarzh<!0>::contents
- ret
- }
-}
-
-.class public PrelGHC_ZCTCCallable<any> {
-}
-
-.class public PrelGHC_BCOzh {
-}
-
-.class public PrelGHC_ZCTCReturnable<any> {
-}
-
-
-//------------------------------------------------------------
-// Builtin Unboxed Tuple Types
-
-.class value sealed 'PrelGHC_Z1H' <any> extends ['mscorlib']System.ValueType {
- .method public rtspecialname specialname instance void .ctor(!0) {
- ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z1H<!0>::fld0
- ret
- }
- .field public !0 fld0
-}
-
-.class value sealed 'PrelGHC_Z2H' <any,any> extends ['mscorlib']System.ValueType {
- .method public rtspecialname specialname instance void .ctor(!0,!1) {
- ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z2H<!0,!1>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z2H<!0,!1>::fld1
- ret
- }
- .field public !0 fld0
- .field public !1 fld1
-}
-
-.class value sealed 'PrelGHC_Z3H' <any,any,any> extends ['mscorlib']System.ValueType {
- .method public rtspecialname specialname instance void .ctor(!0,!1,!2) {
- ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z3H<!0,!1,!2>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z3H<!0,!1,!2>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z3H<!0,!1,!2>::fld2
- ret
- }
- .field public !0 fld0
- .field public !1 fld1
- .field public !2 fld2
-}
-
-.class value sealed 'PrelGHC_Z4H' <any,any,any,any> extends ['mscorlib']System.ValueType {
- .method public rtspecialname specialname instance void .ctor(!0,!1,!2,!3) {
- ldarg 0 ldarg 1 stfld !0 class PrelGHC_Z4H<!0,!1,!2,!3>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z4H<!0,!1,!2,!3>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z4H<!0,!1,!2,!3>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z4H<!0,!1,!2,!3>::fld3
- ret
- }
- .field public !0 fld0
- .field public !1 fld1
- .field public !2 fld2
- .field public !3 fld3
-}
-
-.class value sealed 'PrelGHC_Z5H' <any,any,any,any,any> 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<!0,!1,!2,!3,!4>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z5H<!0,!1,!2,!3,!4>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z5H<!0,!1,!2,!3,!4>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z5H<!0,!1,!2,!3,!4>::fld3
- ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z5H<!0,!1,!2,!3,!4>::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' <any,any,any,any,any,any> 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<!0,!1,!2,!3,!4,!5>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z6H<!0,!1,!2,!3,!4,!5>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z6H<!0,!1,!2,!3,!4,!5>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z6H<!0,!1,!2,!3,!4,!5>::fld3
- ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z6H<!0,!1,!2,!3,!4,!5>::fld4
- ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z6H<!0,!1,!2,!3,!4,!5>::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' <any,any,any,any,any,any,any> 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<!0,!1,!2,!3,!4,!5,!6>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::fld3
- ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::fld4
- ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::fld5
- ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z7H<!0,!1,!2,!3,!4,!5,!6>::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' <any,any,any,any,any,any,any,any> 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<!0,!1,!2,!3,!4,!5,!6,!7>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld3
- ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld4
- ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld5
- ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::fld6
- ldarg 0 ldarg 8 stfld !7 class PrelGHC_Z8H<!0,!1,!2,!3,!4,!5,!6,!7>::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' <any,any,any,any,any,any,any,any,any,any,any,any,any,any,any,any,any,any> 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<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld0
- ldarg 0 ldarg 2 stfld !1 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld1
- ldarg 0 ldarg 3 stfld !2 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld2
- ldarg 0 ldarg 4 stfld !3 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld3
- ldarg 0 ldarg 5 stfld !4 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld4
- ldarg 0 ldarg 6 stfld !5 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld5
- ldarg 0 ldarg 7 stfld !6 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld6
- ldarg 0 ldarg 8 stfld !7 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld7
- ldarg 0 ldarg 9 stfld !8 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld8
- ldarg 0 ldarg 10 stfld !9 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld9
- ldarg 0 ldarg 11 stfld !10 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld10
- ldarg 0 ldarg 12 stfld !11 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld11
- ldarg 0 ldarg 13 stfld !12 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld12
- ldarg 0 ldarg 14 stfld !13 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld13
- ldarg 0 ldarg 15 stfld !14 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld14
- ldarg 0 ldarg 16 stfld !15 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld15
- ldarg 0 ldarg 17 stfld !16 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::fld16
- ldarg 0 ldarg 18 stfld !17 class PrelGHC_Z18H<!0,!1,!2,!3,!4,!5,!6,!7,!8,!9,!10,!11,!12,!13,!14,!15,!16,!17>::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<class '()'> {
- .alternative '()'()
-}
-
+++ /dev/null
-{-# 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 "<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 "<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 "<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
-
-
+++ /dev/null
-{-# 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
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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 "<<loop>>"
- showsPrec _ (Deadlock) = showString "<<deadlock>>"
- 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}
+++ /dev/null
-%
-% (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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
-
-
-
-
+++ /dev/null
----------------------------------------------------------------------------
--- 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 ;
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
--- $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'#, () #)
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
-
-
+++ /dev/null
-{-# 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
+++ /dev/null
------------------------------------------------------------------------------
--- $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}
-
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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 "<<ST action>>"
- 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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-\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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
+++ /dev/null
-{-# 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 ()
-
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $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}
-
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-%
-% (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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
-
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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}
+++ /dev/null
-% ------------------------------------------------------------------------------
-% $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
-
-
-
+++ /dev/null
--- -----------------------------------------------------------------------------
--- $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}
+++ /dev/null
-
--- -----------------------------------------------------------------------------
--- $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 <michael.weber@post.rwth-aachen.de>:
-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
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $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__ */
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $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 <sys/types.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-#ifdef HAVE_FCNTL_H
-# include <fcntl.h>
-#endif
-#ifdef HAVE_TERMIOS_H
-#include <termios.h>
-#endif
-#ifdef HAVE_SIGNAL_H
-#include <signal.h>
-#endif
-#ifdef HAVE_ERRNO_H
-#include <errno.h>
-#endif
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#if defined(HAVE_GETTIMEOFDAY)
-# ifdef HAVE_SYS_TIME_H
-# include <sys/time.h>
-# endif
-#elif defined(HAVE_GETCLOCK)
-# ifdef HAVE_SYS_TIMERS_H
-# define POSIX_4D9 1
-# include <sys/timers.h>
-# endif
-#endif
-#if defined(HAVE_TIME_H)
-# include <time.h>
-#endif
-#ifdef HAVE_SYS_TIMEB_H
-#include <sys/timeb.h>
-#endif
-#ifdef HAVE_WINDOWS_H
-#include <windows.h>
-#endif
-#ifdef HAVE_SYS_TIMES_H
-#include <sys/times.h>
-#endif
-#ifdef HAVE_WINSOCK_H
-#include <winsock.h>
-#endif
-
-#if !defined(mingw32_TARGET_OS) && !defined(irix_TARGET_OS)
-# if defined(HAVE_SYS_RESOURCE_H)
-# include <sys/resource.h>
-# endif
-#endif
-
-#ifdef hpux_TARGET_OS
-#include <sys/syscall.h>
-#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b)
-#define HAVE_GETRUSAGE
-#endif
-
-/* For System */
-#ifdef HAVE_SYS_WAIT_H
-#include <sys/wait.h>
-#endif
-#ifdef HAVE_VFORK_H
-#include <vfork.h>
-#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
+++ /dev/null
-# $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
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-
- *
- * IO / Handle support.
- */
-#include "HsStd.h"
-#include "PrelIOUtils.h"
-#include <stdio.h>
-#include <stdlib.h>
-#include <stddef.h>
-
-#ifndef offsetof
-#define offsetof(t, f) ((size_t) &((t *)0)->f)
-#endif
-
-#ifdef _WIN32
-#include <io.h>
-#include <fcntl.h>
-#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
-}
-
-
+++ /dev/null
-/*
- * (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__ */
-
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-
- *
- * Directory Runtime Support
- */
-#include "dirUtils.h"
-
-#if defined(mingw32_TARGET_OS)
-#include <windows.h>
-#endif
-
-#ifdef HAVE_STDLIB_H
-# include <stdlib.h>
-#endif
-#ifdef HAVE_STDDEF_H
-# include <stddef.h>
-#endif
-#ifdef HAVE_ERRNO_H
-# include <errno.h>
-#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
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-
- *
- * Directory Runtime Support - prototypes.
- */
-#ifndef __DIRUTILS_H__
-#define __DIRUTILS_H__
-#include "HsStd.h"
-
-#include <sys/stat.h>
-#include <dirent.h>
-#include <limits.h>
-#include <errno.h>
-#include <unistd.h>
-
-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__ */
+++ /dev/null
-/*
- * (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__ */
+++ /dev/null
-/*
- * (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
-
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $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
+++ /dev/null
-/*
- * (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
- <current_package>_cbits.dll unless a DLL is explicitly given.
-*/
-
-
-#include "Stg.h"
-#include "HsStd.h"
-#include <stdlib.h>
-#include <stddef.h>
-#include <dirent.h>
-#include <limits.h>
-
-/* 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); }
+++ /dev/null
-/*
- * (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
-}
+++ /dev/null
-/*
- * (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;
-}
+++ /dev/null
-/*
- * (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);
+++ /dev/null
-/* -----------------------------------------------------------------------------
- * $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 */
+++ /dev/null
-/*
- * (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 <windows.h>
-#include <stdlib.h>
-#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
-}
+++ /dev/null
-/*
- * (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);
-}
# -----------------------------------------------------------------------------
-# $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)
# ghc/compiler/main/Config.hs, which is automatically generated by
# ghc/compiler/Makefile.
-HscIfaceFileVersion=5
+HscIfaceFileVersion=6
/* -----------------------------------------------------------------------------
- * $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
*
Maybe_ForeignObj \
Maybe_Stable_Names \
Sym(StgReturn) \
- Sym(__stginit_PrelGHC) \
+ Sym(__stginit_GHCziPrim) \
Sym(init_stack) \
SymX(__stg_chk_0) \
SymX(__stg_chk_1) \
#-----------------------------------------------------------------------------
-# $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).
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
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
/* -----------------------------------------------------------------------------
- * $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
*
* 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 */
/* -----------------------------------------------------------------------------
- * $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
*
#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) \
/* -----------------------------------------------------------------------------
- * $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
*
EXTFUN(stg_init_ret);
EXTFUN(stg_init);
-EXTFUN(__stginit_PrelGHC);
+EXTFUN(__stginit_GHCziPrim);
/* -----------------------------------------------------------------------------
- * $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
*
/* -----------------------------------------------------------------------------
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;
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();
--- /dev/null
+#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
+ ]
+}
--- /dev/null
+#-----------------------------------------------------------------------------
+# $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
+
--- /dev/null
+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"
+ ]
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 ++ ")"
-----------------------------------------------------------------------------
--- $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
-----------------------------------------------------------------------------
| 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 ()
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"
# -----------------------------------------------------------------------------
-# $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
# 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
------------------------------------------------------------------------
--- $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.
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
"#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
# -----------------------------------------------------------------------------
-# $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)
# 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
#
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
################################################################################
#
-# 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@
--- /dev/null
+# -----------------------------------------------------------------------------
+# $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<pkg>.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) /= ""
+
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
PRE_SRCS := $(ALL_SRCS)
##################################################################
+# Include package building machinery
+
+include $(TOP)/mk/package.mk
+
+##################################################################
# FPtools standard targets
#
# depend:
$(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
#
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
#
#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"
# 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
projects / ghc-hetmet.git / commitdiff