pREL_FOREIGN_Name = mkModuleName "PrelForeign"
pREL_STABLE_Name = mkModuleName "PrelStable"
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_INT_Name = mkModuleName "PrelInt"
pREL_WORD_Name = mkModuleName "PrelWord"
+fOREIGNOBJ_Name = mkModuleName "ForeignObj"
+aDDR_Name = mkModuleName "Addr"
+
pREL_GHC = mkPrelModule pREL_GHC_Name
pREL_BASE = mkPrelModule pREL_BASE_Name
pREL_ADDR = mkPrelModule pREL_ADDR_Name
+pREL_PTR = mkPrelModule pREL_PTR_Name
pREL_STABLE = mkPrelModule pREL_STABLE_Name
pREL_IO_BASE = mkPrelModule pREL_IO_BASE_Name
pREL_PACK = mkPrelModule pREL_PACK_Name
int8TyConName = tcQual pREL_INT_Name SLIT("Int8") int8TyConKey
int16TyConName = tcQual pREL_INT_Name SLIT("Int16") int16TyConKey
int32TyConName = tcQual pREL_INT_Name SLIT("Int32") int32TyConKey
-int64TyConName = tcQual pREL_ADDR_Name SLIT("Int64") int64TyConKey
+int64TyConName = tcQual pREL_INT_Name SLIT("Int64") int64TyConKey
+
+word8TyConName = tcQual pREL_WORD_Name SLIT("Word8") word8TyConKey
+word16TyConName = tcQual pREL_WORD_Name SLIT("Word16") word16TyConKey
+word32TyConName = tcQual pREL_WORD_Name SLIT("Word32") word32TyConKey
+word64TyConName = tcQual pREL_WORD_Name SLIT("Word64") word64TyConKey
-wordTyConName = tcQual pREL_ADDR_Name SLIT("Word") wordTyConKey
-wordDataConName = dataQual pREL_ADDR_Name SLIT("W#") wordDataConKey
-word8TyConName = tcQual pREL_WORD_Name SLIT("Word8") word8TyConKey
-word16TyConName = tcQual pREL_WORD_Name SLIT("Word16") word16TyConKey
-word32TyConName = tcQual pREL_WORD_Name SLIT("Word32") word32TyConKey
-word64TyConName = tcQual pREL_ADDR_Name SLIT("Word64") word64TyConKey
+wordTyConName = tcQual pREL_WORD_Name SLIT("Word") wordTyConKey
+wordDataConName = dataQual pREL_WORD_Name SLIT("W#") wordDataConKey
-addrTyConName = tcQual pREL_ADDR_Name SLIT("Addr") addrTyConKey
-addrDataConName = dataQual pREL_ADDR_Name SLIT("A#") addrDataConKey
+addrTyConName = tcQual aDDR_Name SLIT("Addr") addrTyConKey
+addrDataConName = dataQual aDDR_Name SLIT("A#") addrDataConKey
+ptrTyConName = tcQual pREL_PTR_Name SLIT("Ptr") ptrTyConKey
+ptrDataConName = dataQual pREL_PTR_Name SLIT("Ptr") ptrDataConKey
-- Byte array types
byteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("ByteArray") byteArrayTyConKey
mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name SLIT("MutableByteArray") mutableByteArrayTyConKey
-- Forign objects and weak pointers
-foreignObjTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjTyConKey
-foreignObjDataConName = dataQual pREL_IO_BASE_Name SLIT("ForeignObj") foreignObjDataConKey
-foreignPtrTyConName = tcQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrTyConKey
-foreignPtrDataConName = dataQual pREL_FOREIGN_Name SLIT("ForeignPtr") foreignPtrDataConKey
+foreignObjTyConName = tcQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjTyConKey
+foreignObjDataConName = dataQual fOREIGNOBJ_Name SLIT("ForeignObj") foreignObjDataConKey
+foreignPtrTyConName = tcQual pREL_IO_BASE_Name SLIT("ForeignPtr") foreignPtrTyConKey
+foreignPtrDataConName = dataQual pREL_IO_BASE_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
typeConKey = mkPreludeTyConUnique 69
threadIdPrimTyConKey = mkPreludeTyConUnique 70
bcoPrimTyConKey = mkPreludeTyConUnique 71
+ptrTyConKey = mkPreludeTyConUnique 72
-- Usage type constructors
-usageConKey = mkPreludeTyConUnique 72
-usOnceTyConKey = mkPreludeTyConUnique 73
-usManyTyConKey = mkPreludeTyConUnique 74
+usageConKey = mkPreludeTyConUnique 73
+usOnceTyConKey = mkPreludeTyConUnique 74
+usManyTyConKey = mkPreludeTyConUnique 75
-- Generic Type Constructors
-crossTyConKey = mkPreludeTyConUnique 75
-plusTyConKey = mkPreludeTyConUnique 76
-genUnitTyConKey = mkPreludeTyConUnique 77
+crossTyConKey = mkPreludeTyConUnique 76
+plusTyConKey = mkPreludeTyConUnique 77
+genUnitTyConKey = mkPreludeTyConUnique 78
\end{code}
%************************************************************************
trueDataConKey = mkPreludeDataConUnique 15
wordDataConKey = mkPreludeDataConUnique 16
ioDataConKey = mkPreludeDataConUnique 17
+ptrDataConKey = mkPreludeDataConUnique 18
-- Generic data constructors
-crossDataConKey = mkPreludeDataConUnique 17
-inlDataConKey = mkPreludeDataConUnique 18
-inrDataConKey = mkPreludeDataConUnique 19
-genUnitDataConKey = mkPreludeDataConUnique 20
+crossDataConKey = mkPreludeDataConUnique 19
+inlDataConKey = mkPreludeDataConUnique 20
+inrDataConKey = mkPreludeDataConUnique 21
+genUnitDataConKey = mkPreludeDataConUnique 22
\end{code}
%************************************************************************
addrDataCon,
addrTy,
addrTyCon,
+ ptrDataCon,
+ ptrTy,
+ ptrTyCon,
boolTy,
boolTyCon,
charDataCon,
wordTy,
wordTyCon,
- isFFIArgumentTy, -- :: Bool -> Type -> Bool
- isFFIResultTy, -- :: Type -> Bool
- isFFIExternalTy, -- :: Type -> Bool
- isFFIDynArgumentTy, -- :: Type -> Bool
- isFFIDynResultTy, -- :: Type -> Bool
- isFFILabelTy, -- :: Type -> Bool
- isAddrTy, -- :: Type -> Bool
- isForeignPtrTy -- :: Type -> Bool
+ isFFIArgumentTy, -- :: DynFlags -> Bool -> Type -> Bool
+ isFFIImportResultTy, -- :: DynFlags -> Type -> Bool
+ isFFIExportResultTy, -- :: Type -> Bool
+ isFFIExternalTy, -- :: Type -> Bool
+ isFFIDynArgumentTy, -- :: Type -> Bool
+ isFFIDynResultTy, -- :: Type -> Bool
+ isFFILabelTy, -- :: Type -> Bool
+ isAddrTy, -- :: Type -> Bool
+ isForeignPtrTy -- :: Type -> Bool
) where
data_tycons = genericTyCons ++
[ addrTyCon
+ , ptrTyCon
, boolTyCon
, charTyCon
, doubleTyCon
\end{code}
\begin{code}
+ptrTy = mkTyConTy ptrTyCon
+
+ptrTyCon = pcNonRecDataTyCon ptrTyConName alpha_tyvar [(True,False)] [ptrDataCon]
+ptrDataCon = pcDataCon ptrDataConName alpha_tyvar [] [addrPrimTy] ptrTyCon
+\end{code}
+
+\begin{code}
floatTy = mkTyConTy floatTyCon
floatTyCon = pcNonRecDataTyCon floatTyConName [] [] [floatDataCon]
isFFIExternalTy :: Type -> Bool
-- Types that are allowed as arguments of a 'foreign export'
-isFFIExternalTy ty = checkRepTyCon legalIncomingTyCon ty
+isFFIExternalTy ty = checkRepTyCon legalFEArgTyCon ty
+
+isFFIImportResultTy :: DynFlags -> Type -> Bool
+isFFIImportResultTy dflags ty
+ = checkRepTyCon (legalFIResultTyCon dflags) ty
-isFFIResultTy :: Type -> Bool
--- Types that are allowed as a result of a 'foreign import' or of a 'foreign export'
--- Maybe we should distinguish between import and export, but
--- here we just choose the more restrictive 'incoming' predicate
--- But we allow () as well
-isFFIResultTy ty = checkRepTyCon (\tc -> tc == unitTyCon || legalIncomingTyCon tc) ty
+isFFIExportResultTy :: Type -> Bool
+isFFIExportResultTy ty = checkRepTyCon legalFEResultTyCon ty
isFFIDynArgumentTy :: Type -> Bool
-- The argument type of a foreign import dynamic must be either Addr, or
isFFILabelTy :: Type -> Bool
-- The type of a foreign label must be either Addr, or
-- a newtype of Addr.
-isFFILabelTy = checkRepTyCon (== addrTyCon)
+isFFILabelTy = checkRepTyCon (\tc -> tc == addrTyCon || tc == ptrTyCon)
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- look through newtypes
----------------------------------------------
\begin{code}
-legalIncomingTyCon :: TyCon -> Bool
+legalFEArgTyCon :: TyCon -> Bool
-- It's illegal to return foreign objects and (mutable)
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
-legalIncomingTyCon tc
+legalFEArgTyCon tc
| getUnique tc `elem` [ foreignObjTyConKey, foreignPtrTyConKey,
byteArrayTyConKey, mutableByteArrayTyConKey ]
= False
| otherwise
= boxedMarshalableTyCon tc
+legalFIResultTyCon :: DynFlags -> TyCon -> Bool
+legalFIResultTyCon dflags tc
+ | getUnique tc `elem`
+ [ foreignObjTyConKey, foreignPtrTyConKey,
+ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
+ | tc == unitTyCon = True
+ | otherwise = marshalableTyCon dflags tc
+
+legalFEResultTyCon :: TyCon -> Bool
+legalFEResultTyCon tc
+ | getUnique tc `elem`
+ [ foreignObjTyConKey, foreignPtrTyConKey,
+ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
+ | tc == unitTyCon = True
+ | otherwise = boxedMarshalableTyCon tc
+
legalOutgoingTyCon :: DynFlags -> Bool -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
-- The boolean is true for a 'safe' call (when we don't want to
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
- = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
- , wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+ = getUnique tc `elem` [ intTyConKey, int8TyConKey, int16TyConKey
+ , int32TyConKey, int64TyConKey
+ , wordTyConKey, word8TyConKey, word16TyConKey
+ , word32TyConKey, word64TyConKey
, floatTyConKey, doubleTyConKey
- , addrTyConKey, charTyConKey, foreignObjTyConKey
+ , addrTyConKey, ptrTyConKey
+ , charTyConKey, foreignObjTyConKey
, foreignPtrTyConKey
, stablePtrTyConKey
, byteArrayTyConKey, mutableByteArrayTyConKey
genUnitDataCon :: DataCon
genUnitDataCon = pcDataCon genUnitDataConName [] [] [] genUnitTyCon
\end{code}
-
-
-
-
-
, splitTyConApp_maybe
, splitForAllTys
)
-import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
+import TysWiredIn ( isFFIArgumentTy, isFFIImportResultTy,
+ isFFIExportResultTy,
isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
isFFILabelTy
)
getDOptsTc `thenTc` \ dflags ->
check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
| otherwise =
getDOptsTc `thenTc` \ dflags ->
mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ checkForeignRes True {-NonIO ok-} (isFFIImportResultTy dflags) res
checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
checkForeignExport is_dynamic ty args res
case splitFunTys arg of
(arg_tys, res_ty) ->
mapTc (checkForeignArg isFFIExternalTy) arg_tys `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res_ty `thenTc_`
+ checkForeignRes True {-NonIO ok-} isFFIExportResultTy res_ty
+ `thenTc_`
checkForeignRes False {-Must be IO-} isFFIDynResultTy res
_ -> check False (illegalForeignTyErr True{-Arg-} ty)
| otherwise =
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
- checkForeignRes True {-NonIO ok-} isFFIResultTy res
+ checkForeignRes True {-NonIO ok-} isFFIExportResultTy res
checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
)
import Subst ( mkTopTyVarSubst, substClasses )
import VarSet ( mkVarSet, varSetElems )
-import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIResultTy )
+import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
import Name ( Name )
import SrcLoc ( SrcLoc )
Just (tycon, arg_tys) = maybe_tycon_app
ccallable_type dflags ty = isFFIArgumentTy dflags False {- Not safe call -} ty
- creturnable_type ty = isFFIResultTy ty
+ creturnable_type ty = isFFIImportResultTy dflags ty
\end{code}
, "PrelFloat_Fzh_static_info"
, "PrelFloat_Dzh_static_info"
, "PrelAddr_Azh_static_info"
- , "PrelAddr_Wzh_static_info"
- , "PrelAddr_I64zh_static_info"
- , "PrelAddr_W64zh_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"
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.h,v 1.18 2000/11/07 17:05:47 simonmar Exp $
+ * $Id: RtsAPI.h,v 1.19 2001/01/11 17:25:56 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
HaskellObj rts_mkWord16 ( HsWord16 w );
HaskellObj rts_mkWord32 ( HsWord32 w );
HaskellObj rts_mkWord64 ( HsWord64 w );
+HaskellObj rts_mkPtr ( HsPtr a );
HaskellObj rts_mkFloat ( HsFloat f );
HaskellObj rts_mkDouble ( HsDouble f );
HaskellObj rts_mkStablePtr ( HsStablePtr s );
-HaskellObj rts_mkAddr ( HsAddr a );
HaskellObj rts_mkBool ( HsBool b );
HaskellObj rts_mkString ( char *s );
HaskellObj rts_apply ( HaskellObj, HaskellObj );
+/* DEPRECATED (use rts_mkPtr): */
+HaskellObj rts_mkAddr ( HsAddr a );
+
/* ----------------------------------------------------------------------------
Deconstructing Haskell objects
------------------------------------------------------------------------- */
HsInt32 rts_getInt32 ( HaskellObj );
HsWord rts_getWord ( HaskellObj );
HsWord32 rts_getWord32 ( HaskellObj );
+HsPtr rts_getPtr ( HaskellObj );
HsFloat rts_getFloat ( HaskellObj );
HsDouble rts_getDouble ( HaskellObj );
HsStablePtr rts_getStablePtr ( HaskellObj );
-HsAddr rts_getAddr ( HaskellObj );
HsBool rts_getBool ( HaskellObj );
+/* DEPRECATED (use rts_getPtr): */
+HsAddr rts_getAddr ( HaskellObj );
+
/* ----------------------------------------------------------------------------
Evaluating Haskell expressions
% -----------------------------------------------------------------------------
-% $Id: CPUTime.lhs,v 1.26 2001/01/11 07:04:16 qrczak Exp $
+% $Id: CPUTime.lhs,v 1.27 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1995-2000
%
import PrelByteArr ( ByteArray(..), newIntArray )
import PrelArrExtra ( unsafeFreezeByteArray )
import PrelNum ( fromInt )
-import PrelIOBase ( IOError, IOException(..),
+import PrelIOBase ( IOException(..),
IOErrorType( UnsupportedOperation ),
unsafePerformIO, stToIO, ioException )
import Ratio
-% -----------------------------------------------------------------------------
-% $Id: Directory.lhs,v 1.21 2001/01/11 07:04:16 qrczak Exp $
-%
-% (c) The University of Glasgow, 1994-2000
-%
+-- -----------------------------------------------------------------------------
+-- $Id: Directory.hsc,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+--
+-- (c) The University of Glasgow, 1994-2000
+--
-\section[Directory]{Directory interface}
+-- 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
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 <sys/stat.h> -#include <dirent.h> -#include "cbits/stgio.h" #-}
module Directory
(
Permissions -- abstract
, getPermissions -- :: FilePath -> IO Permissions
, setPermissions -- :: FilePath -> Permissions -> IO ()
-
-#ifndef __HUGS__
, getModificationTime -- :: FilePath -> IO ClockTime
-#endif
) where
-#ifdef __HUGS__
---import PreludeBuiltin
-#else
-
import Prelude -- Just to get it in the dependencies
-import PrelGHC ( RealWorld, or#, and# )
-import PrelByteArr ( ByteArray, MutableByteArray,
- newWordArray, readWordArray, newCharArray )
-import PrelArrExtra ( unsafeFreezeByteArray )
-import PrelPack ( packString, unpackCStringST )
-import PrelIOBase ( stToIO,
- constructErrorAndFail, constructErrorAndFailWithInfo,
- IOException(..), ioException, IOErrorType(SystemError) )
import Time ( ClockTime(..) )
-import PrelAddr ( Addr, nullAddr, Word(..), wordToInt, intToWord )
-#endif
-
-\end{code}
-%*********************************************************
-%* *
-\subsection{Permissions}
-%* *
-%*********************************************************
+import PrelStorable
+import PrelCString
+import PrelMarshalAlloc
+import PrelCTypes
+import PrelPosixTypes
+import PrelCError
+import PrelPtr
+import PrelIOBase
+import PrelBase
+
+#include <sys/stat.h>
+#include <dirent.h>
+#include <limits.h>
+#include <errno.h>
+#include <unistd.h>
+
+-----------------------------------------------------------------------------
+-- Permissions
+
+-- The @Permissions@ type is used to record whether certain
+-- operations are permissible on a file/directory:
+-- [to whom? - presumably the "current user"]
-The @Permissions@ type is used to record whether certain
-operations are permissible on a file/directory:
-[to whom? - owner/group/world - the Report don't say much]
-
-\begin{code}
data Permissions
= Permissions {
readable, writable,
executable, searchable :: Bool
} deriving (Eq, Ord, Read, Show)
-\end{code}
-%*********************************************************
-%* *
-\subsection{Implementation}
-%* *
-%*********************************************************
+-----------------------------------------------------------------------------
+-- Implementation
-@createDirectory dir@ creates a new directory {\em dir} which is
-initially empty, or as near to empty as the operating system
-allows.
+-- @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:
+-- The operation may fail with:
+{-
\begin{itemize}
\item @isPermissionError@ / @PermissionDenied@
The process has insufficient privileges to perform the operation.
The path refers to an existing non-directory object.
@[EEXIST]@
\end{itemize}
+-}
-\begin{code}
createDirectory :: FilePath -> IO ()
createDirectory path = do
- rc <- primCreateDirectory (primPackString path)
- if rc == 0 then return () else
- constructErrorAndFailWithInfo "createDirectory" path
-\end{code}
+ withUnsafeCString path $ \s -> do
+ throwErrnoIfMinus1Retry_ "createDirectory" $
+#if defined(mingw32_TARGET_OS)
+ mkdir s
+#else
+ mkdir s 0o777
+#endif
+{-
@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
The operand refers to an existing non-directory object.
@[ENOTDIR]@
\end{itemize}
+-}
-\begin{code}
removeDirectory :: FilePath -> IO ()
removeDirectory path = do
- rc <- primRemoveDirectory (primPackString path)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "removeDirectory" path
-\end{code}
-
-@removeFile file@ removes the directory entry for an existing file
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeDirectory" (rmdir s)
+
+{-
+@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
The operand refers to an existing directory.
@[EPERM, EINVAL]@
\end{itemize}
+-}
-\begin{code}
removeFile :: FilePath -> IO ()
removeFile path = do
- rc <- primRemoveFile (primPackString path)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "removeFile" path
-\end{code}
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "removeFile" (unlink s)
+{-
@renameDirectory 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.
Either path refers to an existing non-directory object.
@[ENOTDIR, EISDIR]@
\end{itemize}
+-}
-\begin{code}
renameDirectory :: FilePath -> FilePath -> IO ()
-renameDirectory opath npath = do
- rc <- primRenameDirectory (primPackString opath) (primPackString npath)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "renameDirectory" ("old: " ++ opath ++ ",new: " ++ npath)
-\end{code}
-
+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
+
+ withUnsafeCString opath $ \s1 ->
+ withUnsafeCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameDirectory" (rename s1 s2)
+
+{-
@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
Either path refers to an existing directory.
@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@
\end{itemize}
+-}
-\begin{code}
renameFile :: FilePath -> FilePath -> IO ()
-renameFile opath npath = do
- rc <- primRenameFile (primPackString opath) (primPackString npath)
- if rc == 0 then
- return ()
- else
- constructErrorAndFailWithInfo "renameFile" opath
-\end{code}
-
+renameFile opath npath =
+ withFileStatus opath $ \st -> do
+ is_dir <- isDirectory st
+ if is_dir
+ then ioException (IOError Nothing InappropriateType "renameFile"
+ "is a directory" (Just opath))
+ else do
+
+ withUnsafeCString opath $ \s1 ->
+ withUnsafeCString npath $ \s2 ->
+ throwErrnoIfMinus1Retry_ "renameFile" (rename s1 s2)
+
+{-
@getDirectoryContents dir@ returns a list of {\em all} entries
in {\em dir}.
The path refers to an existing non-directory object.
@[ENOTDIR]@
\end{itemize}
+-}
-\begin{code}
getDirectoryContents :: FilePath -> IO [FilePath]
getDirectoryContents path = do
- dir <- primOpenDir (primPackString path)
- if dir == nullAddr
- then constructErrorAndFailWithInfo "getDirectoryContents" path
- else loop dir
+ p <- withUnsafeCString path $ \s ->
+ throwErrnoIfNullRetry "getDirectoryContents" (opendir s)
+ loop p
where
- loop :: Addr -> IO [String]
- loop dir = do
- dirent_ptr <- primReadDir dir
- if dirent_ptr == nullAddr
- then do
- -- readDir__ implicitly performs closedir() when the
- -- end is reached.
- return []
- else do
- str <- primGetDirentDName dirent_ptr
- entry <- primUnpackCString str
- entries <- loop dir
- return (entry:entries)
-\end{code}
-
+ loop :: Ptr CDir -> IO [String]
+ loop dir = do
+ p <- readdir dir
+ if (p /= nullPtr)
+ then do entry <- peekCString ((#ptr struct dirent,d_name) p)
+ entries <- loop dir
+ return (entry:entries)
+ else do errno <- getErrno
+ if (errno == eINTR) then loop dir else do
+ throwErrnoIfMinus1_ "getDirectoryContents" $ closedir dir
+ if (isValidErrno errno) -- EOF
+ then throwErrno "getDirectoryContents"
+ else return []
+
+{-
If the operating system has a notion of current directories,
@getCurrentDirectory@ returns an absolute path to the
current directory of the calling process.
\item @UnsupportedOperation@
The operating system has no notion of current directory.
\end{itemize}
+-}
-\begin{code}
getCurrentDirectory :: IO FilePath
getCurrentDirectory = do
- str <- primGetCurrentDirectory
- if str /= nullAddr
- then do
- pwd <- primUnpackCString str
- primFree str
- return pwd
- else
- constructErrorAndFail "getCurrentDirectory"
-\end{code}
-
+ p <- mallocBytes (#const PATH_MAX)
+ go p (#const 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"
+
+{-
If the operating system has a notion of current directories,
@setCurrentDirectory dir@ changes the current
directory of the calling process to {\em dir}.
The path refers to an existing non-directory object.
@[ENOTDIR]@
\end{itemize}
+-}
-\begin{code}
setCurrentDirectory :: FilePath -> IO ()
setCurrentDirectory path = do
- rc <- primSetCurrentDirectory (primPackString path)
- if rc == 0
- then return ()
- else constructErrorAndFailWithInfo "setCurrentDirectory" path
-\end{code}
+ withUnsafeCString path $ \s ->
+ throwErrnoIfMinus1Retry_ "setCurrentDirectory" (chdir s)
+ -- ToDo: add path to error
+{-
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
- (getFileStatus name >>= \ st -> return (isDirectory st))
+ (withFileStatus name $ \st -> isDirectory st)
(\ _ -> return False)
doesFileExist :: FilePath -> IO Bool
doesFileExist name = do
catch
- (getFileStatus name >>= \ st -> return (not (isDirectory st)))
+ (withFileStatus name $ \st -> do b <- isDirectory st; return (not b))
(\ _ -> return False)
-#ifndef __HUGS__
getModificationTime :: FilePath -> IO ClockTime
getModificationTime name =
- getFileStatus name >>= \ st ->
+ withFileStatus name $ \ st ->
modificationTime st
-#endif
getPermissions :: FilePath -> IO Permissions
getPermissions name = do
- st <- getFileStatus name
- read <- primAccess (primPackString name) readOK
- write <- primAccess (primPackString name) writeOK
- exec <- primAccess (primPackString name) executeOK
-
+ withUnsafeCString name $ \s -> do
+ read <- access s (#const R_OK)
+ write <- access s (#const W_OK)
+ exec <- access s (#const X_OK)
+ withFileStatus name $ \st -> do
+ is_dir <- isDirectory st
+ is_reg <- isRegularFile st
return (
Permissions {
readable = read == 0,
writable = write == 0,
- executable = not (isDirectory st) && exec == 0,
- searchable = not (isRegularFile st) && exec == 0
+ executable = not is_dir && exec == 0,
+ searchable = not is_reg && exec == 0
}
)
setPermissions :: FilePath -> Permissions -> IO ()
setPermissions name (Permissions r w e s) = do
let
- read = if r then ownerReadMode else emptyFileMode
- write = if w then ownerWriteMode else emptyFileMode
- exec = if e || s then ownerExecuteMode else emptyFileMode
-
- mode = read `unionFileMode` (write `unionFileMode` exec)
-
- rc <- primChmod (primPackString name) mode
- if rc == 0
- then return ()
- else ioException (IOError Nothing SystemError
- "setPermissions" "insufficient permissions" (Just name))
-\end{code}
-
-(Sigh)..copied from Posix.Files to avoid dep. on posix library
-
-\begin{code}
-type FileStatus = PrimByteArray
-
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus name = do
- bytes <- primNewByteArray sizeof_stat
- rc <- primStat (primPackString name) bytes
- if rc == 0
-#ifdef __HUGS__
- then primUnsafeFreezeByteArray bytes
-#else
- then stToIO (unsafeFreezeByteArray bytes)
-#endif
- else ioException (IOError Nothing SystemError
- "getFileStatus" "" (Just name))
-
-#ifndef __HUGS__
-modificationTime :: FileStatus -> IO ClockTime
-modificationTime stat = do
- i1 <- stToIO (newWordArray (0,1))
- setFileMode i1 stat
- secs <- stToIO (readWordArray i1 0)
- return (TOD (toInteger (wordToInt secs)) 0)
-
-foreign import ccall "libHS_cbits" "set_stat_st_mtime" unsafe
- setFileMode :: PrimMutableByteArray RealWorld -> FileStatus -> IO ()
-#endif
-
-isDirectory :: FileStatus -> Bool
-isDirectory stat = prim_S_ISDIR (fileMode stat) /= 0
+ read = if r then (#const S_IRUSR) else emptyCMode
+ write = if w then (#const S_IWUSR) else emptyCMode
+ exec = if e || s then (#const S_IXUSR) else emptyCMode
-isRegularFile :: FileStatus -> Bool
-isRegularFile stat = prim_S_ISREG (fileMode stat) /= 0
+ mode = read `unionCMode` (write `unionCMode` exec)
-foreign import ccall "libHS_cbits" "sizeof_stat" unsafe sizeof_stat :: Int
-foreign import ccall "libHS_cbits" "prim_stat" unsafe
- primStat :: PrimByteArray -> PrimMutableByteArray RealWorld -> IO Int
+ withUnsafeCString name $ \s ->
+ throwErrnoIfMinus1_ "setPermissions" $ chmod s mode
-foreign import ccall "libHS_cbits" "get_stat_st_mode" unsafe fileMode :: FileStatus -> FileMode
-foreign import ccall "libHS_cbits" "prim_S_ISDIR" unsafe prim_S_ISDIR :: FileMode -> Int
-foreign import ccall "libHS_cbits" "prim_S_ISREG" unsafe prim_S_ISREG :: FileMode -> Int
-\end{code}
+withFileStatus :: FilePath -> (Ptr CStat -> IO a) -> IO a
+withFileStatus name f = do
+ allocaBytes (#const sizeof(struct stat)) $ \p ->
+ withUnsafeCString name $ \s -> do
+ throwErrnoIfMinus1Retry_ "withFileStatus" (stat s p)
+ f p
-\begin{code}
-type FileMode = Word
-
-emptyFileMode :: FileMode
-unionFileMode :: FileMode -> FileMode -> FileMode
-intersectFileMode :: FileMode -> FileMode -> FileMode
-
-foreign import ccall "libHS_cbits" "const_S_IRUSR" unsafe ownerReadMode :: FileMode
-foreign import ccall "libHS_cbits" "const_S_IWUSR" unsafe ownerWriteMode :: FileMode
-foreign import ccall "libHS_cbits" "const_S_IXUSR" unsafe ownerExecuteMode :: FileMode
-
-#ifdef __HUGS__
-emptyFileMode = primIntToWord 0
-unionFileMode = primOrWord
-intersectFileMode = primAndWord
-#else
-emptyFileMode = intToWord 0
-unionFileMode = orWord
-intersectFileMode = andWord
-#endif
-\end{code}
+modificationTime :: Ptr CStat -> IO ClockTime
+modificationTime stat = do
+ mtime <- (#peek struct stat, st_mtime) stat
+ return (TOD (toInteger (mtime :: CTime)) 0)
-\begin{code}
-type AccessMode = Word
+isDirectory :: Ptr CStat -> IO Bool
+isDirectory stat = do
+ mode <- (#peek struct stat, st_mode) stat
+ return (s_ISDIR mode /= 0)
-foreign import ccall "libHS_cbits" "const_R_OK" unsafe readOK :: AccessMode
-foreign import ccall "libHS_cbits" "const_W_OK" unsafe writeOK :: AccessMode
-foreign import ccall "libHS_cbits" "const_X_OK" unsafe executeOK :: AccessMode
-\end{code}
+isRegularFile :: Ptr CStat -> IO Bool
+isRegularFile stat = do
+ mode <- (#peek struct stat, st_mode) stat
+ return (s_ISREG mode /= 0)
-Some defns. to allow us to share code.
+foreign import ccall unsafe s_ISDIR :: CMode -> Int
+#def inline HsInt s_ISDIR(m) {return S_ISDIR(m);}
-\begin{code}
-#ifndef __HUGS__
+foreign import ccall unsafe s_ISREG :: CMode -> Int
+#def inline HsInt s_ISREG(m) {return S_ISREG(m);}
-primPackString :: [Char] -> ByteArray Int
-primPackString = packString
---ToDo: fix.
-primUnpackCString :: Addr -> IO String
-primUnpackCString a = stToIO (unpackCStringST a)
+emptyCMode :: CMode
+emptyCMode = 0
-type PrimByteArray = ByteArray Int
-type PrimMutableByteArray s = MutableByteArray RealWorld Int
-type CString = PrimByteArray
+unionCMode :: CMode -> CMode -> CMode
+unionCMode = (+)
-orWord, andWord :: Word -> Word -> Word
-orWord (W# x#) (W# y#) = W# (x# `or#` y#)
-andWord (W# x#) (W# y#) = W# (x# `and#` y#)
+type UCString = UnsafeCString
-primNewByteArray :: Int -> IO (PrimMutableByteArray s)
-primNewByteArray sz_in_bytes = stToIO (newCharArray (0,sz_in_bytes))
+#if defined(mingw32_TARGET_OS)
+foreign import ccall unsafe mkdir :: UCString -> IO CInt
+#else
+foreign import ccall unsafe mkdir :: UCString -> CInt -> IO CInt
#endif
-foreign import ccall "libHS_cbits" "createDirectory" unsafe primCreateDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "removeDirectory" unsafe primRemoveDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "removeFile" unsafe primRemoveFile :: CString -> IO Int
-foreign import ccall "libHS_cbits" "renameDirectory" unsafe primRenameDirectory :: CString -> CString -> IO Int
-foreign import ccall "libHS_cbits" "renameFile" unsafe primRenameFile :: CString -> CString -> IO Int
-foreign import ccall "libHS_cbits" "openDir__" unsafe primOpenDir :: CString -> IO Addr
-foreign import ccall "libHS_cbits" "readDir__" unsafe primReadDir :: Addr -> IO Addr
-foreign import ccall "libHS_cbits" "get_dirent_d_name" unsafe primGetDirentDName :: Addr -> IO Addr
-foreign import ccall "libHS_cbits" "setCurrentDirectory" unsafe primSetCurrentDirectory :: CString -> IO Int
-foreign import ccall "libHS_cbits" "getCurrentDirectory" unsafe primGetCurrentDirectory :: IO Addr
-foreign import ccall "libc" "free" unsafe primFree :: Addr -> IO ()
-foreign import ccall "libc" "malloc" unsafe primMalloc :: Word -> IO Addr
-foreign import ccall "libc" "chmod" unsafe primChmod :: CString -> Word -> IO Int
-
-foreign import ccall "libc" "access" unsafe
- primAccess :: CString -> Word -> IO Int
-\end{code}
-
+foreign import ccall unsafe chmod :: UCString -> CMode -> IO CInt
+foreign import ccall unsafe access :: UCString -> CMode -> IO CInt
+foreign import ccall unsafe rmdir :: UCString -> IO CInt
+foreign import ccall unsafe chdir :: UCString -> IO CInt
+foreign import ccall unsafe getcwd :: Ptr CChar -> CInt -> IO (Ptr CChar)
+foreign import ccall unsafe unlink :: UCString -> IO CInt
+foreign import ccall unsafe rename :: UCString -> UCString -> IO CInt
+
+foreign import ccall unsafe opendir :: UCString -> IO (Ptr CDir)
+foreign import ccall unsafe readdir :: Ptr CDir -> IO (Ptr CDirent)
+foreign import ccall unsafe closedir :: Ptr CDir -> IO CInt
+
+foreign import ccall unsafe stat :: UCString -> Ptr CStat -> IO CInt
+
+type CDirent = ()
+type CStat = ()
# Setting the standard variables
#
-HC = $(GHC_INPLACE)
+HC = $(GHC_INPLACE)
+CC = $(GHC_INPLACE)
ifneq "$(DLLized)" "YES"
PACKAGE = -package-name std
# we don't want PrelMain in the GHCi library.
GHCI_LIBOBJS = $(filter-out PrelMain.$(way_)o,$(HS_OBJS))
+HS_SRCS += $(patsubst %.hsc,%.hs,$(wildcard *.hsc))
+
#-----------------------------------------------------------------------------
# Setting the GHC compile options
+++ /dev/null
-% -----------------------------------------------------------------------------
-% $Id: PrelAddr.lhs,v 1.18 2000/11/07 10:42:56 simonmar Exp $
-%
-% (c) The University of Glasgow, 1994-2000
-%
-
-\section[PrelAddr]{Module @PrelAddr@}
-
-\begin{code}
-{-# OPTIONS -fno-implicit-prelude #-}
-
-module PrelAddr (
- Addr(..)
- , nullAddr -- :: Addr
- , alignAddr -- :: Addr -> Int -> Addr
- , plusAddr -- :: Addr -> Int -> Addr
- , minusAddr -- :: Addr -> Addr -> Int
-
- , indexAddrOffAddr -- :: Addr -> Int -> Addr
-
- , Word(..)
- , wordToInt
- , intToWord
-
- , Word64(..)
- , Int64(..)
- ) where
-
-import PrelGHC
-import PrelBase
-
-infixl 5 `plusAddr`, `minusAddr`
-\end{code}
-
-\begin{code}
-data Addr = A# Addr# deriving (Eq, Ord)
-data Word = W# Word# deriving (Eq, Ord)
-
-nullAddr :: Addr
-nullAddr = A# (int2Addr# 0#)
-
-alignAddr :: Addr -> Int -> Addr
-alignAddr addr@(A# a) (I# i)
- = case addr2Int# a of { ai ->
- case remInt# ai i of {
- 0# -> addr;
- n -> A# (int2Addr# (ai +# (i -# n))) }}
-
-plusAddr :: Addr -> Int -> Addr
-plusAddr (A# addr) (I# off) = A# (int2Addr# (addr2Int# addr +# off))
-
-minusAddr :: Addr -> Addr -> Int
-minusAddr (A# a1) (A# a2) = I# (addr2Int# a1 -# addr2Int# a2)
-
-instance CCallable Addr
-instance CReturnable Addr
-
-instance CCallable Word
-instance CReturnable Word
-
-wordToInt :: Word -> Int
-wordToInt (W# w#) = I# (word2Int# w#)
-
-intToWord :: Int -> Word
-intToWord (I# i#) = W# (int2Word# i#)
-
-#if WORD_SIZE_IN_BYTES == 8
-data Word64 = W64# Word#
-data Int64 = I64# Int#
-#else
-data Word64 = W64# Word64# --deriving (Eq, Ord) -- Glasgow extension
-data Int64 = I64# Int64# --deriving (Eq, Ord) -- Glasgow extension
-#endif
-
-instance CCallable Word64
-instance CReturnable Word64
-
-instance CCallable Int64
-instance CReturnable Int64
-
-indexAddrOffAddr :: Addr -> Int -> Addr
-indexAddrOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexAddrOffAddr# addr# n# of { r# ->
- (A# r#)}}
-
-\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}
+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`
+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 = shift 0x1 i
+ setBit x i = x .|. bit i
+ clearBit x i = x .&. complement (bit i)
+ complementBit x i = x `xor` bit i
+ testBit x i = (x .&. bit i) /= 0
+
+shiftL, shiftR :: Bits a => a -> Int -> a
+rotateL, rotateR :: Bits a => a -> Int -> a
+shiftL a i = shift a i
+shiftR a i = shift a (-i)
+rotateL a i = rotate a i
+rotateR a i = rotate a (-i)
+\end{code}
% -----------------------------------------------------------------------------
-% $Id: PrelByteArr.lhs,v 1.9 2000/12/12 12:19:58 simonmar Exp $
+% $Id: PrelByteArr.lhs,v 1.10 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
import PrelFloat
import PrelST
import PrelBase
-import PrelAddr
-
\end{code}
%*********************************************************
might be different, though.
\begin{code}
-newCharArray, newIntArray, newWordArray, newAddrArray, newFloatArray, newDoubleArray
+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 newWordArray :: IPr -> ST s (MutableByteArray s Int) #-}
-{-# SPECIALIZE newAddrArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newFloatArray :: IPr -> ST s (MutableByteArray s Int) #-}
{-# SPECIALIZE newDoubleArray :: IPr -> ST s (MutableByteArray s Int) #-}
case (newByteArray# (wORD_SCALE n#) s#) of { (# s2#, barr# #) ->
(# s2#, MutableByteArray l u barr# #) }}
-newAddrArray (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# #) ->
readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char
readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int
-readWordArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Word
-readAddrArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Addr
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 #-}
-{-# SPECIALIZE readAddrArray :: MutableByteArray s Int -> Int -> ST s Addr #-}
--NO:{-# SPECIALIZE readFloatArray :: MutableByteArray s Int -> Int -> ST s Float #-}
{-# SPECIALIZE readDoubleArray :: MutableByteArray s Int -> Int -> ST s Double #-}
case readIntArray# barr# n# s# of { (# s2#, r# #) ->
(# s2#, I# r# #) }}
-readWordArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readWordArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, W# r# #) }}
-
-readAddrArray (MutableByteArray l u barr#) n = ST $ \ s# ->
- case (index (l,u) n) of { I# n# ->
- case readAddrArray# barr# n# s# of { (# s2#, r# #) ->
- (# s2#, A# 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# #) ->
--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
-indexWordArray :: Ix ix => ByteArray ix -> ix -> Word
-indexAddrArray :: Ix ix => ByteArray ix -> ix -> Addr
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 #-}
-{-# SPECIALIZE indexAddrArray :: ByteArray Int -> Int -> Addr #-}
--NO:{-# SPECIALIZE indexFloatArray :: ByteArray Int -> Int -> Float #-}
{-# SPECIALIZE indexDoubleArray :: ByteArray Int -> Int -> Double #-}
case indexIntArray# barr# n# of { r# ->
(I# r#)}}
-indexWordArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexWordArray# barr# n# of { r# ->
- (W# r#)}}
-
-indexAddrArray (ByteArray l u barr#) n
- = case (index (l,u) n) of { I# n# ->
- case indexAddrArray# barr# n# of { r# ->
- (A# r#)}}
-
indexFloatArray (ByteArray l u barr#) n
= case (index (l,u) n) of { I# n# ->
case indexFloatArray# barr# n# of { r# ->
writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s ()
writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> ST s ()
-writeWordArray :: Ix ix => MutableByteArray s ix -> ix -> Word -> ST s ()
-writeAddrArray :: Ix ix => MutableByteArray s ix -> ix -> Addr -> 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 () #-}
-{-# SPECIALIZE writeAddrArray :: MutableByteArray s Int -> Int -> Addr -> ST s () #-}
--NO:{-# SPECIALIZE writeFloatArray :: MutableByteArray s Int -> Int -> Float -> ST s () #-}
{-# SPECIALIZE writeDoubleArray :: MutableByteArray s Int -> Int -> Double -> ST s () #-}
case writeIntArray# barr# n# ele s# of { s2# ->
(# s2#, () #) }}
-writeWordArray (MutableByteArray l u barr#) n (W# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeWordArray# barr# n# ele s# of { s2# ->
- (# s2#, () #) }}
-
-writeAddrArray (MutableByteArray l u barr#) n (A# ele) = ST $ \ s# ->
- case index (l,u) n of { I# n# ->
- case writeAddrArray# 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# ->
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelCError.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+C-specific Marshalling support: Handling of C "errno" error codes
+
+\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
+
+-- this is were we get the CCONST_XXX definitions from that configure
+-- calculated for us
+--
+#include "config.h"
+
+module PrelCError (
+
+ -- Haskell representation for "errno" values
+ --
+ Errno(..), -- instance: Eq
+ 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
+
+ -- 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)
+) where
+
+
+-- system dependent imports
+-- ------------------------
+
+-- GHC allows us to get at the guts inside IO errors/exceptions
+--
+#if __GLASGOW_HASKELL__
+#if __GLASGOW_HASKELL__ < 409
+import PrelIOBase (IOError(..), IOErrorType(..))
+#else
+import PrelIOBase (Exception(..), IOException(..), IOErrorType(..))
+#endif
+#endif /* __GLASGOW_HASKELL__ */
+
+
+-- regular imports
+-- ---------------
+
+import Monad (liftM)
+
+#if __GLASGOW_HASKELL__
+import PrelStorable
+import PrelMarshalError
+import PrelCTypes
+import PrelIOBase
+import PrelPtr
+import PrelNum
+import PrelShow
+import PrelMaybe
+import PrelBase
+#else
+import Ptr (Ptr, nullPtr)
+import CTypes (CInt)
+import MarshalError (void)
+
+import IO (IOError, Handle, ioError)
+#endif
+
+-- system dependent re-definitions
+-- -------------------------------
+
+-- we bring GHC's `IOErrorType' in scope in other compilers to simplify the
+-- routine `errnoToIOError' below
+--
+#if !__GLASGOW_HASKELL__
+data IOErrorType
+ = AlreadyExists | HardwareFault
+ | IllegalOperation | InappropriateType
+ | Interrupted | InvalidArgument
+ | NoSuchThing | OtherError
+ | PermissionDenied | ProtocolError
+ | ResourceBusy | ResourceExhausted
+ | ResourceVanished | SystemError
+ | TimeExpired | UnsatisfiedConstraints
+ | UnsupportedOperation
+ | EOF
+#endif
+
+
+-- "errno" type
+-- ------------
+
+-- 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
+--
+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
+--
+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 0
+--
+isValidErrno (Errno errno) = errno /= 0
+
+
+-- access to the current thread's "errno" value
+-- --------------------------------------------
+
+-- yield the current thread's "errno" value
+--
+getErrno :: IO Errno
+getErrno = liftM Errno (peek _errno)
+
+
+-- 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 discards the result
+--
+throwErrnoIfRetry_ :: (a -> Bool) -> String -> IO a -> IO ()
+throwErrnoIfRetry_ pred loc f = void $ throwErrnoIfRetry pred loc f
+
+-- 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)
+
+-- 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)
+
+
+-- 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@(Errno no) maybeHdl maybeName =
+#if __GLASGOW_HASKELL__
+ IOException (IOError maybeHdl errType loc str maybeName)
+#else
+ userError (loc ++ ": " ++ str ++ maybe "" (": "++) maybeName)
+#endif
+ where
+ (errType, str)
+ | no == 0 = (OtherError,
+ "no error")
+ | errno == e2BIG = (ResourceExhausted,
+ "argument list too long")
+ | errno == eACCES = (PermissionDenied,
+ "inadequate access permission")
+ | errno == eADDRINUSE = (ResourceBusy,
+ "address already in use")
+ | errno == eADDRNOTAVAIL = (UnsupportedOperation,
+ "address not available")
+ | errno == eADV = (OtherError,
+ "RFS advertise error")
+ | errno == eAFNOSUPPORT = (UnsupportedOperation,
+ "address family not supported by " ++
+ "protocol family")
+ -- no multiline strings with cpp
+ | errno == eAGAIN = (ResourceExhausted,
+ "insufficient resources")
+ | errno == eALREADY = (AlreadyExists,
+ "operation already in progress")
+ | errno == eBADF = (OtherError,
+ "internal error (EBADF)")
+ | errno == eBADMSG = (InappropriateType,
+ "next message has wrong type")
+ | errno == eBADRPC = (OtherError,
+ "invalid RPC request or response")
+ | errno == eBUSY = (ResourceBusy,
+ "device busy")
+ | errno == eCHILD = (NoSuchThing,
+ "no child processes")
+ | errno == eCOMM = (ResourceVanished,
+ "no virtual circuit could be found")
+ | errno == eCONNABORTED = (OtherError,
+ "aborted connection")
+ | errno == eCONNREFUSED = (NoSuchThing,
+ "no listener on remote host")
+ | errno == eCONNRESET = (ResourceVanished,
+ "connection reset by peer")
+ | errno == eDEADLK = (ResourceBusy,
+ "resource deadlock avoided")
+ | errno == eDESTADDRREQ = (InvalidArgument,
+ "destination address required")
+ | errno == eDIRTY = (UnsatisfiedConstraints,
+ "file system dirty")
+ | errno == eDOM = (InvalidArgument,
+ "argument too large")
+ | errno == eDQUOT = (PermissionDenied,
+ "quota exceeded")
+ | errno == eEXIST = (AlreadyExists,
+ "file already exists")
+ | errno == eFAULT = (OtherError,
+ "internal error (EFAULT)")
+ | errno == eFBIG = (PermissionDenied,
+ "file too large")
+ | errno == eFTYPE = (InappropriateType,
+ "inappropriate NFS file type or format")
+ | errno == eHOSTDOWN = (NoSuchThing,
+ "destination host down")
+ | errno == eHOSTUNREACH = (NoSuchThing,
+ "remote host is unreachable")
+ | errno == eIDRM = (ResourceVanished,
+ "IPC identifier removed")
+ | errno == eILSEQ = (InvalidArgument,
+ "invalid wide character")
+ | errno == eINPROGRESS = (AlreadyExists,
+ "operation now in progress")
+ | errno == eINTR = (Interrupted,
+ "interrupted system call")
+ | errno == eINVAL = (InvalidArgument,
+ "invalid argument")
+ | errno == eIO = (HardwareFault,
+ "unknown I/O fault")
+ | errno == eISCONN = (AlreadyExists,
+ "socket is already connected")
+ | errno == eISDIR = (InappropriateType,
+ "file is a directory")
+ | errno == eLOOP = (InvalidArgument,
+ "too many symbolic links")
+ | errno == eMFILE = (ResourceExhausted,
+ "process file table full")
+ | errno == eMLINK = (ResourceExhausted,
+ "too many links")
+ | errno == eMSGSIZE = (ResourceExhausted,
+ "message too long")
+ | errno == eMULTIHOP = (UnsupportedOperation,
+ "multi-hop RFS request")
+ | errno == eNAMETOOLONG = (InvalidArgument,
+ "filename too long")
+ | errno == eNETDOWN = (ResourceVanished,
+ "network is down")
+ | errno == eNETRESET = (ResourceVanished,
+ "remote host rebooted; connection lost")
+ | errno == eNETUNREACH = (NoSuchThing,
+ "remote network is unreachable")
+ | errno == eNFILE = (ResourceExhausted,
+ "system file table full")
+ | errno == eNOBUFS = (ResourceExhausted,
+ "no buffer space available")
+ | errno == eNODATA = (NoSuchThing,
+ "no message on the stream head read " ++
+ "queue")
+ -- no multiline strings with cpp
+ | errno == eNODEV = (NoSuchThing,
+ "no such device")
+ | errno == eNOENT = (NoSuchThing,
+ "no such file or directory")
+ | errno == eNOEXEC = (InvalidArgument,
+ "not an executable file")
+ | errno == eNOLCK = (ResourceExhausted,
+ "no file locks available")
+ | errno == eNOLINK = (ResourceVanished,
+ "RFS link has been severed")
+ | errno == eNOMEM = (ResourceExhausted,
+ "not enough virtual memory")
+ | errno == eNOMSG = (NoSuchThing,
+ "no message of desired type")
+ | errno == eNONET = (NoSuchThing,
+ "host is not on a network")
+ | errno == eNOPROTOOPT = (UnsupportedOperation,
+ "operation not supported by protocol")
+ | errno == eNOSPC = (ResourceExhausted,
+ "no space left on device")
+ | errno == eNOSR = (ResourceExhausted,
+ "out of stream resources")
+ | errno == eNOSTR = (InvalidArgument,
+ "not a stream device")
+ | errno == eNOSYS = (UnsupportedOperation,
+ "function not implemented")
+ | errno == eNOTBLK = (InvalidArgument,
+ "not a block device")
+ | errno == eNOTCONN = (InvalidArgument,
+ "socket is not connected")
+ | errno == eNOTDIR = (InappropriateType,
+ "not a directory")
+ | errno == eNOTEMPTY = (UnsatisfiedConstraints,
+ "directory not empty")
+ | errno == eNOTSOCK = (InvalidArgument,
+ "not a socket")
+ | errno == eNOTTY = (IllegalOperation,
+ "inappropriate ioctl for device")
+ | errno == eNXIO = (NoSuchThing,
+ "no such device or address")
+ | errno == eOPNOTSUPP = (UnsupportedOperation,
+ "operation not supported on socket")
+ | errno == ePERM = (PermissionDenied,
+ "privileged operation")
+ | errno == ePFNOSUPPORT = (UnsupportedOperation,
+ "protocol family not supported")
+ | errno == ePIPE = (ResourceVanished,
+ "broken pipe")
+ | errno == ePROCLIM = (PermissionDenied,
+ "too many processes")
+ | errno == ePROCUNAVAIL = (UnsupportedOperation,
+ "unimplemented RPC procedure")
+ | errno == ePROGMISMATCH = (ProtocolError,
+ "unsupported RPC program version")
+ | errno == ePROGUNAVAIL = (UnsupportedOperation,
+ "RPC program unavailable")
+ | errno == ePROTO = (ProtocolError,
+ "error in streams protocol")
+ | errno == ePROTONOSUPPORT = (ProtocolError,
+ "protocol not supported")
+ | errno == ePROTOTYPE = (ProtocolError,
+ "wrong protocol for socket")
+ | errno == eRANGE = (UnsupportedOperation,
+ "result too large")
+ | errno == eREMCHG = (ResourceVanished,
+ "remote address changed")
+ | errno == eREMOTE = (IllegalOperation,
+ "too many levels of remote in path")
+ | errno == eROFS = (PermissionDenied,
+ "read-only file system")
+ | errno == eRPCMISMATCH = (ProtocolError,
+ "RPC version is wrong")
+ | errno == eRREMOTE = (IllegalOperation,
+ "object is remote")
+ | errno == eSHUTDOWN = (IllegalOperation,
+ "can't send after socket shutdown")
+ | errno == eSOCKTNOSUPPORT = (UnsupportedOperation,
+ "socket type not supported")
+ | errno == eSPIPE = (UnsupportedOperation,
+ "can't seek on a pipe")
+ | errno == eSRCH = (NoSuchThing,
+ "no such process")
+ | errno == eSRMNT = (UnsatisfiedConstraints,
+ "RFS resources still mounted by " ++
+ "remote host(s)")
+ -- no multiline strings with cpp
+ | errno == eSTALE = (ResourceVanished,
+ "stale NFS file handle")
+ | errno == eTIME = (TimeExpired,
+ "timer expired")
+ | errno == eTIMEDOUT = (TimeExpired,
+ "connection timed out")
+ | errno == eTOOMANYREFS = (ResourceExhausted,
+ "too many references; can't splice")
+ | errno == eTXTBSY = (ResourceBusy,
+ "text file in-use")
+ | errno == eUSERS = (ResourceExhausted,
+ "quota table full")
+ | errno == eWOULDBLOCK = (OtherError,
+ "operation would block")
+ | errno == eXDEV = (UnsupportedOperation,
+ "can't make a cross-device link")
+ | otherwise = (OtherError,
+ "unexpected error (error code: "
+ ++ show no ++")")
+
+foreign label "errno" _errno :: Ptr CInt
+ -- FIXME: this routine should eventually be provided by the Haskell runtime
+ -- and guarantee that the "errno" of the last operation performed by
+ -- the current thread is returned
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelCString.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+Utilities for primitive marshaling
+
+\begin{code}
+module PrelCString where
+
+import Monad
+
+import PrelMarshalArray
+import PrelMarshalAlloc
+import PrelException
+import PrelPtr
+import PrelStorable
+import PrelCTypes
+import PrelCTypesISO
+import PrelInt
+import PrelByteArr
+import PrelPack
+import PrelBase
+
+#ifdef __GLASGOW_HASKELL__
+import PrelIOBase hiding (malloc, _malloc)
+#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 = liftM cCharsToChars $ peekArray0 nUL cp
+
+-- marshal a C string with explicit length into a Haskell string
+--
+peekCStringLen :: CStringLen -> IO String
+peekCStringLen (cp, len) = liftM cCharsToChars $ peekArray len cp
+
+-- 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 = liftM (pairLength str) $ newArray (charsToCChars str)
+
+-- 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 = castCharToCChar '\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 = chr (fromIntegral (fromIntegral ch :: Word8))
+-- The above produces horrible code. Word and Int modules really
+-- should be cleaned up... Here is an ugly but fast version:
+castCCharToChar ch = case fromIntegral (fromIntegral ch :: Int32) of
+ I# i# -> C# (chr# (word2Int# (int2Word# i# `and#` int2Word# 0xFF#)))
+
+castCharToCChar :: Char -> CChar
+castCharToCChar ch = fromIntegral (ord ch)
+
+
+-- unsafe CStrings
+-- ---------------
+
+#if __GLASGOW_HASKELL__
+newtype UnsafeCString = UnsafeCString (ByteArray Int)
+withUnsafeCString s f = f (UnsafeCString (packString s))
+#else
+newtype UnsafeCString = UnsafeCString (Ptr CChar)
+withUnsafeCString s f = withCString s (\p -> f (UnsafeCString p))
+#endif
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelCTypes.lhs,v 1.1 2001/01/11 17:25:57 simonmar 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}
+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 ( unsafeCoerce# )
+import PrelReal ( Integral(toInt) )
+import PrelNum ( Num(fromInt) )
+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.1 2001/01/11 17:25:57 simonmar 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}
+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(..),
+
+ , CFile, CFpos, CJmpBuf
+ ) where
+\end{code}
+
+\begin{code}
+import PrelBase ( unsafeCoerce# )
+import PrelReal ( Integral(toInt) )
+import PrelBits ( Bits(..) )
+import PrelNum ( Num(fromInt) )
+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
+ #-}
+
+NUMERIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T)
+NUMERIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T)
+
+-- TODO: Instances. But which...? :-}
+
+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}
% -----------------------------------------------------------------------------
-% $Id: PrelDynamic.lhs,v 1.5 2000/06/30 13:39:35 simonmar Exp $
+% $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 exts/Dynamic.lhs.
+available in lang/Dynamic.lhs.
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
% ------------------------------------------------------------------------------
-% $Id: PrelForeign.lhs,v 1.16 2000/12/11 16:56:47 simonmar Exp $
+% $Id: PrelForeign.lhs,v 1.17 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-module PrelForeign (
- module PrelForeign,
-#ifndef __PARALLEL_HASKELL__
- ForeignPtr(..),
-
- -- the rest are deprecated
- ForeignObj(..),
- makeForeignObj,
- mkForeignObj,
- writeForeignObj
-#endif
- ) where
+module PrelForeign where
import PrelIOBase
import PrelBase
-import PrelAddr
-import PrelWeak ( addForeignFinalizer )
+import PrelPtr
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-data ForeignPtr a = ForeignPtr ForeignObj#
-instance CCallable (ForeignPtr a)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Type @ForeignObj@ and its operations}
-%* *
-%*********************************************************
-
-mkForeignObj and writeForeignObj are the building blocks
-for makeForeignObj, they can probably be nuked in the future.
-
-\begin{code}
#ifndef __PARALLEL_HASKELL__
---instance CCallable ForeignObj
---instance CCallable ForeignObj#
-
-makeForeignObj :: Addr -> IO () -> IO ForeignObj
-makeForeignObj addr finalizer = do
- fObj <- mkForeignObj addr
- addForeignFinalizer fObj finalizer
- return fObj
-
-mkForeignObj :: Addr -> IO ForeignObj
-mkForeignObj (A# obj) = IO ( \ s# ->
+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#, ForeignObj fo# #) )
-
-writeForeignObj :: ForeignObj -> Addr -> IO ()
-writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# ->
- case writeForeignObj# fo# datum# s# of { s1# -> (# s1#, () #) } )
-#endif /* !__PARALLEL_HASKELL__ */
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{Unpacking Foreigns}
-%* *
-%*********************************************************
-
-Primitives for converting Foreigns pointing to external
-sequence of bytes into a list of @Char@s (a renamed version
-of the code above).
+ (# s1#, fo# #) -> (# s1#, ForeignPtr fo# #) )
-\begin{code}
-#ifndef __PARALLEL_HASKELL__
-unpackCStringFO :: ForeignObj -> [Char]
-unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo#
+touchForeignPtr :: ForeignPtr a -> IO ()
+touchForeignPtr (ForeignPtr fo)
+ = IO $ \s -> case touch# fo s of s -> (# s, () #)
-unpackCStringFO# :: ForeignObj# -> [Char]
-unpackCStringFO# fo {- ptr. to NUL terminated string-}
- = unpack 0#
- where
- unpack nh
- | ch `eqChar#` '\0'# = []
- | otherwise = C# ch : unpack (nh +# 1#)
- where
- ch = indexCharOffForeignObj# fo nh
+withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b
+withForeignPtr fo io
+ = do r <- io (foreignPtrToPtr fo)
+ touchForeignPtr fo
+ return r
-unpackNBytesFO :: ForeignObj -> Int -> [Char]
-unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l
+foreignPtrToPtr :: ForeignPtr a -> Ptr a
+foreignPtrToPtr (ForeignPtr fo) = Ptr (foreignObjToAddr# fo)
-unpackNBytesFO# :: ForeignObj# -> Int# -> [Char]
- -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
-unpackNBytesFO# fo len
- = unpack 0#
- where
- unpack i
- | i >=# len = []
- | otherwise = C# ch : unpack (i +# 1#)
- where
- ch = indexCharOffForeignObj# fo i
+castForeignPtr (ForeignPtr a) = ForeignPtr a
#endif
\end{code}
+
% ------------------------------------------------------------------------------
-% $Id: PrelHandle.lhs,v 1.65 2001/01/11 07:04:16 qrczak Exp $
+% $Id: PrelHandle.lhs,v 1.66 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-2000
%
import PrelArr
import PrelBase
-import PrelAddr ( Addr, nullAddr )
+import PrelPtr
import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
import PrelList ( break )
import PrelEnum
import PrelNum ( toBig, Integer(..), Num(..) )
import PrelShow
-import PrelAddr ( Addr, nullAddr )
import PrelReal ( toInteger )
import PrelPack ( packString )
-#ifndef __PARALLEL_HASKELL__
-import PrelWeak ( addForeignFinalizer )
-#endif
import PrelConc
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj, mkForeignObj )
+import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer )
#endif
#endif /* ndef(__HUGS__) */
#endif
#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
+#define FILE_OBJECT (ForeignPtr ())
#else
-#define FILE_OBJECT Addr
+#define FILE_OBJECT (Ptr ())
#endif
\end{code}
mkBuffer__ fo sz_in_bytes = do
chunk <-
case sz_in_bytes of
- 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
+ 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer.
_ -> do
chunk <- malloc sz_in_bytes
- if chunk == nullAddr
+ if chunk == nullPtr
then ioException (IOError Nothing ResourceExhausted
"mkBuffer__" "not enough virtual memory" Nothing)
else return chunk
nullFile__ :: FILE_OBJECT
nullFile__ =
#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (makeForeignObj nullAddr (return ()))
+ unsafePerformIO (newForeignPtr nullPtr (return ()))
#else
- nullAddr
+ nullPtr
#endif
foreign import "libHS_cbits" "freeFileObject" unsafe
freeFileObject :: FILE_OBJECT -> IO ()
foreign import "free" unsafe
- free :: Addr -> IO ()
+ free :: Ptr a -> IO ()
\end{code}
%*********************************************************
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
-- I know this is deprecated, but I couldn't bring myself
- -- to move fixIO into the prelude just so I could use makeForeignObj.
- -- --SDM
+ -- to move fixIO into the prelude just so I could use
+ -- newForeignPtr. --SDM
#endif
#ifdef __HUGS__
hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
return hdl
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
-- that anything buffered on stdout is flushed prior to reading from
-- stdin.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTerms stdout hdl
return hdl
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr" [])
-- when stderr and stdout are both connected to a terminal, ensure
-- that anything buffered on stdout is flushed prior to writing to
-- stderr.
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (stdHandleFinalizer hdl)
+ addForeignPtrFinalizer fo (stdHandleFinalizer hdl)
#endif
hConnectTo stdout hdl
return hdl
fo <- primOpenFile (packString f)
(file_mode::Int)
(binary::Int) -- ConcHask: SAFE, won't block
- if fo /= nullAddr then do
+ if fo /= nullPtr then do
#ifndef __PARALLEL_HASKELL__
- fo <- mkForeignObj fo
+ fo <- mkForeignPtr fo
#endif
(bm, bf_size) <- getBMode__ fo
mkBuffer__ fo bf_size
hdl <- newHandle (Handle__ fo htype bm f [])
#ifndef __PARALLEL_HASKELL__
- addForeignFinalizer fo (handleFinalizer hdl)
+ addForeignPtrFinalizer fo (handleFinalizer hdl)
#endif
return hdl
else do
(1::Int){-flush if you can-} -- ConcHask: SAFE, won't block
{- We explicitly close a file object so that we can be told
if there were any errors. Note that after @hClose@
- has been performed, the ForeignObj embedded in the Handle
+ has been performed, the ForeignPtr embedded in the Handle
is still lying around in the heap, so care is taken
- to avoid closing the file object when the ForeignObj
+ to avoid closing the file object when the ForeignPtr
is finalized. (we overwrite the file ptr in the underlying
FileObject with a NULL as part of closeFile())
-}
\begin{code}
-- in one go, read file into an externally allocated buffer.
-slurpFile :: FilePath -> IO (Addr, Int)
+slurpFile :: FilePath -> IO (Ptr (), Int)
slurpFile fname = do
handle <- openFile fname ReadMode
sz <- hFileSize handle
else do
let sz_i = fromInteger sz
chunk <- malloc sz_i
- if chunk == nullAddr
+ if chunk == nullPtr
then do
hClose handle
constructErrorAndFail "slurpFile"
return ()
foreign import ccall "addrOf_ErrorHdrHook" unsafe
- addrOf_ErrorHdrHook :: Addr
+ addrOf_ErrorHdrHook :: Ptr ()
foreign import ccall "writeErrString__" unsafe
- writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
+ writeErrString :: Ptr () -> ByteArray Int -> Int -> IO ()
-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below.
foreign import ccall "stackOverflow" unsafe
foreign import "libHS_cbits" "filePutc" unsafe
filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "write_" unsafe
- write_ :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
+ write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getBufStart" unsafe
- getBufStart :: FILE_OBJECT -> Int -> IO Addr
+ getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ())
foreign import "libHS_cbits" "getWriteableBuf" unsafe
- getWriteableBuf :: FILE_OBJECT -> IO Addr
+ getWriteableBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBuf" unsafe
- getBuf :: FILE_OBJECT -> IO Addr
+ getBuf :: FILE_OBJECT -> IO (Ptr ())
foreign import "libHS_cbits" "getBufWPtr" unsafe
getBufWPtr :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBufWPtr" unsafe
foreign import "libHS_cbits" "ungetChar" unsafe
ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "readChunk" unsafe
- readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
+ readChunk :: FILE_OBJECT -> Ptr a -> Int -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getFileFd" unsafe
getFileFd :: FILE_OBJECT -> IO Int{-fd-}
#ifdef __HUGS__
foreign import "libHS_cbits" "getLock" unsafe
getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-}
foreign import "libHS_cbits" "openStdFile" unsafe
- openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-}
+ openStdFile :: Int{-fd-}
+ -> Int{-Readable?-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "openFile" unsafe
primOpenFile :: ByteArray Int{-CString-}
-> Int{-How-}
-> Int{-Binary-}
- -> IO Addr {-file obj-}
+ -> IO (Ptr ()){-file object-}
foreign import "libHS_cbits" "const_BUFSIZ" unsafe
const_BUFSIZ :: Int
foreign import "libHS_cbits" "setBinaryMode__" unsafe
setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
-
-
% ------------------------------------------------------------------------------
-% $Id: PrelIO.lhs,v 1.17 2001/01/11 07:04:16 qrczak Exp $
+% $Id: PrelIO.lhs,v 1.18 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1992-2000
%
import PrelRead ( Read(..), readIO )
import PrelShow
import PrelMaybe ( Maybe(..) )
-import PrelAddr ( Addr(..), nullAddr, plusAddr )
+import PrelPtr
import PrelList ( concat, reverse, null )
import PrelPack ( unpackNBytesST, unpackNBytesAccST )
import PrelException ( ioError, catch, catchException, throw )
import PrelConc
-\end{code}
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT (ForeignPtr ())
+#else
+#define FILE_OBJECT (Ptr ())
+#endif
+\end{code}
%*********************************************************
%* *
(\fo -> readLine fo)
(\fo bytes -> do
buf <- getBufStart fo bytes
- eol <- readCharOffAddr buf (bytes-1)
+ eol <- readCharOffPtr buf (bytes-1)
xs <- if (eol == '\n')
then stToIO (unpackNBytesST buf (bytes-1))
else stToIO (unpackNBytesST buf bytes)
return (c:s)
-readCharOffAddr (A# a) (I# i)
+readCharOffPtr (Ptr a) (I# i)
= IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
\end{code}
the handle has indeed been closed.
\begin{code}
-#ifndef __PARALLEL_HASKELL__
-lazyReadBlock :: Handle -> ForeignObj -> IO String
-lazyReadLine :: Handle -> ForeignObj -> IO String
-lazyReadChar :: Handle -> ForeignObj -> IO String
-#else
-lazyReadBlock :: Handle -> Addr -> IO String
-lazyReadLine :: Handle -> Addr -> IO String
-lazyReadChar :: Handle -> Addr -> IO String
-#endif
+lazyReadBlock :: Handle -> FILE_OBJECT -> IO String
+lazyReadLine :: Handle -> FILE_OBJECT -> IO String
+lazyReadChar :: Handle -> FILE_OBJECT -> IO String
lazyReadBlock handle fo = do
buf <- getBufStart fo 0
-- malloced buffers is one way around this, but we really ought to
-- be able to handle it with exception handlers/block/unblock etc.
-getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int))
+getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Ptr (), Int))
getBuffer handle_ = do
let bufs = haBuffers__ handle_
fo = haFO__ handle_
mode = haBufferMode__ handle_
sz <- getBufSize fo
case mode of
- NoBuffering -> return (handle_, (mode, nullAddr, 0))
+ NoBuffering -> return (handle_, (mode, nullPtr, 0))
_ -> case bufs of
[] -> do buf <- malloc sz
return (handle_, (mode, buf, sz))
(b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
-freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
+freeBuffer :: Handle__ -> Ptr () -> Int -> IO Handle__
freeBuffer handle_ buf sz = do
fo_sz <- getBufSize (haFO__ handle_)
if (sz /= fo_sz)
then do { free buf; return handle_ }
else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
-swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__
+swapBuffers :: Handle__ -> Ptr () -> Int -> IO Handle__
swapBuffers handle_ buf sz = do
let fo = haFO__ handle_
fo_buf <- getBuf fo
commitAndReleaseBuffer
:: Handle -- handle to commit to
- -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Ptr () -> Int -- address and size (in bytes) of buffer
-> Int -- number of bytes of data in buffer
-> Bool -- flush the handle afterward?
-> IO ()
-- not flushing, and there's enough room in the buffer:
-- just copy the data in and update bufWPtr.
- else do memcpy (plusAddr fo_buf fo_wptr) buf count
+ else do memcpy (plusPtr fo_buf fo_wptr) buf count
setBufWPtr fo (fo_wptr + count)
handle_ <- freeBuffer handle_ buf sz
ok handle_
commitBuffer
:: Handle -- handle to commit to
- -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Ptr () -> Int -- address and size (in bytes) of buffer
-> Int -- number of bytes of data in buffer
-> Bool -- flush the handle afterward?
-> IO ()
if (rc < 0) then constructErrorAndFail "commitBuffer"
else return ()
- else do memcpy (plusAddr fo_buf new_wptr) buf count
+ else do memcpy (plusPtr fo_buf new_wptr) buf count
setBufWPtr fo (new_wptr + count)
return ()
(\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz)
throw e)
-foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
+foreign import "memcpy" unsafe memcpy :: Ptr () -> Ptr () -> Int -> IO ()
\end{code}
Going across the border between Haskell and C is relatively costly,
#warning delayed update of buffer disnae work with killThread
#endif
-writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
writeLines handle buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
#else /* ndef __HUGS__ */
-writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
writeLines hdl buf len@(I# bufLen) s =
let
shoveString :: Int# -> [Char] -> IO ()
#endif /* ndef __HUGS__ */
#ifdef __HUGS__
-writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
writeBlocks hdl buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
#else /* ndef __HUGS__ */
-writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
writeBlocks hdl buf len@(I# bufLen) s =
let
shoveString :: Int# -> [Char] -> IO ()
in
shoveString 0# s
-write_char :: Addr -> Int# -> Char# -> IO ()
-write_char (A# buf#) n# c# =
+write_char :: Ptr () -> Int# -> Char# -> IO ()
+write_char (Ptr buf#) n# c# =
IO $ \ s# ->
case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
#endif /* ndef __HUGS__ */
% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.31 2001/01/11 07:04:16 qrczak Exp $
+% $Id: PrelIOBase.lhs,v 1.32 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
import PrelBase
import PrelNum ( fromInteger ) -- Integer literals
import PrelMaybe ( Maybe(..) )
-import PrelAddr ( Addr(..), nullAddr )
import PrelShow
import PrelList
import PrelDynamic
+import PrelPtr
import PrelPack ( unpackCString )
#if !defined(__CONCURRENT_HASKELL__)
#endif
#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
+#define FILE_OBJECT (ForeignPtr ())
#else
-#define FILE_OBJECT Addr
+#define FILE_OBJECT (Ptr ())
+
#endif
\end{code}
(MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
{-
- Double sigh - ForeignObj is needed here too to break a cycle.
+ Double sigh - ForeignPtr is needed here too to break a cycle.
-}
-data ForeignObj = ForeignObj ForeignObj# -- another one
-instance CCallable ForeignObj
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
-eqForeignObj :: ForeignObj -> ForeignObj -> Bool
-eqForeignObj mp1 mp2
- = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
+eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
+eqForeignPtr mp1 mp2
+ = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
-foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
+foreign import "eqForeignObj" unsafe
+ primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
-instance Eq ForeignObj where
- p == q = eqForeignObj p q
- p /= q = not (eqForeignObj p q)
+instance Eq (ForeignPtr a) where
+ p == q = eqForeignPtr p q
+ p /= q = not (eqForeignPtr p q)
#endif /* ndef __HUGS__ */
#if defined(__CONCURRENT_HASKELL__)
haType__ :: Handle__Type,
haBufferMode__ :: BufferMode,
haFilePath__ :: FilePath,
- haBuffers__ :: [Addr]
+ haBuffers__ :: [Ptr ()]
}
{-
Foreign import declarations to helper routines:
\begin{code}
-foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr
+foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO (Ptr ())
foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
-malloc :: Int -> IO Addr
+-- ToDo: use mallocBytes from PrelMarshal?
+malloc :: Int -> IO (Ptr ())
malloc sz = do
a <- _malloc sz
- if (a == nullAddr)
+ if (a == nullPtr)
then ioException (IOError Nothing ResourceExhausted
"malloc" "out of memory" Nothing)
else return a
-foreign import "malloc" unsafe _malloc :: Int -> IO Addr
+foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ())
foreign import "libHS_cbits" "getBufSize" unsafe
getBufSize :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBuf" unsafe
- setBuf :: FILE_OBJECT -> Addr -> Int -> IO ()
+ setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO ()
\end{code}
%
% (c) The University of Glasgow, 2000
%
-\section[Int]{Module @PrelInt@}
+\section[PrelInt]{Module @PrelInt@}
\begin{code}
{-# OPTIONS -monly-3-regs #-}
, int64ToInt16 -- :: Int64 -> Int16
, int64ToInt32 -- :: Int64 -> Int32
- -- The "official" place to get these from is Addr, importing
- -- them from Int is a non-standard thing to do.
- -- SUP: deprecated in the new FFI, subsumed by the Storable class
- , indexInt8OffAddr
- , indexInt16OffAddr
- , indexInt32OffAddr
- , indexInt64OffAddr
-
- , readInt8OffAddr
- , readInt16OffAddr
- , readInt32OffAddr
- , readInt64OffAddr
-
- , writeInt8OffAddr
- , writeInt16OffAddr
- , writeInt32OffAddr
- , writeInt64OffAddr
-
-- internal stuff
, intToInt8#, i8ToInt#, intToInt16#, i16ToInt#, intToInt32#, i32ToInt#,
, intToInt64#, plusInt64#, minusInt64#, negateInt64#
+
) where
import PrelWord
+import PrelBits
import PrelArr
import PrelRead
-import PrelIOBase
-import PrelAddr
import PrelReal
import PrelNum
import PrelBase
instance Show Int8 where
showsPrec p i8 = showsPrec p (int8ToInt i8)
+binop8 :: (Int32 -> Int32 -> a) -> (Int8 -> Int8 -> a)
+binop8 op x y = int8ToInt32 x `op` int8ToInt32 y
+
+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# 0xff#)))
+ shift (I8# x) i@(I# i#)
+ | i > 0 = I8# (intToInt8# (iShiftL# (i8ToInt# x) i#))
+ | otherwise = I8# (intToInt8# (iShiftRA# (i8ToInt# x) (negateInt# i#)))
+ i8@(I8# x) `rotate` (I# i)
+ | i ==# 0# = i8
+ | i ># 0# =
+ I8# (intToInt8# ( word2Int# (
+ (int2Word# (iShiftL# (i8ToInt# x) i'))
+ `or#`
+ (int2Word# (iShiftRA# (word2Int# (
+ (int2Word# x) `and#`
+ (int2Word# (0x100# -# pow2# i2))))
+ i2)))))
+ | otherwise = rotate i8 (I# (8# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 7#)
+ i2 = 8# -# i'
+ bitSize _ = 8
+ isSigned _ = True
+
+pow2# :: Int# -> Int#
+pow2# x# = iShiftL# 1# x#
+
+pow2_64# :: Int# -> Int64#
+pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#)
+
-- -----------------------------------------------------------------------------
-- Int16
-- -----------------------------------------------------------------------------
instance Show Int16 where
showsPrec p i16 = showsPrec p (int16ToInt i16)
+
+binop16 :: (Int32 -> Int32 -> a) -> (Int16 -> Int16 -> a)
+binop16 op x y = int16ToInt32 x `op` int16ToInt32 y
+
+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# 0xffff#)))
+ shift (I16# x) i@(I# i#)
+ | i > 0 = I16# (intToInt16# (iShiftL# (i16ToInt# x) i#))
+ | otherwise = I16# (intToInt16# (iShiftRA# (i16ToInt# x) (negateInt# i#)))
+ i16@(I16# x) `rotate` (I# i)
+ | i ==# 0# = i16
+ | i ># 0# =
+ I16# (intToInt16# (word2Int# (
+ (int2Word# (iShiftL# (i16ToInt# x) i'))
+ `or#`
+ (int2Word# (iShiftRA# ( word2Int# (
+ (int2Word# x) `and#` (int2Word# (0x100# -# pow2# i2))))
+ i2)))))
+ | otherwise = rotate i16 (I# (16# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 15#)
+ i2 = 16# -# i'
+ bitSize _ = 16
+ isSigned _ = True
+
-- -----------------------------------------------------------------------------
-- Int32
-- -----------------------------------------------------------------------------
instance Show Int32 where
showsPrec p i32 = showsPrec p (int32ToInt i32)
+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)))
+#if WORD_SIZE_IN_BYTES > 4
+ complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# 0xffffffff#)))
+#else
+ complement (I32# x) = I32# (word2Int# ((int2Word# x) `xor#` (int2Word# (negateInt# 1#))))
+#endif
+ shift (I32# x) i@(I# i#)
+ | i > 0 = I32# (intToInt32# (iShiftL# (i32ToInt# x) i#))
+ | otherwise = I32# (intToInt32# (iShiftRA# (i32ToInt# x) (negateInt# i#)))
+ i32@(I32# x) `rotate` (I# i)
+ | i ==# 0# = i32
+ | i ># 0# =
+ -- ( (x<<i') | ((x&(0x100000000-2^i2))>>i2)
+ I32# (intToInt32# ( word2Int# (
+ (int2Word# (iShiftL# (i32ToInt# x) i'))
+ `or#`
+ (int2Word# (iShiftRA# (word2Int# (
+ (int2Word# x)
+ `and#`
+ (int2Word# (maxBound# -# pow2# i2 +# 1#))))
+ i2)))))
+ | otherwise = rotate i32 (I# (32# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 31#)
+ i2 = 32# -# i'
+ (I32# maxBound#) = maxBound
+ bitSize _ = 32
+ isSigned _ = True
+
-- -----------------------------------------------------------------------------
-- Int64
-- -----------------------------------------------------------------------------
#if WORD_SIZE_IN_BYTES == 8
-
---data Int64 = I64# Int#
+data Int64 = I64# Int#
int32ToInt64 (I32# i#) = I64# i#
#else
--assume: support for long-longs
---data Int64 = I64 Int64# deriving (Eq, Ord, Bounded)
+data Int64 = I64# Int64#
int32ToInt64 (I32# i#) = I64# (intToInt64# i#)
int64ToInt32 (I64# i#) = I32# (int64ToInt# i#)
intToInt64 (I# i#) = I64# (intToInt64# i#)
int64ToInt (I64# i#) = I# (int64ToInt# i#)
--- Word64# primop wrappers:
+-- Int64# primop wrappers:
ltInt64# :: Int64# -> Int64# -> Bool
-ltInt64# x# y# = stg_ltInt64 x# y# /= 0
+ltInt64# x# y# = stg_ltInt64 x# y# /=# 0#
leInt64# :: Int64# -> Int64# -> Bool
-leInt64# x# y# = stg_leInt64 x# y# /= 0
+leInt64# x# y# = stg_leInt64 x# y# /=# 0#
eqInt64# :: Int64# -> Int64# -> Bool
-eqInt64# x# y# = stg_eqInt64 x# y# /= 0
+eqInt64# x# y# = stg_eqInt64 x# y# /=# 0#
neInt64# :: Int64# -> Int64# -> Bool
-neInt64# x# y# = stg_neInt64 x# y# /= 0
+neInt64# x# y# = stg_neInt64 x# y# /=# 0#
geInt64# :: Int64# -> Int64# -> Bool
-geInt64# x# y# = stg_geInt64 x# y# /= 0
+geInt64# x# y# = stg_geInt64 x# y# /=# 0#
gtInt64# :: Int64# -> Int64# -> Bool
-gtInt64# x# y# = stg_gtInt64 x# y# /= 0
-
-plusInt64# :: Int64# -> Int64# -> Int64#
-plusInt64# a# b# = case stg_plusInt64 a# b# of { I64# i# -> i# }
-
-minusInt64# :: Int64# -> Int64# -> Int64#
-minusInt64# a# b# = case stg_minusInt64 a# b# of { I64# i# -> i# }
-
-timesInt64# :: Int64# -> Int64# -> Int64#
-timesInt64# a# b# = case stg_timesInt64 a# b# of { I64# i# -> i# }
-
-quotInt64# :: Int64# -> Int64# -> Int64#
-quotInt64# a# b# = case stg_quotInt64 a# b# of { I64# i# -> i# }
-
-remInt64# :: Int64# -> Int64# -> Int64#
-remInt64# a# b# = case stg_remInt64 a# b# of { I64# i# -> i# }
-
-negateInt64# :: Int64# -> Int64#
-negateInt64# a# = case stg_negateInt64 a# of { I64# i# -> i# }
-
-int64ToInt# :: Int64# -> Int#
-int64ToInt# i64# = case stg_int64ToInt i64# of { I# i# -> i# }
-
-intToInt64# :: Int# -> Int64#
-intToInt64# i# = case stg_intToInt64 i# of { I64# i64# -> i64# }
-
-foreign import "stg_intToInt64" unsafe stg_intToInt64 :: Int# -> Int64
-foreign import "stg_int64ToInt" unsafe stg_int64ToInt :: Int64# -> Int
-foreign import "stg_negateInt64" unsafe stg_negateInt64 :: Int64# -> Int64
-foreign import "stg_remInt64" unsafe stg_remInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_quotInt64" unsafe stg_quotInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_timesInt64" unsafe stg_timesInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_minusInt64" unsafe stg_minusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_plusInt64" unsafe stg_plusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_gtInt64" unsafe stg_gtInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_geInt64" unsafe stg_geInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_neInt64" unsafe stg_neInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_eqInt64" unsafe stg_eqInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_leInt64" unsafe stg_leInt64 :: Int64# -> Int64# -> Int
-foreign import "stg_ltInt64" unsafe stg_ltInt64 :: Int64# -> Int64# -> Int
+gtInt64# x# y# = stg_gtInt64 x# y# /=# 0#
+
+foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64#
+foreign import "stg_int64ToInt" unsafe int64ToInt# :: Int64# -> Int#
+foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64#
+foreign import "stg_remInt64" unsafe remInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_quotInt64" unsafe quotInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_gtInt64" unsafe stg_gtInt64 :: Int64# -> Int64# -> Int#
+foreign import "stg_geInt64" unsafe stg_geInt64 :: Int64# -> Int64# -> Int#
+foreign import "stg_neInt64" unsafe stg_neInt64 :: Int64# -> Int64# -> Int#
+foreign import "stg_eqInt64" unsafe stg_eqInt64 :: Int64# -> Int64# -> Int#
+foreign import "stg_leInt64" unsafe stg_leInt64 :: Int64# -> Int64# -> Int#
+foreign import "stg_ltInt64" unsafe stg_ltInt64 :: Int64# -> Int64# -> Int#
#endif
--
-- Code that's independent of Int64 rep.
--
+instance CCallable Int64
+instance CReturnable Int64
+
instance Enum Int64 where
succ i
| i == maxBound = succError "Int64"
instance Real Int64 where
toRational x = toInteger x % 1
--- ---------------------------------------------------------------------------
--- Reading/writing Ints from memory
--- ---------------------------------------------------------------------------
-
-indexInt8OffAddr :: Addr -> Int -> Int8
-indexInt8OffAddr (A# a#) (I# i#) = I8# (indexInt8OffAddr# a# i#)
-
-indexInt16OffAddr :: Addr -> Int -> Int16
-indexInt16OffAddr (A# a#) (I# i#) = I16# (indexInt16OffAddr# a# i#)
-
-indexInt32OffAddr :: Addr -> Int -> Int32
-indexInt32OffAddr (A# a#) (I# i#) = I32# (indexInt32OffAddr# a# i#)
-
-indexInt64OffAddr :: Addr -> Int -> Int64
-#if WORD_SIZE_IN_BYTES==8
-indexInt64OffAddr (A# a#) (I# i#) = I64# (indexIntOffAddr# a# i#)
-#else
-indexInt64OffAddr (A# a#) (I# i#) = I64# (indexInt64OffAddr# a# i#)
-#endif
-
-
-readInt8OffAddr :: Addr -> Int -> IO Int8
-readInt8OffAddr (A# a) (I# i)
- = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #)
-
-readInt16OffAddr :: Addr -> Int -> IO Int16
-readInt16OffAddr (A# a) (I# i)
- = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #)
-
-readInt32OffAddr :: Addr -> Int -> IO Int32
-readInt32OffAddr (A# a) (I# i)
- = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #)
-
-readInt64OffAddr :: Addr -> Int -> IO Int64
#if WORD_SIZE_IN_BYTES == 8
-readInt64OffAddr (A# a) (I# i)
- = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #)
-#else
-readInt64OffAddr (A# a) (I# i)
- = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #)
-#endif
-
-
-writeInt8OffAddr :: Addr -> Int -> Int8 -> IO ()
-writeInt8OffAddr (A# a#) (I# i#) (I8# w#) = IO $ \ s# ->
- case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+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# (negateInt# x)
+ shift (I64# x) i@(I# i#)
+ | i > 0 = I64# (iShiftL# x i#)
+ | otherwise = I64# (iShiftRA# x (negateInt# i#))
+ i64@(I64# x) `rotate` (I# i)
+ | i ==# 0# = i64
+ | i ># 0# =
+ -- ( (x<<i') | ((x&(0x10000000000000000-2^i2))>>i2) )
+ I64# (word2Int# (
+ (int2Word# (iShiftL# x i'))
+ `or#`
+ (int2Word# (iShiftRA# (word2Int# (
+ (int2Word# x)
+ `and#`
+ (int2Word# (maxBound# -# pow2# i2 +# 1#))))
+ i2))))
+ | otherwise = rotate i64 (I# (64# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 63#)
+ i2 = 64# -# i'
+ (I64# maxBound#) = maxBound
+ bitSize _ = 64
+ isSigned _ = True
+
+#else /* WORD_SIZE_IN_BYTES != 8 */
+
+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# (negateInt64# x)
+ shift (I64# x) i@(I# i#)
+ | i > 0 = I64# (iShiftL64# x i#)
+ | otherwise = I64# (iShiftRA64# x (negateInt# i#))
+ i64@(I64# x) `rotate` (I# i)
+ | i ==# 0# = i64
+ | i ># 0# =
+ -- ( (x<<i') | ((x&(0x10000000000000000-2^i2))>>i2) )
+ I64# (word64ToInt64# (
+ (int64ToWord64# (iShiftL64# x i')) `or64#`
+ (int64ToWord64# (iShiftRA64# (word64ToInt64# ((int64ToWord64# x) `and64#`
+ (int64ToWord64# (maxBound# `minusInt64#` (pow2_64# i2 `plusInt64#` (intToInt64# 1#))))))
+ i2))))
+ | otherwise = rotate i64 (I# (64# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 63#)
+ i2 = 64# -# i'
+ (I64# maxBound#) = maxBound
+ bitSize _ = 64
+ isSigned _ = True
+
+foreign import "stg_not64" unsafe not64# :: Word64# -> Word64#
+foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_iShiftRA64" unsafe iShiftRA64# :: Int64# -> Int# -> Int64#
+foreign import "stg_iShiftRL64" unsafe iShiftRL64# :: Int64# -> Int# -> Int64#
+foreign import "stg_iShiftL64" unsafe iShiftL64# :: Int64# -> Int# -> Int64#
+foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
-writeInt16OffAddr :: Addr -> Int -> Int16 -> IO ()
-writeInt16OffAddr (A# a#) (I# i#) (I16# w#) = IO $ \ s# ->
- case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-
-writeInt32OffAddr :: Addr -> Int -> Int32 -> IO ()
-writeInt32OffAddr (A# a#) (I# i#) (I32# w#) = IO $ \ s# ->
- case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-
-writeInt64OffAddr :: Addr -> Int -> Int64 -> IO ()
-#if WORD_SIZE_IN_BYTES == 8
-writeInt64OffAddr (A# a#) (I# i#) (I64# w#) = IO $ \ s# ->
- case (writeIntOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-#else
-writeInt64OffAddr (A# a#) (I# i#) (I64# w#) = IO $ \ s# ->
- case (writeInt64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
#endif
-\end{code}
-Miscellaneous Utilities
+-- ---------------------------------------------------------------------------
+-- Miscellaneous Utilities
+-- ---------------------------------------------------------------------------
-\begin{code}
absReal :: (Ord a, Num a) => a -> a
absReal x | x >= 0 = x
| otherwise = -x
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelMarshalAlloc.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+Marshalling support: basic routines for memory allocation
+
+\begin{code}
+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
+
+import PrelException ( bracket )
+import PrelPtr ( Ptr, nullPtr )
+import PrelStorable ( Storable(sizeOf) )
+import PrelCTypesISO ( CSize )
+
+#ifdef __GLASGOW_HASKELL__
+import PrelIOBase hiding (malloc, _malloc)
+#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
+--
+allocaBytes :: Int -> (Ptr a -> IO b) -> IO b
+allocaBytes size = bracket (mallocBytes size) free
+
+-- 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.1 2001/01/11 17:25:57 simonmar 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}
+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 ()
+
+ -- indexing
+ --
+ advancePtr -- :: Storable a => Ptr a -> Int -> Ptr a
+) where
+
+import Monad (zipWithM_)
+
+import PrelPtr (Ptr, plusPtr)
+import PrelStorable (Storable(sizeOf, peekElemOff, pokeElemOff))
+import PrelMarshalAlloc (mallocBytes, allocaBytes, reallocBytes)
+import PrelMarshalUtils (copyBytes, moveBytes)
+
+
+-- 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
+--
+peekArray :: Storable a => Int -> Ptr a -> IO [a]
+peekArray size ptr = mapM (peekElemOff ptr) [0..size-1]
+
+-- 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 maker
+--
+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 (length vals) $ \ptr -> do
+ pokeArray ptr vals
+ f ptr
+
+-- `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 (length vals) $ \ptr -> do
+ pokeArray0 marker ptr vals
+ f ptr
+
+
+-- copying
+-- -------
+
+-- copies 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)
+
+-- copies 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)
+
+
+-- 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.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+Marshalling support: Handling of common error conditions
+
+\begin{code}
+
+module PrelMarshalError (
+
+ -- 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 PrelBase
+
+-- exported functions
+-- ------------------
+
+-- 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.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+Utilities for primitive marshaling
+
+\begin{code}
+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
+
+import Monad ( liftM )
+
+import PrelPtr ( Ptr, nullPtr )
+import PrelStorable ( Storable (poke) )
+import PrelCTypesISO ( CSize )
+import PrelMarshalAlloc ( malloc, alloca )
+
+
+-- 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; f ptr
+
+
+-- 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 = liftM Just $ peek ptr
+
+
+-- 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}
% ------------------------------------------------------------------------------
-% $Id: PrelPack.lhs,v 1.15 2000/12/12 12:19:58 simonmar Exp $
+% $Id: PrelPack.lhs,v 1.16 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1997-2000
%
packStringST, -- :: [Char] -> ST s (ByteArray Int)
packNBytesST, -- :: Int -> [Char] -> ST s (ByteArray Int)
- unpackCString, -- :: Addr -> [Char]
- unpackCStringST, -- :: Addr -> ST s [Char]
- unpackNBytes, -- :: Addr -> Int -> [Char]
- unpackNBytesST, -- :: Addr -> Int -> ST s [Char]
- unpackNBytesAccST, -- :: Addr -> Int -> [Char] -> ST s [Char]
+ 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]
import PrelST
import PrelNum
import PrelByteArr
-import PrelAddr
+import PrelPtr
\end{code}
%*********************************************************
%* *
-\subsection{Unpacking Addrs}
+\subsection{Unpacking Ptrs}
%* *
%*********************************************************
sequence of bytes into a list of @Char@s:
\begin{code}
-unpackCString :: Addr -> [Char]
-unpackCString a@(A# addr)
- | a == nullAddr = []
+unpackCString :: Ptr a -> [Char]
+unpackCString a@(Ptr addr)
+ | a == nullPtr = []
| otherwise = unpackCString# addr
-unpackNBytes :: Addr -> Int -> [Char]
-unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l
+unpackNBytes :: Ptr a -> Int -> [Char]
+unpackNBytes (Ptr addr) (I# l) = unpackNBytes# addr l
-unpackCStringST :: Addr{- ptr. to NUL terminated string-} -> ST s [Char]
-unpackCStringST a@(A# addr)
- | a == nullAddr = return []
+unpackCStringST :: Ptr a{- ptr. to NUL terminated string-} -> ST s [Char]
+unpackCStringST a@(Ptr addr)
+ | a == nullPtr = return []
| otherwise = unpack 0#
where
unpack nh
where
ch = indexCharOffAddr# addr nh
-unpackNBytesST :: Addr -> Int -> ST s [Char]
-unpackNBytesST (A# addr) (I# l) = unpackNBytesAccST# addr l []
+unpackNBytesST :: Ptr a -> Int -> ST s [Char]
+unpackNBytesST (Ptr addr) (I# l) = unpackNBytesAccST# addr l []
-unpackNBytesAccST :: Addr -> Int -> [Char] -> ST s [Char]
-unpackNBytesAccST (A# addr) (I# l) rest = unpackNBytesAccST# addr l rest
+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# []
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: PrelPosixTypes.hsc,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+--
+-- (c) 2000
+--
+-- Module PrelPosixTypes
+
+module PrelPosixTypes where
+
+import PrelWord
+import PrelInt
+
+#include <sys/types.h>
+#include <termios.h>
+
+data CDir = CDir
+
+type CDev = #type dev_t
+type CGid = #type gid_t
+type CIno = #type ino_t
+type CMode = #type mode_t
+type CNlink = #type nlink_t
+type COff = #type off_t
+type CPid = #type pid_t
+type CSsize = #type ssize_t
+type CUid = #type uid_t
+type CCc = #type cc_t
+type CSpeed = #type speed_t
+type CTcflag = #type tcflag_t
+type CTime = #type time_t
--- /dev/null
+-----------------------------------------------------------------------------
+-- $Id: PrelPtr.lhs,v 1.1 2001/01/11 17:25:57 simonmar 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 (int2Addr# 0#)
+
+castPtr :: Ptr a -> Ptr b
+castPtr (Ptr addr) = Ptr addr
+
+plusPtr :: Ptr a -> Int -> Ptr b
+plusPtr (Ptr addr) (I# d) = Ptr (int2Addr# (addr2Int# addr +# d))
+
+alignPtr :: Ptr a -> Int -> Ptr a
+alignPtr addr@(Ptr a) (I# i)
+ = case addr2Int# a of { ai ->
+ case remInt# ai i of {
+ 0# -> addr;
+ n -> Ptr (int2Addr# (ai +# (i -# n))) }}
+
+minusPtr :: Ptr a -> Ptr b -> Int
+minusPtr (Ptr a1) (Ptr a2) = I# (addr2Int# a1 -# addr2Int# a2)
+
+instance CCallable (Ptr a)
+instance CReturnable (Ptr a)
+
+------------------------------------------------------------------------
+-- Function pointers for the default calling convention.
+
+newtype FunPtr a = FunPtr (Ptr a) deriving (Eq, Ord)
+
+nullFunPtr :: FunPtr a
+nullFunPtr = FunPtr nullPtr
+
+castFunPtr :: FunPtr a -> FunPtr b
+castFunPtr (FunPtr a) = FunPtr (castPtr a)
+
+castFunPtrToPtr :: FunPtr a -> Ptr b
+castFunPtrToPtr (FunPtr a) = castPtr a
+
+castPtrToFunPtr :: Ptr a -> FunPtr b
+castPtrToFunPtr a = FunPtr (castPtr a)
+
+instance CCallable (FunPtr a)
+instance CReturnable (FunPtr a)
+\end{code}
--- /dev/null
+% -----------------------------------------------------------------------------
+% $Id: PrelStorable.lhs,v 1.1 2001/01/11 17:25:57 simonmar Exp $
+%
+% (c) The FFI task force, 2000
+%
+
+A class for primitive marshaling
+
+\begin{code}
+#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 ()
+ ) where
+\end{code}
+
+\begin{code}
+import Char ( chr, ord )
+import Monad ( liftM )
+
+#ifdef __GLASGOW_HASKELL__
+import PrelStable ( StablePtr )
+import PrelInt
+import PrelWord
+import PrelCTypes
+import PrelCTypesISO
+import PrelStable
+import PrelPtr
+import PrelFloat
+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 ()
+
+ -- 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
+\end{code}
+
+System-dependent, but rather obvious instances
+
+\begin{code}
+instance Storable Char where
+ sizeOf _ = sizeOf (undefined::Word32)
+ alignment _ = alignment (undefined::Word32)
+ peekElemOff p i = liftM (chr . fromIntegral) $ peekElemOff (castPtr p::Ptr Word32) i
+ pokeElemOff p i x = pokeElemOff (castPtr p::Ptr Word32) i (fromIntegral (ord x))
+
+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)
+
+instance Storable (FunPtr a) where
+ sizeOf (FunPtr x) = sizeOf x
+ alignment (FunPtr x) = alignment x
+ peekElemOff p i = liftM FunPtr $ peekElemOff (castPtr p) i
+ pokeElemOff p i (FunPtr x) = pokeElemOff (castPtr p) i x
+
+#define STORABLE(T,size,align,read,write) \
+instance Storable (T) where { \
+ sizeOf _ = size; \
+ alignment _ = align; \
+ peekElemOff a i = read a i; \
+ pokeElemOff a i x = write a i x }
+
+STORABLE(Int,SIZEOF_INT,ALIGNMENT_INT,
+ readIntOffPtr,writeIntOffPtr)
+
+STORABLE((Ptr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
+ readPtrOffPtr,writePtrOffPtr)
+
+STORABLE((StablePtr a),SIZEOF_VOID_P,ALIGNMENT_VOID_P,
+ readStablePtrOffPtr,writeStablePtrOffPtr)
+
+STORABLE(Float,SIZEOF_FLOAT,ALIGNMENT_FLOAT,
+ readFloatOffPtr,writeFloatOffPtr)
+
+STORABLE(Double,SIZEOF_DOUBLE,ALIGNMENT_DOUBLE,
+ 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(CPtrdiff)
+NSTORABLE(CSize)
+NSTORABLE(CWchar)
+NSTORABLE(CSigAtomic)
+NSTORABLE(CClock)
+NSTORABLE(CTime)
+\end{code}
+
+Helper functions
+
+\begin{code}
+#ifdef __GLASGOW_HASKELL__
+
+readIntOffPtr :: Ptr Int -> Int -> IO Int
+readPtrOffPtr :: Ptr (Ptr a) -> Int -> IO (Ptr 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
+
+readIntOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readIntOffAddr# a i s of { (# s,x #) -> (# s, I# x #) }
+readPtrOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readAddrOffAddr# a i s of { (# s,x #) -> (# s, Ptr x #) }
+readFloatOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readFloatOffAddr# a i s of { (# s,x #) -> (# s, F# x #) }
+readDoubleOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readDoubleOffAddr# a i s of { (# s,x #) -> (# s, D# x #) }
+readStablePtrOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readStablePtrOffAddr# a i s of { (# s,x #) -> (# s, StablePtr x #) }
+
+readInt8OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt8OffAddr# a i s of (# s, w #) -> (# s, I8# w #)
+
+readInt16OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt16OffAddr# a i s of (# s, w #) -> (# s, I16# w #)
+
+readInt32OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt32OffAddr# a i s of (# s, w #) -> (# s, I32# w #)
+
+#if WORD_SIZE_IN_BYTES == 8
+readInt64OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readIntOffAddr# a i s of (# s, w #) -> (# s, I64# w #)
+#else
+readInt64OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readInt64OffAddr# a i s of (# s, w #) -> (# s, I64# w #)
+#endif
+
+
+writeIntOffPtr :: Ptr Int -> Int -> Int -> IO ()
+writePtrOffPtr :: Ptr (Ptr a) -> Int -> Ptr 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 ()
+
+writeIntOffPtr (Ptr a#) (I# i#) (I# e#) = IO $ \ s# ->
+ case (writeIntOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
+
+writePtrOffPtr (Ptr a#) (I# i#) (Ptr e#) = IO $ \ s# ->
+ case (writeAddrOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
+
+writeFloatOffPtr (Ptr a#) (I# i#) (F# e#) = IO $ \ s# ->
+ case (writeFloatOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
+
+writeDoubleOffPtr (Ptr a#) (I# i#) (D# e#) = IO $ \ s# ->
+ case (writeDoubleOffAddr# a# i# e# s#) of s2# -> (# s2#, () #)
+
+writeStablePtrOffPtr (Ptr a#) (I# i#) (StablePtr e#) = IO $ \ s# ->
+ case (writeStablePtrOffAddr# a# i# e# s#) of s2# -> (# s2# , () #)
+
+writeInt8OffPtr (Ptr a#) (I# i#) (I8# w#) = IO $ \ s# ->
+ case (writeInt8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+writeInt16OffPtr (Ptr a#) (I# i#) (I16# w#) = IO $ \ s# ->
+ case (writeInt16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+writeInt32OffPtr (Ptr a#) (I# i#) (I32# w#) = IO $ \ s# ->
+ case (writeInt32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+#if WORD_SIZE_IN_BYTES == 8
+writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
+ case (writeIntOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+#else
+writeInt64OffPtr (Ptr a#) (I# i#) (I64# w#) = IO $ \ s# ->
+ case (writeInt64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+#endif
+
+readWord8OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #)
+
+readWord16OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #)
+
+readWord32OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #)
+
+#if WORD_SIZE_IN_BYTES == 8
+readWord64OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #)
+#else
+readWord64OffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #)
+#endif
+
+writeWord8OffPtr (Ptr a#) (I# i#) (W8# w#) = IO $ \ s# ->
+ case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+writeWord16OffPtr (Ptr a#) (I# i#) (W16# w#) = IO $ \ s# ->
+ case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+writeWord32OffPtr (Ptr a#) (I# i#) (W32# w#) = IO $ \ s# ->
+ case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+
+#if WORD_SIZE_IN_BYTES == 8
+writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
+ case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+#else
+writeWord64OffPtr (Ptr a#) (I# i#) (W64# w#) = IO $ \ s# ->
+ case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
+#endif
+
+#endif /* __GLASGOW_HASKELL__ */
+\end{code}
% ------------------------------------------------------------------------------
-% $Id: PrelWeak.lhs,v 1.14 2001/01/03 14:47:18 simonmar Exp $
+% $Id: PrelWeak.lhs,v 1.15 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1998-2000
%
import PrelGHC
import PrelBase
import PrelMaybe
--- NOTE: To break a cycle, ForeignObj is not in PrelForeign, but PrelIOBase!
-import PrelIOBase ( IO(..), unIO, ForeignObj(..) )
+import PrelIOBase ( IO(..), unIO )
#ifndef __PARALLEL_HASKELL__
mkWeakPtr key (Just finalizer) -- throw it away
return ()
-addForeignFinalizer :: ForeignObj -> IO () -> IO ()
-addForeignFinalizer (ForeignObj fo) finalizer
- = IO $ \s -> case mkWeak# fo () finalizer s of { (# s1, w #) -> (# s1, () #) }
-
{-
Instance Eq (Weak v) where
(Weak w1) == (Weak w2) = w1 `sameWeak#` w2
#include "MachDeps.h"
module PrelWord (
- Word8(..), Word16(..), Word32(..), Word64(..),
+ Word(..), Word8(..), Word16(..), Word32(..), Word64(..),
-- SUP: deprecated in the new FFI, subsumed by fromIntegral
, intToWord8 -- :: Int -> Word8
, word64ToWord16 -- :: Word64 -> Word16
, word64ToWord32 -- :: Word64 -> Word32
- -- NB! GHC SPECIFIC:
- , wordToWord8 -- :: Word -> Word8
- , wordToWord16 -- :: Word -> Word16
- , wordToWord32 -- :: Word -> Word32
- , wordToWord64 -- :: Word -> Word64
-
- , word8ToWord -- :: Word8 -> Word
- , word16ToWord -- :: Word16 -> Word
- , word32ToWord -- :: Word32 -> Word
- , word64ToWord -- :: Word64 -> Word
-
- -- The "official" place to get these from is Addr.
- -- SUP: deprecated in the new FFI, subsumed by the Storable class
- , indexWord8OffAddr
- , indexWord16OffAddr
- , indexWord32OffAddr
- , indexWord64OffAddr
-
- , readWord8OffAddr
- , readWord16OffAddr
- , readWord32OffAddr
- , readWord64OffAddr
-
- , writeWord8OffAddr
- , writeWord16OffAddr
- , writeWord32OffAddr
- , writeWord64OffAddr
-
-- internal stuff
- , wordToInt
, wordToWord8#, wordToWord16#, wordToWord32#, wordToWord64#
, word64ToInt64#, int64ToWord64#
, toEnumError, fromEnumError, succError, predError, divZeroError
) where
-import Numeric ( showInt )
-
import PrelArr
+import PrelBits
import PrelRead
-import PrelIOBase
import PrelEnum
-import PrelAddr
import PrelReal
import PrelNum
import PrelBase
-- ---------------------------------------------------------------------------
+-- The Word Type
+-- ---------------------------------------------------------------------------
+
+-- A Word is an unsigned integral type, with the same number of bits as Int.
+data Word = W# Word# deriving (Eq, Ord)
+
+instance CCallable Word
+instance CReturnable Word
+
+-- ---------------------------------------------------------------------------
-- Coercion functions (DEPRECATED)
-- ---------------------------------------------------------------------------
word64ToWord16 :: Word64 -> Word16
word64ToWord32 :: Word64 -> Word32
-wordToWord8 :: Word -> Word8
-wordToWord16 :: Word -> Word16
-wordToWord32 :: Word -> Word32
-wordToWord64 :: Word -> Word64
-
-word8ToWord :: Word8 -> Word
-word16ToWord :: Word16 -> Word
-word32ToWord :: Word32 -> Word
-word64ToWord :: Word64 -> Word
-
intToWord8 = word32ToWord8 . intToWord32
intToWord16 = word32ToWord16 . intToWord32
word32ToInt (W32# x) = I# (word2Int# x)
+word2Integer :: Word# -> Integer
+word2Integer w | i >=# 0# = S# i
+ | otherwise = case word2Integer# w of
+ (# s, d #) -> J# s d
+ where i = word2Int# w
+
word32ToInteger (W32# x) = word2Integer x
integerToWord32 = fromInteger
readsPrec _ = readDec
instance Show Word8 where
- showsPrec _ = showInt
-\end{code}
+ showsPrec p w8 = showsPrec p (word8ToInt w8)
+
+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#` int2Word# 0xff#)
+ shift (W8# x#) i@(I# i#)
+ | i > 0 = W8# (wordToWord8# (shiftL# x# i#))
+ | otherwise = W8# (wordToWord8# (shiftRL# x# (negateInt# i#)))
+ w@(W8# x) `rotate` (I# i)
+ | i ==# 0# = w
+ | i ># 0# = W8# ((wordToWord8# (shiftL# x i')) `or#`
+ (shiftRL# (x `and#`
+ (int2Word# (0x100# -# pow2# i2)))
+ i2))
+ | otherwise = rotate w (I# (8# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 7#)
+ i2 = 8# -# i'
+
+ bit (I# i#)
+ | i# >=# 0# && i# <=# 7# = W8# (wordToWord8# (shiftL# (int2Word# 1#) i#))
+ | otherwise = 0 -- We'll be overbearing, for now..
+
+ testBit (W8# x#) (I# i#)
+ | i# <# 8# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
+ | otherwise = False -- for now, this is really an error.
+
+ bitSize _ = 8
+ isSigned _ = False
+
+pow2# :: Int# -> Int#
+pow2# x# = word2Int# (shiftL# (int2Word# 1#) x#)
+
+pow2_64# :: Int# -> Int64#
+pow2_64# x# = word64ToInt64# (shiftL64# (wordToWord64# (int2Word# 1#)) x#)
-\subsection[Word16]{The @Word16@ interface}
+-- ---------------------------------------------------------------------------
+-- Word16
+-- ---------------------------------------------------------------------------
-The double byte type @Word16@ is represented in the Haskell
-heap by boxing up a machine word, @Word#@. An invariant
-for this representation is that only the lower 16 bits are
-`active', any bits above are {\em always} zeroed out.
-A consequence of this is that operations that could possibly
-overflow have to mask out anything above the lower two bytes
-before putting together the resulting @Word16@.
+-- The double byte type @Word16@ is represented in the Haskell
+-- heap by boxing up a machine word, @Word#@. An invariant
+-- for this representation is that only the lower 16 bits are
+-- `active', any bits above are {\em always} zeroed out.
+-- A consequence of this is that operations that could possibly
+-- overflow have to mask out anything above the lower two bytes
+-- before putting together the resulting @Word16@.
-\begin{code}
data Word16 = W16# Word#
instance CCallable Word16
readsPrec _ = readDec
instance Show Word16 where
- showsPrec _ = showInt
-\end{code}
+ showsPrec p w16 = showsPrec p (word16ToInt w16)
+
+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#` int2Word# 0xffff#)
+ shift (W16# x#) i@(I# i#)
+ | i > 0 = W16# (wordToWord16# (shiftL# x# i#))
+ | otherwise = W16# (shiftRL# x# (negateInt# i#))
+ w@(W16# x) `rotate` (I# i)
+ | i ==# 0# = w
+ | i ># 0# = W16# ((wordToWord16# (shiftL# x i')) `or#`
+ (shiftRL# (x `and#`
+ (int2Word# (0x10000# -# pow2# i2)))
+ i2))
+ | otherwise = rotate w (I# (16# +# i'))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 15#)
+ i2 = 16# -# i'
+ bit (I# i#)
+ | i# >=# 0# && i# <=# 15# = W16# (shiftL# (int2Word# 1#) i#)
+ | otherwise = 0 -- We'll be overbearing, for now..
+
+ testBit (W16# x#) (I# i#)
+ | i# <# 16# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
+ | otherwise = False -- for now, this is really an error.
+
+ bitSize _ = 16
+ isSigned _ = False
-\subsection[Word32]{The @Word32@ interface}
+-- ---------------------------------------------------------------------------
+-- Word32
+-- ---------------------------------------------------------------------------
-The quad byte type @Word32@ is represented in the Haskell
-heap by boxing up a machine word, @Word#@. An invariant
-for this representation is that any bits above the lower
-32 are {\em always} zeroed out. A consequence of this is that
-operations that could possibly overflow have to mask
-the result before building the resulting @Word16@.
+-- The quad byte type @Word32@ is represented in the Haskell
+-- heap by boxing up a machine word, @Word#@. An invariant
+-- for this representation is that any bits above the lower
+-- 32 are {\em always} zeroed out. A consequence of this is that
+-- operations that could possibly overflow have to mask
+-- the result before building the resulting @Word16@.
-\begin{code}
data Word32 = W32# Word#
instance CCallable Word32
readsPrec _ = readDec
instance Show Word32 where
- showsPrec _ = showInt
+ showsPrec p w = showsPrec p (word32ToInteger w)
+
+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
+ shift (W32# x) i@(I# i#)
+ | i > 0 = W32# (wordToWord32# (shiftL# x i#))
+ | otherwise = W32# (shiftRL# x (negateInt# i#))
+ w@(W32# x) `rotate` (I# i)
+ | i ==# 0# = w
+ | i ># 0# = W32# ((wordToWord32# (shiftL# x i')) `or#`
+ (shiftRL# (x `and#`
+ (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#)))
+ i2))
+ | otherwise = rotate w (I# (32# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 31#)
+ i2 = 32# -# i'
+ (W32# maxBound#) = maxBound
+
+ bit (I# i#)
+ | i# >=# 0# && i# <=# 31# = W32# (shiftL# (int2Word# 1#) i#)
+ | otherwise = 0 -- We'll be overbearing, for now..
+
+ testBit (W32# x#) (I# i#)
+ | i# <# 32# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
+ | otherwise = False -- for now, this is really an error.
+ bitSize _ = 32
+ isSigned _ = False
-- -----------------------------------------------------------------------------
-- Word64
-- -----------------------------------------------------------------------------
#if WORD_SIZE_IN_BYTES == 8
---data Word64 = W64# Word#
+data Word64 = W64# Word#
word32ToWord64 (W32 w#) = W64# w#
#else /* WORD_SIZE_IN_BYTES < 8 */
---defined in PrelCCall: data Word64 = W64 Word64# deriving (Eq, Ord, Bounded)
+data Word64 = W64# Word64#
-- for completeness sake
word32ToWord64 (W32# w#) = W64# (wordToWord64# w#)
-- Word64# primop wrappers:
ltWord64# :: Word64# -> Word64# -> Bool
-ltWord64# x# y# = stg_ltWord64 x# y# /= 0
+ltWord64# x# y# = stg_ltWord64 x# y# /=# 0#
leWord64# :: Word64# -> Word64# -> Bool
-leWord64# x# y# = stg_leWord64 x# y# /= 0
+leWord64# x# y# = stg_leWord64 x# y# /=# 0#
eqWord64# :: Word64# -> Word64# -> Bool
-eqWord64# x# y# = stg_eqWord64 x# y# /= 0
+eqWord64# x# y# = stg_eqWord64 x# y# /=# 0#
neWord64# :: Word64# -> Word64# -> Bool
-neWord64# x# y# = stg_neWord64 x# y# /= 0
+neWord64# x# y# = stg_neWord64 x# y# /=# 0#
geWord64# :: Word64# -> Word64# -> Bool
-geWord64# x# y# = stg_geWord64 x# y# /= 0
+geWord64# x# y# = stg_geWord64 x# y# /=# 0#
gtWord64# :: Word64# -> Word64# -> Bool
-gtWord64# x# y# = stg_gtWord64 x# y# /= 0
-
-plusInt64# :: Int64# -> Int64# -> Int64#
-plusInt64# a# b# = case stg_plusInt64 a# b# of { I64# i# -> i# }
-
-minusInt64# :: Int64# -> Int64# -> Int64#
-minusInt64# a# b# = case stg_minusInt64 a# b# of { I64# i# -> i# }
-
-timesInt64# :: Int64# -> Int64# -> Int64#
-timesInt64# a# b# = case stg_timesInt64 a# b# of { I64# i# -> i# }
-
-quotWord64# :: Word64# -> Word64# -> Word64#
-quotWord64# a# b# = case stg_quotWord64 a# b# of { W64# w# -> w# }
-
-remWord64# :: Word64# -> Word64# -> Word64#
-remWord64# a# b# = case stg_remWord64 a# b# of { W64# w# -> w# }
-
-negateInt64# :: Int64# -> Int64#
-negateInt64# a# = case stg_negateInt64 a# of { I64# i# -> i# }
-
-word64ToWord# :: Word64# -> Word#
-word64ToWord# w64# = case stg_word64ToWord w64# of { W# w# -> w# }
-
-wordToWord64# :: Word# -> Word64#
-wordToWord64# w# = case stg_wordToWord64 w# of { W64# w64# -> w64# }
-
-word64ToInt64# :: Word64# -> Int64#
-word64ToInt64# w64# = case stg_word64ToInt64 w64# of { I64# i# -> i# }
-
-int64ToWord64# :: Int64# -> Word64#
-int64ToWord64# i64# = case stg_int64ToWord64 i64# of { W64# w# -> w# }
-
-intToInt64# :: Int# -> Int64#
-intToInt64# i# = case stg_intToInt64 i# of { I64# i64# -> i64# }
-
-foreign import "stg_intToInt64" unsafe stg_intToInt64 :: Int# -> Int64
-foreign import "stg_int64ToWord64" unsafe stg_int64ToWord64 :: Int64# -> Word64
-foreign import "stg_word64ToInt64" unsafe stg_word64ToInt64 :: Word64# -> Int64
-foreign import "stg_wordToWord64" unsafe stg_wordToWord64 :: Word# -> Word64
-foreign import "stg_word64ToWord" unsafe stg_word64ToWord :: Word64# -> Word
-foreign import "stg_negateInt64" unsafe stg_negateInt64 :: Int64# -> Int64
-foreign import "stg_remWord64" unsafe stg_remWord64 :: Word64# -> Word64# -> Word64
-foreign import "stg_quotWord64" unsafe stg_quotWord64 :: Word64# -> Word64# -> Word64
-foreign import "stg_timesInt64" unsafe stg_timesInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_minusInt64" unsafe stg_minusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_plusInt64" unsafe stg_plusInt64 :: Int64# -> Int64# -> Int64
-foreign import "stg_gtWord64" unsafe stg_gtWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_geWord64" unsafe stg_geWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_neWord64" unsafe stg_neWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_eqWord64" unsafe stg_eqWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_leWord64" unsafe stg_leWord64 :: Word64# -> Word64# -> Int
-foreign import "stg_ltWord64" unsafe stg_ltWord64 :: Word64# -> Word64# -> Int
+gtWord64# x# y# = stg_gtWord64 x# y# /=# 0#
+
+foreign import "stg_intToInt64" unsafe intToInt64# :: Int# -> Int64#
+foreign import "stg_int64ToWord64" unsafe int64ToWord64# :: Int64# -> Word64#
+foreign import "stg_word64ToInt64" unsafe word64ToInt64# :: Word64# -> Int64#
+foreign import "stg_wordToWord64" unsafe wordToWord64# :: Word# -> Word64#
+foreign import "stg_word64ToWord" unsafe word64ToWord# :: Word64# -> Word#
+foreign import "stg_negateInt64" unsafe negateInt64# :: Int64# -> Int64#
+foreign import "stg_remWord64" unsafe remWord64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_quotWord64" unsafe quotWord64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_timesInt64" unsafe timesInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_minusInt64" unsafe minusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_plusInt64" unsafe plusInt64# :: Int64# -> Int64# -> Int64#
+foreign import "stg_gtWord64" unsafe stg_gtWord64 :: Word64# -> Word64# -> Int#
+foreign import "stg_geWord64" unsafe stg_geWord64 :: Word64# -> Word64# -> Int#
+foreign import "stg_neWord64" unsafe stg_neWord64 :: Word64# -> Word64# -> Int#
+foreign import "stg_eqWord64" unsafe stg_eqWord64 :: Word64# -> Word64# -> Int#
+foreign import "stg_leWord64" unsafe stg_leWord64 :: Word64# -> Word64# -> Int#
+foreign import "stg_ltWord64" unsafe stg_ltWord64 :: Word64# -> Word64# -> Int#
#endif
+instance CCallable Word64
+instance CReturnable Word64
+
instance Enum Word64 where
succ w
| w == maxBound = succError "Word64"
instance Real Word64 where
toRational x = toInteger x % 1
--- -----------------------------------------------------------------------------
--- Reading/writing words to/from memory
--- -----------------------------------------------------------------------------
-
-indexWord8OffAddr :: Addr -> Int -> Word8
-indexWord8OffAddr (A# a#) (I# i#) = W8# (indexWord8OffAddr# a# i#)
-
-indexWord16OffAddr :: Addr -> Int -> Word16
-indexWord16OffAddr (A# a#) (I# i#) = W16# (indexWord16OffAddr# a# i#)
-
-indexWord32OffAddr :: Addr -> Int -> Word32
-indexWord32OffAddr (A# a#) (I# i#) = W32# (indexWord32OffAddr# a# i#)
-
-indexWord64OffAddr :: Addr -> Int -> Word64
-#if WORD_SIZE_IN_BYTES == 8
-indexWord64OffAddr (A# a#) (I# i#) = W64# (indexWordOffAddr# a# i#)
-#else
-indexWord64OffAddr (A# a#) (I# i#) = W64# (indexWord64OffAddr# a# i#)
-#endif
-
-
-readWord8OffAddr :: Addr -> Int -> IO Word8
-readWord8OffAddr (A# a) (I# i)
- = IO $ \s -> case readWord8OffAddr# a i s of (# s, w #) -> (# s, W8# w #)
-
-readWord16OffAddr :: Addr -> Int -> IO Word16
-readWord16OffAddr (A# a) (I# i)
- = IO $ \s -> case readWord16OffAddr# a i s of (# s, w #) -> (# s, W16# w #)
-
-readWord32OffAddr :: Addr -> Int -> IO Word32
-readWord32OffAddr (A# a) (I# i)
- = IO $ \s -> case readWord32OffAddr# a i s of (# s, w #) -> (# s, W32# w #)
-
-readWord64OffAddr :: Addr -> Int -> IO Word64
-#if WORD_SIZE_IN_BYTES == 8
-readWord64OffAddr (A# a) (I# i)
- = IO $ \s -> case readWordOffAddr# a i s of (# s, w #) -> (# s, W64# w #)
-#else
-readWord64OffAddr (A# a) (I# i)
- = IO $ \s -> case readWord64OffAddr# a i s of (# s, w #) -> (# s, W64# w #)
-#endif
-
-
-writeWord8OffAddr :: Addr -> Int -> Word8 -> IO ()
-writeWord8OffAddr (A# a#) (I# i#) (W8# w#) = IO $ \ s# ->
- case (writeWord8OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-
-writeWord16OffAddr :: Addr -> Int -> Word16 -> IO ()
-writeWord16OffAddr (A# a#) (I# i#) (W16# w#) = IO $ \ s# ->
- case (writeWord16OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-
-writeWord32OffAddr :: Addr -> Int -> Word32 -> IO ()
-writeWord32OffAddr (A# a#) (I# i#) (W32# w#) = IO $ \ s# ->
- case (writeWord32OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-
-writeWord64OffAddr :: Addr -> Int -> Word64 -> IO ()
#if WORD_SIZE_IN_BYTES == 8
-writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWordOffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-#else
-writeWord64OffAddr (A# a#) (I# i#) (W64# w#) = IO $ \ s# ->
- case (writeWord64OffAddr# a# i# w# s#) of s2# -> (# s2#, () #)
-#endif
-\end{code}
-
-The Hugs-GHC extension libraries provide functions for going between
-Int and the various (un)signed ints. Here we provide the same for
-the GHC specific Word type:
-\begin{code}
-word8ToWord (W8# w#) = W# w#
-wordToWord8 (W# w#) = W8# (w# `and#` (case (maxBound::Word8) of W8# x# -> x#))
-
-word16ToWord (W16# w#) = W# w#
-wordToWord16 (W# w#) = W16# (w# `and#` (case (maxBound::Word16) of W16# x# -> x#))
-
-word32ToWord (W32# w#) = W# w#
-wordToWord32 (W# w#) = W32# (w# `and#` (case (maxBound::Word32) of W32# x# -> 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#` (case (maxBound::Word64) of W64# x# -> x#))
+ shift (W64# x#) i@(I# i#)
+ | i > 0 = W64# (shiftL# x# i#)
+ | otherwise = W64# (shiftRL# x# (negateInt# i#))
+
+ w@(W64# x) `rotate` (I# i)
+ | i ==# 0# = w
+ | i ># 0# = W64# (shiftL# x i') `or#`
+ (shiftRL# (x `and#`
+ (int2Word# (word2Int# maxBound# -# pow2# i2 +# 1#)))
+ i2))
+ | otherwise = rotate w (I# (64# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 63#)
+ i2 = 64# -# i'
+ (W64# maxBound#) = maxBound
+
+ bit (I# i#)
+ | i# >=# 0# && i# <=# 63# = W64# (shiftL# (int2Word# 1#) i#)
+ | otherwise = 0 -- We'll be overbearing, for now..
+
+ testBit (W64# x#) (I# i#)
+ | i# <# 64# && i# >=# 0# = (word2Int# (x# `and#` (shiftL# (int2Word# 1#) i#))) /=# 0#
+ | otherwise = False -- for now, this is really an error.
+
+ bitSize _ = 64
+ isSigned _ = False
-wordToWord64 (W# w#) = W64# (wordToWord64# w#)
--- lossy on 32-bit platforms, but provided nontheless.
-word64ToWord (W64# w#) = W# (word64ToWord# w#)
+#else /* WORD_SIZE_IN_BYTES < 8 */
-word2Integer :: Word# -> Integer
-word2Integer w | i >=# 0# = S# i
- | otherwise = case word2Integer# w of
- (# s, d #) -> J# s d
- where i = word2Int# w
+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# (x `xor64#` (case (maxBound::Word64) of W64# x# -> x#))
+ shift (W64# x#) i@(I# i#)
+ | i > 0 = W64# (shiftL64# x# i#)
+ | otherwise = W64# (shiftRL64# x# (negateInt# i#))
+
+ w@(W64# x) `rotate` (I# i)
+ | i ==# 0# = w
+ | i ># 0# = W64# ((shiftL64# x i') `or64#`
+ (shiftRL64# (x `and64#`
+ (int64ToWord64# ((word64ToInt64# maxBound#) `minusInt64#`
+ (pow2_64# i2 `plusInt64#` (intToInt64# 1#))))))
+ i2)
+ | otherwise = rotate w (I# (64# +# i))
+ where
+ i' = word2Int# (int2Word# i `and#` int2Word# 63#)
+ i2 = 64# -# i'
+ (W64# maxBound#) = maxBound
+
+ bit (I# i#)
+ | i# >=# 0# && i# <=# 63# = W64# (shiftL64# (wordToWord64# (int2Word# 1#)) i#)
+ | otherwise = 0 -- We'll be overbearing, for now..
+
+ testBit (W64# x#) (I# i#)
+ | i# <# 64# && i# >=# 0# = (word2Int# (word64ToWord# (x# `and64#` (shiftL64# (wordToWord64# (int2Word# 1#)) i#)))) /=# 0#
+ | otherwise = False -- for now, this is really an error.
+
+ bitSize _ = 64
+ isSigned _ = False
+
+foreign import "stg_not64" unsafe not64# :: Word64# -> Word64#
+foreign import "stg_xor64" unsafe xor64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_or64" unsafe or64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_and64" unsafe and64# :: Word64# -> Word64# -> Word64#
+foreign import "stg_shiftRL64" unsafe shiftRL64# :: Word64# -> Int# -> Word64#
+foreign import "stg_shiftL64" unsafe shiftL64# :: Word64# -> Int# -> Word64#
+
+#endif /* WORD_SIZE_IN_BYTES < 8 */
\end{code}
Misc utils.
% -----------------------------------------------------------------------------
-% $Id: System.lhs,v 1.27 2001/01/11 07:04:16 qrczak Exp $
+% $Id: System.lhs,v 1.28 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2000
%
) where
\end{code}
-
-#ifndef __HUGS__
\begin{code}
+import Monad
import Prelude
-import PrelAddr
+import PrelCString
+import PrelCTypes
+import PrelMarshalArray
+import PrelPtr
+import PrelStorable
import PrelIOBase ( IOException(..), ioException,
- IOErrorType(..), constructErrorAndFailWithInfo, stToIO )
-import PrelPack ( unpackCString, unpackCStringST, packString )
+ IOErrorType(..), constructErrorAndFailWithInfo )
import PrelByteArr ( ByteArray )
-
-type PrimByteArray = ByteArray Int
-
-primUnpackCString :: Addr -> IO String
-primUnpackCString s = stToIO ( unpackCStringST s )
-
-primPackString :: String -> PrimByteArray
-primPackString s = packString s
-
\end{code}
%*********************************************************
line arguments (not including the program name).
\begin{code}
-getArgs :: IO [String]
-getArgs = return (unpackArgv primArgv primArgc)
+getArgs :: IO [String]
+getArgs = unpackArgv primArgv primArgc
-foreign import ccall "libHS_cbits.so" "get_prog_argv" unsafe primArgv :: Addr
-foreign import ccall "libHS_cbits.so" "get_prog_argc" unsafe primArgc :: Int
+foreign import ccall "get_prog_argv" unsafe primArgv :: Ptr (Ptr CChar)
+foreign import ccall "get_prog_argc" unsafe primArgc :: Int
\end{code}
Computation $getProgName$ returns the name of the program
as it was invoked.
\begin{code}
-getProgName :: IO String
-getProgName = return (unpackProgName primArgv)
+getProgName :: IO String
+getProgName = unpackProgName primArgv
\end{code}
Computation $getEnv var$ returns the value
\end{itemize}
\begin{code}
-getEnv :: String -> IO String
-getEnv name = do
- litstring <- primGetEnv (primPackString name)
- if litstring /= nullAddr
- then primUnpackCString litstring
+getEnv :: String -> IO String
+getEnv name =
+ withUnsafeCString 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 "libHS_cbits.so" "getenv" unsafe primGetEnv :: PrimByteArray -> IO Addr
+foreign import ccall "getenv" unsafe _getenv :: UnsafeCString -> IO (Ptr CChar)
\end{code}
Computation $system cmd$ returns the exit code
\begin{code}
system :: String -> IO ExitCode
system "" = ioException (IOError Nothing InvalidArgument "system" "null command" Nothing)
-system cmd = do
- status <- primSystem (primPackString cmd)
+system cmd =
+ withUnsafeCString cmd $ \s -> do
+ status <- primSystem s
case status of
0 -> return ExitSuccess
-1 -> constructErrorAndFailWithInfo "system" cmd
n -> return (ExitFailure n)
-foreign import ccall "libHS_cbits.so" "systemCmd" unsafe primSystem :: PrimByteArray -> IO Int
+foreign import ccall "systemCmd" unsafe primSystem :: UnsafeCString -> IO Int
\end{code}
@exitWith code@ terminates the program, returning {\em code} to the program's caller.
%*********************************************************
\begin{code}
-type CHAR_STAR_STAR = Addr -- this is all a HACK
-type CHAR_STAR = Addr
-
-unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
-unpackArgv argv argc = unpack 1
- where
- unpack :: Int -> [String]
- unpack n
- | n >= argc = []
- | otherwise =
- case (indexAddrOffAddr argv n) of
- item -> unpackCString item : unpack (n + 1)
+unpackArgv :: Ptr (Ptr CChar) -> Int -> IO [String] -- argv[1 .. argc-1]
+unpackArgv argv argc = peekArray argc argv >>= mapM peekCString
-unpackProgName :: CHAR_STAR_STAR -> String -- argv[0]
-unpackProgName argv
- = case (indexAddrOffAddr argv 0) of { prog ->
- de_slash [] (unpackCString prog) }
+unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0]
+unpackProgName argv = do
+ s <- peekElemOff argv 0 >>= peekCString
+ return (de_slash "" s)
where
-- re-start accumulating at every '/'
de_slash :: String -> String -> String
de_slash _acc ('/':xs) = de_slash [] xs
de_slash acc (x:xs) = de_slash (x:acc) xs
\end{code}
-
-#else
-
-\begin{code}
------------------------------------------------------------------------------
--- Standard Library: System operations
---
--- Warning: the implementation of these functions in Hugs 98 is very weak.
--- The functions themselves are best suited to uses in compiled programs,
--- and not to use in an interpreter-based environment like Hugs.
---
--- Suitable for use with Hugs 98
------------------------------------------------------------------------------
-import PrelPrim ( primGetRawArgs
- , primGetEnv
- , prelCleanupAfterRunAction
- , copy_String_to_cstring
- , readIORef
- , nh_stderr
- , nh_stdout
- , nh_stdin
- , nh_exitwith
- , nh_flush
- , nh_close
- , nh_system
- , nh_free
- , nh_getPID
- )
-
-
-data ExitCode = ExitSuccess | ExitFailure Int
- deriving (Eq, Ord, Read, Show)
-
-getArgs :: IO [String]
-getArgs = primGetRawArgs >>= \rawargs ->
- return (tail rawargs)
-
-getProgName :: IO String
-getProgName = primGetRawArgs >>= \rawargs ->
- return (head rawargs)
-
-getEnv :: String -> IO String
-getEnv = primGetEnv
-
-exitFailure :: IO a
-exitFailure = exitWith (ExitFailure 1)
-
-toExitCode :: Int -> ExitCode
-toExitCode 0 = ExitSuccess
-toExitCode n = ExitFailure n
-
-fromExitCode :: ExitCode -> Int
-fromExitCode ExitSuccess = 0
-fromExitCode (ExitFailure n) = n
-
--- see comment in Prelude.hs near primRunIO_hugs_toplevel
-exitWith :: ExitCode -> IO a
-exitWith c
- = do cleanup_action <- readIORef prelCleanupAfterRunAction
- case cleanup_action of
- Just xx -> xx
- Nothing -> return ()
- nh_stderr >>= nh_flush
- nh_stdout >>= nh_flush
- nh_stdin >>= nh_close
- nh_exitwith (fromExitCode c)
- (ioException . IOError) "System.exitWith: should not return"
-
-system :: String -> IO ExitCode
-system cmd
- | null cmd
- = (ioException.IOError) "System.system: null command"
- | otherwise
- = do str <- copy_String_to_cstring cmd
- status <- nh_system str
- nh_free str
- case status of
- 0 -> return ExitSuccess
- n -> return (ExitFailure n)
-
-getPID :: IO Int
-getPID
- = nh_getPID
-
------------------------------------------------------------------------------
-\end{code}
-#endif
% ------------------------------------------------------------------------------
-% $Id: Time.lhs,v 1.24 2000/12/12 12:19:58 simonmar Exp $
+% $Id: Time.lhs,v 1.25 2001/01/11 17:25:57 simonmar Exp $
%
% (c) The University of Glasgow, 1995-2000
%
)
import PrelByteArr ( MutableByteArray(..), wORD_SCALE )
import PrelHandle ( Bytes )
-import PrelAddr ( Addr )
+import PrelPtr
#endif
#ifdef __HUGS__
foreign import "libHS_cbits" "prim_toLocalTime" unsafe prim_toLocalTime :: Int64 -> MBytes -> IO Int
foreign import "libHS_cbits" "prim_toUTCTime" unsafe prim_toUTCTime :: Int64 -> MBytes -> IO Int
-foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO Addr
+foreign import "libHS_cbits" "prim_ZONE" unsafe prim_ZONE :: Bytes -> IO (Ptr ())
foreign import "libHS_cbits" "prim_GMTOFF" unsafe prim_GMTOFF :: Bytes -> IO Int
#else
foreign import "libHS_cbits" "toLocalTime" unsafe prim_toLocalTime :: Int -> Bytes -> MBytes -> IO Int
foreign import "libHS_cbits" "toUTCTime" unsafe prim_toUTCTime :: Int -> Bytes -> MBytes -> IO Int
#endif
-foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO Addr
+foreign import "libHS_cbits" "get_ZONE" unsafe get_ZONE :: MBytes -> IO (Ptr ())
foreign import "libHS_cbits" "GMTOFF" unsafe get_GMTOFF :: MBytes -> IO Int
--- /dev/null
+/* -----------------------------------------------------------------------------
+ * $Id: CTypes.h,v 1.1 2001/01/11 17:25:58 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_STORABLE(T) \
+instance Storable T where { \
+ sizeOf (T x) = sizeOf x ; \
+ alignment (T x) = alignment x ; \
+ peekElemOff a i = liftM T (peekElemOff a i) ; \
+ pokeElemOff a i (T x) = pokeElemOff a i x }
+
+#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 ; \
+ toInt (T i) = toInt 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__ */
+
+/* On GHC, we just cast the type of each method to the underlying
+ * type. This means that GHC only needs to generate the dictionary
+ * for each instance, rather than a new function for each method (the
+ * simplifier currently isn't clever enough to reduce a method that
+ * simply deconstructs a newtype and calls the underlying method into
+ * an indirection to the underlying method, so that's what we're doing
+ * here).
+ */
+
+#define NUMERIC_TYPE(T,C,S,B) \
+newtype T = T B ; \
+INSTANCE_EQ(T,B) ; \
+INSTANCE_ORD(T,B) ; \
+INSTANCE_NUM(T,B) ; \
+INSTANCE_READ(T,B) ; \
+INSTANCE_SHOW(T,B) ; \
+INSTANCE_ENUM(T,B)
+
+#define INTEGRAL_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_BOUNDED(T,B) ; \
+INSTANCE_REAL(T,B) ; \
+INSTANCE_INTEGRAL(T,B) ; \
+INSTANCE_BITS(T,B)
+
+#define FLOATING_TYPE(T,C,S,B) \
+NUMERIC_TYPE(T,C,S,B) ; \
+INSTANCE_REAL(T,B) ; \
+INSTANCE_FRACTIONAL(T,B) ; \
+INSTANCE_FLOATING(T,B) ; \
+INSTANCE_REALFRAC(T) ; \
+INSTANCE_REALFLOAT(T,B)
+
+#define INSTANCE_EQ(T,B) \
+instance Eq T where { \
+ (==) = unsafeCoerce# ((==) :: B -> B -> Bool); \
+ (/=) = unsafeCoerce# ((/=) :: B -> B -> Bool); }
+
+#define INSTANCE_ORD(T,B) \
+instance Ord T where { \
+ compare = unsafeCoerce# (compare :: B -> B -> Ordering); \
+ (<) = unsafeCoerce# ((<) :: B -> B -> Bool); \
+ (<=) = unsafeCoerce# ((<=) :: B -> B -> Bool); \
+ (>=) = unsafeCoerce# ((>=) :: B -> B -> Bool); \
+ (>) = unsafeCoerce# ((>) :: B -> B -> Bool); \
+ max = unsafeCoerce# (max :: B -> B -> B); \
+ min = unsafeCoerce# (min :: B -> B -> 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); }
+
+#define INSTANCE_NUM(T,B) \
+instance Num T where { \
+ (+) = unsafeCoerce# ((+) :: B -> B -> B); \
+ (-) = unsafeCoerce# ((-) :: B -> B -> B); \
+ (*) = unsafeCoerce# ((*) :: B -> B -> B); \
+ negate = unsafeCoerce# (negate :: B -> B); \
+ abs = unsafeCoerce# (abs :: B -> B); \
+ signum = unsafeCoerce# (signum :: B -> B); \
+ fromInteger = unsafeCoerce# (fromInteger :: Integer -> B); \
+ fromInt = unsafeCoerce# (fromInt :: Int -> B) }
+
+#define INSTANCE_STORABLE(T,B) \
+instance Storable T where { \
+ sizeOf = unsafeCoerce# (sizeOf :: B -> Int); \
+ alignment = unsafeCoerce# (alignment :: B -> Int); \
+ peekElemOff = unsafeCoerce# (peekElemOff :: Ptr B -> Int -> IO B); \
+ pokeElemOff = unsafeCoerce# (pokeElemOff :: Ptr B -> Int -> B -> IO B); }
+
+#define INSTANCE_BOUNDED(T,B) \
+instance Bounded T where { \
+ minBound = T minBound ; \
+ maxBound = T maxBound }
+
+#define INSTANCE_ENUM(T,B) \
+instance Enum T where { \
+ succ = unsafeCoerce# (succ :: B -> B); \
+ pred = unsafeCoerce# (pred :: B -> B); \
+ toEnum = unsafeCoerce# (toEnum :: Int -> B); \
+ fromEnum = unsafeCoerce# (fromEnum :: B -> Int); \
+ enumFrom = unsafeCoerce# (enumFrom :: B -> [B]); \
+ enumFromThen = unsafeCoerce# (enumFromThen :: B -> B -> [B]); \
+ enumFromTo = unsafeCoerce# (enumFromTo :: B -> B -> [B]); \
+ enumFromThenTo = unsafeCoerce# (enumFromThenTo :: B -> B -> B -> [B]);}
+
+#define INSTANCE_REAL(T,B) \
+instance Real T where { \
+ toRational = unsafeCoerce# (toRational :: B -> Rational) }
+
+#define INSTANCE_INTEGRAL(T,B) \
+instance Integral T where { \
+ quot = unsafeCoerce# (quot:: B -> B -> B); \
+ rem = unsafeCoerce# (rem:: B -> B -> B); \
+ div = unsafeCoerce# (div:: B -> B -> B); \
+ mod = unsafeCoerce# (mod:: B -> B -> B); \
+ quotRem = unsafeCoerce# (quotRem:: B -> B -> (B,B)); \
+ divMod = unsafeCoerce# (divMod:: B -> B -> (B,B)); \
+ toInteger = unsafeCoerce# (toInteger:: B -> Integer); \
+ toInt = unsafeCoerce# (toInt:: B -> Int); }
+
+#define INSTANCE_BITS(T,B) \
+instance Bits T where { \
+ (.&.) = unsafeCoerce# ((.&.) :: B -> B -> B); \
+ (.|.) = unsafeCoerce# ((.|.) :: B -> B -> B); \
+ xor = unsafeCoerce# (xor:: B -> B -> B); \
+ complement = unsafeCoerce# (complement:: B -> B); \
+ shift = unsafeCoerce# (shift:: B -> Int -> B); \
+ rotate = unsafeCoerce# (rotate:: B -> Int -> B); \
+ bit = unsafeCoerce# (bit:: Int -> B); \
+ setBit = unsafeCoerce# (setBit:: B -> Int -> B); \
+ clearBit = unsafeCoerce# (clearBit:: B -> Int -> B); \
+ complementBit = unsafeCoerce# (complementBit:: B -> Int -> B); \
+ testBit = unsafeCoerce# (testBit:: B -> Int -> Bool); \
+ bitSize = unsafeCoerce# (bitSize:: B -> Int); \
+ isSigned = unsafeCoerce# (isSigned:: B -> Bool); }
+
+#define INSTANCE_FRACTIONAL(T,B) \
+instance Fractional T where { \
+ (/) = unsafeCoerce# ((/) :: B -> B -> B); \
+ recip = unsafeCoerce# (recip :: B -> B); \
+ fromRational = unsafeCoerce# (fromRational :: Rational -> B); }
+
+#define INSTANCE_FLOATING(T,B) \
+instance Floating T where { \
+ pi = unsafeCoerce# (pi :: B); \
+ exp = unsafeCoerce# (exp :: B -> B); \
+ log = unsafeCoerce# (log :: B -> B); \
+ sqrt = unsafeCoerce# (sqrt :: B -> B); \
+ (**) = unsafeCoerce# ((**) :: B -> B -> B); \
+ logBase = unsafeCoerce# (logBase :: B -> B -> B); \
+ sin = unsafeCoerce# (sin :: B -> B); \
+ cos = unsafeCoerce# (cos :: B -> B); \
+ tan = unsafeCoerce# (tan :: B -> B); \
+ asin = unsafeCoerce# (asin :: B -> B); \
+ acos = unsafeCoerce# (acos :: B -> B); \
+ atan = unsafeCoerce# (atan :: B -> B); \
+ sinh = unsafeCoerce# (sinh :: B -> B); \
+ cosh = unsafeCoerce# (cosh :: B -> B); \
+ tanh = unsafeCoerce# (tanh :: B -> B); \
+ asinh = unsafeCoerce# (asinh :: B -> B); \
+ acosh = unsafeCoerce# (acosh :: B -> B); \
+ atanh = unsafeCoerce# (atanh :: B -> B); }
+
+/* The coerce trick doesn't work for RealFrac, these methods are
+ * polymorphic and overloaded.
+ */
+#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,B) \
+instance RealFloat T where { \
+ floatRadix = unsafeCoerce# (floatRadix :: B -> Integer); \
+ floatDigits = unsafeCoerce# (floatDigits :: B -> Int); \
+ floatRange = unsafeCoerce# (floatRange :: B -> (Int,Int)); \
+ decodeFloat = unsafeCoerce# (decodeFloat :: B -> (Integer,Int)); \
+ encodeFloat = unsafeCoerce# (encodeFloat :: Integer -> Int -> B); \
+ exponent = unsafeCoerce# (exponent :: B -> Int); \
+ significand = unsafeCoerce# (significand :: B -> B); \
+ scaleFloat = unsafeCoerce# (scaleFloat :: Int -> B -> B); \
+ isNaN = unsafeCoerce# (isNaN :: B -> Bool); \
+ isInfinite = unsafeCoerce# (isInfinite :: B -> Bool); \
+ isDenormalized = unsafeCoerce# (isDenormalized :: B -> Bool); \
+ isNegativeZero = unsafeCoerce# (isNegativeZero :: B -> Bool); \
+ isIEEE = unsafeCoerce# (isIEEE :: B -> Bool); \
+ atan2 = unsafeCoerce# (atan2 :: B -> B -> B); }
+
+#endif /* __GLASGOW_HASKELL__ */
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: createDirectory.c,v 1.4 1999/03/01 09:03:37 sof Exp $
- *
- * createDirectory Runtime Support}
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#if defined(mingw32_TARGET_OS)
-#define mkDir(nm,p) mkdir(nm)
-#else
-#define mkDir(nm,p) mkdir(nm,p)
-#endif
-
-StgInt
-createDirectory(path)
-StgByteArray path;
-{
- int rc;
- struct stat sb;
-
- while((rc = mkDir(path, 0777)) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOENT:
- case GHC_ENOTDIR:
- ghc_errtype = ERR_NOSUCHTHING;
- ghc_errstr = "no path to directory";
- break;
- case GHC_EEXIST:
- if (stat(path, &sb) != 0) {
- ghc_errtype = ERR_OTHERERROR;
- ghc_errstr = "cannot stat existing file";
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_ALREADYEXISTS;
- ghc_errstr = "directory already exists";
- } else {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file already exists";
- }
- break;
- }
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1998
- *
- * $Id: directoryAux.c,v 1.3 2000/08/24 10:27:01 simonmar Exp $
- *
- * Support functions for manipulating directories
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_DIRENT_H
-#include <dirent.h>
-#endif
-
-StgAddr
-openDir__(StgByteArray path)
-{
- struct stat sb;
- DIR *dir;
-
- /* Check for an actual directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return NULL;
- }
-
- while ((dir = opendir(path)) == NULL) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- return dir;
-}
-
-StgAddr
-readDir__(StgAddr dir)
-
-{
- struct dirent *d;
- while ((d = readdir((DIR*)dir)) == NULL) {
- if (errno == 0) {
- (void) closedir((DIR*)dir);
- return NULL;
- } else if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- (void) closedir((DIR*)dir);
- return NULL;
- }
- errno = 0;
- }
- return d;
-}
-
-StgAddr
-get_dirent_d_name(StgAddr d)
-{
- return ((struct dirent*)d)->d_name;
-}
-
-StgInt sizeof_stat( void ) { return sizeof(struct stat); }
-
-StgInt prim_stat(StgAddr x, StgAddr y)
-{
- return stat((char*)x, (struct stat*)y);
-}
-
-
-StgWord
-get_stat_st_mode (StgAddr x)
-{
- return ((struct stat *)x)->st_mode;
-}
-
-
-StgInt64
-get_stat_st_mtime(StgAddr x)
-{
- return ((struct stat *)x)->st_mtime;
-}
-
-void
-set_stat_st_mtime(StgByteArray p, StgByteArray x)
-{
- ((unsigned long *)p)[0] = ((struct stat *)x)->st_mtime;
- return;
-}
-
-StgWord const_S_IRUSR( void ) { return S_IRUSR; }
-StgWord const_S_IWUSR( void ) { return S_IWUSR; }
-StgWord const_S_IXUSR( void ) { return S_IXUSR; }
-
-StgInt
-prim_S_ISDIR( StgWord x )
-{
- return S_ISDIR(x);
-}
-
-StgInt
-prim_S_ISREG( StgWord x )
-{
- return S_ISREG(x);
-}
-
-
-StgWord const_R_OK( void ) { return R_OK; }
-StgWord const_W_OK( void ) { return W_OK; }
-StgWord const_X_OK( void ) { return X_OK; }
-StgWord const_F_OK( void ) { return F_OK; }
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: getCurrentDirectory.c,v 1.3 1998/12/02 13:27:39 simonm Exp $
- *
- * getCurrentDirectory Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifndef PATH_MAX
-#ifdef MAXPATHLEN
-#define PATH_MAX MAXPATHLEN
-#else
-#define PATH_MAX 1024
-#endif
-#endif
-
-StgAddr
-getCurrentDirectory(void)
-{
- char *pwd;
- int alloc;
-
- alloc = PATH_MAX;
- if ((pwd = malloc(alloc)) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- return NULL;
- }
- while (getcwd(pwd, alloc) == NULL) {
- if (errno == ERANGE) {
- alloc += PATH_MAX;
- if ((pwd = realloc(pwd, alloc)) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- return NULL;
- }
- } else if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- return (StgAddr) pwd;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: getDirectoryContents.c,v 1.3 1998/12/02 13:27:40 simonm Exp $
- *
- * getDirectoryContents Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_DIRENT_H
-#include <dirent.h>
-#endif
-
-#ifndef LINK_MAX
-#define LINK_MAX 1024
-#endif
-
-/* For cleanup of partial answer on error */
-
-static void
-freeEntries(char **entries, int count)
-{
- int i;
-
- for (i = 0; i < count; i++)
- free(entries[i]);
- free(entries);
-}
-
-/*
- * Our caller expects a malloc'ed array of malloc'ed string pointers.
- * To ensure consistency when mixing this with other directory
- * operations, we collect the entire list in one atomic operation,
- * rather than reading the directory lazily.
- */
-StgAddr
-getDirectoryContents(path)
-StgByteArray path;
-{
- struct stat sb;
- DIR *dir;
- struct dirent *d;
- char **entries;
- int alloc, count, len;
-
- /* Check for an actual directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return NULL;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return NULL;
- }
-
- alloc = LINK_MAX;
- if ((entries = (char **) malloc(alloc * sizeof(char *))) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- return NULL;
- }
-
- while ((dir = opendir(path)) == NULL) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- free(entries);
- return NULL;
- }
- }
-
- count = 0;
- for (;;) {
- errno = 0; /* unchanged by readdir on EOF */
- while ((d = readdir(dir)) == NULL) {
- if (errno == 0) {
- entries[count] = NULL;
- (void) closedir(dir);
- return (StgAddr) entries;
- } else if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- freeEntries(entries, count);
- (void) closedir(dir);
- return NULL;
- }
- errno = 0;
- }
- len = strlen(d->d_name);
- if ((entries[count] = malloc(len+1)) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- freeEntries(entries, count);
- (void) closedir(dir);
- return NULL;
- }
- strcpy(entries[count], d->d_name);
- /* Terminate the sucker */
- *(entries[count] + len) = 0;
- if (++count == alloc) {
- alloc += LINK_MAX;
- if ((entries = (char **) realloc(entries, alloc * sizeof(char *))) == NULL) {
- ghc_errtype = ERR_RESOURCEEXHAUSTED;
- ghc_errstr = "not enough virtual memory";
- freeEntries(entries, count);
- (void) closedir(dir);
- return NULL;
- }
- }
- }
-}
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: progargs.c,v 1.3 2000/03/14 01:52:25 sof Exp $
+ * $Id: progargs.c,v 1.4 2001/01/11 17:25:58 simonmar Exp $
*
* System.getArgs Runtime Support
*/
#include "Rts.h"
#include "stgio.h"
-StgAddr
+HsAddr
get_prog_argv(void)
{
return prog_argv;
}
-StgInt
+HsInt
get_prog_argc()
{
return prog_argc;
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: removeDirectory.c,v 1.3 1998/12/02 13:27:47 simonm Exp $
- *
- * removeDirectory Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-removeDirectory(path)
-StgByteArray path;
-{
- struct stat sb;
-
- /* Check for an actual directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return -1;
- }
- while (rmdir(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- switch (ghc_errno) {
- default:
- stdErrno();
- break;
- case GHC_ENOTEMPTY:
- case GHC_EEXIST:
- ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS;
- ghc_errstr = "directory not empty";
- break;
- }
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: removeFile.c,v 1.4 2000/04/06 10:33:07 rrt Exp $
- *
- * removeFile Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-removeFile(StgByteArray path)
-{
- struct stat sb;
-
- /* Check for a non-directory */
- while (stat(path, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- return -1;
- }
- while (unlink(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: renameDirectory.c,v 1.3 1998/12/02 13:27:50 simonm Exp $
- *
- * renameDirectory Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-StgInt
-renameDirectory(opath, npath)
-StgByteArray opath;
-StgByteArray npath;
-{
- struct stat sb;
-
- /* Check for an actual directory */
- while (stat(opath, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (!S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "not a directory";
- return -1;
- }
- while(rename(opath, npath) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: renameFile.c,v 1.8 2000/04/06 10:33:06 rrt Exp $
- *
- * renameFile Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-#ifdef HAVE_SYS_TYPES_H
-#include <sys/types.h>
-#endif
-
-#ifdef HAVE_SYS_STAT_H
-#include <sys/stat.h>
-#endif
-
-#ifdef HAVE_FCNTL_H
-#include <fcntl.h>
-#endif
-
-
-StgInt
-renameFile(StgByteArray opath, StgByteArray npath)
-{
- struct stat sb;
-
- /* Check for a non-directory source */
- while (stat(opath, &sb) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- return -1;
- }
-
- /* Check for a non-directory destination */
- while (stat(npath, &sb) != 0 && errno != ENOENT) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- if (errno != ENOENT) {
- if (S_ISDIR(sb.st_mode)) {
- ghc_errtype = ERR_INAPPROPRIATETYPE;
- ghc_errstr = "file is a directory";
- return -1;
- }
- while (chmod(npath, S_IWUSR) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- while (unlink(npath) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- }
-
- while(rename(opath, npath) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
-
- return 0;
-}
+++ /dev/null
-/*
- * (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
- *
- * $Id: setCurrentDirectory.c,v 1.3 1998/12/02 13:27:56 simonm Exp $
- *
- * setCurrentDirectory Runtime Support
- */
-
-#include "Rts.h"
-#include "stgio.h"
-
-StgInt
-setCurrentDirectory(path)
-StgByteArray path;
-{
- while (chdir(path) != 0) {
- if (errno != EINTR) {
- cvtErrno();
- stdErrno();
- return -1;
- }
- }
- return 0;
-}
/* -----------------------------------------------------------------------------
- * $Id: Prelude.h,v 1.12 2000/07/07 11:03:57 simonmar Exp $
+ * $Id: Prelude.h,v 1.13 2001/01/11 17:25:56 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2001
*
* Prelude identifiers that we sometimes need to refer to in the RTS.
*
#define PRELUDE_H
/* Define canonical names so we can abstract away from the actual
- * module these names are defined in.
+ * modules these names are defined in.
*/
#ifndef INTERPRETER
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 PrelAddr_Azh_static_info;
-extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_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 PrelAddr_Azh_con_info;
-extern DLL_IMPORT const StgInfoTable PrelAddr_Wzh_con_info;
-extern DLL_IMPORT const StgInfoTable PrelAddr_I64zh_con_info;
-extern DLL_IMPORT const StgInfoTable PrelAddr_W64zh_con_info;
+extern DLL_IMPORT const StgInfoTable PrelPtr_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;
#define NonTermination_closure (&PrelIOBase_NonTermination_closure)
#define Czh_static_info (&PrelBase_Czh_static_info)
-#define Izh_static_info (&PrelBase_Izh_static_info)
#define Fzh_static_info (&PrelFloat_Fzh_static_info)
#define Dzh_static_info (&PrelFloat_Dzh_static_info)
-#define Azh_static_info (&PrelAddr_Azh_static_info)
-#define Wzh_static_info (&PrelAddr_Wzh_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 Azh_con_info (&PrelAddr_Azh_con_info)
-#define Wzh_con_info (&PrelAddr_Wzh_con_info)
-#define W64zh_con_info (&PrelAddr_W64zh_con_info)
-#define I64zh_con_info (&PrelAddr_I64zh_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)
/* ----------------------------------------------------------------------------
- * $Id: RtsAPI.c,v 1.23 2000/12/04 12:31:21 simonmar Exp $
+ * $Id: RtsAPI.c,v 1.24 2001/01/11 17:25:56 simonmar Exp $
*
- * (c) The GHC Team, 1998-2000
+ * (c) The GHC Team, 1998-2001
*
* API for invoking Haskell functions via the RTS
*
rts_mkInt8 (HsInt8 i)
{
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- /* This is a 'cheat', using the static info table for Ints,
- instead of the one for Int8, but the types have identical
- representation.
- */
- p->header.info = Izh_con_info;
+ p->header.info = I8zh_con_info;
/* Make sure we mask out the bits above the lowest 8 */
p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xff);
return p;
rts_mkInt16 (HsInt16 i)
{
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- /* This is a 'cheat', using the static info table for Ints,
- instead of the one for Int8, but the types have identical
- representation.
- */
- p->header.info = Izh_con_info;
+ p->header.info = I16zh_con_info;
/* Make sure we mask out the relevant bits */
p->payload[0] = (StgClosure *)(StgInt)((unsigned)i & 0xffff);
return p;
rts_mkInt32 (HsInt32 i)
{
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- /* see mk_Int8 comment */
- p->header.info = Izh_con_info;
+ p->header.info = I32zh_con_info;
p->payload[0] = (StgClosure *)(StgInt)i;
return p;
}
{
long long *tmp;
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,2));
- /* see mk_Int8 comment */
p->header.info = I64zh_con_info;
tmp = (long long*)&(p->payload[0]);
*tmp = (StgInt64)i;
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- p->header.info = Wzh_con_info;
+ p->header.info = W8zh_con_info;
p->payload[0] = (StgClosure *)(StgWord)(w & 0xff);
return p;
}
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- p->header.info = Wzh_con_info;
+ p->header.info = W16zh_con_info;
p->payload[0] = (StgClosure *)(StgWord)(w & 0xffff);
return p;
}
{
/* see rts_mkInt* comments */
StgClosure *p = (StgClosure *)allocate(CONSTR_sizeW(0,1));
- p->header.info = Wzh_con_info;
+ p->header.info = W32zh_con_info;
p->payload[0] = (StgClosure *)(StgWord)w;
return p;
}
}
HaskellObj
-rts_mkAddr (HsAddr a)
+rts_mkPtr (HsPtr a)
{
StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
- p->header.info = Azh_con_info;
+ p->header.info = Ptr_con_info;
p->payload[0] = (StgClosure *)a;
return p;
}
HaskellObj
rts_mkString (char *s)
{
- return rts_apply((StgClosure *)unpackCString_closure, rts_mkAddr(s));
+ return rts_apply((StgClosure *)unpackCString_closure, rts_mkPtr(s));
}
#endif /* COMPILER */
rts_getInt32 (HaskellObj p)
{
if ( 1 ||
- p->header.info == Izh_con_info ||
- p->header.info == Izh_static_info ) {
+ p->header.info == I32zh_con_info ||
+ p->header.info == I32zh_static_info ) {
return (int)(p->payload[0]);
} else {
barf("getInt: not an Int");
rts_getWord32 (HaskellObj p)
{
if ( 1 || /* see above comment */
- p->header.info == Wzh_con_info ||
- p->header.info == Wzh_static_info ) {
+ p->header.info == W32zh_con_info ||
+ p->header.info == W32zh_static_info ) {
return (unsigned int)(p->payload[0]);
} else {
barf("getWord: not a Word");
}
}
-HsAddr
-rts_getAddr (HaskellObj p)
+HsPtr
+rts_getPtr (HaskellObj p)
{
- if ( p->header.info == Azh_con_info ||
- p->header.info == Azh_static_info ) {
-
+ if ( p->header.info == Ptr_con_info ||
+ p->header.info == Ptr_static_info ) {
return (void *)(p->payload[0]);
} else {
- barf("getAddr: not an Addr");
+ barf("getPtr: not an Ptr");
}
}
--- /dev/null
+/* ----------------------------------------------------------------------------
+ * $Id: RtsAPIDeprec.c,v 1.1 2001/01/11 17:25:56 simonmar Exp $
+ *
+ * (c) The GHC Team, 1998-2001
+ *
+ * RTS API functions that are deprecated
+ *
+ * --------------------------------------------------------------------------*/
+
+#include "Rts.h"
+#include "RtsUtils.h"
+#include "Storage.h"
+#include "Prelude.h"
+
+HaskellObj
+rts_mkAddr (HsAddr a)
+{
+ StgClosure *p = (StgClosure *)allocate(sizeofW(StgHeader)+1);
+ p->header.info = Azh_con_info;
+ p->payload[0] = (StgClosure *)a;
+ return p;
+}
+
+HsAddr
+rts_getAddr (HaskellObj p)
+{
+ if ( p->header.info == Azh_con_info ||
+ p->header.info == Azh_static_info ) {
+
+ return (void *)(p->payload[0]);
+ } else {
+ barf("getAddr: not an Addr");
+ }
+}
projects / ghc-hetmet.git / commitdiff