diff options
Diffstat (limited to 'ghc/lib/std')
80 files changed, 13448 insertions, 0 deletions
diff --git a/ghc/lib/std/Array.lhs b/ghc/lib/std/Array.lhs new file mode 100644 index 0000000000..390c481b8f --- /dev/null +++ b/ghc/lib/std/Array.lhs @@ -0,0 +1,99 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[Array]{Module @Array@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Array ( + module Ix, -- export all of Ix + Array, -- Array type is abstract + + array, listArray, (!), bounds, indices, elems, assocs, + accumArray, (//), accum, ixmap + ) where + +import Ix +import PrelList +import PrelRead +import PrelArr -- Most of the hard work is done here +import PrelBase + +infixl 9 !, // +\end{code} + + + +%********************************************************* +%* * +\subsection{Definitions of array, !, bounds} +%* * +%********************************************************* + +\begin{code} + +#ifdef USE_FOLDR_BUILD +{-# INLINE indices #-} +{-# INLINE elems #-} +{-# INLINE assocs #-} +#endif + +{-# GENERATE_SPECS listArray a{~,Int,IPr} b{} #-} +listArray :: (Ix a) => (a,a) -> [b] -> Array a b +listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs) + +{-# GENERATE_SPECS indices a{~,Int,IPr} b{} #-} +indices :: (Ix a) => Array a b -> [a] +indices = range . bounds + +{-# GENERATE_SPECS elems a{~,Int,IPr} b{} #-} +elems :: (Ix a) => Array a b -> [b] +elems a = [a!i | i <- indices a] + +{-# GENERATE_SPECS assocs a{~,Int,IPr} b{} #-} +assocs :: (Ix a) => Array a b -> [(a,b)] +assocs a = [(i, a!i) | i <- indices a] + +{-# GENERATE_SPECS amap a{~,Int,IPr} b{} c{} #-} +amap :: (Ix a) => (b -> c) -> Array a b -> Array a c +amap f a = array b [(i, f (a!i)) | i <- range b] + where b = bounds a + +ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c +ixmap b f a = array b [(i, a ! f i) | i <- range b] +\end{code} + + +%********************************************************* +%* * +\subsection{Instance declarations for Array type} +%* * +%********************************************************* + +\begin{code} +instance Ix a => Functor (Array a) where + map = amap + +instance (Ix a, Eq b) => Eq (Array a b) where + a == a' = assocs a == assocs a' + a /= a' = assocs a /= assocs a' + +instance (Ix a, Ord b) => Ord (Array a b) where + compare a b = compare (assocs a) (assocs b) + +instance (Ix a, Show a, Show b) => Show (Array a b) where + showsPrec p a = showParen (p > 9) ( + showString "array " . + shows (bounds a) . showChar ' ' . + shows (assocs a) ) + showList = showList__ (showsPrec 0) + +instance (Ix a, Read a, Read b) => Read (Array a b) where + readsPrec p = readParen (p > 9) + (\r -> [(array b as, u) | ("array",s) <- lex r, + (b,t) <- reads s, + (as,u) <- reads t ]) + readList = readList__ (readsPrec 0) +\end{code} diff --git a/ghc/lib/std/CPUTime.lhs b/ghc/lib/std/CPUTime.lhs new file mode 100644 index 0000000000..e0532cc5b4 --- /dev/null +++ b/ghc/lib/std/CPUTime.lhs @@ -0,0 +1,58 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-1997 +% +\section[CPUTime]{Haskell 1.4 CPU Time Library} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module CPUTime + ( + getCPUTime, -- :: IO Integer + cpuTimePrecision -- :: Integer + ) where + +import PrelBase +import PrelArr ( ByteArray(..), newIntArray, unsafeFreezeByteArray ) +import PrelMaybe +import PrelNum +import PrelAddr +import PrelIOBase +import IO +import PrelUnsafe ( unsafePerformIO ) +import PrelST +import Ratio + +\end{code} + +Computation @getCPUTime@ returns the number of picoseconds CPU time +used by the current program. The precision of this result is +implementation-dependent. + +The @cpuTimePrecision@ constant is the resolution (in picoseconds!) of +the number of + +\begin{code} +getCPUTime :: IO Integer +getCPUTime = + stToIO (newIntArray (0,3)) >>= \ marr -> + stToIO (unsafeFreezeByteArray marr) >>= \ barr@(ByteArray _ frozen#) -> + _ccall_ getCPUTime barr >>= \ ptr -> + if (ptr::Addr) /= ``NULL'' then + return ((fromIntegral (I# (indexIntArray# frozen# 0#)) * 1000000000 + + fromIntegral (I# (indexIntArray# frozen# 1#)) + + fromIntegral (I# (indexIntArray# frozen# 2#)) * 1000000000 + + fromIntegral (I# (indexIntArray# frozen# 3#))) * 1000) + else + fail (IOError Nothing UnsupportedOperation + "getCPUTime: can't get CPU time") + +cpuTimePrecision :: Integer +cpuTimePrecision = round ((1000000000000::Integer) % + fromInt (unsafePerformIO (_ccall_ clockTicks ))) +\end{code} + + + + + diff --git a/ghc/lib/std/Char.lhs b/ghc/lib/std/Char.lhs new file mode 100644 index 0000000000..ce77c98b7c --- /dev/null +++ b/ghc/lib/std/Char.lhs @@ -0,0 +1,45 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[Char]{Module @Char@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Char + ( + isAscii, isLatin1, isControl, + isPrint, isSpace, isUpper, + isLower, isAlpha, isDigit, + isOctDigit, isHexDigit, isAlphanum, -- :: Char -> Bool + + toUpper, toLower, -- :: Char -> Char + + digitToInt, -- :: Char -> Int + intToDigit, -- :: Int -> Char + + ord, -- :: Char -> Int + chr, -- :: Int -> Char + readLitChar, -- :: ReadS Char + showLitChar -- :: Char -> ShowS + ) where + +import PrelBase +import PrelRead (readLitChar) +import PrelErr ( error ) + +\end{code} + +\begin{code} +-- Digit conversion operations + +digitToInt :: Char -> Int +digitToInt c + | isDigit c = fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10 + | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10 + | otherwise = error "Char.digitToInt: not a digit" -- sigh + + +\end{code} diff --git a/ghc/lib/std/Complex.lhs b/ghc/lib/std/Complex.lhs new file mode 100644 index 0000000000..573beb77d0 --- /dev/null +++ b/ghc/lib/std/Complex.lhs @@ -0,0 +1,130 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1997 +% + +\section[Complex]{Module @Complex@} + +\begin{code} +module Complex ( + Complex((:+)), + + realPart, imagPart, conjugate, mkPolar, + cis, polar, magnitude, phase + ) where + +import Prelude + +infix 6 :+ +\end{code} + +%********************************************************* +%* * +\subsection{The @Complex@ type} +%* * +%********************************************************* + +\begin{code} +data (RealFloat a) => Complex a = !a :+ !a deriving (Eq,Read,Show) +\end{code} + + +%********************************************************* +%* * +\subsection{Functions over @Complex@} +%* * +%********************************************************* + +\begin{code} +realPart, imagPart :: (RealFloat a) => Complex a -> a +realPart (x:+y) = x +imagPart (x:+y) = y + +conjugate :: (RealFloat a) => Complex a -> Complex a +conjugate (x:+y) = x :+ (-y) + +mkPolar :: (RealFloat a) => a -> a -> Complex a +mkPolar r theta = r * cos theta :+ r * sin theta + +cis :: (RealFloat a) => a -> Complex a +cis theta = cos theta :+ sin theta + +polar :: (RealFloat a) => Complex a -> (a,a) +polar z = (magnitude z, phase z) + +magnitude, phase :: (RealFloat a) => Complex a -> a +magnitude (x:+y) = scaleFloat k + (sqrt ((scaleFloat mk x)^2 + (scaleFloat mk y)^2)) + where k = max (exponent x) (exponent y) + mk = - k + +phase (0 :+ 0) = 0 -- SLPJ July 97 from John Peterson +phase (x:+y) = atan2 y x +\end{code} + + +%********************************************************* +%* * +\subsection{Instances of @Complex@} +%* * +%********************************************************* + +\begin{code} +instance (RealFloat a) => Num (Complex a) where + (x:+y) + (x':+y') = (x+x') :+ (y+y') + (x:+y) - (x':+y') = (x-x') :+ (y-y') + (x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x') + negate (x:+y) = negate x :+ negate y + abs z = magnitude z :+ 0 + signum 0 = 0 + signum z@(x:+y) = x/r :+ y/r where r = magnitude z + fromInteger n = fromInteger n :+ 0 + +instance (RealFloat a) => Fractional (Complex a) where + (x:+y) / (x':+y') = (x*x''+y*y'') / d :+ (y*x''-x*y'') / d + where x'' = scaleFloat k x' + y'' = scaleFloat k y' + k = - max (exponent x') (exponent y') + d = x'*x'' + y'*y'' + + fromRational a = fromRational a :+ 0 + +instance (RealFloat a) => Floating (Complex a) where + pi = pi :+ 0 + exp (x:+y) = expx * cos y :+ expx * sin y + where expx = exp x + log z = log (magnitude z) :+ phase z + + sqrt 0 = 0 + sqrt z@(x:+y) = u :+ (if y < 0 then -v else v) + where (u,v) = if x < 0 then (v',u') else (u',v') + v' = abs y / (u'*2) + u' = sqrt ((magnitude z + abs x) / 2) + + sin (x:+y) = sin x * cosh y :+ cos x * sinh y + cos (x:+y) = cos x * cosh y :+ (- sin x * sinh y) + tan (x:+y) = (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy)) + where sinx = sin x + cosx = cos x + sinhy = sinh y + coshy = cosh y + + sinh (x:+y) = cos y * sinh x :+ sin y * cosh x + cosh (x:+y) = cos y * cosh x :+ sin y * sinh x + tanh (x:+y) = (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx) + where siny = sin y + cosy = cos y + sinhx = sinh x + coshx = cosh x + + asin z@(x:+y) = y':+(-x') + where (x':+y') = log (((-y):+x) + sqrt (1 - z*z)) + acos z@(x:+y) = y'':+(-x'') + where (x'':+y'') = log (z + ((-y'):+x')) + (x':+y') = sqrt (1 - z*z) + atan z@(x:+y) = y':+(-x') + where (x':+y') = log (((1-y):+x) / sqrt (1+z*z)) + + asinh z = log (z + sqrt (1+z*z)) + acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1))) + atanh z = log ((1+z) / sqrt (1-z*z)) +\end{code} diff --git a/ghc/lib/std/Directory.lhs b/ghc/lib/std/Directory.lhs new file mode 100644 index 0000000000..14be0e4b6d --- /dev/null +++ b/ghc/lib/std/Directory.lhs @@ -0,0 +1,548 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1997 +% +\section[Directory]{Directory interface} + +A directory contains a series of entries, each of which is a named +reference to a file system object (file, directory etc.). Some +entries may be hidden, inaccessible, or have some administrative +function (e.g. "." or ".." under POSIX), but in this standard all such +entries are considered to form part of the directory contents. +Entries in sub-directories are not, however, considered to form part +of the directory contents. + +Each file system object is referenced by a {\em path}. There is +normally at least one absolute path to each file system object. In +some operating systems, it may also be possible to have paths which +are relative to the current directory. + +\begin{code} +{-# OPTIONS -#include <sys/stat.h> #-} +module Directory + ( + Permissions(Permissions), + + createDirectory, + removeDirectory, + renameDirectory, + getDirectoryContents, + getCurrentDirectory, + setCurrentDirectory, + + removeFile, + renameFile, + + doesFileExist, + doesDirectoryExist, + getPermissions, + setPermissions, + getModificationTime + ) where + +import PrelBase +import PrelIOBase +import PrelST +import PrelUnsafe ( unsafePerformIO ) +import PrelArr +import PrelPack ( unpackNBytesST ) +import PrelForeign ( Word(..) ) +import PrelAddr +import Time ( ClockTime(..) ) + +\end{code} + +%********************************************************* +%* * +\subsection{Signatures} +%* * +%********************************************************* + +\begin{code} +createDirectory :: FilePath -> IO () +removeDirectory :: FilePath -> IO () +removeFile :: FilePath -> IO () +renameDirectory :: FilePath -> FilePath -> IO () +renameFile :: FilePath -> FilePath -> IO () +getDirectoryContents :: FilePath -> IO [FilePath] +getCurrentDirectory :: IO FilePath +setCurrentDirectory :: FilePath -> IO () +doesFileExist :: FilePath -> IO Bool +doesDirectoryExist :: FilePath -> IO Bool +getPermissions :: FilePath -> IO Permissions +setPermissions :: FilePath -> Permissions -> IO () +getModificationTime :: FilePath -> IO ClockTime +\end{code} + + +%********************************************************* +%* * +\subsection{Permissions} +%* * +%********************************************************* + +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, writeable, + executable, searchable :: Bool + } deriving (Eq, Ord, Read, Show) +\end{code} + +%********************************************************* +%* * +\subsection{Implementation} +%* * +%********************************************************* + +@createDirectory dir@ creates a new directory {\em dir} which is +initially empty, or as near to empty as the operating system +allows. + +The operation may fail with: + +\begin{itemize} +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES]@ +\item @isAlreadyExistsError@ / @AlreadyExists@ +The operand refers to a directory that already exists. +@ [EEXIST]@ +\item @HardwareFault@ +A physical I/O error has occurred. +@ [EIO]@ +\item @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ +\item @NoSuchThing@ +There is no path to the directory. +@[ENOENT, ENOTDIR]@ +\item @ResourceExhausted@ +Insufficient resources (virtual memory, process file descriptors, +physical disk space, etc.) are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @InappropriateType@ +The path refers to an existing non-directory object. +@[EEXIST]@ +\end{itemize} + +\begin{code} +createDirectory path = do + rc <- _ccall_ createDirectory path + if rc == 0 then return () else + constructErrorAndFail "createDirectory" +\end{code} + +@removeDirectory dir@ removes an existing directory {\em dir}. The +implementation may specify additional constraints which must be +satisfied before a directory can be removed (e.g. the directory has to +be empty, or may not be in use by other processes). It is not legal +for an implementation to partially remove a directory unless the +entire directory is removed. A conformant implementation need not +support directory removal in all situations (e.g. removal of the root +directory). + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +[@EIO@] +\item @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExist@ / @NoSuchThing@ +The directory does not exist. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ +\item @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ +\item @UnsupportedOperation@ +The implementation does not support removal in this situation. +@[EINVAL]@ +\item @InappropriateType@ +The operand refers to an existing non-directory object. +@[ENOTDIR]@ +\end{itemize} + +\begin{code} +removeDirectory path = do + rc <- _ccall_ removeDirectory path + if rc == 0 then + return () + else + constructErrorAndFail "removeDirectory" +\end{code} + +@removeFile file@ removes the directory entry for an existing file +{\em file}, where {\em file} is not itself a directory. The +implementation may specify additional constraints which must be +satisfied before a file can be removed (e.g. the file may not be in +use by other processes). + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @InvalidArgument@ +The operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExist@ / @NoSuchThing@ +The file does not exist. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ +\item @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ +\item @InappropriateType@ +The operand refers to an existing directory. +@[EPERM, EINVAL]@ +\end{itemize} + +\begin{code} +removeFile path = do + rc <- _ccall_ removeFile path + if rc == 0 then + return () + else + constructErrorAndFail "removeFile" +\end{code} + +@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. +If the {\em new} directory is neither the {\em old} directory nor an +alias of the {\em old} directory, it is removed as if by +$removeDirectory$. A conformant implementation need not support +renaming directories in all situations (e.g. renaming to an existing +directory, or across different physical devices), but the constraints +must be documented. + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @InvalidArgument@ +Either operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ +The original directory does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ +\item @ResourceExhausted@ +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY, ENOTEMPTY, EEXIST]@ +\item @UnsupportedOperation@ +The implementation does not support renaming in this situation. +@[EINVAL, EXDEV]@ +\item @InappropriateType@ +Either path refers to an existing non-directory object. +@[ENOTDIR, EISDIR]@ +\end{itemize} + +\begin{code} +renameDirectory opath npath = do + rc <- _ccall_ renameDirectory opath npath + if rc == 0 then + return () + else + constructErrorAndFail "renameDirectory" +\end{code} + +@renameFile old@ {\em new} changes the name of an existing file system +object from {\em old} to {\em new}. If the {\em new} object already +exists, it is atomically replaced by the {\em old} object. Neither +path may refer to an existing directory. A conformant implementation +need not support renaming files in all situations (e.g. renaming +across different physical devices), but the constraints must be +documented. + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @InvalidArgument@ +Either operand is not a valid file name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ +The original file does not exist, or there is no path to the target. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EROFS, EACCES, EPERM]@ +\item @ResourceExhausted@ +Insufficient resources are available to perform the operation. +@[EDQUOT, ENOSPC, ENOMEM, EMLINK]@ +\item @UnsatisfiedConstraints@ +Implementation-dependent constraints are not satisfied. +@[EBUSY]@ +\item @UnsupportedOperation@ +The implementation does not support renaming in this situation. +@[EXDEV]@ +\item @InappropriateType@ +Either path refers to an existing directory. +@[ENOTDIR, EISDIR, EINVAL, EEXIST, ENOTEMPTY]@ +\end{itemize} + +\begin{code} +renameFile opath npath = do + rc <- _ccall_ renameFile opath npath + if rc == 0 then + return () + else + constructErrorAndFail "renameFile" +\end{code} + +@getDirectoryContents dir@ returns a list of {\em all} entries +in {\em dir}. + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ +The directory does not exist. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EACCES]@ +\item @ResourceExhausted@ +Insufficient resources are available to perform the operation. +@[EMFILE, ENFILE]@ +\item @InappropriateType@ +The path refers to an existing non-directory object. +@[ENOTDIR]@ +\end{itemize} + +\begin{code} +getDirectoryContents path = do + ptr <- _ccall_ getDirectoryContents path + if ptr == ``NULL'' + then constructErrorAndFail "getDirectoryContents" + else do + entries <- getEntries ptr 0 + _ccall_ free ptr + return entries + where + getEntries :: Addr -> Int -> IO [FilePath] + getEntries ptr n = do + str <- _casm_ ``%r = ((char **)%0)[%1];'' ptr n + if str == ``NULL'' + then return [] + else do + len <- _ccall_ strlen str + entry <- stToIO (unpackNBytesST str len) + _ccall_ free str + entries <- getEntries ptr (n+1) + return (entry : entries) +\end{code} + +If the operating system has a notion of current directories, +@getCurrentDirectory@ returns an absolute path to the +current directory of the calling process. + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @isDoesNotExistError@ / @NoSuchThing@ +There is no path referring to the current directory. +@[EPERM, ENOENT, ESTALE...]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EACCES]@ +\item @ResourceExhausted@ +Insufficient resources are available to perform the operation. +\item @UnsupportedOperation@ +The operating system has no notion of current directory. +\end{itemize} + +\begin{code} +getCurrentDirectory = do + str <- _ccall_ getCurrentDirectory + if str /= ``NULL'' + then do + len <- _ccall_ strlen str + pwd <- stToIO (unpackNBytesST str len) + _ccall_ free str + return pwd + else + constructErrorAndFail "getCurrentDirectory" +\end{code} + +If the operating system has a notion of current directories, +@setCurrentDirectory dir@ changes the current +directory of the calling process to {\em dir}. + +The operation may fail with: +\begin{itemize} +\item @HardwareFault@ +A physical I/O error has occurred. +@[EIO]@ +\item @InvalidArgument@ +The operand is not a valid directory name. +@[ENAMETOOLONG, ELOOP]@ +\item @isDoesNotExistError@ / @NoSuchThing@ +The directory does not exist. +@[ENOENT, ENOTDIR]@ +\item @isPermissionError@ / @PermissionDenied@ +The process has insufficient privileges to perform the operation. +@[EACCES]@ +\item @UnsupportedOperation@ +The operating system has no notion of current directory, or the +current directory cannot be dynamically changed. +\item @InappropriateType@ +The path refers to an existing non-directory object. +@[ENOTDIR]@ +\end{itemize} + +\begin{code} +setCurrentDirectory path = do + rc <- _ccall_ setCurrentDirectory path + if rc == 0 + then return () + else constructErrorAndFail "setCurrentDirectory" +\end{code} + + +\begin{code} +--doesFileExist :: FilePath -> IO Bool +doesFileExist name = do + rc <- _ccall_ access name (``F_OK''::Int) + return (rc == 0) + +--doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + (getFileStatus name >>= \ st -> return (isDirectory st)) + `catch` + (\ _ -> return False) + +--getModificationTime :: FilePath -> IO ClockTime +getModificationTime name = + getFileStatus name >>= \ st -> + modificationTime st + +--getPermissions :: FilePath -> IO Permissions +getPermissions name = + getFileStatus name >>= \ st -> + let + fm = fileMode st + isect v = intersectFileMode v fm == v + in + return ( + Permissions { + readable = isect ownerReadMode, + writeable = isect ownerWriteMode, + executable = not (isDirectory st) && isect ownerExecuteMode, + searchable = not (isRegularFile st) && isect ownerExecuteMode + } + ) + +--setPermissions :: FilePath -> Permissions -> IO () +setPermissions name (Permissions r w e s) = do + let + read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# } + write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# } + exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# } + + mode = I# (word2Int# (read# `or#` write# `or#` exec#)) + + rc <- _ccall_ chmod name mode + if rc == 0 + then return () + else fail (IOError Nothing SystemError "Directory.setPermissions") + +\end{code} + + +(Sigh)..copied from Posix.Files to avoid dep. on posix library + +\begin{code} +type FileStatus = ByteArray Int + +getFileStatus :: FilePath -> IO FileStatus +getFileStatus name = do + bytes <- stToIO (newCharArray (0,``sizeof(struct stat)'')) + rc <- _casm_ ``%r = stat(%0,(struct stat *)%1);'' name bytes + if rc == 0 + then stToIO (unsafeFreezeByteArray bytes) + else fail (IOError Nothing SystemError "Directory.getFileStatus") + +modificationTime :: FileStatus -> IO ClockTime +modificationTime stat = do + i1 <- malloc1 + _casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1 + secs <- cvtUnsigned i1 + return (TOD secs 0) + where + malloc1 = IO $ \ s# -> + case newIntArray# 1# s# of + StateAndMutableByteArray# s2# barr# -> + IOok s2# (MutableByteArray bnds barr#) + + bnds = (0,1) + -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,' + -- so we freeze the data bits and use them for an MP_INT structure. Note that + -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably + -- acceptable to gmp. + + cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# -> + case readIntArray# arr# 0# s# of + StateAndInt# s2# r# -> + if r# ==# 0# then + IOok s2# 0 + else + case unsafeFreezeByteArray# arr# s2# of + StateAndByteArray# s3# frozen# -> + IOok s3# (J# 1# 1# frozen#) + +isDirectory :: FileStatus -> Bool +isDirectory stat = unsafePerformIO $ do + rc <- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat + return (rc /= 0) + +isRegularFile :: FileStatus -> Bool +isRegularFile stat = unsafePerformIO $ do + rc <- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat + return (rc /= 0) +\end{code} + +\begin{code} +type FileMode = Word +ownerReadMode :: FileMode +ownerReadMode = ``S_IRUSR'' + +ownerWriteMode :: FileMode +ownerWriteMode = ``S_IWUSR'' + +ownerExecuteMode :: FileMode +ownerExecuteMode = ``S_IXUSR'' + +intersectFileMode :: FileMode -> FileMode -> FileMode +intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#) + +fileMode :: FileStatus -> FileMode +fileMode stat = unsafePerformIO ( + _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat) + +\end{code} diff --git a/ghc/lib/std/IO.lhs b/ghc/lib/std/IO.lhs new file mode 100644 index 0000000000..fe5851888e --- /dev/null +++ b/ghc/lib/std/IO.lhs @@ -0,0 +1,669 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[IO]{Module @IO@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} + +module IO ( + Handle, HandlePosn, + + IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), + BufferMode(NoBuffering,LineBuffering,BlockBuffering), + SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), + + stdin, stdout, stderr, + + openFile, hClose, + hFileSize, hIsEOF, isEOF, + hSetBuffering, hGetBuffering, hFlush, + hGetPosn, hSetPosn, hSeek, + hWaitForInput, hReady, hGetChar, hGetLine, hLookAhead, hGetContents, + hPutChar, hPutStr, hPutStrLn, hPrint, + hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, + + isAlreadyExistsError, isDoesNotExistError, isAlreadyInUseError, + isFullError, isEOFError, + isIllegalOperation, isPermissionError, isUserError, + ioeGetErrorString, + ioeGetHandle, ioeGetFileName, + try, bracket, bracket_ + ) where + +import PrelST +import PrelUnsafe ( unsafePerformIO, unsafeInterleaveIO ) +import PrelIOBase +import PrelArr ( MutableByteArray(..), newCharArray ) +import PrelHandle -- much of the real stuff is in here +import PrelPack ( unpackNBytesST ) +import PrelBase +import PrelRead ( readParen, Read(..), reads, lex ) +import PrelMaybe +import PrelEither +import PrelAddr +import PrelGHC + +#ifndef __PARALLEL_HASKELL__ +import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj ) +#endif + +import Ix +import Char ( ord, chr ) +\end{code} + +%********************************************************* +%* * +\subsection{Signatures} +%* * +%********************************************************* + +\begin{code} +--IOHandle:hClose :: Handle -> IO () +--IOHandle:hFileSize :: Handle -> IO Integer +--IOHandle:hFlush :: Handle -> IO () +--IOHandle:hGetBuffering :: Handle -> IO BufferMode +hGetChar :: Handle -> IO Char +hGetContents :: Handle -> IO String +--IOHandle:hGetPosn :: Handle -> IO HandlePosn +--IOHandle:hIsClosed :: Handle -> IO Bool +--IOHandle:hIsEOF :: Handle -> IO Bool +--IOHandle:hIsOpen :: Handle -> IO Bool +--IOHandle:hIsReadable :: Handle -> IO Bool +--IOHandle:hIsSeekable :: Handle -> IO Bool +--IOHandle:hIsWritable :: Handle -> IO Bool +hLookAhead :: Handle -> IO Char +hPrint :: Show a => Handle -> a -> IO () +hPutChar :: Handle -> Char -> IO () +hPutStr :: Handle -> String -> IO () +hPutStrLn :: Handle -> String -> IO () +hReady :: Handle -> IO Bool +hWaitForInput :: Handle -> Int -> IO Bool + +--IOHandle:hSeek :: Handle -> SeekMode -> Integer -> IO () +--IOHandle:hSetBuffering :: Handle -> BufferMode -> IO () +--IOHandle:hSetPosn :: HandlePosn -> IO () +-- ioeGetFileName :: IOError -> Maybe FilePath +-- ioeGetErrorString :: IOError -> Maybe String +-- ioeGetHandle :: IOError -> Maybe Handle +-- isAlreadyExistsError :: IOError -> Bool +-- isAlreadyInUseError :: IOError -> Bool +--IOHandle:isEOF :: IO Bool +-- isEOFError :: IOError -> Bool +-- isFullError :: IOError -> Bool +-- isIllegalOperation :: IOError -> Bool +-- isPermissionError :: IOError -> Bool +-- isUserError :: IOError -> Bool +--IOHandle:openFile :: FilePath -> IOMode -> IO Handle +--IOHandle:stdin, stdout, stderr :: Handle +\end{code} + +Standard instances for @Handle@: + +\begin{code} +instance Eq IOError where + (IOError h1 e1 str1) == (IOError h2 e2 str2) = + e1==e2 && str1==str2 && h1==h2 + +#ifndef __CONCURRENT_HASKELL__ + +instance Eq Handle where + (Handle h1) == (Handle h2) = h1 == h2 + +#else + +{- OLD equality instance. The simpler one above + seems more accurate! This one is still used for concurrent haskell, + since there's no equality instance over MVars. +-} + +instance Eq Handle where + h1 == h2 = + unsafePerformIO (do + h1_ <- readHandle h1 + writeHandle h1 h1_ + h2_<- readHandle h2 + writeHandle h2 h2_ + return ( + case (h1_,h2_) of + (ErrorHandle (IOError h1 _ _), ErrorHandle (IOError h2 _ _)) -> h1 == h2 + (ClosedHandle, ClosedHandle) -> True + (SemiClosedHandle v1 _, SemiClosedHandle v2 _) -> v1 == v2 + (ReadHandle v1 _ _ , ReadHandle v2 _ _) -> v1 == v2 + (WriteHandle v1 _ _ , WriteHandle v2 _ _) -> v1 == v2 + (AppendHandle v1 _ _ , AppendHandle v2 _ _) -> v1 == v2 + (ReadWriteHandle v1 _ _ , ReadWriteHandle v2 _ _) -> v1 == v2 + _ -> False)) + +#endif + +instance Show Handle where {showsPrec p h = showString "<<Handle>>"} + +--Type declared in IOHandle, instance here because it depends on Eq.Handle +instance Eq HandlePosn where + (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 + +-- Type declared in IOBase, instance here because it +-- depends on PrelRead.(Read Maybe) instance. +instance Read BufferMode where + readsPrec p = + readParen False + (\r -> let lr = lex r + in + [(NoBuffering, rest) | ("NoBuffering", rest) <- lr] ++ + [(LineBuffering,rest) | ("LineBuffering",rest) <- lr] ++ + [(BlockBuffering mb,rest2) | ("BlockBuffering",rest1) <- lr, + (mb, rest2) <- reads rest1]) + +\end{code} + +%********************************************************* +%* * +\subsection{Simple input operations} +%* * +%********************************************************* + +Computation @hReady hdl@ indicates whether at least +one item is available for input from handle {\em hdl}. + +@hWaitForInput@ is the generalisation, wait for \tr{n} seconds +before deciding whether the Handle has run dry or not. + +\begin{code} +--hReady :: Handle -> IO Bool +hReady h = hWaitForInput h 0 + +--hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput handle nsecs = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + AppendHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation + "handle is not open for reading") + WriteHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation + "handle is not open for reading") + other -> do + rc <- _ccall_ inputReady (filePtr other) nsecs + writeHandle handle (markHandle htype) + case rc of + 0 -> return False + 1 -> return True + _ -> constructErrorAndFail "hWaitForInput" +\end{code} + +Computation $hGetChar hdl$ reads the next character from handle +{\em hdl}, blocking until a character is available. + +\begin{code} +--hGetChar :: Handle -> IO Char + +hGetChar handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> + writeHandle handle htype >> + fail ioError + ClosedHandle -> + writeHandle handle htype >> + ioe_closedHandle handle + SemiClosedHandle _ _ -> + writeHandle handle htype >> + ioe_closedHandle handle + AppendHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + WriteHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + other -> do + intc <- _ccall_ fileGetc (filePtr other) + writeHandle handle (markHandle htype) + if intc /= ``EOF'' then + return (chr intc) + else + constructErrorAndFail "hGetChar" + +hGetLine :: Handle -> IO String +hGetLine h = + hGetChar h >>= \ c -> + if c == '\n' then + return "" + else + hGetLine h >>= \ s -> return (c:s) +\end{code} + +Computation $hLookahead hdl$ returns the next character from handle +{\em hdl} without removing it from the input buffer, blocking until a +character is available. + +\begin{code} +--hLookAhead :: Handle -> IO Char + +hLookAhead handle = + readHandle handle >>= \ htype -> + case htype of + ErrorHandle ioError -> + writeHandle handle htype >> + fail ioError + ClosedHandle -> + writeHandle handle htype >> + ioe_closedHandle handle + SemiClosedHandle _ _ -> + writeHandle handle htype >> + ioe_closedHandle handle + AppendHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + WriteHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + other -> do + intc <- _ccall_ fileLookAhead (filePtr other) + writeHandle handle (markHandle htype) + if intc /= ``EOF'' then + return (chr intc) + else + constructErrorAndFail "hLookAhead" +\end{code} + + +%********************************************************* +%* * +\subsection{Getting the entire contents of a handle} +%* * +%********************************************************* + +Computation $hGetContents hdl$ returns the list of characters +corresponding to the unread portion of the channel or file managed by +{\em hdl}, which is made semi-closed. + +\begin{code} +--hGetContents :: Handle -> IO String + +hGetContents handle = + readHandle handle >>= \ htype -> + case htype of + ErrorHandle ioError -> + writeHandle handle htype >> + fail ioError + ClosedHandle -> + writeHandle handle htype >> + ioe_closedHandle handle + SemiClosedHandle _ _ -> + writeHandle handle htype >> + ioe_closedHandle handle + AppendHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + WriteHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for reading") + other -> + {- + To avoid introducing an extra layer of buffering here, + we provide three lazy read methods, based on character, + line, and block buffering. + -} + getBufferMode other >>= \ other -> + case (bufferMode other) of + Just LineBuffering -> + allocBuf Nothing >>= \ buf_info -> + writeHandle handle (SemiClosedHandle (filePtr other) buf_info) + >> + unsafeInterleaveIO (lazyReadLine handle) + >>= \ contents -> + return contents + + Just (BlockBuffering size) -> + allocBuf size >>= \ buf_info -> + writeHandle handle (SemiClosedHandle (filePtr other) buf_info) + >> + unsafeInterleaveIO (lazyReadBlock handle) + >>= \ contents -> + return contents + _ -> -- Nothing is treated pessimistically as NoBuffering + writeHandle handle (SemiClosedHandle (filePtr other) (``NULL'', 0)) + >> + unsafeInterleaveIO (lazyReadChar handle) >>= \ contents -> + return contents + where + allocBuf :: Maybe Int -> IO (Addr, Int) + allocBuf msize = + _ccall_ malloc size >>= \ buf -> + if buf /= ``NULL'' then + return (buf, size) + else + fail (IOError Nothing ResourceExhausted "not enough virtual memory") + where + size = + case msize of + Just x -> x + Nothing -> ``BUFSIZ'' +\end{code} + +Note that someone may yank our handle out from under us, and then re-use +the same FILE * for something else. Therefore, we have to re-examine the +handle every time through. + +\begin{code} +lazyReadBlock :: Handle -> IO String +lazyReadLine :: Handle -> IO String +lazyReadChar :: Handle -> IO String + +lazyReadBlock handle = + readHandle handle >>= \ htype -> + case htype of + -- There cannae be an ErrorHandle here + ClosedHandle -> + writeHandle handle htype >> + return "" + SemiClosedHandle fp (buf, size) -> + _ccall_ readBlock buf fp size >>= \ bytes -> + (if bytes <= 0 + then return "" + else stToIO (unpackNBytesST buf bytes)) >>= \ some -> + if bytes < 0 then + _ccall_ free buf >>= \ () -> + _ccall_ closeFile fp >> +#ifndef __PARALLEL_HASKELL__ + writeForeignObj fp ``NULL'' >> + writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> +#else + writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> +#endif + return some + else + writeHandle handle htype >> + unsafeInterleaveIO (lazyReadBlock handle) >>= \ more -> + return (some ++ more) + +lazyReadLine handle = + readHandle handle >>= \ htype -> + case htype of + -- There cannae be an ErrorHandle here + ClosedHandle -> + writeHandle handle htype >> + return "" + SemiClosedHandle fp (buf, size) -> + _ccall_ readLine buf fp size >>= \ bytes -> + (if bytes <= 0 + then return "" + else stToIO (unpackNBytesST buf bytes)) >>= \ some -> + if bytes < 0 then + _ccall_ free buf >>= \ () -> + _ccall_ closeFile fp >> +#ifndef __PARALLEL_HASKELL__ + writeForeignObj fp ``NULL'' >> + writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> +#else + writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> +#endif + return some + else + writeHandle handle htype >> + unsafeInterleaveIO (lazyReadLine handle) + >>= \ more -> + return (some ++ more) + +lazyReadChar handle = + readHandle handle >>= \ htype -> + case htype of + -- There cannae be an ErrorHandle here + ClosedHandle -> + writeHandle handle htype >> + return "" + SemiClosedHandle fp buf_info -> + _ccall_ readChar fp >>= \ char -> + if char == ``EOF'' then + _ccall_ closeFile fp >> +#ifndef __PARALLEL_HASKELL__ + writeForeignObj fp ``NULL'' >> + writeHandle handle (SemiClosedHandle fp (``NULL'', 0)) >> +#else + writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0)) >> +#endif + return "" + else + writeHandle handle htype >> + unsafeInterleaveIO (lazyReadChar handle) >>= \ more -> + return (chr char : more) + +\end{code} + + +%********************************************************* +%* * +\subsection{Simple output functions} +%* * +%********************************************************* + +Computation $hPutChar hdl c$ writes the character {\em c} to the file +or channel managed by {\em hdl}. Characters may be buffered if +buffering is enabled for {\em hdl}. + +\begin{code} +--hPutChar :: Handle -> Char -> IO () + +hPutChar handle c = + readHandle handle >>= \ htype -> + case htype of + ErrorHandle ioError -> + writeHandle handle htype >> + fail ioError + ClosedHandle -> + writeHandle handle htype >> + ioe_closedHandle handle + SemiClosedHandle _ _ -> + writeHandle handle htype >> + ioe_closedHandle handle + ReadHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for writing") + other -> + _ccall_ filePutc (filePtr other) (ord c) >>= \ rc -> + writeHandle handle (markHandle htype) >> + if rc == 0 then + return () + else + constructErrorAndFail "hPutChar" +\end{code} + +Computation $hPutStr hdl s$ writes the string {\em s} to the file or +channel managed by {\em hdl}. + +\begin{code} +--hPutStr :: Handle -> String -> IO () + +hPutStr handle str = + readHandle handle >>= \ htype -> + case htype of + ErrorHandle ioError -> + writeHandle handle htype >> + fail ioError + ClosedHandle -> + writeHandle handle htype >> + ioe_closedHandle handle + SemiClosedHandle _ _ -> + writeHandle handle htype >> + ioe_closedHandle handle + ReadHandle _ _ _ -> + writeHandle handle htype >> + fail (IOError (Just handle) IllegalOperation "handle is not open for writing") + other -> + {- + The code below is not correct for line-buffered terminal streams, + as the output stream is not flushed when terminal input is requested + again, just upon seeing a newline character. A temporary fix for the + most common line-buffered output stream, stdout, is to assume the + buffering it was given when created (no buffering). This is not + as bad as it looks, since stdio buffering sits underneath this. + + ToDo: fix me + -} + getBufferMode other >>= \ other -> + (case bufferMode other of + Just LineBuffering -> + writeChars (filePtr other) str + --writeLines (filePtr other) str + Just (BlockBuffering (Just size)) -> + writeBlocks (filePtr other) size str + Just (BlockBuffering Nothing) -> + writeBlocks (filePtr other) ``BUFSIZ'' str + _ -> -- Nothing is treated pessimistically as NoBuffering + writeChars (filePtr other) str + ) >>= \ success -> + writeHandle handle (markHandle other) >> + if success then + return () + else + constructErrorAndFail "hPutStr" + where +#ifndef __PARALLEL_HASKELL__ + writeLines :: ForeignObj -> String -> IO Bool +#else + writeLines :: Addr -> String -> IO Bool +#endif + writeLines = writeChunks ``BUFSIZ'' True + +#ifndef __PARALLEL_HASKELL__ + writeBlocks :: ForeignObj -> Int -> String -> IO Bool +#else + writeBlocks :: Addr -> Int -> String -> IO Bool +#endif + writeBlocks fp size s = writeChunks size False fp s + + {- + The breaking up of output into lines along \n boundaries + works fine as long as there are newlines to split by. + Avoid the splitting up into lines alltogether (doesn't work + for overly long lines like the stuff that showsPrec instances + normally return). Instead, we split them up into fixed size + chunks before blasting them off to the Real World. + + Hacked to avoid multiple passes over the strings - unsightly, but + a whole lot quicker. -- SOF 3/96 + -} + +#ifndef __PARALLEL_HASKELL__ + writeChunks :: Int -> Bool -> ForeignObj -> String -> IO Bool +#else + writeChunks :: Int -> Bool -> Addr -> String -> IO Bool +#endif + writeChunks (I# bufLen) chopOnNewLine fp s = + stToIO (newCharArray (0,I# bufLen)) >>= \ arr@(MutableByteArray _ arr#) -> + let + write_char :: MutableByteArray# RealWorld -> Int# -> Char# -> IO () + write_char arr# n x = IO $ \ s# -> + case (writeCharArray# arr# n x s#) of { s1# -> + IOok s1# () } + + shoveString :: Int# -> [Char] -> IO Bool + shoveString n ls = + case ls of + [] -> + if n ==# 0# then + return True + else + _ccall_ writeFile arr fp (I# n) >>= \rc -> + return (rc==0) + + ((C# x):xs) -> + write_char arr# n x >> + + {- Flushing lines - should we bother? Yes, for line-buffered output. -} + if n ==# bufLen || (chopOnNewLine && (x `eqChar#` '\n'#)) then + _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \ rc -> + if rc == 0 then + shoveString 0# xs + else + return False + else + shoveString (n +# 1#) xs + in + shoveString 0# s + +#ifndef __PARALLEL_HASKELL__ + writeChars :: ForeignObj -> String -> IO Bool +#else + writeChars :: Addr -> String -> IO Bool +#endif + writeChars fp "" = return True + writeChars fp (c:cs) = + _ccall_ filePutc fp (ord c) >>= \ rc -> + if rc == 0 then + writeChars fp cs + else + return False +\end{code} + +Computation $hPrint hdl t$ writes the string representation of {\em t} +given by the $shows$ function to the file or channel managed by {\em +hdl}. + +SOF 2/97: Seem to have disappeared in 1.4 libs. + +\begin{code} +--hPrint :: Show a => Handle -> a -> IO () +hPrint hdl = hPutStr hdl . show +\end{code} + +Derived action @hPutStrLn hdl str@ writes the string \tr{str} to +the handle \tr{hdl}, adding a newline at the end. + +\begin{code} +--hPutStrLn :: Handle -> String -> IO () +hPutStrLn hndl str = do + hPutStr hndl str + hPutChar hndl '\n' + +\end{code} + + +%********************************************************* +%* * +\subsection{Try and bracket} +%* * +%********************************************************* + +The construct $try comp$ exposes errors which occur within a +computation, and which are not fully handled. It always succeeds. + +\begin{code} +try :: IO a -> IO (Either IOError a) +try f = catch (do r <- f + return (Right r)) + (return . Left) + +bracket :: IO a -> (a -> IO b) -> (a -> IO c) -> IO c +bracket before after m = do + x <- before + rs <- try (m x) + after x + case rs of + Right r -> return r + Left e -> fail e + +-- variant of the above where middle computation doesn't want x +bracket_ :: IO a -> (a -> IO b) -> IO c -> IO c +bracket_ before after m = do + x <- before + rs <- try m + after x + case rs of + Right r -> return r + Left e -> fail e +\end{code} + diff --git a/ghc/lib/std/Ix.lhs b/ghc/lib/std/Ix.lhs new file mode 100644 index 0000000000..af16fda1f7 --- /dev/null +++ b/ghc/lib/std/Ix.lhs @@ -0,0 +1,168 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[Ix]{Module @Ix@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Ix + ( + Ix(range, index, inRange), + rangeSize + ) where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelTup +import PrelBase +\end{code} + +%********************************************************* +%* * +\subsection{The @Ix@ class} +%* * +%********************************************************* + +\begin{code} +class (Show a, Ord a) => Ix a where + range :: (a,a) -> [a] + index :: (a,a) -> a -> Int + inRange :: (a,a) -> a -> Bool +\end{code} + + +%********************************************************* +%* * +\subsection{Instances of @Ix@} +%* * +%********************************************************* + +\begin{code} +instance Ix Char where + range (c,c') = [c..c'] + index b@(c,c') ci + | inRange b ci = fromEnum ci - fromEnum c + | otherwise = error (showString "Ix{Char}.index: Index " . + showParen True (showsPrec 0 ci) . + showString " out of range " $ + showParen True (showsPrec 0 b) "") + inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c' + where i = fromEnum ci + +instance Ix Int where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = i - m + | otherwise = error (showString "Ix{Int}.index: Index " . + showParen True (showsPrec 0 i) . + showString " out of range " $ + showParen True (showsPrec 0 b) "") + inRange (m,n) i = m <= i && i <= n + +-- Integer instance is in PrelNum + +---------------------------------------------------------------------- +instance Ix Bool where -- as derived + range (l,u) = map toEnum [fromEnum l .. fromEnum u] + index (l,u) i = fromEnum i - fromEnum l + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix Ordering where -- as derived + range (l,u) = map toEnum [fromEnum l .. fromEnum u] + index (l,u) i = fromEnum i - fromEnum l + inRange (l,u) i = fromEnum i >= fromEnum l && fromEnum i <= fromEnum u + +---------------------------------------------------------------------- +instance Ix () where + {-# INLINE range #-} + range ((), ()) = [()] + {-# INLINE index #-} + index ((), ()) () = 0 + {-# INLINE inRange #-} + inRange ((), ()) () = True + +---------------------------------------------------------------------- +instance (Ix a, Ix b) => Ix (a, b) where -- as derived + {-# INLINE range #-} + range ((l1,l2),(u1,u2)) = + [ (i1,i2) | i1 <- range (l1,u1), i2 <- range (l2,u2) ] + + {-# INLINE index #-} + index ((l1,l2),(u1,u2)) (i1,i2) = + index (l1,u1) i1 * rangeSize (l2,u2) + index (l2,u2) i2 + + {-# INLINE inRange #-} + inRange ((l1,l2),(u1,u2)) (i1,i2) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 + +instance (Ix a1, Ix a2, Ix a3) => Ix (a1,a2,a3) where + range ((l1,l2,l3),(u1,u2,u3)) = + [(i1,i2,i3) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3)] + + index ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + index (l3,u3) i3 + rangeSize (l3,u3) * ( + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1)) + + inRange ((l1,l2,l3),(u1,u2,u3)) (i1,i2,i3) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 + +instance (Ix a1, Ix a2, Ix a3, Ix a4) => Ix (a1,a2,a3,a4) where + range ((l1,l2,l3,l4),(u1,u2,u3,u4)) = + [(i1,i2,i3,i4) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4)] + + index ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + index (l4,u4) i4 + rangeSize (l4,u4) * ( + index (l3,u3) i3 + rangeSize (l3,u3) * ( + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1))) + + inRange ((l1,l2,l3,l4),(u1,u2,u3,u4)) (i1,i2,i3,i4) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 + +instance (Ix a1, Ix a2, Ix a3, Ix a4, Ix a5) => Ix (a1,a2,a3,a4,a5) where + range ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) = + [(i1,i2,i3,i4,i5) | i1 <- range (l1,u1), + i2 <- range (l2,u2), + i3 <- range (l3,u3), + i4 <- range (l4,u4), + i5 <- range (l5,u5)] + + index ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + index (l5,u5) i5 + rangeSize (l5,u5) * ( + index (l4,u4) i4 + rangeSize (l4,u4) * ( + index (l3,u3) i3 + rangeSize (l3,u3) * ( + index (l2,u2) i2 + rangeSize (l2,u2) * ( + index (l1,u1) i1)))) + + inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) = + inRange (l1,u1) i1 && inRange (l2,u2) i2 && + inRange (l3,u3) i3 && inRange (l4,u4) i4 && + inRange (l5,u5) i5 +\end{code} + +%******************************************************** +%* * +\subsection{Size of @Ix@ interval} +%* * +%******************************************************** + +The @rangeSize@ operator returns the number of elements +in the range for an @Ix@ pair: + +\begin{code} +rangeSize :: (Ix a) => (a,a) -> Int +rangeSize b@(l,h) + | l > h = 0 + | otherwise = index b h + 1 + +\end{code} diff --git a/ghc/lib/std/List.lhs b/ghc/lib/std/List.lhs new file mode 100644 index 0000000000..1e133a68c4 --- /dev/null +++ b/ghc/lib/std/List.lhs @@ -0,0 +1,383 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[List]{Module @Lhar@} + +\begin{code} +module List ( + {- + This list follows the type signatures for the + standard List interface. -- 8/97 + -} + elemIndex, elemIndices, + find, findIndex, findIndices, + nub, nubBy, + delete, deleteBy, (\\), deleteFirstsBy, + union, unionBy, + intersect, intersectBy, + intersperse, transpose, partition, + group, groupBy, + inits, tails, + isPrefixOf, isSuffixOf, + mapAccumL, mapAccumR, + sort, sortBy, + insertBy, + maximumBy, minimumBy, + genericTake, genericDrop, genericSplitAt, + genericIndex, genericReplicate, genericLength, + + zip4, zip5, zip6, zip7, + zipWith4, zipWith5, zipWith6, zipWith7, + unzip4, unzip5, unzip6, unzip7 + + ) where + +import Prelude +import Maybe ( listToMaybe ) +import PrelBase ( Int(..) ) +import PrelGHC ( (+#) ) + +infix 5 \\ +\end{code} + +%********************************************************* +%* * +\subsection{List functions} +%* * +%********************************************************* + +\begin{code} +elemIndex :: Eq a => a -> [a] -> Maybe Int +elemIndex x = findIndex (x==) + +elemIndices :: Eq a => a -> [a] -> [Int] +elemIndices x = findIndices (x==) + +find :: (a -> Bool) -> [a] -> Maybe a +find p = listToMaybe . filter p + +findIndex :: (a -> Bool) -> [a] -> Maybe Int +findIndex p = listToMaybe . findIndices p + +findIndices :: (a -> Bool) -> [a] -> [Int] + +#ifdef USE_REPORT_PRELUDE +findIndices p xs = [ i | (x,i) <- zip xs [0..], p x] +#else +-- Efficient definition +findIndices p xs = loop 0# p xs + where + loop n p [] = [] + loop n p (x:xs) | p x = I# n : loop (n +# 1#) p xs + | otherwise = loop (n +# 1#) p xs +#endif + +isPrefixOf :: (Eq a) => [a] -> [a] -> Bool +isPrefixOf [] _ = True +isPrefixOf _ [] = False +isPrefixOf (x:xs) (y:ys)= x == y && isPrefixOf xs ys + +isSuffixOf :: (Eq a) => [a] -> [a] -> Bool +isSuffixOf x y = reverse x `isPrefixOf` reverse y + +-- nub (meaning "essence") remove duplicate elements from its list argument. +nub :: (Eq a) => [a] -> [a] +#ifdef USE_REPORT_PRELUDE +nub = nubBy (==) +#else +-- stolen from HBC +nub l = nub' l [] + where + nub' [] _ = [] + nub' (x:xs) l = if x `elem` l then nub' xs l else x : nub' xs (x:l) +#endif + +nubBy :: (a -> a -> Bool) -> [a] -> [a] +#ifdef USE_REPORT_PRELUDE +nubBy eq [] = [] +nubBy eq (x:xs) = x : nubBy eq (filter (\ y -> not (eq x y)) xs) +#else +nubBy eq l = nubBy' l [] + where + nubBy' [] _ = [] + nubBy' (x:xs) l = if elemBy eq x l then nubBy' xs l else x : nubBy' xs (x:l) + +--not exported: +elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool +elemBy eq _ [] = False +elemBy eq x (y:ys) = x `eq` y || elemBy eq x ys +#endif + + +-- delete x removes the first occurrence of x from its list argument. +delete :: (Eq a) => a -> [a] -> [a] +delete = deleteBy (==) + +deleteBy :: (a -> a -> Bool) -> a -> [a] -> [a] +deleteBy eq x [] = [] +deleteBy eq x (y:ys) = if x `eq` y then ys else y : deleteBy eq x ys + +-- list difference (non-associative). In the result of xs \\ ys, +-- the first occurrence of each element of ys in turn (if any) +-- has been removed from xs. Thus, (xs ++ ys) \\ xs == ys. +(\\) :: (Eq a) => [a] -> [a] -> [a] +(\\) = foldl (flip delete) + +-- List union, remove the elements of first list from second. +union :: (Eq a) => [a] -> [a] -> [a] +union = unionBy (==) + +unionBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +unionBy eq xs ys = xs ++ foldl (flip (deleteBy eq)) (nubBy eq ys) xs + +intersect :: (Eq a) => [a] -> [a] -> [a] +intersect = intersectBy (==) + +intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] + +-- intersperse sep inserts sep between the elements of its list argument. +-- e.g. intersperse ',' "abcde" == "a,b,c,d,e" +intersperse :: a -> [a] -> [a] +intersperse sep [] = [] +intersperse sep [x] = [x] +intersperse sep (x:xs) = x : sep : intersperse sep xs + +transpose :: [[a]] -> [[a]] +transpose = foldr + (\xs xss -> zipWith (:) xs (xss ++ repeat [])) + [] + + +-- partition takes a predicate and a list and returns a pair of lists: +-- those elements of the argument list that do and do not satisfy the +-- predicate, respectively; i,e,, +-- partition p xs == (filter p xs, filter (not . p) xs). +partition :: (a -> Bool) -> [a] -> ([a],[a]) +partition p xs = foldr select ([],[]) xs + where select x (ts,fs) | p x = (x:ts,fs) + | otherwise = (ts, x:fs) +\end{code} + +@mapAccumL@ behaves like a combination +of @map@ and @foldl@; +it applies a function to each element of a list, passing an accumulating +parameter from left to right, and returning a final value of this +accumulator together with the new list. + +\begin{code} + +mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumL f s [] = (s, []) +mapAccumL f s (x:xs) = (s'',y:ys) + where (s', y ) = f s x + (s'',ys) = mapAccumL f s' xs +\end{code} + +@mapAccumR@ does the same, but working from right to left instead. Its type is +the same as @mapAccumL@, though. + +\begin{code} +mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list + -- and accumulator, returning new + -- accumulator and elt of result list + -> acc -- Initial accumulator + -> [x] -- Input list + -> (acc, [y]) -- Final accumulator and result list +mapAccumR f s [] = (s, []) +mapAccumR f s (x:xs) = (s'', y:ys) + where (s'',y ) = f s' x + (s', ys) = mapAccumR f s xs +\end{code} + +\begin{code} +insertBy :: (a -> a -> Ordering) -> a -> [a] -> [a] +insertBy cmp x [] = [x] +insertBy cmp x ys@(y:ys') + = case cmp x y of + GT -> y : insertBy cmp x ys' + _ -> x : ys + +maximumBy :: (a -> a -> a) -> [a] -> a +maximumBy max [] = error "List.maximumBy: empty list" +maximumBy max xs = foldl1 max xs + +minimumBy :: (a -> a -> a) -> [a] -> a +minimumBy min [] = error "List.minimumBy: empty list" +minimumBy min xs = foldl1 min xs + +genericLength :: (Num i) => [b] -> i +genericLength [] = 0 +genericLength (_:l) = 1 + genericLength l + +genericTake :: (Integral i) => i -> [a] -> [a] +genericTake 0 _ = [] +genericTake _ [] = [] +genericTake n (x:xs) | n > 0 = x : genericTake (n-1) xs +genericTake _ _ = error "List.genericTake: negative argument" + +genericDrop :: (Integral i) => i -> [a] -> [a] +genericDrop 0 xs = xs +genericDrop _ [] = [] +genericDrop n (_:xs) | n > 0 = genericDrop (n-1) xs +genericDrop _ _ = error "List.genericDrop: negative argument" + +genericSplitAt :: (Integral i) => i -> [b] -> ([b],[b]) +genericSplitAt 0 xs = ([],xs) +genericSplitAt _ [] = ([],[]) +genericSplitAt n (x:xs) | n > 0 = (x:xs',xs'') where + (xs',xs'') = genericSplitAt (n-1) xs +genericSplitAt _ _ = error "List.genericSplitAt: negative argument" + + +genericIndex :: (Integral a) => [b] -> a -> b +genericIndex (x:_) 0 = x +genericIndex (_:xs) n + | n > 0 = genericIndex xs (n-1) + | otherwise = error "List.genericIndex: negative argument." +genericIndex _ _ = error "List.genericIndex: index too large." + +genericReplicate :: (Integral i) => i -> a -> [a] +genericReplicate n x = genericTake n (repeat x) + + +zip4 :: [a] -> [b] -> [c] -> [d] -> [(a,b,c,d)] +zip4 = zipWith4 (,,,) + +zip5 :: [a] -> [b] -> [c] -> [d] -> [e] -> [(a,b,c,d,e)] +zip5 = zipWith5 (,,,,) + +zip6 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [(a,b,c,d,e,f)] +zip6 = zipWith6 (,,,,,) + +zip7 :: [a] -> [b] -> [c] -> [d] -> [e] -> [f] -> + [g] -> [(a,b,c,d,e,f,g)] +zip7 = zipWith7 (,,,,,,) + +zipWith4 :: (a->b->c->d->e) -> [a]->[b]->[c]->[d]->[e] +zipWith4 z (a:as) (b:bs) (c:cs) (d:ds) + = z a b c d : zipWith4 z as bs cs ds +zipWith4 _ _ _ _ _ = [] + +zipWith5 :: (a->b->c->d->e->f) -> + [a]->[b]->[c]->[d]->[e]->[f] +zipWith5 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) + = z a b c d e : zipWith5 z as bs cs ds es +zipWith5 _ _ _ _ _ _ = [] + +zipWith6 :: (a->b->c->d->e->f->g) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g] +zipWith6 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) + = z a b c d e f : zipWith6 z as bs cs ds es fs +zipWith6 _ _ _ _ _ _ _ = [] + +zipWith7 :: (a->b->c->d->e->f->g->h) -> + [a]->[b]->[c]->[d]->[e]->[f]->[g]->[h] +zipWith7 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) + = z a b c d e f g : zipWith7 z as bs cs ds es fs gs +zipWith7 _ _ _ _ _ _ _ _ = [] + +unzip4 :: [(a,b,c,d)] -> ([a],[b],[c],[d]) +unzip4 = foldr (\(a,b,c,d) ~(as,bs,cs,ds) -> + (a:as,b:bs,c:cs,d:ds)) + ([],[],[],[]) + +unzip5 :: [(a,b,c,d,e)] -> ([a],[b],[c],[d],[e]) +unzip5 = foldr (\(a,b,c,d,e) ~(as,bs,cs,ds,es) -> + (a:as,b:bs,c:cs,d:ds,e:es)) + ([],[],[],[],[]) + +unzip6 :: [(a,b,c,d,e,f)] -> ([a],[b],[c],[d],[e],[f]) +unzip6 = foldr (\(a,b,c,d,e,f) ~(as,bs,cs,ds,es,fs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs)) + ([],[],[],[],[],[]) + +unzip7 :: [(a,b,c,d,e,f,g)] -> ([a],[b],[c],[d],[e],[f],[g]) +unzip7 = foldr (\(a,b,c,d,e,f,g) ~(as,bs,cs,ds,es,fs,gs) -> + (a:as,b:bs,c:cs,d:ds,e:es,f:fs,g:gs)) + ([],[],[],[],[],[],[]) + + + +deleteFirstsBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +deleteFirstsBy eq = foldl (flip (deleteBy eq)) + + +-- group splits its list argument into a list of lists of equal, adjacent +-- elements. e.g., +-- group "Mississippi" == ["M","i","ss","i","ss","i","pp","i"] +group :: (Eq a) => [a] -> [[a]] +group = groupBy (==) + +groupBy :: (a -> a -> Bool) -> [a] -> [[a]] +groupBy eq [] = [] +groupBy eq (x:xs) = (x:ys) : groupBy eq zs + where (ys,zs) = span (eq x) xs + +-- inits xs returns the list of initial segments of xs, shortest first. +-- e.g., inits "abc" == ["","a","ab","abc"] +inits :: [a] -> [[a]] +inits [] = [[]] +inits (x:xs) = [[]] ++ map (x:) (inits xs) + +-- tails xs returns the list of all final segments of xs, longest first. +-- e.g., tails "abc" == ["abc", "bc", "c",""] +tails :: [a] -> [[a]] +tails [] = [[]] +tails xxs@(_:xs) = xxs : tails xs + +\end{code} + +%----------------------------------------------------------------------------- +Quick Sort algorithm taken from HBC's QSort library. + +\begin{code} +sort :: (Ord a) => [a] -> [a] +sortBy :: (a -> a -> Ordering) -> [a] -> [a] + +#ifdef USE_REPORT_PRELUDE +sort = sortBy compare +sortBy cmp = foldr (insertBy cmp) [] +#else + +sortBy cmp l = qsort cmp l [] +sort l = qsort compare l [] + +-- rest is not exported: + +-- qsort is stable and does not concatenate. +qsort cmp [] r = r +qsort cmp [x] r = x:r +qsort cmp (x:xs) r = qpart cmp x xs [] [] r + +-- qpart partitions and sorts the sublists +qpart cmp x [] rlt rge r = + -- rlt and rge are in reverse order and must be sorted with an + -- anti-stable sorting + rqsort cmp rlt (x:rqsort cmp rge r) +qpart cmp x (y:ys) rlt rge r = + case cmp x y of + GT -> qpart cmp x ys (y:rlt) rge r + _ -> qpart cmp x ys rlt (y:rge) r + +-- rqsort is as qsort but anti-stable, i.e. reverses equal elements +rqsort cmp [] r = r +rqsort cmp [x] r = x:r +rqsort cmp (x:xs) r = rqpart cmp x xs [] [] r + +rqpart cmp x [] rle rgt r = + qsort cmp rle (x:qsort cmp rgt r) +rqpart cmp x (y:ys) rle rgt r = + case cmp y x of + GT -> rqpart cmp x ys rle (y:rgt) r + _ -> rqpart cmp x ys (y:rle) rgt r + +#endif /* USE_REPORT_PRELUDE */ +\end{code} diff --git a/ghc/lib/std/Locale.lhs b/ghc/lib/std/Locale.lhs new file mode 100644 index 0000000000..cea6caa22f --- /dev/null +++ b/ghc/lib/std/Locale.lhs @@ -0,0 +1,39 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-97 +% +\section[Time]{Haskell 1.4 Locale Library} + + +\begin{code} +module Locale(TimeLocale(..), defaultTimeLocale) where + +data TimeLocale = TimeLocale { + wDays :: [(String, String)], -- full and abbreviated week days + months :: [(String, String)], -- full and abbreviated months + amPm :: (String, String), -- AM/PM symbols + dateTimeFmt, dateFmt, -- formatting strings + timeFmt, time12Fmt :: String + } deriving (Eq, Ord, Show) + +defaultTimeLocale :: TimeLocale +defaultTimeLocale = TimeLocale { + wDays = [("Sunday", "Sun"), ("Monday", "Mon"), + ("Tuesday", "Tue"), ("Wednesday", "Wed"), + ("Thursday", "Thu"), ("Friday", "Fri"), + ("Saturday", "Sat")], + + months = [("January", "Jan"), ("February", "Feb"), + ("March", "Mar"), ("April", "Apr"), + ("May", "May"), ("June", "Jun"), + ("July", "Jul"), ("August", "Aug"), + ("September", "Sep"), ("October", "Oct"), + ("November", "Nov"), ("December", "Dec")], + + amPm = ("AM", "PM"), + dateTimeFmt = "%a %b %e %H:%M:%S %Z %Y", + dateFmt = "%m/%d/%y", + timeFmt = "%H:%M:%S", + time12Fmt = "%I:%M:%S %p" + } + +\end{code} diff --git a/ghc/lib/std/Main.hi-boot b/ghc/lib/std/Main.hi-boot new file mode 100644 index 0000000000..d4bd8ff350 --- /dev/null +++ b/ghc/lib/std/Main.hi-boot @@ -0,0 +1,13 @@ +--------------------------------------------------------------------------- +-- Main.hi +-- +-- This hand-written interface file fakes a "Main" module +-- It is used *solely* so that GHCmain generates the right kind of +-- external reference to Main.main +--------------------------------------------------------------------------- + +_interface_ Main 1 +_exports_ +Main main ; +_declarations_ +1 main _:_ PrelIOBase.IO PrelBase.();; diff --git a/ghc/lib/std/Maybe.lhs b/ghc/lib/std/Maybe.lhs new file mode 100644 index 0000000000..3c86e9148e --- /dev/null +++ b/ghc/lib/std/Maybe.lhs @@ -0,0 +1,105 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% +\section[Maybe]{Module @Maybe@} + +The standard Haskell 1.3 library for working with +@Maybe@ values. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Maybe + ( + Maybe(..), + isJust, fromJust, + fromMaybe, + listToMaybe, maybeToList, + catMaybes, + mapMaybe, + unfoldr + ) where + +import PrelErr ( error ) +import Monad ( filter ) +import PrelList +import PrelMaybe +import PrelBase +\end{code} + + +%********************************************************* +%* * +\subsection{Functions} +%* * +%********************************************************* + +\begin{code} +isJust :: Maybe a -> Bool +isJust Nothing = False +isJust _ = True + +fromJust :: Maybe a -> a +fromJust Nothing = error "Maybe.fromJust: Nothing" -- yuck +fromJust (Just x) = x + +fromMaybe :: a -> Maybe a -> a +fromMaybe d x = case x of {Nothing -> d;Just v -> v} + +maybeToList :: Maybe a -> [a] +maybeToList Nothing = [] +maybeToList (Just x) = [x] + +listToMaybe :: [a] -> Maybe a +listToMaybe [] = Nothing +listToMaybe (a:_) = Just a + +findMaybe :: (a -> Bool) -> [a] -> Maybe a +findMaybe p = listToMaybe . filter p + +catMaybes :: [Maybe a] -> [a] +catMaybes ls = [x | Just x <- ls] + +mapMaybe :: (a -> Maybe b) -> [a] -> [b] +mapMaybe f [] = [] +mapMaybe f (x:xs) = + let rs = mapMaybe f xs in + case f x of + Nothing -> rs + Just r -> r:rs + +--OLD: mapMaybe f = catMaybes . map f +-- new version is potentially more space efficient + +-- Not exported +joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +joinMaybe f m1 m2 = + case m1 of + Nothing -> m2 + Just v1 -> case m2 of {Nothing -> m1; Just v2 -> Just (f v1 v2)} + +{- OLD: Note: stricter than the above. +joinMaybe _ Nothing Nothing = Nothing +joinMaybe _ (Just g) Nothing = Just g +joinMaybe _ Nothing (Just g) = Just g +joinMaybe f (Just g) (Just h) = Just (f g h) +-} + +\end{code} + +\begin{verbatim} + unfoldr f' (foldr f z xs) == (xs,z) + + if the following holds: + + f' (f x y) = Just (x,y) + f' z = Nothing +\end{verbatim} + +\begin{code} +unfoldr :: (a -> Maybe (b, a)) -> a -> ([b],a) +unfoldr f x = + case f x of + Just (y,x') -> let (ys,x'') = unfoldr f x' in (y:ys,x'') + Nothing -> ([],x) +\end{code} diff --git a/ghc/lib/std/Monad.lhs b/ghc/lib/std/Monad.lhs new file mode 100644 index 0000000000..2be1dba439 --- /dev/null +++ b/ghc/lib/std/Monad.lhs @@ -0,0 +1,118 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% +\section[Monad]{Module @Monad@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Monad ( + Functor(..), + Monad(..), MonadZero(..), MonadPlus(..), + + -- Prelude monad functions + accumulate, sequence, + mapM, mapM_, guard, filter, concat, applyM, + + -- Standard Monad interface: + join, -- :: (Monad m) => m (m a) -> m a + mapAndUnzipM, -- :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) + zipWithM, -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] + zipWithM_, -- :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () + foldM, -- :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a + when, -- :: (Monad m) => Bool -> m () -> m () + unless, -- :: (Monad m) => Bool -> m () -> m () + ap, -- :: (Monad m) => (m (a -> b)) -> (m a) -> m b + liftM, liftM2, + liftM3, liftM4, + liftM5 + ) where + +import PrelList +import PrelTup +import PrelBase +\end{code} + +%********************************************************* +%* * +\subsection{Functions mandated by the Prelude} +%* * +%********************************************************* + +\begin{code} +accumulate :: Monad m => [m a] -> m [a] +accumulate [] = return [] +accumulate (m:ms) = do { x <- m; xs <- accumulate ms; return (x:xs) } + +sequence :: Monad m => [m a] -> m () +sequence = foldr (>>) (return ()) + +mapM :: Monad m => (a -> m b) -> [a] -> m [b] +mapM f as = accumulate (map f as) + +mapM_ :: Monad m => (a -> m b) -> [a] -> m () +mapM_ f as = sequence (map f as) + +guard :: MonadZero m => Bool -> m () +guard p = if p then return () else zero + +-- This subsumes the list-based filter function. + +filter :: MonadZero m => (a -> Bool) -> m a -> m a +filter p = applyM (\x -> if p x then return x else zero) + +-- This subsumes the list-based concat function. + +concat :: MonadPlus m => [m a] -> m a +concat = foldr (++) zero + +applyM :: Monad m => (a -> m b) -> m a -> m b +applyM f x = x >>= f +\end{code} + + +%********************************************************* +%* * +\subsection{Other monad functions} +%* * +%********************************************************* + +\begin{code} +join :: (Monad m) => m (m a) -> m a +join x = x >>= id + +mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c]) +mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip + +zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c] +zipWithM f xs ys = accumulate (zipWith f xs ys) + +zipWithM_ :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m () +zipWithM_ f xs ys = sequence (zipWith f xs ys) + +foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a +foldM f a [] = return a +foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs + +unless :: (Monad m) => Bool -> m () -> m () +unless p s = if p then return () else s + +when :: (Monad m) => Bool -> m () -> m () +when p s = if p then s else return () + +ap :: (Monad m) => m (a->b) -> m a -> m b +ap = liftM2 ($) + +liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r +liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r +liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r +liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r +liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r + +liftM f m1 = do { x1 <- m1; return (f x1) } +liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) } +liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) } +liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) } +liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) } + +\end{code} diff --git a/ghc/lib/std/Numeric.lhs b/ghc/lib/std/Numeric.lhs new file mode 100644 index 0000000000..067c6728b1 --- /dev/null +++ b/ghc/lib/std/Numeric.lhs @@ -0,0 +1,98 @@ +% +% (c) The AQUA Project, Glasgow University, 1997-98 +% +\section[Numeric]{Numeric interface} + +Odds and ends, mostly functions for reading and showing +\tr{RealFloat}-like kind of values. + + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} +module Numeric + ( + fromRat, + showSigned, + readSigned, + showInt, + readInt, + + readDec, readOct, readHex, + + showEFloat, + showFFloat, + showGFloat, + showFloat, + readFloat, + + floatToDigits, + lexDigits + + ) where + +import PrelBase +import PrelMaybe +import PrelArr +import PrelNum +import PrelRead + +\end{code} + +%********************************************************* +%* * +\subsection[Numeric-signatures]{Signatures} +%* * +%********************************************************* + +Interface on offer: + +\begin{pseudocode} +fromRat :: (RealFloat a) => Rational -> a + +showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS +readSigned :: (Real a) => ReadS a -> ReadS a + +showInt :: Integral a => a -> ShowS +readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a + +readDec :: (Integral a) => ReadS a +readOct :: (Integral a) => ReadS a +readHex :: (Integral a) => ReadS a + +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFloat :: (RealFloat a) => a -> ShowS + +readFloat :: (RealFloat a) => ReadS a + +floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) +lexDigits :: ReadS String +\end{pseudocode} + +\begin{code} +showInt :: Integral a => a -> ShowS +showInt n r + = case quotRem n 10 of { (n', d) -> + case chr (ord_0 + fromIntegral d) of { C# c# -> -- stricter than necessary + let + r' = C# c# : r + in + if n' == 0 then r' else showInt n' r' + }} +\end{code} + +Controlling the format and precision of floats. The code that +implements the formatting itself is in @PrelNum@ to avoid +mutual module deps. + +\begin{code} +showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS +showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS + +showEFloat d x = showString (formatRealFloat FFExponent d x) +showFFloat d x = showString (formatRealFloat FFFixed d x) +showGFloat d x = showString (formatRealFloat FFGeneric d x) + +\end{code} diff --git a/ghc/lib/std/PrelAddr.lhs b/ghc/lib/std/PrelAddr.lhs new file mode 100644 index 0000000000..6543bfbdeb --- /dev/null +++ b/ghc/lib/std/PrelAddr.lhs @@ -0,0 +1,84 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelAddr]{Module @PrelAddr@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelAddr ( + Addr(..), + nullAddr, -- :: Addr + plusAddr, -- :: Addr -> Int -> Addr + ) where + +import PrelGHC +import PrelBase +import PrelST +import PrelCCall +\end{code} + +\begin{code} +data Addr = A# Addr# deriving (Eq, Ord) + +instance Show Addr where + showsPrec p (A# a) = showsPrec p (I# (addr2Int# a)) + +nullAddr = ``NULL'' :: Addr + +plusAddr :: Addr -> Int -> Addr +plusAddr (A# addr) (I# off) = A# (int2Addr# (addr2Int# addr +# off)) + +instance CCallable Addr +instance CCallable Addr# +instance CReturnable Addr +\end{code} + +ToDo: + +-- read value out of _immutable_ memory + indexCharOffAddr :: Addr -> Int -> Char + indexIntOffAddr :: Addr -> Int -> Int -- should we drop this? + indexAddrOffAddr :: Addr -> Int -> Addr + indexFloatOffAddr :: Addr -> Int -> Float + indexDoubleOffAddr :: Addr -> Int -> Double + indexWord8OffAddr :: Addr -> Int -> Word8 + indexWord16OffAddr :: Addr -> Int -> Word16 + indexWord32OffAddr :: Addr -> Int -> Word32 + indexWord64OffAddr :: Addr -> Int -> Word64 + indexInt8OffAddr :: Addr -> Int -> Int8 + indexInt16OffAddr :: Addr -> Int -> Int16 + indexInt32OffAddr :: Addr -> Int -> Int32 + indexInt64OffAddr :: Addr -> Int -> Int64 + + -- read value out of mutable memory + readCharOffAddr :: Addr -> Int -> IO Char + readIntOffAddr :: Addr -> Int -> IO Int -- should we drop this? + readAddrOffAddr :: Addr -> Int -> IO Addr + readFloatOffAddr :: Addr -> Int -> IO Float + readDoubleOffAddr :: Addr -> Int -> IO Double + readWord8OffAddr :: Addr -> Int -> IO Word8 + readWord16OffAddr :: Addr -> Int -> IO Word16 + readWord32OffAddr :: Addr -> Int -> IO Word32 + readWord64OffAddr :: Addr -> Int -> IO Word64 + readInt8OffAddr :: Addr -> Int -> IO Int8 + readInt16OffAddr :: Addr -> Int -> IO Int16 + readInt32OffAddr :: Addr -> Int -> IO Int32 + readInt64OffAddr :: Addr -> Int -> IO Int64 + + -- write value into mutable memory + writeCharOffAddr :: Addr -> Int -> Char -> IO () + writeIntOffAddr :: Addr -> Int -> Int -> IO () -- should we drop this? + writeAddrOffAddr :: Addr -> Int -> Addr -> IO () + writeFloatOffAddr :: Addr -> Int -> Float -> IO () + writeDoubleOffAddr :: Addr -> Int -> Double -> IO () + writeWord8OffAddr :: Addr -> Int -> Word8 -> IO () + writeWord16OffAddr :: Addr -> Int -> Word16 -> IO () + writeWord32OffAddr :: Addr -> Int -> Word32 -> IO () + writeWord64OffAddr :: Addr -> Int -> Word64 -> IO () + writeInt8OffAddr :: Addr -> Int -> Int8 -> IO () + writeInt16OffAddr :: Addr -> Int -> Int16 -> IO () + writeInt32OffAddr :: Addr -> Int -> Int32 -> IO () + writeInt64OffAddr :: Addr -> Int -> Int64 -> IO () + diff --git a/ghc/lib/std/PrelArr.lhs b/ghc/lib/std/PrelArr.lhs new file mode 100644 index 0000000000..806b93204d --- /dev/null +++ b/ghc/lib/std/PrelArr.lhs @@ -0,0 +1,700 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% +\section[PrelArr]{Module @PrelArr@} + +Array implementation, @PrelArr@ exports the basic array +types and operations. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelArr where + +import {-# SOURCE #-} PrelErr ( error ) +import Ix +import PrelList (foldl) +import PrelST +import PrelBase +import PrelCCall +import PrelAddr +import PrelUnsafeST ( runST ) +import PrelGHC + +infixl 9 !, // +\end{code} + +\begin{code} +{-# GENERATE_SPECS array a{~,Int,IPr} b{} #-} +array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b + +{-# GENERATE_SPECS (!) a{~,Int,IPr} b{} #-} +(!) :: (Ix a) => Array a b -> a -> b + +bounds :: (Ix a) => Array a b -> (a,a) + +{-# GENERATE_SPECS (//) a{~,Int,IPr} b{} #-} +(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b + +{-# GENERATE_SPECS accum a{~,Int,IPr} b{} c{} #-} +accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b + +{-# GENERATE_SPECS accumArray a{~,Int,IPr} b{} c{} #-} +accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b +\end{code} + + +%********************************************************* +%* * +\subsection{The @Array@ types} +%* * +%********************************************************* + +\begin{code} +type IPr = (Int, Int) + +data Ix ix => Array ix elt = Array (ix,ix) (Array# elt) +data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray# +data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt) +data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s) + +instance CCallable (MutableByteArray s ix) +instance CCallable (MutableByteArray# s) + +instance CCallable (ByteArray ix) +instance CCallable ByteArray# + +-- A one-element mutable array: +type MutableVar s a = MutableArray s Int a + +-- just pointer equality on arrays: +instance Eq (MutableArray s ix elt) where + MutableArray _ arr1# == MutableArray _ arr2# + = sameMutableArray# arr1# arr2# + +instance Eq (MutableByteArray s ix) where + MutableByteArray _ arr1# == MutableByteArray _ arr2# + = sameMutableByteArray# arr1# arr2# +\end{code} + +%********************************************************* +%* * +\subsection{Operations on mutable variables} +%* * +%********************************************************* + +\begin{code} +newVar :: a -> ST s (MutableVar s a) +readVar :: MutableVar s a -> ST s a +writeVar :: MutableVar s a -> a -> ST s () + +newVar init = ST $ \ s# -> + case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# -> + STret s2# (MutableArray vAR_IXS arr#) } + where + vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n" + +readVar (MutableArray _ var#) = ST $ \ s# -> + case readArray# var# 0# s# of { StateAndPtr# s2# r -> + STret s2# r } + +writeVar (MutableArray _ var#) val = ST $ \ s# -> + case writeArray# var# 0# val s# of { s2# -> + STret s2# () } +\end{code} + +%********************************************************* +%* * +\subsection{Operations on immutable arrays} +%* * +%********************************************************* + +"array", "!" and "bounds" are basic; the rest can be defined in terms of them + +\begin{code} +bounds (Array b _) = b + +(Array bounds arr#) ! i + = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range + in + case (indexArray# arr# n#) of + Lift v -> v + +#ifdef USE_FOLDR_BUILD +{-# INLINE array #-} +#endif +array ixs@(ix_start, ix_end) ivs = + runST ( ST $ \ s -> + case (newArray ixs arrEleBottom) of { ST new_array_thing -> + case (new_array_thing s) of { STret s# arr@(MutableArray _ arr#) -> + let + fill_in s# [] = s# + fill_in s# ((i,v):ivs) = + case (index ixs i) of { I# n# -> + case writeArray# arr# n# v s# of { s2# -> + fill_in s2# ivs }} + in + + case (fill_in s# ivs) of { s# -> + case (freezeArray arr) of { ST freeze_array_thing -> + freeze_array_thing s# }}}}) + +arrEleBottom = error "(Array.!): undefined array element" + +fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s () +fill_it_in arr lst + = foldr fill_one_in (return ()) lst + where -- **** STRICT **** (but that's OK...) + fill_one_in (i, v) rst + = writeArray arr i v >> rst + +----------------------------------------------------------------------- +-- these also go better with magic: (//), accum, accumArray + +old_array // ivs + = runST (do + -- copy the old array: + arr <- thawArray old_array + -- now write the new elements into the new array: + fill_it_in arr ivs + freezeArray arr + ) + where + bottom = error "(Array.//): error in copying old array\n" + +zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s () +-- zap_with_f: reads an elem out first, then uses "f" on that and the new value + +zap_with_f f arr lst + = foldr zap_one (return ()) lst + where + zap_one (i, new_v) rst = do + old_v <- readArray arr i + writeArray arr i (f old_v new_v) + rst + +accum f old_array ivs + = runST (do + -- copy the old array: + arr <- thawArray old_array + -- now zap the elements in question with "f": + zap_with_f f arr ivs + freezeArray arr + ) + where + bottom = error "Array.accum: error in copying old array\n" + +accumArray f zero ixs ivs + = runST (do + arr# <- newArray ixs zero + zap_with_f f arr# ivs + freezeArray arr# + ) +\end{code} + + +%********************************************************* +%* * +\subsection{Operations on mutable arrays} +%* * +%********************************************************* + +Idle ADR question: What's the tradeoff here between flattening these +datatypes into @MutableArray ix ix (MutableArray# s elt)@ and using +it as is? As I see it, the former uses slightly less heap and +provides faster access to the individual parts of the bounds while the +code used has the benefit of providing a ready-made @(lo, hi)@ pair as +required by many array-related functions. Which wins? Is the +difference significant (probably not). + +Idle AJG answer: When I looked at the outputted code (though it was 2 +years ago) it seems like you often needed the tuple, and we build +it frequently. Now we've got the overloading specialiser things +might be different, though. + +\begin{code} +newArray :: Ix ix => (ix,ix) -> elt -> ST s (MutableArray s ix elt) +newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray + :: Ix ix => (ix,ix) -> ST s (MutableByteArray s ix) + +{-# SPECIALIZE newArray :: IPr -> elt -> ST s (MutableArray s Int elt), + (IPr,IPr) -> elt -> ST s (MutableArray s IPr elt) + #-} +{-# SPECIALIZE newCharArray :: IPr -> ST s (MutableByteArray s Int) #-} +{-# SPECIALIZE newIntArray :: 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) #-} + +newArray ixs init = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newArray# n# init s#) of { StateAndMutableArray# s2# arr# -> + STret s2# (MutableArray ixs arr#) }} + +newCharArray ixs = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray ixs barr#) }} + +newIntArray ixs = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray ixs barr#) }} + +newAddrArray ixs = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray ixs barr#) }} + +newFloatArray ixs = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray ixs barr#) }} + +newDoubleArray ixs = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray ixs barr#) }} + +boundsOfArray :: Ix ix => MutableArray s ix elt -> (ix, ix) +boundsOfByteArray :: Ix ix => MutableByteArray s ix -> (ix, ix) + +{-# SPECIALIZE boundsOfArray :: MutableArray s Int elt -> IPr #-} +{-# SPECIALIZE boundsOfByteArray :: MutableByteArray s Int -> IPr #-} + +boundsOfArray (MutableArray ixs _) = ixs +boundsOfByteArray (MutableByteArray ixs _) = ixs + +readArray :: Ix ix => MutableArray s ix elt -> ix -> ST s elt + +readCharArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Char +readIntArray :: Ix ix => MutableByteArray s ix -> ix -> ST s Int +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 readArray :: MutableArray s Int elt -> Int -> ST s elt, + MutableArray s IPr elt -> IPr -> ST s elt + #-} +{-# 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 #-} + +readArray (MutableArray ixs arr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readArray# arr# n# s# of { StateAndPtr# s2# r -> + STret s2# r }} + +readCharArray (MutableByteArray ixs barr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readCharArray# barr# n# s# of { StateAndChar# s2# r# -> + STret s2# (C# r#) }} + +readIntArray (MutableByteArray ixs barr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readIntArray# barr# n# s# of { StateAndInt# s2# r# -> + STret s2# (I# r#) }} + +readAddrArray (MutableByteArray ixs barr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readAddrArray# barr# n# s# of { StateAndAddr# s2# r# -> + STret s2# (A# r#) }} + +readFloatArray (MutableByteArray ixs barr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readFloatArray# barr# n# s# of { StateAndFloat# s2# r# -> + STret s2# (F# r#) }} + +readDoubleArray (MutableByteArray ixs barr#) n = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case readDoubleArray# barr# n# s# of { StateAndDouble# s2# r# -> + STret s2# (D# r#) }} + +--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here. +indexCharArray :: Ix ix => ByteArray ix -> ix -> Char +indexIntArray :: Ix ix => ByteArray ix -> ix -> Int +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 #-} + +indexCharArray (ByteArray ixs barr#) n + = case (index ixs n) of { I# n# -> + case indexCharArray# barr# n# of { r# -> + (C# r#)}} + +indexIntArray (ByteArray ixs barr#) n + = case (index ixs n) of { I# n# -> + case indexIntArray# barr# n# of { r# -> + (I# r#)}} + +indexAddrArray (ByteArray ixs barr#) n + = case (index ixs n) of { I# n# -> + case indexAddrArray# barr# n# of { r# -> + (A# r#)}} + +indexFloatArray (ByteArray ixs barr#) n + = case (index ixs n) of { I# n# -> + case indexFloatArray# barr# n# of { r# -> + (F# r#)}} + +indexDoubleArray (ByteArray ixs barr#) n + = case (index ixs n) of { I# n# -> + case indexDoubleArray# barr# n# of { r# -> + (D# r#)}} + +--Indexing off @Addrs@ is similar, and therefore given here. +indexCharOffAddr :: Addr -> Int -> Char +indexIntOffAddr :: Addr -> Int -> Int +indexAddrOffAddr :: Addr -> Int -> Addr +indexFloatOffAddr :: Addr -> Int -> Float +indexDoubleOffAddr :: Addr -> Int -> Double + +indexCharOffAddr (A# addr#) n + = case n of { I# n# -> + case indexCharOffAddr# addr# n# of { r# -> + (C# r#)}} + +indexIntOffAddr (A# addr#) n + = case n of { I# n# -> + case indexIntOffAddr# addr# n# of { r# -> + (I# r#)}} + +indexAddrOffAddr (A# addr#) n + = case n of { I# n# -> + case indexAddrOffAddr# addr# n# of { r# -> + (A# r#)}} + +indexFloatOffAddr (A# addr#) n + = case n of { I# n# -> + case indexFloatOffAddr# addr# n# of { r# -> + (F# r#)}} + +indexDoubleOffAddr (A# addr#) n + = case n of { I# n# -> + case indexDoubleOffAddr# addr# n# of { r# -> + (D# r#)}} + +writeArray :: Ix ix => MutableArray s ix elt -> ix -> elt -> ST s () +writeCharArray :: Ix ix => MutableByteArray s ix -> ix -> Char -> ST s () +writeIntArray :: Ix ix => MutableByteArray s ix -> ix -> Int -> 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 writeArray :: MutableArray s Int elt -> Int -> elt -> ST s (), + MutableArray s IPr elt -> IPr -> elt -> 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 () #-} + +writeArray (MutableArray ixs arr#) n ele = ST $ \ s# -> + case index ixs n of { I# n# -> + case writeArray# arr# n# ele s# of { s2# -> + STret s2# () }} + +writeCharArray (MutableByteArray ixs barr#) n (C# ele) = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case writeCharArray# barr# n# ele s# of { s2# -> + STret s2# () }} + +writeIntArray (MutableByteArray ixs barr#) n (I# ele) = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case writeIntArray# barr# n# ele s# of { s2# -> + STret s2# () }} + +writeAddrArray (MutableByteArray ixs barr#) n (A# ele) = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case writeAddrArray# barr# n# ele s# of { s2# -> + STret s2# () }} + +writeFloatArray (MutableByteArray ixs barr#) n (F# ele) = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case writeFloatArray# barr# n# ele s# of { s2# -> + STret s2# () }} + +writeDoubleArray (MutableByteArray ixs barr#) n (D# ele) = ST $ \ s# -> + case (index ixs n) of { I# n# -> + case writeDoubleArray# barr# n# ele s# of { s2# -> + STret s2# () }} +\end{code} + + +%********************************************************* +%* * +\subsection{Moving between mutable and immutable} +%* * +%********************************************************* + +\begin{code} +freezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +freezeCharArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeIntArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeAddrArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeFloatArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) +freezeDoubleArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) + +{-# SPECIALISE freezeArray :: MutableArray s Int elt -> ST s (Array Int elt), + MutableArray s IPr elt -> ST s (Array IPr elt) + #-} +{-# SPECIALISE freezeCharArray :: MutableByteArray s Int -> ST s (ByteArray Int) #-} + +freezeArray (MutableArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndArray# s2# frozen# -> + STret s2# (Array ixs frozen#) }} + where + freeze :: MutableArray# s ele -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndArray# s ele + + freeze arr# n# s# + = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# -> + case copy 0# n# arr# newarr1# s2# of { StateAndMutableArray# s3# newarr2# -> + unsafeFreezeArray# newarr2# s3# + }} + where + init = error "freezeArray: element not copied" + + copy :: Int# -> Int# + -> MutableArray# s ele -> MutableArray# s ele + -> State# s + -> StateAndMutableArray# s ele + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableArray# s# to# + | otherwise + = case readArray# from# cur# s# of { StateAndPtr# s1# ele -> + case writeArray# to# cur# ele s1# of { s2# -> + copy (cur# +# 1#) end# from# to# s2# + }} + +freezeCharArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndByteArray# s + + freeze arr# n# s# + = case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> + case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> StateAndMutableByteArray# s + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableByteArray# s# to# + | otherwise + = case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele -> + case (writeCharArray# to# cur# ele s1#) of { s2# -> + copy (cur# +# 1#) end# from# to# s2# + }} + +freezeIntArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndByteArray# s + + freeze arr# n# s# + = case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> + case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> StateAndMutableByteArray# s + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableByteArray# s# to# + | otherwise + = case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele -> + case (writeIntArray# to# cur# ele s1#) of { s2# -> + copy (cur# +# 1#) end# from# to# s2# + }} + +freezeAddrArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndByteArray# s + + freeze arr# n# s# + = case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> + case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> StateAndMutableByteArray# s + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableByteArray# s# to# + | otherwise + = case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele -> + case (writeAddrArray# to# cur# ele s1#) of { s2# -> + copy (cur# +# 1#) end# from# to# s2# + }} + +freezeFloatArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndByteArray# s + + freeze arr# end# s# + = case (newFloatArray# end# s#) of { StateAndMutableByteArray# s2# newarr1# -> + case copy 0# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> StateAndMutableByteArray# s + + copy cur# from# to# s# + | cur# ==# end# + = StateAndMutableByteArray# s# to# + | otherwise + = case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele -> + case (writeFloatArray# to# cur# ele s1#) of { s2# -> + copy (cur# +# 1#) from# to# s2# + }} + +freezeDoubleArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case freeze arr# n# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) }} + where + freeze :: MutableByteArray# s -- the thing + -> Int# -- size of thing to be frozen + -> State# s -- the Universe and everything + -> StateAndByteArray# s + + freeze arr# n# s# + = case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# -> + case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# -> + unsafeFreezeByteArray# newarr2# s3# + }} + where + copy :: Int# -> Int# + -> MutableByteArray# s -> MutableByteArray# s + -> State# s + -> StateAndMutableByteArray# s + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableByteArray# s# to# + | otherwise + = case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele -> + case (writeDoubleArray# to# cur# ele s1#) of { s2# -> + copy (cur# +# 1#) end# from# to# s2# + }} + +unsafeFreezeArray :: Ix ix => MutableArray s ix elt -> ST s (Array ix elt) +unsafeFreezeByteArray :: Ix ix => MutableByteArray s ix -> ST s (ByteArray ix) + +{-# SPECIALIZE unsafeFreezeByteArray :: MutableByteArray s Int -> ST s (ByteArray Int) + #-} + +unsafeFreezeArray (MutableArray ixs arr#) = ST $ \ s# -> + case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# -> + STret s2# (Array ixs frozen#) } + +unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ s# -> + case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray ixs frozen#) } + + +--This takes a immutable array, and copies it into a mutable array, in a +--hurry. + +{-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt), + Array IPr elt -> ST s (MutableArray s IPr elt) + #-} + +thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt) +thawArray (Array ixs arr#) = ST $ \ s# -> + case rangeSize ixs of { I# n# -> + case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# -> + STret s2# (MutableArray ixs thawed#)}} + where + thaw :: Array# ele -- the thing + -> Int# -- size of thing to be thawed + -> State# s -- the Universe and everything + -> StateAndMutableArray# s ele + + thaw arr# n# s# + = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# -> + copy 0# n# arr# newarr1# s2# } + where + init = error "thawArray: element not copied" + + copy :: Int# -> Int# + -> Array# ele + -> MutableArray# s ele + -> State# s + -> StateAndMutableArray# s ele + + copy cur# end# from# to# s# + | cur# ==# end# + = StateAndMutableArray# s# to# + | otherwise + = case indexArray# from# cur# of { Lift ele -> + case writeArray# to# cur# ele s# of { s1# -> + copy (cur# +# 1#) end# from# to# s1# + }} +\end{code} + +%********************************************************* +%* * +\subsection{Ghastly return types} +%* * +%********************************************************* + +\begin{code} +data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt) +data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt) +data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray# +data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s) +\end{code} diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs new file mode 100644 index 0000000000..3f5bc1df2d --- /dev/null +++ b/ghc/lib/std/PrelBase.lhs @@ -0,0 +1,850 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[PrelBase]{Module @PrelBase@} + + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelBase( + module PrelBase, + module PrelGHC -- Re-export PrelGHC, to avoid lots of people + -- having to import it explicitly + ) where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelGHC + +infixr 9 . +infixl 9 !! +infixl 7 * +infixl 6 +, - +infixr 5 ++, : +infix 4 ==, /=, <, <=, >=, > +infixr 3 && +infixr 2 || +infixl 1 >>, >>= +infixr 0 $ +\end{code} + + +\begin{code} +{- +class Eval a +data Bool = False | True +data Int = I# Int# +data Double = D# Double# +data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) + -- (avoids weird-named functions, e.g., con2tag_()# + +data Maybe a = Nothing | Just a +data Ordering = LT | EQ | GT deriving( Eq ) + +type String = [Char] + +data Char = C# Char# +data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) + -- to avoid weird names like con2tag_[]# + + +-------------- Stage 2 ----------------------- +not True = False +not False = True +True && x = x +False && x = False +otherwise = True + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + +-------------- Stage 3 ----------------------- +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +-- f :: Eq a => a -> a -> Bool +f x y = x == y + +g :: Eq a => a -> a -> Bool +g x y = f x y + +-------------- Stage 4 ----------------------- + +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + +-- An instance of Ord should define either compare or <= +-- Using compare can be more efficient for complex types. + compare x y + | x == y = EQ + | x <= y = LT + | otherwise = GT + + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } + +eqInt (I# x) (I# y) = x ==# y + +instance Eq Int where + (==) x y = x `eqInt` y + +instance Ord Int where + compare x y = error "help" + +class Bounded a where + minBound, maxBound :: a + + +type ShowS = String -> String + +class Show a where + showsPrec :: Bool -> a -> ShowS + showList :: [a] -> ShowS + + showList ls = showList__ (showsPrec True) ls + +showList__ :: (a -> ShowS) -> [a] -> ShowS +showList__ showx [] = showString "[]" + +showString :: String -> ShowS +showString = (++) + +[] ++ [] = [] + +shows :: (Show a) => a -> ShowS +shows = showsPrec True + +-- show :: (Show a) => a -> String +--show x = shows x "" +-} +\end{code} + + +%********************************************************* +%* * +\subsection{Standard classes @Eq@, @Ord@, @Bounded@, @Eval@} +%* * +%********************************************************* + +\begin{code} +class Eq a where + (==), (/=) :: a -> a -> Bool + + x /= y = not (x == y) + +class (Eq a) => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>=), (>):: a -> a -> Bool + max, min :: a -> a -> a + +-- An instance of Ord should define either compare or <= +-- Using compare can be more efficient for complex types. + compare x y + | x == y = EQ + | x <= y = LT + | otherwise = GT + + x <= y = compare x y /= GT + x < y = compare x y == LT + x >= y = compare x y /= LT + x > y = compare x y == GT + max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y } + +class Bounded a where + minBound, maxBound :: a + +class Eval a +\end{code} + +%********************************************************* +%* * +\subsection{Monadic classes @Functor@, @Monad@, @MonadZero@, @MonadPlus@} +%* * +%********************************************************* + +\begin{code} +class Functor f where + map :: (a -> b) -> f a -> f b + +class Monad m where + (>>=) :: m a -> (a -> m b) -> m b + (>>) :: m a -> m b -> m b + return :: a -> m a + + m >> k = m >>= \_ -> k + +class (Monad m) => MonadZero m where + zero :: m a + +class (MonadZero m) => MonadPlus m where + (++) :: m a -> m a -> m a +\end{code} + + +%********************************************************* +%* * +\subsection{Classes @Num@ and @Enum@} +%* * +%********************************************************* + +\begin{code} +class Enum a where + toEnum :: Int -> a + fromEnum :: a -> Int + enumFrom :: a -> [a] -- [n..] + enumFromThen :: a -> a -> [a] -- [n,n'..] + enumFromTo :: a -> a -> [a] -- [n..m] + enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m] + + enumFromTo n m = map toEnum [fromEnum n .. fromEnum m] + enumFromThenTo n n' m + = map toEnum [fromEnum n, fromEnum n' .. fromEnum m] + +class (Eq a, Show a, Eval a) => Num a where + (+), (-), (*) :: a -> a -> a + negate :: a -> a + abs, signum :: a -> a + fromInteger :: Integer -> a + fromInt :: Int -> a -- partain: Glasgow extension + + x - y = x + negate y + fromInt (I# i#) = fromInteger (int2Integer# i#) + -- Go via the standard class-op if the + -- non-standard one ain't provided +\end{code} + +\begin{code} +succ, pred :: Enum a => a -> a +succ = toEnum . (+1) . fromEnum +pred = toEnum . (subtract 1) . fromEnum + +chr = (toEnum :: Int -> Char) +ord = (fromEnum :: Char -> Int) + +ord_0 :: Num a => a +ord_0 = fromInt (ord '0') + +{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-} +subtract :: (Num a) => a -> a -> a +subtract x y = y - x +\end{code} + + +%********************************************************* +%* * +\subsection{The @Show@ class} +%* * +%********************************************************* + +\begin{code} +type ShowS = String -> String + +class Show a where + showsPrec :: Int -> a -> ShowS + showList :: [a] -> ShowS + + showList ls = showList__ (showsPrec 0) ls +\end{code} + +%********************************************************* +%* * +\subsection{The list type} +%* * +%********************************************************* + +\begin{code} +data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord) + -- to avoid weird names like con2tag_[]# + +instance (Eq a) => Eq [a] where + [] == [] = True + (x:xs) == (y:ys) = x == y && xs == ys + xs == ys = False + xs /= ys = if (xs == ys) then False else True + +instance (Ord a) => Ord [a] where + a < b = case compare a b of { LT -> True; EQ -> False; GT -> False } + a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False } + a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True } + a > b = case compare a b of { LT -> False; EQ -> False; GT -> True } + + max a b = case compare a b of { LT -> b; EQ -> a; GT -> a } + min a b = case compare a b of { LT -> a; EQ -> a; GT -> b } + + compare [] [] = EQ + compare (x:xs) [] = GT + compare [] (y:ys) = LT + compare (x:xs) (y:ys) = case compare x y of + LT -> LT + GT -> GT + EQ -> compare xs ys + +instance Functor [] where + map f [] = [] + map f (x:xs) = f x : map f xs + +instance Monad [] where + m >>= k = foldr ((++) . k) [] m + m >> k = foldr ((++) . (\ _ -> k)) [] m + return x = [x] + +instance MonadZero [] where + zero = [] + +instance MonadPlus [] where +#ifdef USE_REPORT_PRELUDE + xs ++ ys = foldr (:) ys xs +#else + [] ++ ys = ys + (x:xs) ++ ys = x : (xs ++ ys) +#endif + +instance (Show a) => Show [a] where + showsPrec p = showList + showList ls = showList__ (showsPrec 0) ls +\end{code} + +\end{code} + +A few list functions that appear here because they are used here. +The rest of the prelude list functions are in PrelList. + +\begin{code} +foldr :: (a -> b -> b) -> b -> [a] -> b +foldr f z [] = z +foldr f z (x:xs) = f x (foldr f z xs) + +-- takeWhile, applied to a predicate p and a list xs, returns the longest +-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs +-- returns the remaining suffix. Span p xs is equivalent to +-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p. + +takeWhile :: (a -> Bool) -> [a] -> [a] +takeWhile p [] = [] +takeWhile p (x:xs) + | p x = x : takeWhile p xs + | otherwise = [] + +dropWhile :: (a -> Bool) -> [a] -> [a] +dropWhile p [] = [] +dropWhile p xs@(x:xs') + | p x = dropWhile p xs' + | otherwise = xs + +-- List index (subscript) operator, 0-origin +(!!) :: [a] -> Int -> a +#ifdef USE_REPORT_PRELUDE +(x:_) !! 0 = x +(_:xs) !! n | n > 0 = xs !! (n-1) +(_:_) !! _ = error "PreludeList.!!: negative index" +[] !! _ = error "PreludeList.!!: index too large" +#else +-- HBC version (stolen), then unboxified +-- The semantics is not quite the same for error conditions +-- in the more efficient version. +-- +_ !! n | n < 0 = error "(!!){PreludeList}: negative index\n" +xs !! n = sub xs (case n of { I# n# -> n# }) + where sub :: [a] -> Int# -> a + sub [] _ = error "(!!){PreludeList}: index too large\n" + sub (x:xs) n# = if n# ==# 0# + then x + else sub xs (n# -# 1#) +#endif +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Void@} +%* * +%********************************************************* + +The type @Void@ is built in, but it needs a @Show@ instance. + +\begin{code} +void :: Void +void = error "You tried to evaluate void" + +instance Show Void where + showsPrec p f = showString "<<void>>" + showList ls = showList__ (showsPrec 0) ls +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Bool@} +%* * +%********************************************************* + +\begin{code} +data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) + +-- Boolean functions + +(&&), (||) :: Bool -> Bool -> Bool +True && x = x +False && x = False +True || x = True +False || x = x + +not :: Bool -> Bool +not True = False +not False = True + +otherwise :: Bool +otherwise = True +\end{code} + + +%********************************************************* +%* * +\subsection{The @()@ type} +%* * +%********************************************************* + +The Unit type is here because virtually any program needs it (whereas +some programs may get away without consulting PrelTup). Furthermore, +the renamer currently *always* asks for () to be in scope, so that +ccalls can use () as their default type; so when compiling PrelBase we +need (). (We could arrange suck in () only if -fglasgow-exts, but putting +it here seems more direct. + +\begin{code} +data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded) + -- (avoids weird-named functions, e.g., con2tag_()# + +instance Eq () where + () == () = True + () /= () = False + +instance Ord () where + () <= () = True + () < () = False + () >= () = True + () > () = False + max () () = () + min () () = () + compare () () = EQ + +instance Enum () where + toEnum 0 = () + toEnum _ = error "Prelude.Enum.().toEnum: argument not 0" + fromEnum () = 0 + enumFrom () = [()] + enumFromThen () () = [()] + enumFromTo () () = [()] + enumFromThenTo () () () = [()] + +instance Show () where + showsPrec p () = showString "()" + showList ls = showList__ (showsPrec 0) ls +\end{code} + +%********************************************************* +%* * +\subsection{Type @Ordering@} +%* * +%********************************************************* + +\begin{code} +data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Bounded, Show {- Read -}) +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Char@ and @String@} +%* * +%********************************************************* + +\begin{code} +type String = [Char] + +data Char = C# Char# deriving (Eq, Ord) + +instance Enum Char where + toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i) + | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i)) + fromEnum (C# c) = I# (ord# c) + + enumFrom (C# c) = efttCh (ord# c) 1# (># 255#) + enumFromTo (C# c1) (C# c2) = efttCh (ord# c1) 1# (># (ord# c2)) + + enumFromThen (C# c1) (C# c2) + | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># 255#) + | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# 0#) + + enumFromThenTo (C# c1) (C# c2) (C# c3) + | c1 `leChar#` c2 = efttCh (ord# c1) (ord# c2 -# ord# c1) (># (ord# c3)) + | otherwise = efttCh (ord# c1) (ord# c2 -# ord# c1) (<# (ord# c3)) + +efttCh :: Int# -> Int# -> (Int# -> Bool) -> [Char] +efttCh now step done + = go now + where + go now | done now = [] + | otherwise = C# (chr# now) : go (now +# step) + +instance Show Char where + showsPrec p '\'' = showString "'\\''" + showsPrec p c = showChar '\'' . showLitChar c . showChar '\'' + + showList cs = showChar '"' . showl cs + where showl "" = showChar '"' + showl ('"':cs) = showString "\\\"" . showl cs + showl (c:cs) = showLitChar c . showl cs +\end{code} + + +\begin{code} +isAscii, isLatin1, isControl, isPrint, isSpace, isUpper, + isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool +isAscii c = fromEnum c < 128 +isLatin1 c = c <= '\xff' +isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f' +isPrint c = not (isControl c) + +-- isSpace includes non-breaking space +-- Done with explicit equalities both for efficiency, and to avoid a tiresome +-- recursion with PrelList elem +isSpace c = c == ' ' || + c == '\t' || + c == '\n' || + c == '\r' || + c == '\f' || + c == '\v' || + c == '\xa0' + +-- The upper case ISO characters have the multiplication sign dumped +-- randomly in the middle of the range. Go figure. +isUpper c = c >= 'A' && c <= 'Z' || + c >= '\xC0' && c <= '\xD6' || + c >= '\xD8' && c <= '\xDE' +-- The lower case ISO characters have the division sign dumped +-- randomly in the middle of the range. Go figure. +isLower c = c >= 'a' && c <= 'z' || + c >= '\xDF' && c <= '\xF6' || + c >= '\xF8' && c <= '\xFF' +isAlpha c = isLower c || isUpper c +isDigit c = c >= '0' && c <= '9' +isOctDigit c = c >= '0' && c <= '7' +isHexDigit c = isDigit c || c >= 'A' && c <= 'F' || + c >= 'a' && c <= 'f' +isAlphanum c = isAlpha c || isDigit c + +-- Case-changing operations + +toUpper, toLower :: Char -> Char +toUpper c | isLower c && c /= '\xDF' && c /= '\xFF' + = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A') + | otherwise = c + +toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A' + + fromEnum 'a') + | otherwise = c + +asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ') + ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", + "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", + "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", + "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US", + "SP"] +\end{code} + +%********************************************************* +%* * +\subsection{Type @Int@} +%* * +%********************************************************* + +\begin{code} +data Int = I# Int# + +instance Eq Int where + (==) x y = x `eqInt` y + (/=) x y = x `neInt` y + +instance Ord Int where + compare x y = compareInt x y + + (<) x y = ltInt x y + (<=) x y = leInt x y + (>=) x y = geInt x y + (>) x y = gtInt x y + max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x } + min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y } + +(I# x) `compareInt` (I# y) | x <# y = LT + | x ==# y = EQ + | otherwise = GT + +instance Enum Int where + toEnum x = x + fromEnum x = x + +#ifndef USE_FOLDR_BUILD + enumFrom (I# c) = eftInt c 1# + enumFromTo (I# c1) (I# c2) = efttInt c1 1# (># c2) + enumFromThen (I# c1) (I# c2) = eftInt c1 (c2 -# c1) + + enumFromThenTo (I# c1) (I# c2) (I# c3) + | c1 <=# c2 = efttInt c1 (c2 -# c1) (># c3) + | otherwise = efttInt c1 (c2 -# c1) (<# c3) + +#else + {-# INLINE enumFrom #-} + {-# INLINE enumFromTo #-} + enumFrom x = build (\ c _ -> + let g x = x `c` g (x `plusInt` 1) in g x) + enumFromTo x y = build (\ c n -> + let g x = if x <= y then x `c` g (x `plusInt` 1) else n in g x) +#endif + +efttInt :: Int# -> Int# -> (Int# -> Bool) -> [Int] +efttInt now step done + = go now + where + go now | done now = [] + | otherwise = I# now : go (now +# step) + +eftInt :: Int# -> Int# -> [Int] +eftInt now step + = go now + where + go now = I# now : go (now +# step) + + +instance Num Int where + (+) x y = plusInt x y + (-) x y = minusInt x y + negate x = negateInt x + (*) x y = timesInt x y + abs n = if n `geInt` 0 then n else (negateInt n) + + signum n | n `ltInt` 0 = negateInt 1 + | n `eqInt` 0 = 0 + | otherwise = 1 + + fromInteger (J# a# s# d#) + = case (integer2Int# a# s# d#) of { i# -> I# i# } + + fromInt n = n + +instance Show Int where + showsPrec p n = showSignedInt p n + showList ls = showList__ (showsPrec 0) ls +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Integer@, @Float@, @Double@} +%* * +%********************************************************* + +Just the type declarations. If we don't actually use any @Integers@ we'd +rather not link the @Integer@ module at all; and the default-decl stuff +in the renamer tends to slurp in @Double@ regardless. + +\begin{code} +data Float = F# Float# +data Double = D# Double# +data Integer = J# Int# Int# ByteArray# +\end{code} + + +%********************************************************* +%* * +\subsection{The function type} +%* * +%********************************************************* + +\begin{code} +instance Eval (a -> b) + +instance Show (a -> b) where + showsPrec p f = showString "<<function>>" + showList ls = showList__ (showsPrec 0) ls + + +-- identity function +id :: a -> a +id x = x + +-- constant function +const :: a -> b -> a +const x _ = x + +-- function composition +{-# INLINE (.) #-} +{-# GENERATE_SPECS (.) a b c #-} +(.) :: (b -> c) -> (a -> b) -> a -> c +(.) f g x = f (g x) + +-- flip f takes its (first) two arguments in the reverse order of f. +flip :: (a -> b -> c) -> b -> a -> c +flip f x y = f y x + +-- right-associating infix application operator (useful in continuation- +-- passing style) +($) :: (a -> b) -> a -> b +f $ x = f x + +-- until p f yields the result of applying f until p holds. +until :: (a -> Bool) -> (a -> a) -> a -> a +until p f x | p x = x + | otherwise = until p f (f x) + +-- asTypeOf is a type-restricted version of const. It is usually used +-- as an infix operator, and its typing forces its first argument +-- (which is usually overloaded) to have the same type as the second. +asTypeOf :: a -> a -> a +asTypeOf = const +\end{code} + + +%********************************************************* +%* * +\subsection{Miscellaneous} +%* * +%********************************************************* + + +\begin{code} +data Lift a = Lift a +{-# GENERATE_SPECS data a :: Lift a #-} +\end{code} + + + + +%********************************************************* +%* * +\subsection{Support code for @Show@} +%* * +%********************************************************* + +\begin{code} +shows :: (Show a) => a -> ShowS +shows = showsPrec 0 + +show :: (Show a) => a -> String +show x = shows x "" + +showChar :: Char -> ShowS +showChar = (:) + +showString :: String -> ShowS +showString = (++) + +showParen :: Bool -> ShowS -> ShowS +showParen b p = if b then showChar '(' . p . showChar ')' else p + +{-# GENERATE_SPECS showList__ a #-} +showList__ :: (a -> ShowS) -> [a] -> ShowS + +showList__ showx [] = showString "[]" +showList__ showx (x:xs) = showChar '[' . showx x . showl xs + where + showl [] = showChar ']' + showl (x:xs) = showString ", " . showx x . showl xs + +showSpace :: ShowS +showSpace = {-showChar ' '-} \ xs -> ' ' : xs +\end{code} + +Code specific for characters + +\begin{code} +showLitChar :: Char -> ShowS +showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c)) +showLitChar '\DEL' = showString "\\DEL" +showLitChar '\\' = showString "\\\\" +showLitChar c | c >= ' ' = showChar c +showLitChar '\a' = showString "\\a" +showLitChar '\b' = showString "\\b" +showLitChar '\f' = showString "\\f" +showLitChar '\n' = showString "\\n" +showLitChar '\r' = showString "\\r" +showLitChar '\t' = showString "\\t" +showLitChar '\v' = showString "\\v" +showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO") +showLitChar c = showString ('\\' : asciiTab!!ord c) + +protectEsc p f = f . cont + where cont s@(c:_) | p c = "\\&" ++ s + cont s = s + +intToDigit :: Int -> Char +intToDigit i + | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) + | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i -10) + | otherwise = error "Char.intToDigit: not a digit" ++ show i) + +\end{code} + +Code specific for Ints. + +\begin{code} +showSignedInt :: Int -> Int -> ShowS +showSignedInt p (I# n) r + = -- from HBC version; support code follows + if n <# 0# && p > 6 then '(':itos n++(')':r) else itos n ++ r + +itos :: Int# -> String +itos n = + if n <# 0# then + if negateInt# n <# 0# then + -- n is minInt, a difficult number + itos (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) [] + else + '-':itos' (negateInt# n) [] + else + itos' n [] + where + itos' :: Int# -> String -> String + itos' n cs = + if n <# 10# then + C# (chr# (n +# ord# '0'#)) : cs + else + itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# +# ord# '0'#)) : cs) +\end{code} + +%********************************************************* +%* * +\subsection{Numeric primops} +%* * +%********************************************************* + +Definitions of the boxed PrimOps; these will be +used in the case of partial applications, etc. + +\begin{code} +{-# INLINE eqInt #-} +{-# INLINE neInt #-} + +plusInt (I# x) (I# y) = I# (x +# y) +minusInt(I# x) (I# y) = I# (x -# y) +timesInt(I# x) (I# y) = I# (x *# y) +quotInt (I# x) (I# y) = I# (quotInt# x y) +remInt (I# x) (I# y) = I# (remInt# x y) +negateInt (I# x) = I# (negateInt# x) +gtInt (I# x) (I# y) = x ># y +geInt (I# x) (I# y) = x >=# y +eqInt (I# x) (I# y) = x ==# y +neInt (I# x) (I# y) = x /=# y +ltInt (I# x) (I# y) = x <# y +leInt (I# x) (I# y) = x <=# y +\end{code} diff --git a/ghc/lib/std/PrelBounded.lhs b/ghc/lib/std/PrelBounded.lhs new file mode 100644 index 0000000000..3d1d0fd68c --- /dev/null +++ b/ghc/lib/std/PrelBounded.lhs @@ -0,0 +1,26 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[PrelBounded]{Module @PrelBounded@} + +Instances of Bounded for various datatypes. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelBounded where + +import PrelBase + +instance Bounded () where + minBound = () + maxBound = () + +instance Bounded Char where + minBound = '\0' + maxBound = '\255' + +instance Bounded Int where + minBound = -2147483648 -- GHC <= 2.09 had this at -2147483647 + maxBound = 2147483647 +\end{code} diff --git a/ghc/lib/std/PrelCCall.lhs b/ghc/lib/std/PrelCCall.lhs new file mode 100644 index 0000000000..6f886ff7bd --- /dev/null +++ b/ghc/lib/std/PrelCCall.lhs @@ -0,0 +1,53 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelCCall]{Module @PrelCCall@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelCCall ( + CCallable(..), CReturnable(..), + Word(..) + ) where + +import PrelBase +import PrelGHC +\end{code} + +%********************************************************* +%* * +\subsection{Classes @CCallable@ and @CReturnable@} +%* * +%********************************************************* + +\begin{code} +instance CCallable Char +instance CCallable Char# +instance CReturnable Char + +instance CCallable Int +instance CCallable Int# +instance CReturnable Int + +-- DsCCall knows how to pass strings... +instance CCallable [Char] + +instance CCallable Float +instance CCallable Float# +instance CReturnable Float + +instance CCallable Double +instance CCallable Double# +instance CReturnable Double + +data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension + +instance CCallable Word +instance CCallable Word# +instance CReturnable Word + +instance CReturnable () -- Why, exactly? +\end{code} + diff --git a/ghc/lib/std/PrelConc.lhs b/ghc/lib/std/PrelConc.lhs new file mode 100644 index 0000000000..04d6d6051e --- /dev/null +++ b/ghc/lib/std/PrelConc.lhs @@ -0,0 +1,174 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelConc]{Module @PrelConc@} + +Basic concurrency stuff + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} +module PrelConc( + -- Forking and suchlike + ST, forkST, + IO, forkIO, + par, fork, + threadDelay, threadWaitRead, threadWaitWrite, + + -- MVars + MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar + ) where + +import PrelBase +import PrelST ( ST(..), STret(..), StateAndPtr#(..) ) +import PrelIOBase ( IO(..), IOResult(..), MVar(..) ) +import PrelErr ( parError ) +import PrelBase ( Int(..) ) +import PrelGHC ( fork#, delay#, waitRead#, waitWrite#, + SynchVar#, newSynchVar#, takeMVar#, putMVar#, + State#, RealWorld, par# + ) + +infixr 0 `par`, `fork` +\end{code} + + + +%************************************************************************ +%* * +\subsection{@par@, and @fork@} +%* * +%************************************************************************ + +\begin{code} +forkST :: ST s a -> ST s a + +forkST (ST action) = ST $ \ s -> + let d@(STret _ r) = action s in + d `fork` STret s r + +forkIO :: IO () -> IO () +forkIO (IO action) = IO $ \ s -> (action s) `fork` IOok s () + +par, fork :: Eval a => a -> b -> b + +{-# INLINE par #-} +{-# INLINE fork #-} + +#if defined(__PARALLEL_HASKELL__) || defined (__GRANSIM__) +par x y = case (par# x) of { 0# -> parError; _ -> y } +#else +par x y = y +#endif + +#if defined(__CONCURRENT_HASKELL__) || defined (__GRANSIM__) +fork x y = case (fork# x) of { 0# -> parError; _ -> y } +#else +fork x y = y +#endif + +runOrBlockIO m = m -- ????? + +\end{code} + +%************************************************************************ +%* * +\subsection[mvars]{M-Structures} +%* * +%************************************************************************ + +M-Vars are rendezvous points for concurrent threads. They begin +empty, and any attempt to read an empty M-Var blocks. When an M-Var +is written, a single blocked thread may be freed. Reading an M-Var +toggles its state from full back to empty. Therefore, any value +written to an M-Var may only be read once. Multiple reads and writes +are allowed, but there must be at least one read between any two +writes. + +\begin{code} +--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a) + +newEmptyMVar :: IO (MVar a) + +newEmptyMVar = IO $ \ s# -> + case newSynchVar# s# of + StateAndSynchVar# s2# svar# -> IOok s2# (MVar svar#) + +takeMVar :: MVar a -> IO a + +takeMVar (MVar mvar#) = IO $ \ s# -> + case takeMVar# mvar# s# of + StateAndPtr# s2# r -> IOok s2# r + +putMVar :: MVar a -> a -> IO () + +putMVar (MVar mvar#) x = IO $ \ s# -> + case putMVar# mvar# x s# of + s2# -> IOok s2# () + +newMVar :: a -> IO (MVar a) + +newMVar value = + newEmptyMVar >>= \ mvar -> + putMVar mvar value >> + return mvar + +readMVar :: MVar a -> IO a + +readMVar mvar = + takeMVar mvar >>= \ value -> + putMVar mvar value >> + return value + +swapMVar :: MVar a -> a -> IO a + +swapMVar mvar new = + takeMVar mvar >>= \ old -> + putMVar mvar new >> + return old +\end{code} + + +%************************************************************************ +%* * +\subsection{Thread waiting} +%* * +%************************************************************************ + +@threadDelay@ delays rescheduling of a thread until the indicated +number of microseconds have elapsed. Generally, the microseconds are +counted by the context switch timer, which ticks in virtual time; +however, when there are no runnable threads, we don't accumulate any +virtual time, so we start ticking in real time. (The granularity is +the effective resolution of the context switch timer, so it is +affected by the RTS -C option.) + +@threadWaitRead@ delays rescheduling of a thread until input on the +specified file descriptor is available for reading (just like select). +@threadWaitWrite@ is similar, but for writing on a file descriptor. + +\begin{code} +threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () + +threadDelay (I# x#) = IO $ \ s# -> + case delay# x# s# of + s2# -> IOok s2# () + +threadWaitRead (I# x#) = IO $ \ s# -> + case waitRead# x# s# of + s2# -> IOok s2# () + +threadWaitWrite (I# x#) = IO $ \ s# -> + case waitWrite# x# s# of + s2# -> IOok s2# () +\end{code} + +%********************************************************* +%* * +\subsection{Ghastly return types} +%* * +%********************************************************* + +\begin{code} +data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt) +\end{code} diff --git a/ghc/lib/std/PrelEither.lhs b/ghc/lib/std/PrelEither.lhs new file mode 100644 index 0000000000..71969aa912 --- /dev/null +++ b/ghc/lib/std/PrelEither.lhs @@ -0,0 +1,20 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1997 +% +\section[PrelEither]{Module @PrelEither@} + +The @Either@ Type. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelEither where + +import PrelBase + +data Either a b = Left a | Right b deriving (Eq, Ord, Show {- Read -} ) + +either :: (a -> c) -> (b -> c) -> Either a b -> c +either f g (Left x) = f x +either f g (Right y) = g y +\end{code} diff --git a/ghc/lib/std/PrelErr.hi-boot b/ghc/lib/std/PrelErr.hi-boot new file mode 100644 index 0000000000..629034907f --- /dev/null +++ b/ghc/lib/std/PrelErr.hi-boot @@ -0,0 +1,12 @@ +--------------------------------------------------------------------------- +-- PrelErr.hi-boot +-- +-- This hand-written interface file is the initial bootstrap version +-- for PrelErr.hi. +-- It doesn't need to give "error" a type signature, +-- because it's wired into the compiler +--------------------------------------------------------------------------- + +_interface_ PrelErr 1 +_exports_ +PrelErr error; diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs new file mode 100644 index 0000000000..643900e916 --- /dev/null +++ b/ghc/lib/std/PrelErr.lhs @@ -0,0 +1,180 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelErr]{Module @PrelErr@} + +The PrelErr module defines the code for the wired-in error functions, +which have a special type in the compiler (with "open tyvars"). + +We cannot define these functions in a module where they might be used +(e.g., PrelBase), because the magical wired-in type will get confused +with what the typechecker figures out. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} +module PrelErr + + ( + irrefutPatError + , noMethodBindingError + , nonExhaustiveGuardsError + , patError + , recConError + , recUpdError -- :: String -> a + + , absentErr, parError -- :: a + , seqError -- :: a + + , error -- :: String -> a + , ioError -- :: String -> a + , assert__ -- :: String -> Bool -> a -> a + ) where + +--import Prelude +import PrelBase +import PrelIOBase +import PrelAddr +import PrelForeign ( StablePtr, deRefStablePtr ) +import PrelList ( span ) + + +--------------------------------------------------------------- +-- HACK: Magic unfoldings not implemented for unboxed lists +-- Need to define a "build" to avoid undefined symbol +-- in this module to avoid .hi proliferation. + +build = error "GHCbase.build" +augment = error "GHCbase.augment" +--{-# GENERATE_SPECS build a #-} +--build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +--build g = g (:) [] +\end{code} + +%********************************************************* +%* * +\subsection{Error-ish functions} +%* * +%********************************************************* + +\begin{code} +errorIO :: IO () -> a + +errorIO (IO io) + = case (errorIO# io) of + _ -> bottom + where + bottom = bottom -- Never evaluated + +ioError :: String -> a +ioError s = error__ ( \ x -> _ccall_ IOErrorHdrHook x ) s + +-- error stops execution and displays an error message +error :: String -> a +error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s + +error__ :: (Addr{-FILE *-} -> IO ()) -> String -> a + +error__ msg_hdr s +#ifdef __PARALLEL_HASKELL__ + = errorIO (msg_hdr sTDERR{-msg hdr-} >> + _ccall_ fflush sTDERR >> + fputs sTDERR s >> + _ccall_ fflush sTDERR >> + _ccall_ stg_exit (1::Int) + ) +#else + = errorIO (msg_hdr sTDERR{-msg hdr-} >> + _ccall_ fflush sTDERR >> + fputs sTDERR s >> + _ccall_ fflush sTDERR >> + _ccall_ getErrorHandler >>= \ errorHandler -> + if errorHandler == (-1::Int) then + _ccall_ stg_exit (1::Int) + else + _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler + >>= \ osptr -> + _ccall_ decrementErrorCount >>= \ () -> + deRefStablePtr osptr >>= \ oact -> + oact + ) +#endif {- !parallel -} + where + sTDERR = (``stderr'' :: Addr) +\end{code} + +%********************************************************* +%* * +\subsection{Compiler generated errors + local utils} +%* * +%********************************************************* + +Used for compiler-generated error message; +encoding saves bytes of string junk. + +\begin{code} +absentErr, parError, seqError :: a + +absentErr = error "Oops! The program has entered an `absent' argument!\n" +parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n" +seqError = error "Oops! Entered seqError (a GHC bug -- please report it!)\n" + +\end{code} + +\begin{code} +irrefutPatError + , noMethodBindingError + --, noExplicitMethodError + , nonExhaustiveGuardsError + , patError + , recConError + , recUpdError :: String -> a + +--noDefaultMethodError s = error ("noDefaultMethodError:"++s) +--noExplicitMethodError s = error ("No default method for class operation "++s) +noMethodBindingError s = error (untangle s "No instance nor default method for class operation") +irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern") +nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in") +patError s = error (untangle s "Non-exhaustive patterns in") +recConError s = error (untangle s "Missing field in record construction:") +recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated") + + +assert__ :: String -> Bool -> a -> a +assert__ str pred v + | pred = v + | otherwise = error (untangle str "Assertion failed") + +\end{code} + + +(untangle coded message) expects "coded" to be of the form + + "location|details" + +It prints + + location message details + +\begin{code} +untangle coded message + = location + ++ ": " + ++ message + ++ details + ++ "\n" + where + (location, details) + = case (span not_bar coded) of { (location, rest) -> + case rest of + ('|':details) -> (location, ' ' : details) + _ -> (location, "") + } + not_bar c = c /= '|' +\end{code} + +-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook, +-- but the former does exactly the same as the latter, so I nuked it. +-- SLPJ Jan 97 +-- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x) + diff --git a/ghc/lib/std/PrelForeign.lhs b/ghc/lib/std/PrelForeign.lhs new file mode 100644 index 0000000000..7a5c6d27a1 --- /dev/null +++ b/ghc/lib/std/PrelForeign.lhs @@ -0,0 +1,162 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[Foreign]{Module @Foreign@} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelForeign ( + module PrelForeign, +#ifndef __PARALLEL_HASKELL__ + ForeignObj(..), +#endif + Word(..), + +#ifndef __PARALLEL_HASKELL__ + unpackCStringFO, -- :: ForeignObj -> [Char] + unpackNBytesFO, -- :: ForeignObj -> Int -> [Char] + unpackCStringFO#, -- :: ForeignObj# -> [Char] + unpackNBytesFO# -- :: ForeignObj# -> Int# -> [Char] +#endif + ) where + +import PrelIOBase +import PrelST +import PrelUnsafe +import PrelBase +import PrelCCall +import PrelAddr +import PrelGHC +\end{code} + + +%********************************************************* +%* * +\subsection{Type @ForeignObj@ and its operations} +%* * +%********************************************************* + +\begin{code} +#ifndef __PARALLEL_HASKELL__ +instance CCallable ForeignObj +instance CCallable ForeignObj# + +eqForeignObj :: ForeignObj -> ForeignObj -> Bool +makeForeignObj :: Addr -> Addr -> IO ForeignObj +writeForeignObj :: ForeignObj -> Addr -> IO () + +{- derived op - attaching a free() finaliser to a malloc() allocated reference. -} +makeMallocPtr :: Addr -> IO ForeignObj + +makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# -> + case makeForeignObj# obj finaliser s# of + StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#)) + +writeForeignObj (ForeignObj fo#) (A# datum#) = IO ( \ s# -> + case writeForeignObj# fo# datum# s# of { s1# -> IOok s1# () } ) + +makeMallocPtr a = makeForeignObj a (``&free''::Addr) + +eqForeignObj mp1 mp2 + = unsafePerformIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int) + +instance Eq ForeignObj where + p == q = eqForeignObj p q + p /= q = not (eqForeignObj p q) +#endif /* !__PARALLEL_HASKELL__ */ +\end{code} + +%********************************************************* +%* * +\subsection{Type @StablePtr@ and its operations} +%* * +%********************************************************* + +\begin{code} +#ifndef __PARALLEL_HASKELL__ +data StablePtr a = StablePtr (StablePtr# a) +instance CCallable (StablePtr a) +instance CCallable (StablePtr# a) +instance CReturnable (StablePtr a) + +-- Nota Bene: it is important {\em not\/} to inline calls to +-- @makeStablePtr#@ since the corresponding macro is very long and we'll +-- get terrible code-bloat. + +makeStablePtr :: a -> IO (StablePtr a) +deRefStablePtr :: StablePtr a -> IO a +freeStablePtr :: StablePtr a -> IO () + +{-# INLINE deRefStablePtr #-} +{-# INLINE freeStablePtr #-} + +makeStablePtr f = IO $ \ rw1# -> + case makeStablePtr# f rw1# of + StateAndStablePtr# rw2# sp# -> IOok rw2# (StablePtr sp#) + +deRefStablePtr (StablePtr sp#) = IO $ \ rw1# -> + case deRefStablePtr# sp# rw1# of + StateAndPtr# rw2# a -> IOok rw2# a + +freeStablePtr sp = _ccall_ freeStablePointer sp + +#endif /* !__PARALLEL_HASKELL__ */ +\end{code} + +%********************************************************* +%* * +\subsection{Ghastly return types} +%* * +%********************************************************* + +\begin{code} +#ifndef __PARALLEL_HASKELL__ +data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a) +#endif +data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj# +\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). + +\begin{code} +#ifndef __PARALLEL_HASKELL__ +unpackCStringFO :: ForeignObj -> [Char] +unpackCStringFO (ForeignObj fo#) = unpackCStringFO# fo# + +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 + +unpackNBytesFO :: ForeignObj -> Int -> [Char] +unpackNBytesFO (ForeignObj fo) (I# l) = unpackNBytesFO# fo l + +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 +#endif +\end{code} + + diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot new file mode 100644 index 0000000000..9d8a1b2031 --- /dev/null +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -0,0 +1,240 @@ +--------------------------------------------------------------------------- +-- GHC.hi +-- +-- This hand-written interface file allows you to bring into scope the +-- primitive operations and types that GHC knows about. +--------------------------------------------------------------------------- + +_interface_ PrelGHC 2 +_exports_ +PrelGHC + -> + + All -- Pseudo class used for universal quantification + CCallable + CReturnable + + Void +-- void CAF is defined in PrelBase + +-- I/O primitives + RealWorld + realWorld# + State# + + fork# + delay# + seq# + par# + parGlobal# + parLocal# + parAt# + parAtAbs# + parAtRel# + parAtForNow# + + SynchVar# + newSynchVar# + takeMVar# + putMVar# + waitRead# + waitWrite# + + errorIO# + + Char# + gtChar# + geChar# + eqChar# + neChar# + ltChar# + leChar# + ord# + chr# + + Int# + ># + >=# + ==# + /=# + <# + <=# + +# + -# + *# + /# + quotInt# + remInt# + negateInt# + iShiftL# + iShiftRA# + iShiftRL# + + Word# + gtWord# + geWord# + eqWord# + neWord# + ltWord# + leWord# + quotWord# + remWord# + and# + or# + not# + xor# + shiftL# + shiftRA# + shiftRL# + int2Word# + word2Int# + + Addr# + gtAddr# + geAddr# + eqAddr# + neAddr# + ltAddr# + leAddr# + int2Addr# + addr2Int# + + Float# + gtFloat# + geFloat# + eqFloat# + neFloat# + ltFloat# + leFloat# + plusFloat# + minusFloat# + timesFloat# + divideFloat# + negateFloat# + float2Int# + int2Float# + expFloat# + logFloat# + sqrtFloat# + sinFloat# + cosFloat# + tanFloat# + asinFloat# + acosFloat# + atanFloat# + sinhFloat# + coshFloat# + tanhFloat# + powerFloat# + decodeFloat# + encodeFloat# + + Double# + >## + >=## + ==## + /=## + <## + <=## + +## + -## + *## + /## + negateDouble# + double2Int# + int2Double# + double2Float# + float2Double# + expDouble# + logDouble# + sqrtDouble# + sinDouble# + cosDouble# + tanDouble# + asinDouble# + acosDouble# + atanDouble# + sinhDouble# + coshDouble# + tanhDouble# + **## + decodeDouble# + encodeDouble# + + cmpInteger# + negateInteger# + plusInteger# + minusInteger# + timesInteger# + quotRemInteger# + integer2Int# + int2Integer# + word2Integer# + + Array# + ByteArray# + MutableArray# + MutableByteArray# + + sameMutableArray# + sameMutableByteArray# + + newArray# + newCharArray# + newIntArray# + newFloatArray# + newDoubleArray# + newAddrArray# + + indexArray# + indexCharArray# + indexIntArray# + indexFloatArray# + indexDoubleArray# + indexAddrArray# + +-- indexOffAddr# +indexCharOffAddr# +indexIntOffAddr# +indexAddrOffAddr# +indexFloatOffAddr# +indexDoubleOffAddr# + +-- indexOffForeignObj# +indexCharOffForeignObj# +indexIntOffForeignObj# +indexAddrOffForeignObj# +indexFloatOffForeignObj# +indexDoubleOffForeignObj# + + writeArray# + writeCharArray# + writeIntArray# + writeFloatArray# + writeDoubleArray# + writeAddrArray# + + readArray# + readCharArray# + readIntArray# + readFloatArray# + readDoubleArray# + readAddrArray# + + unsafeFreezeArray# + unsafeFreezeByteArray# + + ForeignObj# + makeForeignObj# + writeForeignObj# + + StablePtr# + makeStablePtr# + deRefStablePtr# + reallyUnsafePtrEquality# +; + +_declarations_ + +1 class CCallable a :: ** ; +1 class CReturnable a :: ** ; diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs new file mode 100644 index 0000000000..a597284fcd --- /dev/null +++ b/ghc/lib/std/PrelHandle.lhs @@ -0,0 +1,894 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelHandle]{Module @PrelHandle@} + +This module defines Haskell {\em handles} and the basic operations +which are supported for them. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} +#include "error.h" + + +module PrelHandle where + +import PrelST +import PrelArr ( ByteArray(..), newVar, readVar, writeVar ) +import PrelRead ( Read ) +import PrelList ( span ) +import PrelIOBase +import PrelUnsafe ( unsafePerformIO ) +import PrelTup +import PrelMaybe +import PrelBase +import PrelAddr +import PrelErr ( error ) +import PrelGHC +import Ix + +#ifndef __PARALLEL_HASKELL__ +import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj ) +#endif + +import PrelConc -- concurrent only +\end{code} + + +%********************************************************* +%* * +\subsection{Types @FilePath@, @Handle@, @Handle__@} +%* * +%********************************************************* + +The @Handle@ and @Handle__@ types are defined in @IOBase@. + +\begin{code} +type FilePath = String + +{-# INLINE newHandle #-} +{-# INLINE readHandle #-} +{-# INLINE writeHandle #-} +newHandle :: Handle__ -> IO Handle +readHandle :: Handle -> IO Handle__ +writeHandle :: Handle -> Handle__ -> IO () + +#if defined(__CONCURRENT_HASKELL__) + +-- Use MVars for concurrent Haskell +newHandle hc = newMVar hc >>= \ h -> + return (Handle h) + +readHandle (Handle h) = takeMVar h +writeHandle (Handle h) hc = putMVar h hc + +#else + +-- Use ordinary MutableVars for non-concurrent Haskell +newHandle hc = stToIO (newVar hc >>= \ h -> + return (Handle h)) + +readHandle (Handle h) = stToIO (readVar h) +writeHandle (Handle h) hc = stToIO (writeVar h hc) + +#endif +\end{code} + +%********************************************************* +%* * +\subsection{Functions} +%* * +%********************************************************* + +\begin{code} +#ifndef __PARALLEL_HASKELL__ +filePtr :: Handle__ -> ForeignObj +#else +filePtr :: Handle__ -> Addr +#endif +filePtr (SemiClosedHandle fp _) = fp +filePtr (ReadHandle fp _ _) = fp +filePtr (WriteHandle fp _ _) = fp +filePtr (AppendHandle fp _ _) = fp +filePtr (ReadWriteHandle fp _ _) = fp + +bufferMode :: Handle__ -> Maybe BufferMode +bufferMode (ReadHandle _ m _) = m +bufferMode (WriteHandle _ m _) = m +bufferMode (AppendHandle _ m _) = m +bufferMode (ReadWriteHandle _ m _) = m + +markHandle :: Handle__ -> Handle__ +markHandle h@(ReadHandle fp m b) + | b = h + | otherwise = ReadHandle fp m True +markHandle h@(WriteHandle fp m b) + | b = h + | otherwise = WriteHandle fp m True +markHandle h@(AppendHandle fp m b) + | b = h + | otherwise = AppendHandle fp m True +markHandle h@(ReadWriteHandle fp m b) + | b = h + | otherwise = ReadWriteHandle fp m True +\end{code} + +------------------------------------------- + +%********************************************************* +%* * +\subsection[StdHandles]{Standard handles} +%* * +%********************************************************* + +Three handles are allocated during program initialisation. The first +two manage input or output from the Haskell program's standard input +or output channel respectively. The third manages output to the +standard error channel. These handles are initially open. + +\begin{code} +stdin, stdout, stderr :: Handle + +stdin = unsafePerformIO (do + rc <- _ccall_ getLock (``stdin''::Addr) 0 + case rc of + 0 -> newHandle ClosedHandle + 1 -> do +#ifndef __PARALLEL_HASKELL__ + fp <- makeForeignObj (``stdin''::Addr) (``&freeStdFile''::Addr) + newHandle (ReadHandle fp Nothing False) +#else + newHandle (ReadHandle ``stdin'' Nothing False) +#endif + _ -> do ioError <- constructError "stdin" + newHandle (ErrorHandle ioError) + ) + +stdout = unsafePerformIO (do + rc <- _ccall_ getLock (``stdout''::Addr) 1 + case rc of + 0 -> newHandle ClosedHandle + 1 -> do +#ifndef __PARALLEL_HASKELL__ + fp <- makeForeignObj (``stdout''::Addr) (``&freeStdFile''::Addr) + newHandle (WriteHandle fp Nothing False) +#else + newHandle (WriteHandle ``stdout'' Nothing False) +#endif + _ -> do ioError <- constructError "stdout" + newHandle (ErrorHandle ioError) + ) + +stderr = unsafePerformIO (do + rc <- _ccall_ getLock (``stderr''::Addr) 1 + case rc of + 0 -> newHandle ClosedHandle + 1 -> do +#ifndef __PARALLEL_HASKELL__ + fp <- makeForeignObj (``stderr''::Addr) (``&freeStdFile''::Addr) + newHandle (WriteHandle fp (Just NoBuffering) False) +#else + newHandle (WriteHandle ``stderr'' (Just NoBuffering) False) +#endif + _ -> do ioError <- constructError "stderr" + newHandle (ErrorHandle ioError) + ) +\end{code} + +%********************************************************* +%* * +\subsection[OpeningClosing]{Opening and Closing Files} +%* * +%********************************************************* + +\begin{code} +data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode + deriving (Eq, Ord, Ix, Enum, Read, Show) + +openFile :: FilePath -> IOMode -> IO Handle + +openFile f m = do + ptr <- _ccall_ openFile f m' + if ptr /= ``NULL'' then do +#ifndef __PARALLEL_HASKELL__ + fp <- makeForeignObj ptr ((``&freeFile'')::Addr) + newHandle (htype fp Nothing False) +#else + newHandle (htype ptr Nothing False) +#endif + else do + ioError@(IOError hn iot msg) <- constructError "openFile" + let + improved_error -- a HACK, I guess + = case iot of + AlreadyExists -> IOError hn AlreadyExists (msg ++ ": " ++ f) + NoSuchThing -> IOError hn NoSuchThing (msg ++ ": " ++ f) + PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f) + _ -> ioError + fail improved_error + where + m' = case m of + ReadMode -> "r" + WriteMode -> "w" + AppendMode -> "a" + ReadWriteMode -> "r+" + + htype = case m of + ReadMode -> ReadHandle + WriteMode -> WriteHandle + AppendMode -> AppendHandle + ReadWriteMode -> ReadWriteHandle +\end{code} + +Computation $openFile file mode$ allocates and returns a new, open +handle to manage the file {\em file}. It manages input if {\em mode} +is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$, +and both input and output if mode is $ReadWriteMode$. + +If the file does not exist and it is opened for output, it should be +created as a new file. If {\em mode} is $WriteMode$ and the file +already exists, then it should be truncated to zero length. The +handle is positioned at the end of the file if {\em mode} is +$AppendMode$, and otherwise at the beginning (in which case its +internal position is 0). + +Implementations should enforce, locally to the Haskell process, +multiple-reader single-writer locking on files, which is to say that +there may either be many handles on the same file which manage input, +or just one handle on the file which manages output. If any open or +semi-closed handle is managing a file for output, no new handle can be +allocated for that file. If any open or semi-closed handle is +managing a file for input, new handles can only be allocated if they +do not manage output. + +Two files are the same if they have the same absolute name. An +implementation is free to impose stricter conditions. + +\begin{code} +hClose :: Handle -> IO () + +hClose handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle fp (buf,_) -> do + (if buf /= ``NULL'' then + _ccall_ free buf + else + return ()) + fp_a <- _casm_ `` %r = (char *)%0; '' fp + if fp_a /= (``NULL''::Addr) then do + -- Under what condition can this be NULL? + rc <- _ccall_ closeFile fp + {- 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 + is still lying around in the heap, so care is taken + to avoid closing the file object when the ForeignObj + is finalised. -} + if rc == 0 then do +#ifndef __PARALLEL_HASKELL__ + -- Mark the foreign object data value as + -- gone to the finaliser (freeFile()) + writeForeignObj fp ``NULL'' +#endif + writeHandle handle ClosedHandle + else do + writeHandle handle htype + constructErrorAndFail "hClose" + + else writeHandle handle htype + + other -> do + let fp = filePtr other + rc <- _ccall_ closeFile fp + if rc == 0 then do +#ifndef __PARALLEL_HASKELL__ + -- Mark the foreign object data + writeForeignObj fp ``NULL'' +#endif + writeHandle handle ClosedHandle + else do + writeHandle handle htype + constructErrorAndFail "hClose" +\end{code} + +Computation $hClose hdl$ makes handle {\em hdl} closed. Before the +computation finishes, any items buffered for output and not already +sent to the operating system are flushed as for $flush$. + +%********************************************************* +%* * +\subsection[EOF]{Detecting the End of Input} +%* * +%********************************************************* + + +For a handle {\em hdl} which attached to a physical file, $hFileSize +hdl$ returns the size of {\em hdl} in terms of the number of items +which can be read from {\em hdl}. + +\begin{code} +hFileSize :: Handle -> IO Integer +hFileSize handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> + -- HACK! We build a unique MP_INT of the right shape to hold + -- a single unsigned word, and we let the C routine + -- change the data bits + -- + -- For some reason, this fails to typecheck if converted to a do + -- expression --SDM + _casm_ ``%r = 1;'' >>= \(I# hack#) -> + case int2Integer# hack# of + result@(J# _ _ d#) -> do + let bogus_bounds = (error "fileSize"::(Int,Int)) + rc <- _ccall_ fileSize (filePtr other) + (ByteArray bogus_bounds d#) + writeHandle handle htype + if rc == 0 then + return result + else + constructErrorAndFail "hFileSize" +\end{code} + +For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns +$True$ if no further input can be taken from {\em hdl} or for a +physical file, if the current I/O position is equal to the length of +the file. Otherwise, it returns $False$. + +\begin{code} +hIsEOF :: Handle -> IO Bool +hIsEOF handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + WriteHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation + "handle is not open for reading") + AppendHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation + "handle is not open for reading") + other -> do + rc <- _ccall_ fileEOF (filePtr other) + writeHandle handle (markHandle htype) + case rc of + 0 -> return False + 1 -> return True + _ -> constructErrorAndFail "hIsEOF" + +isEOF :: IO Bool +isEOF = hIsEOF stdin +\end{code} + +%********************************************************* +%* * +\subsection[Buffering]{Buffering Operations} +%* * +%********************************************************* + +Three kinds of buffering are supported: line-buffering, +block-buffering or no-buffering. See @IOBase@ for definition +and further explanation of what the type represent. + +Computation @hSetBuffering hdl mode@ sets the mode of buffering for +handle {\em hdl} on subsequent reads and writes. + +\begin{itemize} +\item +If {\em mode} is @LineBuffering@, line-buffering should be +enabled if possible. +\item +If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering +should be enabled if possible. The size of the buffer is {\em n} items +if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent. +\item +If {\em mode} is @NoBuffering@, then buffering is disabled if possible. +\end{itemize} + +If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@ +to @NoBuffering@, then any items in the output buffer are written to +the device, and any items in the input buffer are discarded. The +default buffering mode when a handle is opened is +implementation-dependent and may depend on the object which is +attached to that handle. + +\begin{code} +hSetBuffering :: Handle -> BufferMode -> IO () + +hSetBuffering handle mode = + case mode of + BlockBuffering (Just n) + | n <= 0 -> fail (IOError (Just handle) InvalidArgument + "illegal buffer size") + other -> do + htype <- readHandle handle + if isMarked htype then do + writeHandle handle htype + fail (IOError (Just handle) + UnsupportedOperation + "can't set buffering for a dirty handle") + else + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + rc <- _ccall_ setBuffering (filePtr other) bsize + if rc == 0 then + writeHandle handle ((hcon other) (filePtr other) + (Just mode) True) + else do + writeHandle handle htype + constructErrorAndFail "hSetBuffering" + + where + isMarked :: Handle__ -> Bool + isMarked (ReadHandle fp m b) = b + isMarked (WriteHandle fp m b) = b + isMarked (AppendHandle fp m b) = b + isMarked (ReadWriteHandle fp m b) = b + + bsize :: Int + bsize = case mode of + NoBuffering -> 0 + LineBuffering -> -1 + BlockBuffering Nothing -> -2 + BlockBuffering (Just n) -> n + +#ifndef __PARALLEL_HASKELL__ + hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__) +#else + hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__) +#endif + hcon (ReadHandle _ _ _) = ReadHandle + hcon (WriteHandle _ _ _) = WriteHandle + hcon (AppendHandle _ _ _) = AppendHandle + hcon (ReadWriteHandle _ _ _) = ReadWriteHandle +\end{code} + +Computation $flush hdl$ causes any items buffered for output in handle +{\em hdl} to be sent immediately to the operating system. + +\begin{code} +hFlush :: Handle -> IO () +hFlush handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + rc <- _ccall_ flushFile (filePtr other) + writeHandle handle (markHandle htype) + if rc == 0 then + return () + else + constructErrorAndFail "hFlush" +\end{code} + + +%********************************************************* +%* * +\subsection[Seeking]{Repositioning Handles} +%* * +%********************************************************* + +\begin{code} +data HandlePosn = HandlePosn Handle Int + +data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd + deriving (Eq, Ord, Ix, Enum, Read, Show) +\end{code} + +Computation $hGetPosn hdl$ returns the current I/O +position of {\em hdl} as an abstract position. Computation +$hSetPosn p$ sets the position of {\em hdl} +to a previously obtained position {\em p}. + +\begin{code} +hGetPosn :: Handle -> IO HandlePosn +hGetPosn handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + posn <- _ccall_ getFilePosn (filePtr other) + writeHandle handle htype + if posn /= -1 then + return (HandlePosn handle posn) + else + constructErrorAndFail "hGetPosn" + +hSetPosn :: HandlePosn -> IO () +hSetPosn (HandlePosn handle posn) = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + AppendHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation "handle is not seekable") + other -> do + rc <- _ccall_ setFilePosn (filePtr other) posn + writeHandle handle (markHandle htype) + if rc == 0 then + return () + else + constructErrorAndFail "hSetPosn" +\end{code} + +Computation $hSeek hdl mode i$ sets the position of handle +{\em hdl} depending on $mode$. If {\em mode} is +\begin{itemize} +\item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}. +\item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from +the current position. +\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from +the end of the file. +\item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from +the beginning of the file. +\end{itemize} + +Some handles may not be seekable $hIsSeekable$, or only support a +subset of the possible positioning operations (e.g. it may only be +possible to seek to the end of a tape, or to a positive offset from +the beginning or current position). + +It is not possible to set a negative I/O position, or for a physical +file, an I/O position beyond the current end-of-file. + +\begin{code} +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek handle mode offset@(J# _ s# d#) = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + AppendHandle _ _ _ -> do + writeHandle handle htype + fail (IOError (Just handle) IllegalOperation "handle is not seekable") + other -> do + rc <- _ccall_ seekFile (filePtr other) whence (I# s#) + (ByteArray (0,0) d#) + writeHandle handle (markHandle htype) + if rc == 0 then + return () + else + constructErrorAndFail "hSeek" + where + whence :: Int + whence = case mode of + AbsoluteSeek -> ``SEEK_SET'' + RelativeSeek -> ``SEEK_CUR'' + SeekFromEnd -> ``SEEK_END'' +\end{code} + +%********************************************************* +%* * +\subsection[Query]{Handle Properties} +%* * +%********************************************************* + +A number of operations return information about the properties of a +handle. Each of these operations returns $True$ if the +handle has the specified property, and $False$ +otherwise. + +Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if +{\em hdl} is not block-buffered. Otherwise it returns +$( True, size )$, where {\em size} is $Nothing$ for default buffering, and +$( Just n )$ for block-buffering of {\em n} bytes. + +\begin{code} +hIsOpen :: Handle -> IO Bool +hIsOpen handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + return False + SemiClosedHandle _ _ -> do + writeHandle handle htype + return False + other -> do + writeHandle handle htype + return True + +hIsClosed :: Handle -> IO Bool +hIsClosed handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + return True + other -> do + writeHandle handle htype + return False + +hIsReadable :: Handle -> IO Bool +hIsReadable handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + writeHandle handle htype + return (isReadable other) + where + isReadable (ReadHandle _ _ _) = True + isReadable (ReadWriteHandle _ _ _) = True + isReadable _ = False + +hIsWritable :: Handle -> IO Bool +hIsWritable handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + writeHandle handle htype + return (isWritable other) + where + isWritable (AppendHandle _ _ _) = True + isWritable (WriteHandle _ _ _) = True + isWritable (ReadWriteHandle _ _ _) = True + isWritable _ = False + +getBufferMode :: Handle__ -> IO Handle__ +getBufferMode htype = + case bufferMode htype of + Just x -> return htype + Nothing -> do + rc <- _ccall_ getBufferMode (filePtr htype) + let + mode = + case rc of + 0 -> Just NoBuffering + -1 -> Just LineBuffering + -2 -> Just (BlockBuffering Nothing) + -3 -> Nothing + n -> Just (BlockBuffering (Just n)) + return (case htype of + ReadHandle fp _ b -> ReadHandle fp mode b + WriteHandle fp _ b -> WriteHandle fp mode b + AppendHandle fp _ b -> AppendHandle fp mode b + ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b) + +hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int) +hIsBlockBuffered handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + other <- getBufferMode other + case bufferMode other of + Just (BlockBuffering size) -> do + writeHandle handle other + return (True, size) + Just _ -> do + writeHandle handle other + return (False, Nothing) + Nothing -> + constructErrorAndFail "hIsBlockBuffered" + +hIsLineBuffered :: Handle -> IO Bool +hIsLineBuffered handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + other <- getBufferMode other + case bufferMode other of + Just LineBuffering -> do + writeHandle handle other + return True + Just _ -> do + writeHandle handle other + return False + Nothing -> + constructErrorAndFail "hIsLineBuffered" + +hIsNotBuffered :: Handle -> IO Bool +hIsNotBuffered handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + other <- getBufferMode other + case bufferMode other of + Just NoBuffering -> do + writeHandle handle other + return True + Just _ -> do + writeHandle handle other + return False + Nothing -> + constructErrorAndFail "hIsNotBuffered" + +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + other -> do + other <- getBufferMode other + case bufferMode other of + Just v -> do + writeHandle handle other + return v + Nothing -> + constructErrorAndFail "hGetBuffering" + +hIsSeekable :: Handle -> IO Bool +hIsSeekable handle = do + htype <- readHandle handle + case htype of + ErrorHandle ioError -> do + writeHandle handle htype + fail ioError + ClosedHandle -> do + writeHandle handle htype + ioe_closedHandle handle + SemiClosedHandle _ _ -> do + writeHandle handle htype + ioe_closedHandle handle + AppendHandle _ _ _ -> do + writeHandle handle htype + return False + other -> do + rc <- _ccall_ seekFileP (filePtr other) + writeHandle handle htype + case rc of + 0 -> return False + 1 -> return True + _ -> constructErrorAndFail "hIsSeekable" +\end{code} + + +%********************************************************* +%* * +\subsection{Miscellaneous} +%* * +%********************************************************* + +These two functions are meant to get things out of @IOErrors@. They don't! + +\begin{code} +ioeGetFileName :: IOError -> Maybe FilePath +ioeGetErrorString :: IOError -> String +ioeGetHandle :: IOError -> Maybe Handle + +ioeGetHandle (IOError h _ _) = h +ioeGetErrorString (IOError _ iot str) = + case iot of + EOF -> "end of file" + _ -> str + +ioeGetFileName (IOError _ _ str) = + case span (/=':') str of + (fs,[]) -> Nothing + (fs,_) -> Just fs + +\end{code} + +Internal function for creating an @IOError@ representing the +access of a closed file. + +\begin{code} + +ioe_closedHandle :: Handle -> IO a +ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed") +\end{code} diff --git a/ghc/lib/std/PrelIO.lhs b/ghc/lib/std/PrelIO.lhs new file mode 100644 index 0000000000..2de7d3b6b6 --- /dev/null +++ b/ghc/lib/std/PrelIO.lhs @@ -0,0 +1,78 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelIO]{Module @PrelIO@} + +Input/output functions mandated by the standard Prelude. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelIO ( + IO, FilePath, IOError, + fail, userError, catch, + putChar, putStr, putStrLn, print, + getChar, getLine, getContents, interact, + readFile, writeFile, appendFile, readIO, readLn + ) where + +import IO +import PrelHandle +import PrelIOBase +import PrelBase +import PrelRead + +\end{code} + +\begin{code} +putChar :: Char -> IO () +putChar c = hPutChar stdout c + +putStr :: String -> IO () +putStr s = hPutStr stdout s + +putStrLn :: String -> IO () +putStrLn s = do putStr s + putChar '\n' + +print :: Show a => a -> IO () +print x = putStrLn (show x) + +getChar :: IO Char +getChar = hGetChar stdin + +getLine :: IO String +getLine = hGetLine stdin + +getContents :: IO String +getContents = hGetContents stdin + +interact :: (String -> String) -> IO () +interact f = do s <- getContents + putStr (f s) + +readFile :: FilePath -> IO String +readFile name = openFile name ReadMode >>= hGetContents + +writeFile :: FilePath -> String -> IO () +writeFile name str + = openFile name WriteMode >>= \hdl -> hPutStr hdl str >> hClose hdl + +appendFile :: FilePath -> String -> IO () +appendFile name str + = openFile name AppendMode >>= \hdl -> hPutStr hdl str >> hClose hdl + +readIO :: Read a => String -> IO a + -- raises an exception instead of an error +readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> return x + [] -> fail (userError "PreludeIO.readIO: no parse") + _ -> fail (userError + "PreludeIO.readIO: ambiguous parse") + +readLn :: Read a => IO a +readLn = do l <- getLine + r <- readIO l + return r +\end{code} diff --git a/ghc/lib/std/PrelIOBase.lhs b/ghc/lib/std/PrelIOBase.lhs new file mode 100644 index 0000000000..bcf6d7dec9 --- /dev/null +++ b/ghc/lib/std/PrelIOBase.lhs @@ -0,0 +1,389 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelIOBase]{Module @PrelIOBase@} + +Definitions for the @IO@ monad and its friends. Everything is exported +concretely; the @IO@ module itself exports abstractly. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} +#include "error.h" + +module PrelIOBase where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelST +import PrelTup +import PrelMaybe +import PrelAddr +import PrelPack ( unpackCString ) +import PrelBase +import PrelArr ( ByteArray(..), MutableVar(..) ) +import PrelGHC + +\end{code} + +%********************************************************* +%* * +\subsection{The @IO@ monad} +%* * +%********************************************************* + +IO is no longer built on top of PrimIO (which used to be a specialised +version of the ST monad), instead it is now has its own type. This is +purely for efficiency purposes, since we get to remove several levels +of lifting in the type of the monad. + +\begin{code} +newtype IO a = IO (State# RealWorld -> IOResult a) + +{-# INLINE unIO #-} +unIO (IO a) = a + +data IOResult a = IOok (State# RealWorld) a + | IOfail (State# RealWorld) IOError + +instance Functor IO where + map f x = x >>= (return . f) + +instance Monad IO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return x = IO $ \ s -> IOok s x + + (IO m) >>= k = + IO $ \s -> + case m s of + IOfail new_s err -> IOfail new_s err + IOok new_s a -> unIO (k a) new_s + +fixIO :: (a -> IO a) -> IO a + -- not required but worth having around + +fixIO k = IO $ \ s -> + let + (IO k_loop) = k loop + result = k_loop s + IOok _ loop = result + in + result + +fail :: IOError -> IO a +fail err = IO $ \ s -> IOfail s err + +userError :: String -> IOError +userError str = IOError Nothing UserError str + +catch :: IO a -> (IOError -> IO a) -> IO a +catch (IO m) k = IO $ \ s -> + case m s of + IOok new_s a -> IOok new_s a + IOfail new_s e -> unIO (k e) new_s + +instance Show (IO a) where + showsPrec p f = showString "<<IO action>>" + showList = showList__ (showsPrec 0) +\end{code} + +%********************************************************* +%* * +\subsection{Coercions to @ST@} +%* * +%********************************************************* + +\begin{code} +stToIO :: ST RealWorld a -> IO a +stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r + +ioToST :: IO a -> ST RealWorld a +ioToST (IO io) = ST $ \ s -> + case (io s) of + IOok new_s a -> STret new_s a + IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n") +\end{code} + +%********************************************************* +%* * +\subsection{Utility functions} +%* * +%********************************************************* + +I'm not sure why this little function is here... + +\begin{code} +fputs :: Addr{-FILE*-} -> String -> IO Bool + +fputs stream [] = return True + +fputs stream (c : cs) + = _ccall_ stg_putc c stream >> -- stg_putc expands to putc + fputs stream cs -- (just does some casting stream) +\end{code} + + +%********************************************************* +%* * +\subsection{Type @IOError@} +%* * +%********************************************************* + +A value @IOError@ encode errors occurred in the @IO@ monad. +An @IOError@ records a more specific error type, a descriptive +string and maybe the handle that was used when the error was +flagged. + +\begin{code} +data IOError + = IOError + (Maybe Handle) -- the handle used by the action flagging the + -- the error. + IOErrorType -- what it was. + String -- error type specific information. + + +data IOErrorType + = AlreadyExists | HardwareFault + | IllegalOperation | InappropriateType + | Interrupted | InvalidArgument + | NoSuchThing | OtherError + | PermissionDenied | ProtocolError + | ResourceBusy | ResourceExhausted + | ResourceVanished | SystemError + | TimeExpired | UnsatisfiedConstraints + | UnsupportedOperation | UserError + | EOF + deriving (Eq, Show) + +\end{code} + +Predicates on IOError; little effort made on these so far... + +\begin{code} + +isAlreadyExistsError (IOError _ AlreadyExists _) = True +isAlreadyExistsError _ = False + +isAlreadyInUseError (IOError _ ResourceBusy _) = True +isAlreadyInUseError _ = False + +isFullError (IOError _ ResourceExhausted _) = True +isFullError _ = False + +isEOFError (IOError _ EOF _) = True +isEOFError _ = True + +isIllegalOperation (IOError _ IllegalOperation _) = True +isIllegalOperation _ = False + +isPermissionError (IOError _ PermissionDenied _) = True +isPermissionError _ = False + +isDoesNotExistError (IOError _ NoSuchThing _) = True +isDoesNotExistError _ = False + +isUserError (IOError _ UserError _) = True +isUserError _ = False +\end{code} + +Showing @IOError@s + +\begin{code} +instance Show IOError where + showsPrec p (IOError _ UserError s) rs = + showString s rs +{- + showsPrec p (IOError _ EOF _) rs = + showsPrec p EOF rs +-} + showsPrec p (IOError _ iot s) rs = + showsPrec p + iot + (case s of { + "" -> rs; + _ -> showString ": " $ + showString s rs}) + +\end{code} + +The @String@ part of an @IOError@ is platform-dependent. However, to +provide a uniform mechanism for distinguishing among errors within +these broad categories, each platform-specific standard shall specify +the exact strings to be used for particular errors. For errors not +explicitly mentioned in the standard, any descriptive string may be +used. + +\begin{change} +SOF & 4/96 & added argument to indicate function that flagged error +\end{change} +% Hmm..does these envs work?!...SOF + +\begin{code} +constructErrorAndFail :: String -> IO a +constructErrorAndFail call_site + = constructError call_site >>= \ io_error -> + fail io_error + +\end{code} + +This doesn't seem to be documented/spelled out anywhere, +so here goes: (SOF) + +The implementation of the IO prelude uses various C stubs +to do the actual interaction with the OS. The bandwidth +\tr{C<->Haskell} is somewhat limited, so the general strategy +for flaggging any errors (apart from possibly using the +return code of the external call), is to set the @ghc_errtype@ +to a value that is one of the \tr{#define}s in @includes/error.h@. +@ghc_errstr@ holds a character string providing error-specific +information. + +\begin{code} +constructError :: String -> IO IOError +constructError call_site = + _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) -> + _casm_ ``%r = ghc_errstr;'' >>= \ str -> + let + iot = + case errtype# of + ERR_ALREADYEXISTS# -> AlreadyExists + ERR_HARDWAREFAULT# -> HardwareFault + ERR_ILLEGALOPERATION# -> IllegalOperation + ERR_INAPPROPRIATETYPE# -> InappropriateType + ERR_INTERRUPTED# -> Interrupted + ERR_INVALIDARGUMENT# -> InvalidArgument + ERR_NOSUCHTHING# -> NoSuchThing + ERR_OTHERERROR# -> OtherError + ERR_PERMISSIONDENIED# -> PermissionDenied + ERR_PROTOCOLERROR# -> ProtocolError + ERR_RESOURCEBUSY# -> ResourceBusy + ERR_RESOURCEEXHAUSTED# -> ResourceExhausted + ERR_RESOURCEVANISHED# -> ResourceVanished + ERR_SYSTEMERROR# -> SystemError + ERR_TIMEEXPIRED# -> TimeExpired + ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints + ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation + ERR_EOF# -> EOF + _ -> OtherError + + msg = + call_site ++ ':' : ' ' : unpackCString str ++ + case iot of + OtherError -> "(error code: " ++ show (I# errtype#) ++ ")" + _ -> "" + in + return (IOError Nothing iot msg) +\end{code} + +%********************************************************* +%* * +\subsection{Types @Handle@, @Handle__@} +%* * +%********************************************************* + +The type for @Handle@ is defined rather than in @IOHandle@ +module, as the @IOError@ type uses it..all operations over +a handles reside in @IOHandle@. + +\begin{code} + +{- + Sigh, the MVar ops in ConcBase depend on IO, the IO + representation here depend on MVars for handles (when + compiling a concurrent way). Break the cycle by having + the definition of MVars go here: + +-} +data MVar a = MVar (SynchVar# RealWorld a) + +{- + Double sigh - ForeignObj is needed here too to break a cycle. +-} +data ForeignObj = ForeignObj ForeignObj# -- another one + +#if defined(__CONCURRENT_HASKELL__) +newtype Handle = Handle (MVar Handle__) +#else +newtype Handle = Handle (MutableVar RealWorld Handle__) +#endif + +data Handle__ + = ErrorHandle IOError + | ClosedHandle +#ifndef __PARALLEL_HASKELL__ + | SemiClosedHandle ForeignObj (Addr, Int) + | ReadHandle ForeignObj (Maybe BufferMode) Bool + | WriteHandle ForeignObj (Maybe BufferMode) Bool + | AppendHandle ForeignObj (Maybe BufferMode) Bool + | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool +#else + | SemiClosedHandle Addr (Addr, Int) + | ReadHandle Addr (Maybe BufferMode) Bool + | WriteHandle Addr (Maybe BufferMode) Bool + | AppendHandle Addr (Maybe BufferMode) Bool + | ReadWriteHandle Addr (Maybe BufferMode) Bool +#endif + +-- Standard Instances as defined by the Report.. +-- instance Eq Handle (defined in IO) +-- instance Show Handle "" + +\end{code} + +%********************************************************* +%* * +\subsection[BufferMode]{Buffering modes} +%* * +%********************************************************* + +Three kinds of buffering are supported: line-buffering, +block-buffering or no-buffering. These modes have the following +effects. For output, items are written out from the internal +buffer according to the buffer mode: + +\begin{itemize} +\item[line-buffering] the entire output buffer is written +out whenever a newline is output, the output buffer overflows, +a flush is issued, or the handle is closed. + +\item[block-buffering] the entire output buffer is written out whenever +it overflows, a flush is issued, or the handle +is closed. + +\item[no-buffering] output is written immediately, and never stored +in the output buffer. +\end{itemize} + +The output buffer is emptied as soon as it has been written out. + +Similarly, input occurs according to the buffer mode for handle {\em hdl}. +\begin{itemize} +\item[line-buffering] when the input buffer for {\em hdl} is not empty, +the next item is obtained from the buffer; +otherwise, when the input buffer is empty, +characters up to and including the next newline +character are read into the buffer. No characters +are available until the newline character is +available. +\item[block-buffering] when the input buffer for {\em hdl} becomes empty, +the next block of data is read into this buffer. +\item[no-buffering] the next input item is read and returned. +\end{itemize} +For most implementations, physical files will normally be block-buffered +and terminals will normally be line-buffered. + +\begin{code} +data BufferMode + = NoBuffering | LineBuffering | BlockBuffering (Maybe Int) + deriving (Eq, Ord, Show) + {- Read instance defined in IO. -} + +\end{code} + +\begin{code} +performGC :: IO () +performGC = _ccall_GC_ StgPerformGarbageCollection +\end{code} diff --git a/ghc/lib/std/PrelList.lhs b/ghc/lib/std/PrelList.lhs new file mode 100644 index 0000000000..cae955e8ab --- /dev/null +++ b/ghc/lib/std/PrelList.lhs @@ -0,0 +1,420 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelList]{Module @PrelList@} + +The List data type and its operations + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelList ( + [] (..), + + head, last, tail, init, null, length, (!!), + foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1, + iterate, repeat, replicate, cycle, + take, drop, splitAt, takeWhile, dropWhile, span, break, + lines, words, unlines, unwords, reverse, and, or, + any, all, elem, notElem, lookup, + sum, product, maximum, minimum, concatMap, + zip, zip3, zipWith, zipWith3, unzip, unzip3 + ) where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelTup +import PrelMaybe +import PrelBase + +infix 4 `elem`, `notElem` +\end{code} + +%********************************************************* +%* * +\subsection{List-manipulation functions} +%* * +%********************************************************* + +\begin{code} +-- head and tail extract the first element and remaining elements, +-- respectively, of a list, which must be non-empty. last and init +-- are the dual functions working from the end of a finite list, +-- rather than the beginning. + +head :: [a] -> a +head (x:_) = x +head [] = error "PreludeList.head: empty list" + +last :: [a] -> a +last [x] = x +last (_:xs) = last xs +last [] = error "PreludeList.last: empty list" + +tail :: [a] -> [a] +tail (_:xs) = xs +tail [] = error "PreludeList.tail: empty list" + +init :: [a] -> [a] +init [x] = [] +init (x:xs) = x : init xs +init [] = error "PreludeList.init: empty list" + +null :: [a] -> Bool +null [] = True +null (_:_) = False + +-- length returns the length of a finite list as an Int; it is an instance +-- of the more general genericLength, the result type of which may be +-- any kind of number. +length :: [a] -> Int +#ifdef USE_REPORT_PRELUDE +length [] = 0 +length (_:l) = 1 + length l +#else +length l = len l 0# + where + len :: [a] -> Int# -> Int + len [] a# = I# a# + len (_:xs) a# = len xs (a# +# 1#) +#endif + +-- foldl, applied to a binary operator, a starting value (typically the +-- left-identity of the operator), and a list, reduces the list using +-- the binary operator, from left to right: +-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn +-- foldl1 is a variant that has no starting value argument, and thus must +-- be applied to non-empty lists. scanl is similar to foldl, but returns +-- a list of successive reduced values from the left: +-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...] +-- Note that last (scanl f z xs) == foldl f z xs. +-- scanl1 is similar, again without the starting element: +-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...] + +foldl :: (a -> b -> a) -> a -> [b] -> a +foldl f z [] = z +foldl f z (x:xs) = foldl f (f z x) xs + +foldl1 :: (a -> a -> a) -> [a] -> a +foldl1 f (x:xs) = foldl f x xs +foldl1 _ [] = error "PreludeList.foldl1: empty list" + +scanl :: (a -> b -> a) -> a -> [b] -> [a] +scanl f q xs = q : (case xs of + [] -> [] + x:xs -> scanl f (f q x) xs) + +scanl1 :: (a -> a -> a) -> [a] -> [a] +scanl1 f (x:xs) = scanl f x xs +scanl1 _ [] = error "PreludeList.scanl1: empty list" + +-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the +-- above functions. + +foldr1 :: (a -> a -> a) -> [a] -> a +foldr1 f [x] = x +foldr1 f (x:xs) = f x (foldr1 f xs) +foldr1 _ [] = error "PreludeList.foldr1: empty list" + +scanr :: (a -> b -> b) -> b -> [a] -> [b] +scanr f q0 [] = [q0] +scanr f q0 (x:xs) = f x q : qs + where qs@(q:_) = scanr f q0 xs + +scanr1 :: (a -> a -> a) -> [a] -> [a] +scanr1 f [x] = [x] +scanr1 f (x:xs) = f x q : qs + where qs@(q:_) = scanr1 f xs +scanr1 _ [] = error "PreludeList.scanr1: empty list" + +-- iterate f x returns an infinite list of repeated applications of f to x: +-- iterate f x == [x, f x, f (f x), ...] +iterate :: (a -> a) -> a -> [a] +iterate f x = x : iterate f (f x) + +-- repeat x is an infinite list, with x the value of every element. +repeat :: a -> [a] +repeat x = xs where xs = x:xs + +-- replicate n x is a list of length n with x the value of every element +replicate :: Int -> a -> [a] +replicate n x = take n (repeat x) + +-- cycle ties a finite list into a circular one, or equivalently, +-- the infinite repetition of the original list. It is the identity +-- on infinite lists. + +cycle :: [a] -> [a] +cycle xs = xs' where xs' = xs ++ xs' + +-- take n, applied to a list xs, returns the prefix of xs of length n, +-- or xs itself if n > length xs. drop n xs returns the suffix of xs +-- after the first n elements, or [] if n > length xs. splitAt n xs +-- is equivalent to (take n xs, drop n xs). +#ifdef USE_REPORT_PRELUDE +take :: Int -> [a] -> [a] +take 0 _ = [] +take _ [] = [] +take n (x:xs) | n > 0 = x : take (n-1) xs +take _ _ = error "PreludeList.take: negative argument" + +drop :: Int -> [a] -> [a] +drop 0 xs = xs +drop _ [] = [] +drop n (_:xs) | n > 0 = drop (n-1) xs +drop _ _ = error "PreludeList.drop: negative argument" + +splitAt :: Int -> [a] -> ([a],[a]) +splitAt 0 xs = ([],xs) +splitAt _ [] = ([],[]) +splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs +splitAt _ _ = error "PreludeList.splitAt: negative argument" + +#else /* hack away */ +take :: Int -> [b] -> [b] +take (I# n#) xs = takeUInt n# xs + +-- The general code for take, below, checks n <= maxInt +-- No need to check for maxInt overflow when specialised +-- at type Int or Int# since the Int must be <= maxInt + +takeUInt :: Int# -> [b] -> [b] +takeUInt n xs + | n >=# 0# = take_unsafe_UInt n xs + | otherwise = error "take{PreludeList}: negative index" + +take_unsafe_UInt 0# _ = [] +take_unsafe_UInt _ [] = [] +take_unsafe_UInt m (x:xs) = x : take_unsafe_UInt (m -# 1#) xs + +drop :: Int -> [b] -> [b] +drop (I# n#) xs + | n# <# 0# = error "drop{PreludeList}: negative index" + | otherwise = drop# n# xs + where + drop# :: Int# -> [a] -> [a] + drop# 0# xs = xs + drop# _ [] = [] + drop# m# (_:xs) = drop# (m# -# 1#) xs + +splitAt :: Int -> [b] -> ([b], [b]) +splitAt (I# n#) xs + | n# <# 0# = error "splitAt{PreludeList}: negative index" + | otherwise = splitAt# n# xs + where + splitAt# :: Int# -> [a] -> ([a], [a]) + splitAt# 0# xs = ([], xs) + splitAt# _ [] = ([], []) + splitAt# m# (x:xs) = (x:xs', xs'') + where + (xs', xs'') = splitAt# (m# -# 1#) xs + +#endif /* USE_REPORT_PRELUDE */ + +span, break :: (a -> Bool) -> [a] -> ([a],[a]) +span p [] = ([],[]) +span p xs@(x:xs') + | p x = let (ys,zs) = span p xs' in (x:ys,zs) + | otherwise = ([],xs) + +#ifdef USE_REPORT_PRELUDE +break p = span (not . p) +#else +-- HBC version (stolen) +break p [] = ([],[]) +break p xs@(x:xs') + | p x = ([],xs) + | otherwise = let (ys,zs) = break p xs' in (x:ys,zs) +#endif + +-- reverse xs returns the elements of xs in reverse order. xs must be finite. +reverse :: [a] -> [a] +#ifdef USE_REPORT_PRELUDE +reverse = foldl (flip (:)) [] +#else +reverse l = rev l [] + where + rev [] a = a + rev (x:xs) a = rev xs (x:a) +#endif + +-- and returns the conjunction of a Boolean list. For the result to be +-- True, the list must be finite; False, however, results from a False +-- value at a finite index of a finite or infinite list. or is the +-- disjunctive dual of and. +and, or :: [Bool] -> Bool +#ifdef USE_REPORT_PRELUDE +and = foldr (&&) True +or = foldr (||) False +#else +and [] = True +and (x:xs) = x && and xs +or [] = False +or (x:xs) = x || or xs +#endif + +-- Applied to a predicate and a list, any determines if any element +-- of the list satisfies the predicate. Similarly, for all. +any, all :: (a -> Bool) -> [a] -> Bool +#ifdef USE_REPORT_PRELUDE +any p = or . map p +all p = and . map p +#else +any p [] = False +any p (x:xs) = p x || any p xs +all p [] = True +all p (x:xs) = p x && all p xs +#endif + +-- elem is the list membership predicate, usually written in infix form, +-- e.g., x `elem` xs. notElem is the negation. +elem, notElem :: (Eq a) => a -> [a] -> Bool +#ifdef USE_REPORT_PRELUDE +elem x = any (== x) +notElem x = all (/= x) +#else +elem _ [] = False +elem x (y:ys) = x==y || elem x ys + +notElem x [] = True +notElem x (y:ys)= x /= y && notElem x ys +#endif + +-- lookup key assocs looks up a key in an association list. +lookup :: (Eq a) => a -> [(a,b)] -> Maybe b +lookup key [] = Nothing +lookup key ((x,y):xys) + | key == x = Just y + | otherwise = lookup key xys + +-- sum and product compute the sum or product of a finite list of numbers. +sum, product :: (Num a) => [a] -> a +#ifdef USE_REPORT_PRELUDE +sum = foldl (+) 0 +product = foldl (*) 1 +#else +sum l = sum' l 0 + where + sum' [] a = a + sum' (x:xs) a = sum' xs (a+x) +product l = prod l 1 + where + prod [] a = a + prod (x:xs) a = prod xs (a*x) +#endif + +-- maximum and minimum return the maximum or minimum value from a list, +-- which must be non-empty, finite, and of an ordered type. +maximum, minimum :: (Ord a) => [a] -> a +maximum [] = error "PreludeList.maximum: empty list" +maximum xs = foldl1 max xs + +minimum [] = error "PreludeList.minimum: empty list" +minimum xs = foldl1 min xs + +concatMap :: (a -> [b]) -> [a] -> [b] +concatMap f = foldr ((++) . f) [] +\end{code} + + +%********************************************************* +%* * +\subsection{The zip family} +%* * +%********************************************************* + +zip takes two lists and returns a list of corresponding pairs. If one +input list is short, excess elements of the longer list are discarded. +zip3 takes three lists and returns a list of triples. Zips for larger +tuples are in the List library + +\begin{code} +zip :: [a] -> [b] -> [(a,b)] +-- Specification +-- zip = zipWith (,) +zip (a:as) (b:bs) = (a,b) : zip as bs +zip _ _ = [] + +zip3 :: [a] -> [b] -> [c] -> [(a,b,c)] +-- Specification +-- zip3 = zipWith3 (,,) +zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs +zip3 _ _ _ = [] + +-- The zipWith family generalises the zip family by zipping with the +-- function given as the first argument, instead of a tupling function. +-- For example, zipWith (+) is applied to two lists to produce the list +-- of corresponding sums. + +zipWith :: (a->b->c) -> [a]->[b]->[c] +zipWith z (a:as) (b:bs) = z a b : zipWith z as bs +zipWith _ _ _ = [] + +zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d] +zipWith3 z (a:as) (b:bs) (c:cs) + = z a b c : zipWith3 z as bs cs +zipWith3 _ _ _ _ = [] + + +-- unzip transforms a list of pairs into a pair of lists. + +unzip :: [(a,b)] -> ([a],[b]) +unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[]) + +unzip3 :: [(a,b,c)] -> ([a],[b],[c]) +unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs)) + ([],[],[]) +\end{code} + +%********************************************************* +%* * +\subsection{Functions on strings} +%* * +%********************************************************* + +lines breaks a string up into a list of strings at newline characters. +The resulting strings do not contain newlines. Similary, words +breaks a string up into a list of words, which were delimited by +white space. unlines and unwords are the inverse operations. +unlines joins lines with terminating newlines, and unwords joins +words with separating spaces. + +\begin{code} +lines :: String -> [String] +lines "" = [] +lines s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines s'' + +words :: String -> [String] +words s = case dropWhile {-partain:Char.-}isSpace s of + "" -> [] + s' -> w : words s'' + where (w, s'') = + break {-partain:Char.-}isSpace s' + +unlines :: [String] -> String +#ifdef USE_REPORT_PRELUDE +unlines = concatMap (++ "\n") +#else +-- HBC version (stolen) +-- here's a more efficient version +unlines [] = [] +unlines (l:ls) = l ++ '\n' : unlines ls + +#endif + +unwords :: [String] -> String +#ifdef USE_REPORT_PRELUDE +unwords [] = "" +unwords ws = foldr1 (\w s -> w ++ ' ':s) ws +#else +-- HBC version (stolen) +-- here's a more efficient version +unwords [] = "" +unwords [w] = w +unwords (w:ws) = w ++ ' ' : unwords ws +#endif + +\end{code} diff --git a/ghc/lib/std/PrelMain.lhs b/ghc/lib/std/PrelMain.lhs new file mode 100644 index 0000000000..a64b36157f --- /dev/null +++ b/ghc/lib/std/PrelMain.lhs @@ -0,0 +1,20 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1997 +% + +\section[PrelMain]{Module @PrelMain@} + +\begin{code} +module PrelMain( mainIO ) where + +import Prelude +import {-# SOURCE #-} qualified Main -- for type of "Main.main" +import PrelErr ( ioError ) +\end{code} + +\begin{code} +mainIO :: IO () -- It must be of type (IO t) because that's what + -- the RTS expects. GHC doesn't check this, so + -- make sure this type signature stays! +mainIO = catch Main.main (\err -> ioError (showsPrec 0 err "\n")) +\end{code} diff --git a/ghc/lib/std/PrelMaybe.lhs b/ghc/lib/std/PrelMaybe.lhs new file mode 100644 index 0000000000..974e5de872 --- /dev/null +++ b/ghc/lib/std/PrelMaybe.lhs @@ -0,0 +1,44 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[PrelMaybe]{Module @PrelMaybe@} + +The @Maybe@ type. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelMaybe where + +import PrelBase + +data Maybe a = Nothing | Just a deriving (Eq, Ord, Show {- Read -}) + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe n f Nothing = n +maybe n f (Just x) = f x + +instance Functor Maybe where + map f Nothing = Nothing + map f (Just a) = Just (f a) + +instance Monad Maybe where + (Just x) >>= k = k x + Nothing >>= k = Nothing + + (Just x) >> k = k + Nothing >> k = Nothing + + return = Just + +instance MonadZero Maybe where + zero = Nothing + +instance MonadPlus Maybe where + Nothing ++ ys = ys + xs ++ ys = xs +\end{code} + + + + diff --git a/ghc/lib/std/PrelNum.lhs b/ghc/lib/std/PrelNum.lhs new file mode 100644 index 0000000000..a562facc64 --- /dev/null +++ b/ghc/lib/std/PrelNum.lhs @@ -0,0 +1,1265 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelNum]{Module @PrelNum@} + +Numeric part of the prelude. + +It's rather big! + +\begin{code} +{-# OPTIONS -fno-implicit-prelude -#include "cbits/floatExtreme.h" #-} +{-# OPTIONS -H20m #-} + +#include "../includes/ieee-flpt.h" + +\end{code} + +\begin{code} +module PrelNum where + +import PrelBase +import PrelGHC +import {-# SOURCE #-} PrelErr ( error ) +import PrelList +import PrelMaybe + +import PrelArr ( Array, array, (!) ) +import PrelUnsafe ( unsafePerformIO ) +import Ix ( Ix(..) ) +import PrelCCall () -- we need the definitions of CCallable and + -- CReturnable for the _ccall_s herein. + + +infixr 8 ^, ^^, ** +infixl 7 /, %, `quot`, `rem`, `div`, `mod` +\end{code} + + +%********************************************************* +%* * +\subsection{Standard numeric classes} +%* * +%********************************************************* + +\begin{code} +class (Num a, Ord a) => Real a where + toRational :: a -> Rational + +class (Real a, Enum a) => Integral a where + quot, rem, div, mod :: a -> a -> a + quotRem, divMod :: a -> a -> (a,a) + toInteger :: a -> Integer + toInt :: a -> Int -- partain: Glasgow extension + + n `quot` d = q where (q,r) = quotRem n d + n `rem` d = r where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr + where qr@(q,r) = quotRem n d + +class (Num a) => Fractional a where + (/) :: a -> a -> a + recip :: a -> a + fromRational :: Rational -> a + + recip x = 1 / x + +class (Fractional a) => Floating a where + pi :: a + exp, log, sqrt :: a -> a + (**), logBase :: a -> a -> a + sin, cos, tan :: a -> a + asin, acos, atan :: a -> a + sinh, cosh, tanh :: a -> a + asinh, acosh, atanh :: a -> a + + x ** y = exp (log x * y) + logBase x y = log y / log x + sqrt x = x ** 0.5 + tan x = sin x / cos x + tanh x = sinh x / cosh x + +class (Real a, Fractional a) => RealFrac a where + properFraction :: (Integral b) => a -> (b,a) + truncate, round :: (Integral b) => a -> b + ceiling, floor :: (Integral b) => a -> b + + truncate x = m where (m,_) = properFraction x + + round x = let (n,r) = properFraction x + m = if r < 0 then n - 1 else n + 1 + in case signum (abs r - 0.5) of + -1 -> n + 0 -> if even n then n else m + 1 -> m + + ceiling x = if r > 0 then n + 1 else n + where (n,r) = properFraction x + + floor x = if r < 0 then n - 1 else n + where (n,r) = properFraction x + +class (RealFrac a, Floating a) => RealFloat a where + floatRadix :: a -> Integer + floatDigits :: a -> Int + floatRange :: a -> (Int,Int) + decodeFloat :: a -> (Integer,Int) + encodeFloat :: Integer -> Int -> a + exponent :: a -> Int + significand :: a -> a + scaleFloat :: Int -> a -> a + isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE + :: a -> Bool + + exponent x = if m == 0 then 0 else n + floatDigits x + where (m,n) = decodeFloat x + + significand x = encodeFloat m (negate (floatDigits x)) + where (m,_) = decodeFloat x + + scaleFloat k x = encodeFloat m (n+k) + where (m,n) = decodeFloat x +\end{code} + +%********************************************************* +%* * +\subsection{Overloaded numeric functions} +%* * +%********************************************************* + +\begin{code} +even, odd :: (Integral a) => a -> Bool +even n = n `rem` 2 == 0 +odd = not . even + +{-# GENERATE_SPECS gcd a{Int#,Int,Integer} #-} +gcd :: (Integral a) => a -> a -> a +gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" +gcd x y = gcd' (abs x) (abs y) + where gcd' x 0 = x + gcd' x y = gcd' y (x `rem` y) + +{-# GENERATE_SPECS lcm a{Int#,Int,Integer} #-} +lcm :: (Integral a) => a -> a -> a +lcm _ 0 = 0 +lcm 0 _ = 0 +lcm x y = abs ((x `quot` (gcd x y)) * y) + +(^) :: (Num a, Integral b) => a -> b -> a +x ^ 0 = 1 +x ^ n | n > 0 = f x (n-1) x + where f _ 0 y = y + f x n y = g x n where + g x n | even n = g (x*x) (n `quot` 2) + | otherwise = f x (n-1) (x*y) +_ ^ _ = error "Prelude.^: negative exponent" + +(^^) :: (Fractional a, Integral b) => a -> b -> a +x ^^ n = if n >= 0 then x^n else recip (x^(negate n)) + +fromIntegral :: (Integral a, Num b) => a -> b +fromIntegral = fromInteger . toInteger + +fromRealFrac :: (RealFrac a, Fractional b) => a -> b +fromRealFrac = fromRational . toRational + +atan2 :: (RealFloat a) => a -> a -> a +atan2 y x = case (signum y, signum x) of + ( 0, 1) -> 0 + ( 1, 0) -> pi/2 + ( 0,-1) -> pi + (-1, 0) -> (negate pi)/2 + ( _, 1) -> atan (y/x) + ( _,-1) -> atan (y/x) + pi + ( 0, 0) -> error "Prelude.atan2: atan2 of origin" +\end{code} + + +%********************************************************* +%* * +\subsection{Instances for @Int@} +%* * +%********************************************************* + +\begin{code} +instance Real Int where + toRational x = toInteger x % 1 + +instance Integral Int where + a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b) + -- OK, so I made it a little stricter. Shoot me. (WDP 94/10) + + -- Following chks for zero divisor are non-standard (WDP) + a `quot` b = if b /= 0 + then a `quotInt` b + else error "Integral.Int.quot{PreludeCore}: divide by 0\n" + a `rem` b = if b /= 0 + then a `remInt` b + else error "Integral.Int.rem{PreludeCore}: divide by 0\n" + + x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y + else if x < 0 && y > 0 then quotInt (x-y+1) y + else quotInt x y + x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then + if r/=0 then r+y else 0 + else + r + where r = remInt x y + + divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y) + -- Stricter. Sorry if you don't like it. (WDP 94/10) + +--OLD: even x = eqInt (x `mod` 2) 0 +--OLD: odd x = neInt (x `mod` 2) 0 + + toInteger (I# n#) = int2Integer# n# -- give back a full-blown Integer + toInt x = x + +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Integer@} +%* * +%********************************************************* + +These types are used to return from integer primops + +\begin{code} +data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray# +data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray# +\end{code} + +Instances + +\begin{code} +instance Eq Integer where + (J# a1 s1 d1) == (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0# + + (J# a1 s1 d1) /= (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0# + +instance Ord Integer where + (J# a1 s1 d1) <= (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0# + + (J# a1 s1 d1) < (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) <# 0# + + (J# a1 s1 d1) >= (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0# + + (J# a1 s1 d1) > (J# a2 s2 d2) + = (cmpInteger# a1 s1 d1 a2 s2 d2) ># 0# + + x@(J# a1 s1 d1) `max` y@(J# a2 s2 d2) + = if ((cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#) then x else y + + x@(J# a1 s1 d1) `min` y@(J# a2 s2 d2) + = if ((cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#) then x else y + + compare (J# a1 s1 d1) (J# a2 s2 d2) + = case cmpInteger# a1 s1 d1 a2 s2 d2 of { res# -> + if res# <# 0# then LT else + if res# ># 0# then GT else EQ + } + +instance Num Integer where + (+) (J# a1 s1 d1) (J# a2 s2 d2) + = plusInteger# a1 s1 d1 a2 s2 d2 + + (-) (J# a1 s1 d1) (J# a2 s2 d2) + = minusInteger# a1 s1 d1 a2 s2 d2 + + negate (J# a s d) = negateInteger# a s d + + (*) (J# a1 s1 d1) (J# a2 s2 d2) + = timesInteger# a1 s1 d1 a2 s2 d2 + + -- ORIG: abs n = if n >= 0 then n else -n + + abs n@(J# a1 s1 d1) + = case 0 of { J# a2 s2 d2 -> + if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0# + then n + else negateInteger# a1 s1 d1 + } + + signum n@(J# a1 s1 d1) + = case 0 of { J# a2 s2 d2 -> + let + cmp = cmpInteger# a1 s1 d1 a2 s2 d2 + in + if cmp ># 0# then 1 + else if cmp ==# 0# then 0 + else (negate 1) + } + + fromInteger x = x + + fromInt (I# n#) = int2Integer# n# -- gives back a full-blown Integer + +instance Real Integer where + toRational x = x % 1 + +instance Integral Integer where + quotRem (J# a1 s1 d1) (J# a2 s2 d2) + = case (quotRemInteger# a1 s1 d1 a2 s2 d2) of + Return2GMPs a3 s3 d3 a4 s4 d4 + -> (J# a3 s3 d3, J# a4 s4 d4) + +{- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW: + + divMod (J# a1 s1 d1) (J# a2 s2 d2) + = case (divModInteger# a1 s1 d1 a2 s2 d2) of + Return2GMPs a3 s3 d3 a4 s4 d4 + -> (J# a3 s3 d3, J# a4 s4 d4) +-} + toInteger n = n + toInt (J# a s d) = case (integer2Int# a s d) of { n# -> I# n# } + + -- the rest are identical to the report default methods; + -- you get slightly better code if you let the compiler + -- see them right here: + n `quot` d = if d /= 0 then q else + error "Integral.Integer.quot{PreludeCore}: divide by 0\n" + where (q,r) = quotRem n d + n `rem` d = if d /= 0 then r else + error "Integral.Integer.quot{PreludeCore}: divide by 0\n" + where (q,r) = quotRem n d + n `div` d = q where (q,r) = divMod n d + n `mod` d = r where (q,r) = divMod n d + + divMod n d = case (quotRem n d) of { qr@(q,r) -> + if signum r == negate (signum d) then (q - 1, r+d) else qr } + -- Case-ified by WDP 94/10 + +instance Enum Integer where + toEnum n = toInteger n + fromEnum n = toInt n + enumFrom n = n : enumFrom (n + 1) + enumFromThen m n = en' m (n - m) + where en' m n = m : en' (m + n) n + enumFromTo n m = takeWhile (<= m) (enumFrom n) + enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) + (enumFromThen n m) + +instance Show Integer where + showsPrec x = showSignedInteger x + showList = showList__ (showsPrec 0) + +instance Ix Integer where + range (m,n) = [m..n] + index b@(m,n) i + | inRange b i = fromInteger (i - m) + | otherwise = error "Integer.index: Index out of range." + inRange (m,n) i = m <= i && i <= n + +integer_0, integer_1, integer_2, integer_m1 :: Integer +integer_0 = int2Integer# 0# +integer_1 = int2Integer# 1# +integer_2 = int2Integer# 2# +integer_m1 = int2Integer# (negateInt# 1#) +\end{code} + + +%********************************************************* +%* * +\subsection{Type @Float@} +%* * +%********************************************************* + +\begin{code} +instance Eq Float where + (F# x) == (F# y) = x `eqFloat#` y + +instance Ord Float where + (F# x) `compare` (F# y) | x `ltFloat#` y = LT + | x `eqFloat#` y = EQ + | otherwise = GT + + (F# x) < (F# y) = x `ltFloat#` y + (F# x) <= (F# y) = x `leFloat#` y + (F# x) >= (F# y) = x `geFloat#` y + (F# x) > (F# y) = x `gtFloat#` y + +instance Num Float where + (+) x y = plusFloat x y + (-) x y = minusFloat x y + negate x = negateFloat x + (*) x y = timesFloat x y + abs x | x >= 0.0 = x + | otherwise = negateFloat x + signum x | x == 0.0 = 0 + | x > 0.0 = 1 + | otherwise = negate 1 + fromInteger n = encodeFloat n 0 + fromInt i = int2Float i + +instance Real Float where + toRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Float where + (/) x y = divideFloat x y + fromRational x = fromRat x + recip x = 1.0 / x + +instance Floating Float where + pi = 3.141592653589793238 + exp x = expFloat x + log x = logFloat x + sqrt x = sqrtFloat x + sin x = sinFloat x + cos x = cosFloat x + tan x = tanFloat x + asin x = asinFloat x + acos x = acosFloat x + atan x = atanFloat x + sinh x = sinhFloat x + cosh x = coshFloat x + tanh x = tanhFloat x + (**) x y = powerFloat x y + logBase x y = log y / log x + + asinh x = log (x + sqrt (1.0+x*x)) + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + atanh x = log ((x+1.0) / sqrt (1.0-x*x)) + +instance RealFrac Float where + + {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} + {-# SPECIALIZE truncate :: Float -> Int #-} + {-# SPECIALIZE round :: Float -> Int #-} + {-# SPECIALIZE ceiling :: Float -> Int #-} + {-# SPECIALIZE floor :: Float -> Int #-} + + {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-} + {-# SPECIALIZE truncate :: Float -> Integer #-} + {-# SPECIALIZE round :: Float -> Integer #-} + {-# SPECIALIZE ceiling :: Float -> Integer #-} + {-# SPECIALIZE floor :: Float -> Integer #-} + + properFraction x + = case (decodeFloat x) of { (m,n) -> + let b = floatRadix x in + if n >= 0 then + (fromInteger m * fromInteger b ^ n, 0.0) + else + case (quotRem m (b^(negate n))) of { (w,r) -> + (fromInteger w, encodeFloat r n) + } + } + + truncate x = case properFraction x of + (n,_) -> n + + round x = case properFraction x of + (n,r) -> let + m = if r < 0.0 then n - 1 else n + 1 + half_down = abs r - 0.5 + in + case (compare half_down 0.0) of + LT -> n + EQ -> if even n then n else m + GT -> m + + ceiling x = case properFraction x of + (n,r) -> if r > 0.0 then n + 1 else n + + floor x = case properFraction x of + (n,r) -> if r < 0.0 then n - 1 else n + +instance RealFloat Float where + floatRadix _ = FLT_RADIX -- from float.h + floatDigits _ = FLT_MANT_DIG -- ditto + floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto + + decodeFloat (F# f#) + = case decodeFloat# f# of + ReturnIntAndGMP exp# a# s# d# -> + (J# a# s# d#, I# exp#) + + encodeFloat (J# a# s# d#) (I# e#) + = case encodeFloat# a# s# d# e# of { flt# -> F# flt# } + + exponent x = case decodeFloat x of + (m,n) -> if m == 0 then 0 else n + floatDigits x + + significand x = case decodeFloat x of + (m,_) -> encodeFloat m (negate (floatDigits x)) + + scaleFloat k x = case decodeFloat x of + (m,n) -> encodeFloat m (n+k) + isNaN x = + (0::Int) /= unsafePerformIO (_ccall_ isFloatNaN x) {- a _pure_function! -} + isInfinite x = + (0::Int) /= unsafePerformIO (_ccall_ isFloatInfinite x) {- ditto! -} + isDenormalized x = + (0::Int) /= unsafePerformIO (_ccall_ isFloatDenormalized x) -- .. + isNegativeZero x = + (0::Int) /= unsafePerformIO (_ccall_ isFloatNegativeZero x) -- ... + isIEEE x = True + +instance Show Float where + showsPrec x = showSigned showFloat x + showList = showList__ (showsPrec 0) +\end{code} + +%********************************************************* +%* * +\subsection{Type @Double@} +%* * +%********************************************************* + +\begin{code} +instance Eq Double where + (D# x) == (D# y) = x ==## y + +instance Ord Double where + (D# x) `compare` (D# y) | x <## y = LT + | x ==## y = EQ + | otherwise = GT + + (D# x) < (D# y) = x <## y + (D# x) <= (D# y) = x <=## y + (D# x) >= (D# y) = x >=## y + (D# x) > (D# y) = x >## y + +instance Num Double where + (+) x y = plusDouble x y + (-) x y = minusDouble x y + negate x = negateDouble x + (*) x y = timesDouble x y + abs x | x >= 0.0 = x + | otherwise = negateDouble x + signum x | x == 0.0 = 0 + | x > 0.0 = 1 + | otherwise = negate 1 + fromInteger n = encodeFloat n 0 + fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# } + +instance Real Double where + toRational x = (m%1)*(b%1)^^n + where (m,n) = decodeFloat x + b = floatRadix x + +instance Fractional Double where + (/) x y = divideDouble x y + fromRational x = fromRat x + recip x = 1.0 / x + +instance Floating Double where + pi = 3.141592653589793238 + exp x = expDouble x + log x = logDouble x + sqrt x = sqrtDouble x + sin x = sinDouble x + cos x = cosDouble x + tan x = tanDouble x + asin x = asinDouble x + acos x = acosDouble x + atan x = atanDouble x + sinh x = sinhDouble x + cosh x = coshDouble x + tanh x = tanhDouble x + (**) x y = powerDouble x y + logBase x y = log y / log x + + asinh x = log (x + sqrt (1.0+x*x)) + acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) + atanh x = log ((x+1.0) / sqrt (1.0-x*x)) + +instance RealFrac Double where + + {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} + {-# SPECIALIZE truncate :: Double -> Int #-} + {-# SPECIALIZE round :: Double -> Int #-} + {-# SPECIALIZE ceiling :: Double -> Int #-} + {-# SPECIALIZE floor :: Double -> Int #-} + + {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-} + {-# SPECIALIZE truncate :: Double -> Integer #-} + {-# SPECIALIZE round :: Double -> Integer #-} + {-# SPECIALIZE ceiling :: Double -> Integer #-} + {-# SPECIALIZE floor :: Double -> Integer #-} + +#if defined(__UNBOXED_INSTANCES__) + {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-} + {-# SPECIALIZE truncate :: Double -> Int# #-} + {-# SPECIALIZE round :: Double -> Int# #-} + {-# SPECIALIZE ceiling :: Double -> Int# #-} + {-# SPECIALIZE floor :: Double -> Int# #-} +#endif + + properFraction x + = case (decodeFloat x) of { (m,n) -> + let b = floatRadix x in + if n >= 0 then + (fromInteger m * fromInteger b ^ n, 0.0) + else + case (quotRem m (b^(negate n))) of { (w,r) -> + (fromInteger w, encodeFloat r n) + } + } + + truncate x = case properFraction x of + (n,_) -> n + + round x = case properFraction x of + (n,r) -> let + m = if r < 0.0 then n - 1 else n + 1 + half_down = abs r - 0.5 + in + case (compare half_down 0.0) of + LT -> n + EQ -> if even n then n else m + GT -> m + + ceiling x = case properFraction x of + (n,r) -> if r > 0.0 then n + 1 else n + + floor x = case properFraction x of + (n,r) -> if r < 0.0 then n - 1 else n + +instance RealFloat Double where + floatRadix _ = FLT_RADIX -- from float.h + floatDigits _ = DBL_MANT_DIG -- ditto + floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto + + decodeFloat (D# d#) + = case decodeDouble# d# of + ReturnIntAndGMP exp# a# s# d# -> + (J# a# s# d#, I# exp#) + + encodeFloat (J# a# s# d#) (I# e#) + = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# } + + exponent x = case decodeFloat x of + (m,n) -> if m == 0 then 0 else n + floatDigits x + + significand x = case decodeFloat x of + (m,_) -> encodeFloat m (negate (floatDigits x)) + + scaleFloat k x = case decodeFloat x of + (m,n) -> encodeFloat m (n+k) + isNaN x = + (0::Int) /= unsafePerformIO (_ccall_ isDoubleNaN x) {- a _pure_function! -} + isInfinite x = + (0::Int) /= unsafePerformIO (_ccall_ isDoubleInfinite x) {- ditto -} + isDenormalized x = + (0::Int) /= unsafePerformIO (_ccall_ isDoubleDenormalized x) -- .. + isNegativeZero x = + (0::Int) /= unsafePerformIO (_ccall_ isDoubleNegativeZero x) -- ... + isIEEE x = True + +instance Show Double where + showsPrec x = showSigned showFloat x + showList = showList__ (showsPrec 0) +\end{code} + + +%********************************************************* +%* * +\subsection{Common code for @Float@ and @Double@} +%* * +%********************************************************* + +The @Enum@ instances for Floats and Doubles are slightly unusual. +The @toEnum@ function truncates numbers to Int. The definitions +of @enumFrom@ and @enumFromThen@ allow floats to be used in arithmetic +series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat +dubious. This example may have either 10 or 11 elements, depending on +how 0.1 is represented. + +NOTE: The instances for Float and Double do not make use of the default +methods for @enumFromTo@ and @enumFromThenTo@, as these rely on there being +a `non-lossy' conversion to and from Ints. Instead we make use of the +1.2 default methods (back in the days when Enum had Ord as a superclass) +for these (@numericEnumFromTo@ and @numericEnumFromThenTo@ below.) + +\begin{code} +instance Enum Float where + toEnum = fromIntegral + fromEnum = fromInteger . truncate -- may overflow + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +instance Enum Double where + toEnum = fromIntegral + fromEnum = fromInteger . truncate -- may overflow + enumFrom = numericEnumFrom + enumFromThen = numericEnumFromThen + enumFromThenTo = numericEnumFromThenTo + +numericEnumFrom :: (Real a) => a -> [a] +numericEnumFromThen :: (Real a) => a -> a -> [a] +numericEnumFromThenTo :: (Real a) => a -> a -> a -> [a] +numericEnumFrom = iterate (+1) +numericEnumFromThen n m = iterate (+(m-n)) n +numericEnumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p)) + (numericEnumFromThen n m) +\end{code} + + +%********************************************************* +%* * +\subsection{The @Ratio@ and @Rational@ types} +%* * +%********************************************************* + +\begin{code} +data (Eval a, Integral a) => Ratio a = !a :% !a deriving (Eq) +type Rational = Ratio Integer +\end{code} + +\begin{code} +(%) :: (Integral a) => a -> a -> Ratio a +numerator, denominator :: (Integral a) => Ratio a -> a +approxRational :: (RealFrac a) => a -> a -> Rational + +\end{code} + +\tr{reduce} is a subsidiary function used only in this module . +It normalises a ratio by dividing both numerator and denominator by +their greatest common divisor. + +\begin{code} +reduce x 0 = error "{Ratio.%}: zero denominator" +reduce x y = (x `quot` d) :% (y `quot` d) + where d = gcd x y +\end{code} + +\begin{code} +x % y = reduce (x * signum y) (abs y) + +numerator (x:%y) = x + +denominator (x:%y) = y +\end{code} + + +@approxRational@, applied to two real fractional numbers x and epsilon, +returns the simplest rational number within epsilon of x. A rational +number n%d in reduced form is said to be simpler than another n'%d' if +abs n <= abs n' && d <= d'. Any real interval contains a unique +simplest rational; here, for simplicity, we assume a closed rational +interval. If such an interval includes at least one whole number, then +the simplest rational is the absolutely least whole number. Otherwise, +the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d +and abs r' < d', and the simplest rational is q%1 + the reciprocal of +the simplest rational between d'%r' and d%r. + +\begin{code} +approxRational x eps = simplest (x-eps) (x+eps) + where simplest x y | y < x = simplest y x + | x == y = xr + | x > 0 = simplest' n d n' d' + | y < 0 = - simplest' (-n') d' (-n) d + | otherwise = 0 :% 1 + where xr = toRational x + n = numerator xr + d = denominator xr + nd' = toRational y + n' = numerator nd' + d' = denominator nd' + + simplest' n d n' d' -- assumes 0 < n%d < n'%d' + | r == 0 = q :% 1 + | q /= q' = (q+1) :% 1 + | otherwise = (q*n''+d'') :% n'' + where (q,r) = quotRem n d + (q',r') = quotRem n' d' + nd'' = simplest' d' r' d r + n'' = numerator nd'' + d'' = denominator nd'' +\end{code} + + +\begin{code} +instance (Integral a) => Ord (Ratio a) where + (x:%y) <= (x':%y') = x * y' <= x' * y + (x:%y) < (x':%y') = x * y' < x' * y + +instance (Integral a) => Num (Ratio a) where + (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y') + (x:%y) - (x':%y') = reduce (x*y' - x'*y) (y*y') + (x:%y) * (x':%y') = reduce (x * x') (y * y') + negate (x:%y) = (-x) :% y + abs (x:%y) = abs x :% y + signum (x:%y) = signum x :% 1 + fromInteger x = fromInteger x :% 1 + +instance (Integral a) => Real (Ratio a) where + toRational (x:%y) = toInteger x :% toInteger y + +instance (Integral a) => Fractional (Ratio a) where + (x:%y) / (x':%y') = (x*y') % (y*x') + recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x + fromRational (x:%y) = fromInteger x :% fromInteger y + +instance (Integral a) => RealFrac (Ratio a) where + properFraction (x:%y) = (fromIntegral q, r:%y) + where (q,r) = quotRem x y + +instance (Integral a) => Enum (Ratio a) where + enumFrom = iterate ((+)1) + enumFromThen n m = iterate ((+)(m-n)) n + toEnum n = fromIntegral n :% 1 + fromEnum = fromInteger . truncate + +ratio_prec :: Int +ratio_prec = 7 + +instance (Integral a) => Show (Ratio a) where + showsPrec p (x:%y) = showParen (p > ratio_prec) + (shows x . showString " % " . shows y) +\end{code} + +\begin{code} +--Exported from std library Numeric, defined here to +--avoid mut. rec. between PrelNum and Numeric. +showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS +showSigned showPos p x = if x < 0 then showParen (p > 6) + (showChar '-' . showPos (-x)) + else showPos x + +showSignedInteger :: Int -> Integer -> ShowS +showSignedInteger p n r + = -- from HBC version; support code follows + if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r + +jtos :: Integer -> String +jtos n + = if n < 0 then + '-' : jtos' (-n) [] + else + jtos' n [] + +jtos' :: Integer -> String -> String +jtos' n cs + = if n < 10 then + chr (fromInteger (n + ord_0)) : cs + else + jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs) + +showFloat x = showString (formatRealFloat FFGeneric Nothing x) + +-- These are the format types. This type is not exported. + +data FFFormat = FFExponent | FFFixed | FFGeneric --no need: deriving (Eq, Ord, Show) + +formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String +formatRealFloat fmt decs x = s + where + base = 10 + s = if isNaN x + then "NaN" + else + if isInfinite x then + if x < 0 then "-Infinity" else "Infinity" + else + if x < 0 || isNegativeZero x then + '-':doFmt fmt (floatToDigits (toInteger base) (-x)) + else + doFmt fmt (floatToDigits (toInteger base) x) + + doFmt fmt (is, e) = + let ds = map intToDigit is in + case fmt of + FFGeneric -> + doFmt (if e <0 || e > 7 then FFExponent else FFFixed) + (is,e) + FFExponent -> + case decs of + Nothing -> + let e' = if e==0 then 0 else e-1 in + (case ds of + [d] -> d : ".0e" + (d:ds) -> d : '.' : ds ++ "e") ++ show e' + Just dec -> + let dec' = max dec 1 in + case is of + [0] -> '0':'.':take dec' (repeat '0') ++ "e0" + _ -> + let + (ei,is') = roundTo base (dec'+1) is + d:ds = map intToDigit (if ei > 0 then init is' else is') + in + d:'.':ds ++ 'e':show (e-1+ei) + FFFixed -> + let + mk0 ls = case ls of { "" -> "0" ; _ -> ls} + in + case decs of + Nothing -> + let + f 0 s ds = mk0 (reverse s) ++ '.':mk0 ds + f n s "" = f (n-1) ('0':s) "" + f n s (d:ds) = f (n-1) (d:s) ds + in + f e "" ds + Just dec -> + let dec' = max dec 1 in + if e >= 0 then + let + (ei,is') = roundTo base (dec' + e) is + (ls,rs) = splitAt (e+ei) (map intToDigit is') + in + mk0 ls ++ (if null rs then "" else '.':rs) + else + let + (ei,is') = roundTo base dec' (replicate (-e) 0 ++ is) + d:ds = map intToDigit (if ei > 0 then is' else 0:is') + in + d : '.' : ds + + +roundTo :: Int -> Int -> [Int] -> (Int,[Int]) +roundTo base d is = + let + v = f d is + in + case v of + (0,is) -> v + (1,is) -> (1, 1:is) + where + b2 = base `div` 2 + + f n [] = (0, replicate n 0) + f 0 (i:_) = (if i>=b2 then 1 else 0, []) + f d (i:is) = + let + (c,ds) = f (d-1) is + i' = c + i + in + if i' == base then (1,0:ds) else (0,i':ds) + +-- +-- Based on "Printing Floating-Point Numbers Quickly and Accurately" +-- by R.G. Burger and R.K. Dybvig in PLDI 96. +-- This version uses a much slower logarithm estimator. It should be improved. + +-- This function returns a list of digits (Ints in [0..base-1]) and an +-- exponent. +--floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int) +floatToDigits _ 0 = ([0], 0) +floatToDigits base x = + let + (f0, e0) = decodeFloat x + (minExp0, _) = floatRange x + p = floatDigits x + b = floatRadix x + minExp = minExp0 - p -- the real minimum exponent + -- Haskell requires that f be adjusted so denormalized numbers + -- will have an impossibly low exponent. Adjust for this. + (f, e) = + let n = minExp - e0 in + if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + (r, s, mUp, mDn) = + if e >= 0 then + let be = b^ e in + if f == b^(p-1) then + (f*be*b*2, 2*b, be*b, b) + else + (f*be*2, 2, be, be) + else + if e > minExp && f == b^(p-1) then + (f*b*2, b^(-e+1)*2, b, 1) + else + (f*2, b^(-e)*2, 1, 1) + k = + let + k0 = + if b == 2 && base == 10 then + -- logBase 10 2 is slightly bigger than 3/10 so + -- the following will err on the low side. Ignoring + -- the fraction will make it err even more. + -- Haskell promises that p-1 <= logBase b f < p. + (p - 1 + e0) * 3 `div` 10 + else + ceiling ((log (fromInteger (f+1)) + + fromInt e * log (fromInteger b)) / + fromInt e * log (fromInteger b)) + + fixup n = + if n >= 0 then + if r + mUp <= expt base n * s then n else fixup (n+1) + else + if expt base (-n) * (r + mUp) <= s then n else fixup (n+1) + in + fixup k0 + + gen ds rn sN mUpN mDnN = + let + (dn, rn') = (rn * base) `divMod` sN + mUpN' = mUpN * base + mDnN' = mDnN * base + in + case (rn' < mDnN', rn' + mUpN' > sN) of + (True, False) -> dn : ds + (False, True) -> dn+1 : ds + (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds + (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN' + + rds = + if k >= 0 then + gen [] r (s * expt base k) mUp mDn + else + let bk = expt base (-k) in + gen [] (r * bk) s (mUp * bk) (mDn * bk) + in + (map toInt (reverse rds), k) + +\end{code} + +@showRational@ converts a Rational to a string that looks like a +floating point number, but without converting to any floating type +(because of the possible overflow). + +From/by Lennart, 94/09/26 + +\begin{code} +showRational :: Int -> Rational -> String +showRational n r = + if r == 0 then + "0.0" + else + let (r', e) = normalize r + in prR n r' e + +startExpExp = 4 :: Int + +-- make sure 1 <= r < 10 +normalize :: Rational -> (Rational, Int) +normalize r = if r < 1 then + case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1) + else + norm startExpExp r 0 + where norm :: Int -> Rational -> Int -> (Rational, Int) + -- Invariant: r*10^e == original r + norm 0 r e = (r, e) + norm ee r e = + let n = 10^ee + tn = 10^n + in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e + +drop0 "" = "" +drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs)) + +prR :: Int -> Rational -> Int -> String +prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment +prR n r e | r >= 10 = prR n (r/10) (e+1) +prR n r e0 = + let s = show ((round (r * 10^n))::Integer) + e = e0+1 + in if e > 0 && e < 8 then + take e s ++ "." ++ drop0 (drop e s) + else if e <= 0 && e > -3 then + "0." ++ take (-e) (repeat '0') ++ drop0 s + else + head s : "."++ drop0 (tail s) ++ "e" ++ show e0 +\end{code} + + +[In response to a request for documentation of how fromRational works, +Joe Fasel writes:] A quite reasonable request! This code was added to +the Prelude just before the 1.2 release, when Lennart, working with an +early version of hbi, noticed that (read . show) was not the identity +for floating-point numbers. (There was a one-bit error about half the +time.) The original version of the conversion function was in fact +simply a floating-point divide, as you suggest above. The new version +is, I grant you, somewhat denser. + +Unfortunately, Joe's code doesn't work! Here's an example: + +main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n") + +This program prints + 0.0000000000000000 +instead of + 1.8217369128763981e-300 + +Lennart's code follows, and it works... + +\begin{pseudocode} +{-# GENERATE_SPECS fromRational__ a{Double#,Double} #-} +fromRat :: (RealFloat a) => Rational -> a +fromRat x = x' + where x' = f e + +-- If the exponent of the nearest floating-point number to x +-- is e, then the significand is the integer nearest xb^(-e), +-- where b is the floating-point radix. We start with a good +-- guess for e, and if it is correct, the exponent of the +-- floating-point number we construct will again be e. If +-- not, one more iteration is needed. + + f e = if e' == e then y else f e' + where y = encodeFloat (round (x * (1 % b)^^e)) e + (_,e') = decodeFloat y + b = floatRadix x' + +-- We obtain a trial exponent by doing a floating-point +-- division of x's numerator by its denominator. The +-- result of this division may not itself be the ultimate +-- result, because of an accumulation of three rounding +-- errors. + + (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x' + / fromInteger (denominator x)) +\end{pseudocode} + +Now, here's Lennart's code. + +\begin{code} +--fromRat :: (RealFloat a) => Rational -> a +fromRat x = + if x == 0 then encodeFloat 0 0 -- Handle exceptional cases + else if x < 0 then - fromRat' (-x) -- first. + else fromRat' x + +-- Conversion process: +-- Scale the rational number by the RealFloat base until +-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat). +-- Then round the rational to an Integer and encode it with the exponent +-- that we got from the scaling. +-- To speed up the scaling process we compute the log2 of the number to get +-- a first guess of the exponent. + +fromRat' :: (RealFloat a) => Rational -> a +fromRat' x = r + where b = floatRadix r + p = floatDigits r + (minExp0, _) = floatRange r + minExp = minExp0 - p -- the real minimum exponent + xMin = toRational (expt b (p-1)) + xMax = toRational (expt b p) + p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp + f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1 + (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f) + r = encodeFloat (round x') p' + +-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp. +scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int) +scaleRat b minExp xMin xMax p x = + if p <= minExp then + (x, p) + else if x >= xMax then + scaleRat b minExp xMin xMax (p+1) (x/b) + else if x < xMin then + scaleRat b minExp xMin xMax (p-1) (x*b) + else + (x, p) + +-- Exponentiation with a cache for the most common numbers. +minExpt = 0::Int +maxExpt = 1100::Int +expt :: Integer -> Int -> Integer +expt base n = + if base == 2 && n >= minExpt && n <= maxExpt then + expts!n + else + base^n +expts :: Array Int Integer +expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] + +-- Compute the (floor of the) log of i in base b. +-- Simplest way would be just divide i by b until it's smaller then b, but that would +-- be very slow! We are just slightly more clever. +integerLogBase :: Integer -> Integer -> Int +integerLogBase b i = + if i < b then + 0 + else + -- Try squaring the base first to cut down the number of divisions. + let l = 2 * integerLogBase (b*b) i + doDiv :: Integer -> Int -> Int + doDiv i l = if i < b then l else doDiv (i `div` b) (l+1) + in doDiv (i `div` (b^l)) l +\end{code} + +%********************************************************* +%* * +\subsection{Numeric primops} +%* * +%********************************************************* + +Definitions of the boxed PrimOps; these will be +used in the case of partial applications, etc. + +\begin{code} +plusFloat (F# x) (F# y) = F# (plusFloat# x y) +minusFloat (F# x) (F# y) = F# (minusFloat# x y) +timesFloat (F# x) (F# y) = F# (timesFloat# x y) +divideFloat (F# x) (F# y) = F# (divideFloat# x y) +negateFloat (F# x) = F# (negateFloat# x) + +gtFloat (F# x) (F# y) = gtFloat# x y +geFloat (F# x) (F# y) = geFloat# x y +eqFloat (F# x) (F# y) = eqFloat# x y +neFloat (F# x) (F# y) = neFloat# x y +ltFloat (F# x) (F# y) = ltFloat# x y +leFloat (F# x) (F# y) = leFloat# x y + +float2Int (F# x) = I# (float2Int# x) +int2Float (I# x) = F# (int2Float# x) + +expFloat (F# x) = F# (expFloat# x) +logFloat (F# x) = F# (logFloat# x) +sqrtFloat (F# x) = F# (sqrtFloat# x) +sinFloat (F# x) = F# (sinFloat# x) +cosFloat (F# x) = F# (cosFloat# x) +tanFloat (F# x) = F# (tanFloat# x) +asinFloat (F# x) = F# (asinFloat# x) +acosFloat (F# x) = F# (acosFloat# x) +atanFloat (F# x) = F# (atanFloat# x) +sinhFloat (F# x) = F# (sinhFloat# x) +coshFloat (F# x) = F# (coshFloat# x) +tanhFloat (F# x) = F# (tanhFloat# x) + +powerFloat (F# x) (F# y) = F# (powerFloat# x y) + +-- definitions of the boxed PrimOps; these will be +-- used in the case of partial applications, etc. + +plusDouble (D# x) (D# y) = D# (x +## y) +minusDouble (D# x) (D# y) = D# (x -## y) +timesDouble (D# x) (D# y) = D# (x *## y) +divideDouble (D# x) (D# y) = D# (x /## y) +negateDouble (D# x) = D# (negateDouble# x) + +gtDouble (D# x) (D# y) = x >## y +geDouble (D# x) (D# y) = x >=## y +eqDouble (D# x) (D# y) = x ==## y +neDouble (D# x) (D# y) = x /=## y +ltDouble (D# x) (D# y) = x <## y +leDouble (D# x) (D# y) = x <=## y + +double2Int (D# x) = I# (double2Int# x) +int2Double (I# x) = D# (int2Double# x) +double2Float (D# x) = F# (double2Float# x) +float2Double (F# x) = D# (float2Double# x) + +expDouble (D# x) = D# (expDouble# x) +logDouble (D# x) = D# (logDouble# x) +sqrtDouble (D# x) = D# (sqrtDouble# x) +sinDouble (D# x) = D# (sinDouble# x) +cosDouble (D# x) = D# (cosDouble# x) +tanDouble (D# x) = D# (tanDouble# x) +asinDouble (D# x) = D# (asinDouble# x) +acosDouble (D# x) = D# (acosDouble# x) +atanDouble (D# x) = D# (atanDouble# x) +sinhDouble (D# x) = D# (sinhDouble# x) +coshDouble (D# x) = D# (coshDouble# x) +tanhDouble (D# x) = D# (tanhDouble# x) + +powerDouble (D# x) (D# y) = D# (x **## y) +\end{code} diff --git a/ghc/lib/std/PrelPack.lhs b/ghc/lib/std/PrelPack.lhs new file mode 100644 index 0000000000..39b4a235a3 --- /dev/null +++ b/ghc/lib/std/PrelPack.lhs @@ -0,0 +1,258 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\section[PrelPack]{Packing/unpacking bytes} + +This module provides a small set of low-level functions for packing +and unpacking a chunk of bytes. Used by code emitted by the compiler +plus the prelude libraries. + +The programmer level view of packed strings is provided by a GHC +system library PackedString. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelPack + ( + -- (**) - emitted by compiler. + + packCString#, -- :: [Char] -> ByteArray# ** + packString, -- :: [Char] -> ByteArray Int + packStringST, -- :: [Char] -> ST s (ByteArray Int) + packNBytesST, -- :: Int -> [Char] -> ST s (ByteArray Int) + + unpackCString, -- :: Addr -> [Char] + unpackNBytes, -- :: Addr -> Int -> [Char] + unpackNBytesST, -- :: Addr -> Int -> ST s [Char] + unpackCString#, -- :: Addr# -> [Char] ** + unpackNBytes#, -- :: Addr# -> Int# -> [Char] ** + unpackNBytesST#, -- :: Addr# -> Int# -> ST s [Char] + + unpackCStringBA, -- :: ByteArray Int -> [Char] + unpackNBytesBA, -- :: ByteArray Int -> Int -> [Char] + unpackCStringBA#, -- :: ByteArray# -> Int# -> [Char] + unpackNBytesBA#, -- :: ByteArray# -> Int# -> [Char] + + + unpackFoldrCString#, -- ** + unpackAppendCString#, -- ** + + new_ps_array, -- Int# -> ST s (MutableByteArray s Int) + write_ps_array, -- MutableByteArray s Int -> Int# -> Char# -> ST s () + freeze_ps_array -- MutableByteArray s Int -> Int# -> ST s (ByteArray Int) + + + ) + where + +import PrelBase +import {-# SOURCE #-} PrelErr ( error ) +import PrelList ( length ) +import PrelST +import PrelArr +import PrelAddr +import PrelUnsafeST ( runST ) + +\end{code} + +%********************************************************* +%* * +\subsection{Unpacking Addrs} +%* * +%********************************************************* + +Primitives for converting Addrs pointing to external +sequence of bytes into a list of @Char@s: + +\begin{code} +unpackCString :: Addr{- ptr. to NUL terminated string-} -> [Char] +unpackCString a@(A# addr) = + if a == ``NULL'' then + [] + else + unpackCString# addr + +unpackCString# :: Addr# -> [Char] +unpackCString# addr + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +unpackNBytes :: Addr -> Int -> [Char] +unpackNBytes (A# addr) (I# l) = unpackNBytes# addr l + +unpackNBytesST :: Addr -> Int -> ST s [Char] +unpackNBytesST (A# addr) (I# l) = unpackNBytesST# addr l + +unpackNBytes# :: Addr# -> Int# -> [Char] + -- This one is called by the compiler to unpack literal strings with NULs in them; rare. +unpackNBytes# addr len + = unpack 0# + where + unpack i + | i >=# len = [] + | otherwise = C# ch : unpack (i +# 1#) + where + ch = indexCharOffAddr# addr i + +unpackNBytesST# :: Addr# -> Int# -> ST s [Char] +unpackNBytesST# addr len + = unpack 0# + where + unpack i + | i >=# len = return [] + | otherwise = + case indexCharOffAddr# addr i of + ch -> unpack (i +# 1#) >>= \ ls -> return (C# ch : ls) + +\end{code} + +%******************************************************** +%* * +\subsection{Unpacking ByteArrays} +%* * +%******************************************************** + +Converting byte arrays into list of chars: + +\begin{code} +unpackCStringBA :: ByteArray Int -> [Char] +unpackCStringBA (ByteArray (l@(I# l#),u@(I# u#)) bytes) + | l > u = [] + | otherwise = unpackCStringBA# bytes (u# -# l# +# 1#) + +{- + unpack until NUL or end of BA is reached, whatever comes first. +-} +unpackCStringBA# :: ByteArray# -> Int# -> [Char] +unpackCStringBA# bytes len + = unpack 0# + where + unpack nh + | nh >=# len || + ch `eqChar#` '\0'# = [] + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharArray# bytes nh + +unpackNBytesBA :: ByteArray Int -> Int -> [Char] +unpackNBytesBA (ByteArray (l,u) bytes) i + = unpackNBytesBA# bytes len# + where + len# = case max 0 (min i len) of I# v# -> v# + len | u > l = 0 + | otherwise = u-l+1 + +unpackNBytesBA# :: ByteArray# -> Int# -> [Char] +unpackNBytesBA# bytes nh + = unpack 0# + where + unpack i + | i >=# nh = [] + | otherwise = C# ch : unpack (i +# 1#) + where + ch = indexCharArray# bytes i +\end{code} + + +%******************************************************** +%* * +\subsection{Packing Strings} +%* * +%******************************************************** + +Converting a list of chars into a packed @ByteArray@ representation. + +\begin{code} +packCString# :: [Char] -> ByteArray# +packCString# str = case (packString str) of { ByteArray _ bytes -> bytes } + +packString :: [Char] -> ByteArray Int +packString str = runST (packStringST str) + +packStringST :: [Char] -> ST s (ByteArray Int) +packStringST str = + let len = length str in + packNBytesST len str + +packNBytesST :: Int -> [Char] -> ST s (ByteArray Int) +packNBytesST len@(I# length#) str = + {- + allocate an array that will hold the string + (not forgetting the NUL byte at the end) + -} + new_ps_array (length# +# 1#) >>= \ ch_array -> + -- fill in packed string from "str" + fill_in ch_array 0# str >> + -- freeze the puppy: + freeze_ps_array ch_array length# + where + fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s () + fill_in arr_in# idx [] = + write_ps_array arr_in# idx (chr# 0#) >> + return () + + fill_in arr_in# idx (C# c : cs) = + write_ps_array arr_in# idx c >> + fill_in arr_in# (idx +# 1#) cs + +\end{code} + +(Very :-) ``Specialised'' versions of some CharArray things... + +\begin{code} +new_ps_array :: Int# -> ST s (MutableByteArray s Int) +write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s () +freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int) + +new_ps_array size = ST $ \ s -> + case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# -> + STret s2# (MutableByteArray bot barr#) } + where + bot = error "new_ps_array" + +write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ s# -> + case writeCharArray# barr# n ch s# of { s2# -> + STret s2# () } + +-- same as unsafeFreezeByteArray +freeze_ps_array (MutableByteArray _ arr#) len# = ST $ \ s# -> + case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# -> + STret s2# (ByteArray (0,I# len#) frozen#) } +\end{code} + + +%******************************************************** +%* * +\subsection{Misc} +%* * +%******************************************************** + +The compiler may emit these two + +\begin{code} +unpackAppendCString# :: Addr# -> [Char] -> [Char] +unpackAppendCString# addr rest + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = rest + | otherwise = C# ch : unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh + +unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a +unpackFoldrCString# addr f z + = unpack 0# + where + unpack nh + | ch `eqChar#` '\0'# = z + | otherwise = C# ch `f` unpack (nh +# 1#) + where + ch = indexCharOffAddr# addr nh +\end{code} diff --git a/ghc/lib/std/PrelRead.lhs b/ghc/lib/std/PrelRead.lhs new file mode 100644 index 0000000000..fd5ffaf398 --- /dev/null +++ b/ghc/lib/std/PrelRead.lhs @@ -0,0 +1,405 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelRead]{Module @PrelRead@} + +Instances of the Read class. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelRead where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelNum +import PrelList +import PrelTup +import PrelMaybe +import PrelEither +import PrelBase +\end{code} + +%********************************************************* +%* * +\subsection{The @Read@ class} +%* * +%********************************************************* + +\begin{code} +type ReadS a = String -> [(a,String)] + +class Read a where + readsPrec :: Int -> ReadS a + + readList :: ReadS [a] + readList = readList__ reads +\end{code} + +%********************************************************* +%* * +\subsection{Utility functions} +%* * +%********************************************************* + +\begin{code} +reads :: (Read a) => ReadS a +reads = readsPrec 0 + +read :: (Read a) => String -> a +read s = case [x | (x,t) <- reads s, ("","") <- lex t] of + [x] -> x + [] -> error "PreludeText.read: no parse" + _ -> error "PreludeText.read: ambiguous parse" + +readParen :: Bool -> ReadS a -> ReadS a +readParen b g = if b then mandatory else optional + where optional r = g r ++ mandatory r + mandatory r = [(x,u) | ("(",s) <- lex r, + (x,t) <- optional s, + (")",u) <- lex t ] + + +{-# GENERATE_SPECS readList__ a #-} +readList__ :: ReadS a -> ReadS [a] + +readList__ readx + = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s]) + where readl s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,u) | (x,t) <- readx s, + (xs,u) <- readl2 t] + readl2 s = [([],t) | ("]",t) <- lex s] ++ + [(x:xs,v) | (",",t) <- lex s, + (x,u) <- readx t, + (xs,v) <- readl2 u] +\end{code} + + +%********************************************************* +%* * +\subsection{Lexical analysis} +%* * +%********************************************************* + +This lexer is not completely faithful to the Haskell lexical syntax. +Current limitations: + Qualified names are not handled properly + A `--' does not terminate a symbol + Octal and hexidecimal numerics are not recognized as a single token + +\begin{code} +lex :: ReadS String + +lex "" = [("","")] +lex (c:s) | isSpace c = lex (dropWhile isSpace s) +lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s, + ch /= "'" ] +lex ('"':s) = [('"':str, t) | (str,t) <- lexString s] + where + lexString ('"':s) = [("\"",s)] + lexString s = [(ch++str, u) + | (ch,t) <- lexStrItem s, + (str,u) <- lexString t ] + + lexStrItem ('\\':'&':s) = [("\\&",s)] + lexStrItem ('\\':c:s) | isSpace c + = [("\\&",t) | '\\':t <- [dropWhile isSpace s]] + lexStrItem s = lexLitChar s + +lex (c:s) | isSingle c = [([c],s)] + | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]] + | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]] + | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s], + (fe,t) <- lexFracExp s ] + | otherwise = [] -- bad character + where + isSingle c = c `elem` ",;()[]{}_`" + isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~" + isIdChar c = isAlphanum c || c `elem` "_'" + + lexFracExp ('.':cs) = [('.':ds++e,u) | (ds,t) <- lex0Digits cs, + (e,u) <- lexExp t] + lexFracExp s = [("",s)] + + lexExp (e:s) | e `elem` "eE" + = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-", + (ds,u) <- lexDigits t] ++ + [(e:ds,t) | (ds,t) <- lexDigits s] + lexExp s = [("",s)] + +lexDigits :: ReadS String +lexDigits = nonnull isDigit + +-- 0 or more digits +lex0Digits :: ReadS String +lex0Digits s = [span isDigit s] + +nonnull :: (Char -> Bool) -> ReadS String +nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]] + +lexLitChar :: ReadS String +lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s] + where + lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)] + lexEsc s@(d:_) | isDigit d = lexDigits s + lexEsc _ = [] +lexLitChar (c:s) = [([c],s)] +lexLitChar "" = [] +\end{code} + +%********************************************************* +%* * +\subsection{Instances of @Read@} +%* * +%********************************************************* + +\begin{code} +instance Read Char where + readsPrec p = readParen False + (\r -> [(c,t) | ('\'':s,t)<- lex r, + (c,_) <- readLitChar s]) + + readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r, + (l,_) <- readl s ]) + where readl ('"':s) = [("",s)] + readl ('\\':'&':s) = readl s + readl s = [(c:cs,u) | (c ,t) <- readLitChar s, + (cs,u) <- readl t ] + +instance Read Bool where + readsPrec p = readParen False + (\r -> let lr = lex r + in + [(True, rest) | ("True", rest) <- lr] ++ + [(False,rest) | ("False",rest) <- lr]) + + +instance Read Ordering where + readsPrec p = readParen False + (\r -> let lr = lex r + in + [(LT, rest) | ("LT", rest) <- lr] ++ + [(EQ, rest) | ("EQ", rest) <- lr] ++ + [(GT, rest) | ("GT", rest) <- lr]) + +instance Read a => Read (Maybe a) where + readsPrec p = readParen False + (\r -> let lr = lex r + in + [(Nothing, rest) | ("Nothing", rest) <- lr] ++ + [(Just x, rest2) | ("Just", rest1) <- lr, + (x, rest2) <- reads rest1]) + +instance (Read a, Read b) => Read (Either a b) where + readsPrec p = readParen False + (\r -> let lr = lex r + in + [(Left x, rest2) | ("Left", rest1) <- lr, + (x, rest2) <- reads rest1] ++ + [(Right x, rest2) | ("Right", rest1) <- lr, + (x, rest2) <- reads rest1]) + +instance Read Int where + readsPrec p x = readSigned readDec x + +instance Read Integer where + readsPrec p x = readSigned readDec x + +instance Read Float where + readsPrec p x = readSigned readFloat x + +instance Read Double where + readsPrec p x = readSigned readFloat x + +instance (Integral a, Read a) => Read (Ratio a) where + readsPrec p = readParen (p > ratio_prec) + (\r -> [(x%y,u) | (x,s) <- reads r, + ("%",t) <- lex s, + (y,u) <- reads t ]) + +instance (Read a) => Read [a] where + readsPrec p = readList + +instance Read () where + readsPrec p = readParen False + (\r -> [((),t) | ("(",s) <- lex r, + (")",t) <- lex s ] ) + +instance (Read a, Read b) => Read (a,b) where + readsPrec p = readParen False + (\r -> [((x,y), w) | ("(",s) <- lex r, + (x,t) <- reads s, + (",",u) <- lex t, + (y,v) <- reads u, + (")",w) <- lex v ] ) + +instance (Read a, Read b, Read c) => Read (a, b, c) where + readsPrec p = readParen False + (\a -> [((x,y,z), h) | ("(",b) <- lex a, + (x,c) <- readsPrec 0 b, + (",",d) <- lex c, + (y,e) <- readsPrec 0 d, + (",",f) <- lex e, + (z,g) <- readsPrec 0 f, + (")",h) <- lex g ] ) + +instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where + readsPrec p = readParen False + (\a -> [((w,x,y,z), j) | ("(",b) <- lex a, + (w,c) <- readsPrec 0 b, + (",",d) <- lex c, + (x,e) <- readsPrec 0 d, + (",",f) <- lex e, + (y,g) <- readsPrec 0 f, + (",",h) <- lex g, + (z,i) <- readsPrec 0 h, + (")",j) <- lex i ] ) + +instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where + readsPrec p = readParen False + (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a, + (w,c) <- readsPrec 0 b, + (",",d) <- lex c, + (x,e) <- readsPrec 0 d, + (",",f) <- lex e, + (y,g) <- readsPrec 0 f, + (",",h) <- lex g, + (z,i) <- readsPrec 0 h, + (",",j) <- lex i, + (v,k) <- readsPrec 0 j, + (")",l) <- lex k ] ) +\end{code} + + +%********************************************************* +%* * +\subsection{Reading characters} +%* * +%********************************************************* + +\begin{code} +readLitChar :: ReadS Char + +readLitChar ('\\':s) = readEsc s + where + readEsc ('a':s) = [('\a',s)] + readEsc ('b':s) = [('\b',s)] + readEsc ('f':s) = [('\f',s)] + readEsc ('n':s) = [('\n',s)] + readEsc ('r':s) = [('\r',s)] + readEsc ('t':s) = [('\t',s)] + readEsc ('v':s) = [('\v',s)] + readEsc ('\\':s) = [('\\',s)] + readEsc ('"':s) = [('"',s)] + readEsc ('\'':s) = [('\'',s)] + readEsc ('^':c:s) | c >= '@' && c <= '_' + = [(chr (ord c - ord '@'), s)] + readEsc s@(d:_) | isDigit d + = [(chr n, t) | (n,t) <- readDec s] + readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s] + readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s] + readEsc s@(c:_) | isUpper c + = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab + in case [(c,s') | (c, mne) <- table, + ([],s') <- [match mne s]] + of (pr:_) -> [pr] + [] -> [] + readEsc _ = [] +readLitChar (c:s) = [(c,s)] + +match :: (Eq a) => [a] -> [a] -> ([a],[a]) +match (x:xs) (y:ys) | x == y = match xs ys +match xs ys = (xs,ys) + +\end{code} + + +%********************************************************* +%* * +\subsection{Reading numbers} +%* * +%********************************************************* + +\begin{code} +{-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-} +readDec :: (Integral a) => ReadS a +readDec = readInt 10 isDigit (\d -> ord d - ord_0) + +{-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-} +readOct :: (Integral a) => ReadS a +readOct = readInt 8 isOctDigit (\d -> ord d - ord_0) + +{-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-} +readHex :: (Integral a) => ReadS a +readHex = readInt 16 isHexDigit hex + where hex d = ord d - (if isDigit d then ord_0 + else ord (if isUpper d then 'A' else 'a') - 10) + +{-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-} +readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a +readInt radix isDig digToInt s = + [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r) + | (ds,r) <- nonnull isDig s ] + +{-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-} +readSigned :: (Real a) => ReadS a -> ReadS a +readSigned readPos = readParen False read' + where read' r = read'' r ++ + [(-x,t) | ("-",s) <- lex r, + (x,t) <- read'' s] + read'' r = [(n,s) | (str,s) <- lex r, + (n,"") <- readPos str] +\end{code} + +The functions readFloat below uses rational arithmetic +to insure correct conversion between the floating-point radix and +decimal. It is often possible to use a higher-precision floating- +point type to obtain the same results. + +\begin{code} +{-# GENERATE_SPECS readFloat a{Double#,Double} #-} +readFloat :: (RealFloat a) => ReadS a +readFloat r = [(fromRational x, t) | (x, t) <- readRational r] + +readRational :: ReadS Rational -- NB: doesn't handle leading "-" + +readRational r + = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r, + (k,t) <- readExp s] ++ + [(0/0, t) | ("NaN", t) <- lex r] ++ + [(1/0, t) | ("Infinity", t) <- lex r] + where readFix r = [(read (ds++ds'), length ds', t) + | (ds,s) <- lexDigits r, + (ds',t) <- lexDotDigits s ] + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = [(0,s)] + + readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s] + readExp' ('+':s) = readDec s + readExp' s = readDec s + + lexDotDigits ('.':s) = lex0Digits s + lexDotDigits s = [("",s)] + +readRational__ :: String -> Rational -- we export this one (non-std) + -- NB: *does* handle a leading "-" +readRational__ top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case [x | (x,t) <- readRational s, ("","") <- lex t] of + [x] -> x + [] -> error ("readRational__: no parse:" ++ top_s) + _ -> error ("readRational__: ambiguous parse:" ++ top_s) + +-- The number of decimal digits m below is chosen to guarantee +-- read (show x) == x. See +-- Matula, D. W. A formalization of floating-point numeric base +-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August), +-- 681-692. +\end{code} + + diff --git a/ghc/lib/std/PrelST.lhs b/ghc/lib/std/PrelST.lhs new file mode 100644 index 0000000000..b3b541122a --- /dev/null +++ b/ghc/lib/std/PrelST.lhs @@ -0,0 +1,76 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% +\section[PrelST]{The @ST@ monad} + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelST where + +import Monad +import PrelBase +import PrelGHC +\end{code} + +%********************************************************* +%* * +\subsection{The @ST@ monad} +%* * +%********************************************************* + +The state-transformer monad proper. By default the monad is strict; +too many people got bitten by space leaks when it was lazy. + +\begin{code} +newtype ST s a = ST (State# s -> STret s a) + +data STret s a = STret (State# s) a + +instance Monad (ST s) where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + return x = ST $ \ s -> STret s x + m >> k = m >>= \ _ -> k + + (ST m) >>= k + = ST $ \ s -> + case (m s) of { STret new_s r -> + case (k r) of { ST k2 -> + (k2 new_s) }} + + + +fixST :: (a -> ST s a) -> ST s a +fixST k = ST $ \ s -> + let (ST k_r) = k r + ans = k_r s + STret _ r = ans + in + ans + +\end{code} + + +%********************************************************* +%* * +\subsection{Ghastly return types} +%* * +%********************************************************* + +The @State@ type is the return type of a _ccall_ with no result. It +never actually exists, since it's always deconstructed straight away; +the desugarer ensures this. + +\begin{code} +data State s = S# (State# s) +data StateAndPtr# s elt = StateAndPtr# (State# s) elt + +data StateAndChar# s = StateAndChar# (State# s) Char# +data StateAndInt# s = StateAndInt# (State# s) Int# +data StateAndWord# s = StateAndWord# (State# s) Word# +data StateAndFloat# s = StateAndFloat# (State# s) Float# +data StateAndDouble# s = StateAndDouble# (State# s) Double# +data StateAndAddr# s = StateAndAddr# (State# s) Addr# +\end{code} diff --git a/ghc/lib/std/PrelTup.lhs b/ghc/lib/std/PrelTup.lhs new file mode 100644 index 0000000000..daccfb80a2 --- /dev/null +++ b/ghc/lib/std/PrelTup.lhs @@ -0,0 +1,138 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelTup]{Module @PrelTup@} + +This modules defines the typle data types. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelTup where + +import {-# SOURCE #-} PrelErr ( error ) +import PrelBase +\end{code} + + +%********************************************************* +%* * +\subsection{Other tuple types} +%* * +%********************************************************* + +\begin{code} +data (,) a b = (,) a b deriving (Eq, Ord, Bounded) +data (,,) a b c = (,,) a b c deriving (Eq, Ord, Bounded) +data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord, Bounded) +data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord, Bounded) +data (,,,,,) a b c d e f = (,,,,,) a b c d e f +data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g +data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h +data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i +data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j +data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k +data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l +data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m +data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n +data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o +data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p +data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q + = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q +data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r + = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r +data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s + = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s +data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t + = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t +data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u + = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u +data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v + = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v +data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w + = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w +data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x + = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x +data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y + = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y +data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z + = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z +data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ +data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ + = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ +\end{code} + +@Show@ instances for just the first few. + +\begin{code} +instance (Show a, Show b) => Show (a,b) where + showsPrec p (x,y) = showChar '(' . shows x . showString ", " . + shows y . showChar ')' + showList = showList__ (showsPrec 0) + +instance (Show a, Show b, Show c) => Show (a, b, c) where + showsPrec p (x,y,z) = showChar '(' . showsPrec 0 x . showString ", " . + showsPrec 0 y . showString ", " . + showsPrec 0 z . showChar ')' + showList = showList__ (showsPrec 0) + +instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where + showsPrec p (w,x,y,z) = showChar '(' . showsPrec 0 w . showString ", " . + showsPrec 0 x . showString ", " . + showsPrec 0 y . showString ", " . + showsPrec 0 z . showChar ')' + + showList = showList__ (showsPrec 0) + +instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where + showsPrec p (v,w,x,y,z) = showChar '(' . showsPrec 0 v . showString ", " . + showsPrec 0 w . showString ", " . + showsPrec 0 x . showString ", " . + showsPrec 0 y . showString ", " . + showsPrec 0 z . showChar ')' + showList = showList__ (showsPrec 0) +\end{code} + + +%********************************************************* +%* * +\subsection{Standard functions over tuples} +* * +%********************************************************* + +\begin{code} +fst :: (a,b) -> a +fst (x,y) = x + +snd :: (a,b) -> b +snd (x,y) = y + +-- curry converts an uncurried function to a curried function; +-- uncurry converts a curried function to a function on pairs. +curry :: ((a, b) -> c) -> a -> b -> c +curry f x y = f (x, y) + +uncurry :: (a -> b -> c) -> ((a, b) -> c) +uncurry f p = f (fst p) (snd p) +\end{code} + diff --git a/ghc/lib/std/PrelUnsafe.lhs b/ghc/lib/std/PrelUnsafe.lhs new file mode 100644 index 0000000000..775582c18d --- /dev/null +++ b/ghc/lib/std/PrelUnsafe.lhs @@ -0,0 +1,58 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[PrelUnsafe]{Module @PrelUnsafe@} + +These functions have their own module because we definitely don't want +them to be inlined. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelUnsafe + ( unsafePerformIO, + unsafeInterleaveIO, + trace, + ) where +\end{code} + +\begin{code} +import PrelBase +import PrelIOBase +import PrelAddr +import {-# SOURCE #-} PrelErr ( error ) +\end{code} + +%********************************************************* +%* * +\subsection{Unsafe @IO@ operations} +%* * +%********************************************************* + +\begin{code} +unsafePerformIO :: IO a -> a +unsafePerformIO (IO m) + = case m realWorld# of + IOok _ r -> r + IOfail _ e -> error ("unsafePerformIO: I/O error: " ++ show e ++ "\n") + +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO (IO m) = IO ( \ s -> + let + IOok _ r = m s + in + IOok s r) + +{-# GENERATE_SPECS _trace a #-} +trace :: String -> a -> a +trace string expr + = unsafePerformIO ( + ((_ccall_ PreTraceHook sTDERR{-msg-}):: IO ()) >> + fputs sTDERR string >> + ((_ccall_ PostTraceHook sTDERR{-msg-}):: IO ()) >> + return expr ) + where + sTDERR = (``stderr'' :: Addr) +\end{code} + diff --git a/ghc/lib/std/PrelUnsafeST.lhs b/ghc/lib/std/PrelUnsafeST.lhs new file mode 100644 index 0000000000..17feed9b40 --- /dev/null +++ b/ghc/lib/std/PrelUnsafeST.lhs @@ -0,0 +1,68 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[UnsafeST]{Module @UnsafeST@} + +These functions have their own module because we definitely don't want +them to be inlined. + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module PrelUnsafeST (unsafeInterleaveST, runST) where + +import PrelST +import PrelBase +\end{code} + +\begin{code} +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST (ST m) = ST ( \ s -> + let + STret _ r = m s + in + STret s r) + +\end{code} + +Definition of runST +~~~~~~~~~~~~~~~~~~~ + +SLPJ 95/04: Why @runST@ must not have an unfolding; consider: +\begin{verbatim} +f x = + runST ( \ s -> let + (a, s') = newArray# 100 [] s + (_, s'') = fill_in_array_or_something a x s' + in + freezeArray# a s'' ) +\end{verbatim} +If we inline @runST@, we'll get: +\begin{verbatim} +f x = let + (a, s') = newArray# 100 [] realWorld#{-NB-} + (_, s'') = fill_in_array_or_something a x s' + in + freezeArray# a s'' +\end{verbatim} +And now the @newArray#@ binding can be floated to become a CAF, which +is totally and utterly wrong: +\begin{verbatim} +f = let + (a, s') = newArray# 100 [] realWorld#{-NB-} -- YIKES!!! + in + \ x -> + let (_, s'') = fill_in_array_or_something a x s' in + freezeArray# a s'' +\end{verbatim} +All calls to @f@ will share a {\em single} array! End SLPJ 95/04. + +\begin{code} +runST :: (All s => ST s a) -> a +runST st = + case st of + ST m -> case m realWorld# of + STret _ r -> r +\end{code} + diff --git a/ghc/lib/std/Prelude.lhs b/ghc/lib/std/Prelude.lhs new file mode 100644 index 0000000000..000dd10798 --- /dev/null +++ b/ghc/lib/std/Prelude.lhs @@ -0,0 +1,107 @@ +We add the option -fno-implicit-prelude here to tell the reader that +special names such as () and -> shouldn't be resolved to Prelude.() +and Prelude.-> (as they are normally). -- SDM 8/10/97 + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Prelude ( + + -- Everything from these modules + module PrelList, + module PrelIO, + module PrelTup, + + -- From PrelBase + (->), + Eq(..), + Ord(..), Ordering(..), + Bounded(..), + Enum(..), succ, pred, + Show(..), ShowS, shows, show, showChar, showString, showParen, + Eval(..), seq, strict, + Bool(..), (&&), (||), not, otherwise, + Char, String, Int, Integer, Float, Double, Void, + Maybe(..), maybe, + Either(..), either, + ()(..), -- The unit type + + + id, const, (.), flip, ($), until, asTypeOf, undefined, + + -- From Error + error, + + -- From Monad + Functor(..), Monad(..), MonadZero(..), MonadPlus(..), + accumulate, sequence, mapM, mapM_, guard, filter, concat, applyM, + + -- From PrelRead + ReadS, Read(readsPrec, readList), + reads, read, lex, readParen, + + -- From PrelShow + + -- From PrelNum + Ratio, Rational, + (%), numerator, denominator, approxRational, + + Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt{-glaExt-}), + Real(toRational), + Integral(quot, rem, div, mod, quotRem, divMod, toInteger, toInt{-partain-}), + Fractional((/), recip, fromRational), + Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan, + asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh), + RealFrac(properFraction, truncate, round, ceiling, floor), + RealFloat(floatRadix, floatDigits, floatRange, decodeFloat, + encodeFloat, exponent, significand, scaleFloat, isNaN, + isInfinite, isDenormalized, isIEEE, isNegativeZero), + subtract, even, odd, gcd, lcm, (^), (^^), + fromIntegral, fromRealFrac, atan2 + ) where + +import PrelBase +import PrelList +import PrelIO +import PrelRead +import PrelNum +import PrelTup +import PrelMaybe +import PrelEither +import PrelBounded +import Monad +import Maybe +import PrelErr ( error, seqError ) + +-- These can't conveniently be defined in PrelBase because they use numbers, +-- or I/O, so here's a convenient place to do them. + +strict :: Eval a => (a -> b) -> a -> b +strict f x = x `seq` f x + + +-- "seq" is defined a bit wierdly (see below) +-- +-- The reason for the strange "0# -> parError" case is that +-- it fools the compiler into thinking that seq is non-strict in +-- its second argument (even if it inlines seq at the call site). +-- If it thinks seq is strict in "y", then it often evaluates +-- "y" before "x", which is totally wrong. +-- +-- Just before converting from Core to STG there's a bit of magic +-- that recognises the seq# and eliminates the duff case. + +{-# INLINE seq #-} +seq :: Eval a => a -> b -> b +seq x y = case (seq# x) of { 0# -> seqError; _ -> y } + +-- It is expected that compilers will recognize this and insert error +-- messages which are more appropriate to the context in which undefined +-- appears. + +undefined :: a +undefined = error "Prelude.undefined" +\end{code} + + + diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs new file mode 100644 index 0000000000..faae80ae2e --- /dev/null +++ b/ghc/lib/std/Random.lhs @@ -0,0 +1,67 @@ + +This module implements a (good) random number generator. + +The June 1988 (v31 #6) issue of the Communications of the ACM has an +article by Pierre L'Ecuyer called, "Efficient and Portable Combined +Random Number Generators". Here is the Portable Combined Generator of +L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18. + +Transliterator: Lennart Augustsson + +\begin{code} +module Random + ( + random, + randomIO + ) where + +import CPUTime (getCPUTime) +import Time (getClockTime, ClockTime(..)) + +randomIO :: (Integer, Integer) -> IO [Integer] +randomIO lh = do + ct <- getCPUTime + (TOD sec _) <- getClockTime + return (random lh (sec * 12345 + ct)) + +random :: (Integer, Integer) -> Integer -> [Integer] +random (l, h) s = + if l > h then error "Random.random: Empty interval" else + if s < 0 then random (l, h) (-s) else + let (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + k = h-l + 1 + b = 2147483561 + n = iLogBase b k + f is = let (xs, is') = splitAt n is + in foldr (\ i r -> fromInt i + r * b) 0 xs `mod` k + l : f is' + in f (randomInts (toInt (s1+1)) (toInt (s2+1))) + +iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) + +-- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate +-- an infinite list of random Ints. +randomInts :: Int -> Int -> [Int] +randomInts s1 s2 = + if 1 <= s1 && s1 <= 2147483562 then + if 1 <= s2 && s2 <= 2147483398 then + rands s1 s2 + else + error "randomInts: Bad second seed." + else + error "randomInts: Bad first seed." + +rands :: Int -> Int -> [Int] +rands s1 s2 = z' : rands s1'' s2'' + where z' = if z < 1 then z + 2147483562 else z + z = s1'' - s2'' + + k = s1 `quot` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `quot` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + +\end{code} diff --git a/ghc/lib/std/Ratio.lhs b/ghc/lib/std/Ratio.lhs new file mode 100644 index 0000000000..46e3d0b38f --- /dev/null +++ b/ghc/lib/std/Ratio.lhs @@ -0,0 +1,19 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[Ratio]{Module @Ratio@} + +Standard functions on rational numbers + +\begin{code} +{-# OPTIONS -fno-implicit-prelude #-} + +module Ratio ( + Ratio, Rational, (%), numerator, denominator, approxRational + ) where + +import PrelNum +\end{code} + + diff --git a/ghc/lib/std/System.lhs b/ghc/lib/std/System.lhs new file mode 100644 index 0000000000..ad0b66c6cf --- /dev/null +++ b/ghc/lib/std/System.lhs @@ -0,0 +1,159 @@ +% +% (c) The AQUA Project, Glasgow University, 1994-1996 +% + +\section[System]{Module @System@} + +\begin{code} +module System ( + ExitCode(ExitSuccess,ExitFailure), + getArgs, getProgName, getEnv, system, exitWith + ) where + +import Prelude +import PrelAddr +import PrelIOBase ( IOError(..), IOErrorType(..), constructErrorAndFail ) +import PrelArr ( indexAddrOffAddr ) +import PrelPack ( unpackCString ) + +\end{code} + +%********************************************************* +%* * +\subsection{The @ExitCode@ type} +%* * +%********************************************************* + +The $ExitCode$ type defines the exit codes that a program +can return. $ExitSuccess$ indicates successful termination; +and $ExitFailure code$ indicates program failure +with value {\em code}. The exact interpretation of {\em code} +is operating-system dependent. In particular, some values of +{\em code} may be prohibited (e.g. 0 on a POSIX-compliant system). + +\begin{code} +data ExitCode = ExitSuccess | ExitFailure Int + deriving (Eq, Ord, Read, Show) + +\end{code} + + +%********************************************************* +%* * +\subsection{Other functions} +%* * +%********************************************************* + +\begin{code} +getArgs :: IO [String] +getProgName :: IO String +getEnv :: String -> IO String +system :: String -> IO ExitCode +exitWith :: ExitCode -> IO a +\end{code} + +Computation $getArgs$ returns a list of the program's command +line arguments (not including the program name). + +\begin{code} +getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int)) +\end{code} + +Computation $getProgName$ returns the name of the program +as it was invoked. + +\begin{code} +getProgName = return (unpackProgName ``prog_argv'') +\end{code} + +Computation $getEnv var$ returns the value +of the environment variable {\em var}. + +This computation may fail with +\begin{itemize} +\item $NoSuchThing$ +The environment variable does not exist. +\end{itemize} + +\begin{code} +getEnv name = do + litstring <- _ccall_ getenv name + if litstring /= ``NULL'' + then return (unpackCString litstring) + else fail (IOError Nothing NoSuchThing + ("environment variable: " ++ name)) +\end{code} + +Computation $system cmd$ returns the exit code +produced when the operating system processes the command {\em cmd}. + +This computation may fail with +\begin{itemize} +\item $PermissionDenied$ +The process has insufficient privileges to perform the operation. +\item $ResourceExhausted$ +Insufficient resources are available to perform the operation. +\item $UnsupportedOperation$ +The implementation does not support system calls. +\end{itemize} + +\begin{code} +system "" = fail (IOError Nothing InvalidArgument "null command") +system cmd = do + status <- _ccall_ systemCmd cmd + case status of + 0 -> return ExitSuccess + -1 -> constructErrorAndFail "system" + n -> return (ExitFailure n) + +\end{code} + +Computation $exitWith code$ terminates the +program, returning {\em code} to the program's caller. +Before it terminates, any open or semi-closed handles are first closed. + +\begin{code} +exitWith ExitSuccess = do + _ccall_ EXIT (0::Int) + fail (IOError Nothing OtherError "exit should not return") + +exitWith (ExitFailure n) + | n == 0 = fail (IOError Nothing InvalidArgument "ExitFailure 0") + | otherwise = do + _ccall_ EXIT n + fail (IOError Nothing OtherError "exit should not return") +\end{code} + + +%********************************************************* +%* * +\subsection{Local utilities} +%* * +%********************************************************* + +\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] +unpackProgName :: CHAR_STAR_STAR -> String -- argv[0] + +unpackArgv argv argc = unpack 1 + where + unpack :: Int -> [String] + unpack n + = if (n >= argc) + then ([] :: [String]) + else case (indexAddrOffAddr argv n) of { item -> + unpackCString item : unpack (n + 1) } + +unpackProgName argv + = case (indexAddrOffAddr argv 0) of { prog -> + de_slash [] (unpackCString prog) } + where + -- re-start accumulating at every '/' + de_slash :: String -> String -> String + de_slash acc [] = reverse acc + de_slash acc ('/':xs) = de_slash [] xs + de_slash acc (x:xs) = de_slash (x:acc) xs +\end{code} diff --git a/ghc/lib/std/Time.lhs b/ghc/lib/std/Time.lhs new file mode 100644 index 0000000000..4ce9925699 --- /dev/null +++ b/ghc/lib/std/Time.lhs @@ -0,0 +1,395 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-97 +% +\section[Time]{Haskell 1.4 Time of Day Library} + +The {\em Time} library provides standard functionality for +clock times, including timezone information (i.e, the functionality of +"time.h", adapted to the Haskell environment), It follows RFC 1129 in +its use of Coordinated Universal Time (UTC). + +\begin{code} +{-# OPTIONS -#include "cbits/timezone.h" -#include "cbits/stgio.h" #-} + +module Time + ( + Month, + Day, + CalendarTime(CalendarTime), + TimeDiff(TimeDiff), + ClockTime(..), -- non-standard, lib. report gives this as abstract + + getClockTime, + addToClockTime, + diffClockTimes, + + toCalendarTime, + toUTCTime, + toClockTime, + calendarTimeToString, + formatCalendarTime + ) where + +import PrelBase +import PrelIOBase +import PrelArr +import PrelST +import PrelUnsafe ( unsafePerformIO ) +import PrelAddr +import PrelPack ( unpackCString ) + +import Ix +import Char ( intToDigit ) +import Locale + +\end{code} + +One way to partition and give name to chunks of a year and a week: + +\begin{code} +data Month + = January | February | March | April + | May | June | July | August + | September | October | November | December + deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) + +data Day + = Sunday | Monday | Tuesday | Wednesday + | Thursday | Friday | Saturday + deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show) + +\end{code} + +@ClockTime@ is an abstract type, used for the internal clock time. +Clock times may be compared, converted to strings, or converted to an +external calendar time @CalendarTime@. + +\begin{code} +data ClockTime = TOD Integer Integer deriving (Eq, Ord) +\end{code} + +When a @ClockTime@ is shown, it is converted to a string of the form +@"Mon Nov 28 21:45:41 GMT 1994"@. + +For now, we are restricted to roughly: +Fri Dec 13 20:45:52 1901 through Tue Jan 19 03:14:07 2038, because +we use the C library routines based on 32 bit integers. + +\begin{code} +instance Show ClockTime where + showsPrec p (TOD sec@(J# a# s# d#) nsec) = showString $ unsafePerformIO $ + allocChars 32 >>= \ buf -> + _ccall_ showTime (I# s#) (ByteArray bottom d#) buf + >>= \ str -> + return (unpackCString str) + + showList = showList__ (showsPrec 0) +\end{code} + + +@CalendarTime@ is a user-readable and manipulable +representation of the internal $ClockTime$ type. The +numeric fields have the following ranges. + +\begin{verbatim} +Value Range Comments +----- ----- -------- + +year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate] +mon 0 .. 11 [Jan = 0, Dec = 11] +day 1 .. 31 +hour 0 .. 23 +min 0 .. 59 +sec 0 .. 61 [Allows for two leap seconds] +picosec 0 .. (10^12)-1 [This could be over-precise?] +wday 0 .. 6 [Sunday = 0, Saturday = 6] +yday 0 .. 365 [364 in non-Leap years] +tz -43200 .. 43200 [Variation from UTC in seconds] +\end{verbatim} + +The {\em tzname} field is the name of the time zone. The {\em isdst} +field indicates whether Daylight Savings Time would be in effect. + +\begin{code} +data CalendarTime + = CalendarTime { + ctYear :: Int, + ctMonth :: Int, + ctDay :: Int, + ctHour :: Int, + ctMin :: Int, + ctSec :: Int, + ctPicosec :: Integer, + ctWDay :: Day, + ctYDay :: Int, + ctTZName :: String, + ctTZ :: Int, + ctIsDST :: Bool + } + deriving (Eq,Ord,Read,Show) + +\end{code} + +The @TimeDiff@ type records the difference between two clock times in +a user-readable way. + +\begin{code} +data TimeDiff + = TimeDiff { + tdYear :: Int, + tdMonth :: Int, + tdDay :: Int, + tdHour :: Int, + tdMin :: Int, + tdSec :: Int, + tdPicosec :: Integer -- not standard + } + deriving (Eq,Ord,Read,Show) +\end{code} + +@getClockTime@ returns the current time in its internal representation. + +\begin{code} +getClockTime :: IO ClockTime +getClockTime = + malloc1 >>= \ i1 -> + malloc1 >>= \ i2 -> + _ccall_ getClockTime i1 i2 >>= \ rc -> + if rc == 0 + then + cvtUnsigned i1 >>= \ sec -> + cvtUnsigned i2 >>= \ nsec -> + return (TOD sec (nsec * 1000)) + else + constructErrorAndFail "getClockTime" + where + malloc1 = IO $ \ s# -> + case newIntArray# 1# s# of + StateAndMutableByteArray# s2# barr# -> + IOok s2# (MutableByteArray bottom barr#) + + -- The C routine fills in an unsigned word. We don't have + -- `unsigned2Integer#,' so we freeze the data bits and use them + -- for an MP_INT structure. Note that zero is still handled specially, + -- although (J# 1# 1# (ptr to 0#)) is probably acceptable to gmp. + + cvtUnsigned (MutableByteArray _ arr#) = IO $ \ s# -> + case readIntArray# arr# 0# s# of + StateAndInt# s2# r# -> + if r# ==# 0# + then IOok s2# 0 + else case unsafeFreezeByteArray# arr# s2# of + StateAndByteArray# s3# frozen# -> + IOok s3# (J# 1# 1# frozen#) + +\end{code} + +@addToClockTime@ {\em d} {\em t} adds a time difference {\em d} and a +clock time {\em t} to yield a new clock time. The difference {\em d} +may be either positive or negative. @[diffClockTimes@ {\em t1} {\em +t2} returns the difference between two clock times {\em t1} and {\em +t2} as a @TimeDiff@. + + +\begin{code} +addToClockTime :: TimeDiff -> ClockTime -> ClockTime +addToClockTime (TimeDiff year mon day hour min sec psec) + (TOD c_sec c_psec) = unsafePerformIO $ + allocWords (``sizeof(time_t)'') >>= \ res -> + _ccall_ toClockSec year mon day hour min sec 0 res + >>= \ ptr@(A# ptr#) -> + if ptr /= ``NULL'' + then let + diff_sec = (int2Integer# (indexIntOffAddr# ptr# 0#)) + diff_psec = psec + in + return (TOD (c_sec + diff_sec) (c_psec + diff_psec)) + else + error "Time.addToClockTime: can't perform conversion of TimeDiff" + + +diffClockTimes :: ClockTime -> ClockTime -> TimeDiff +diffClockTimes tod_a tod_b = + let + CalendarTime year_a mon_a day_a hour_a min_a sec_a psec_a _ _ _ _ _ = toCalendarTime tod_a + CalendarTime year_b mon_b day_b hour_b min_b sec_b psec_b _ _ _ _ _ = toCalendarTime tod_b + in + TimeDiff (year_a - year_b) + (mon_a - mon_b) + (day_a - day_b) + (hour_a - hour_b) + (min_b - min_a) + (sec_a - sec_b) + (psec_a - psec_b) +\end{code} + +@toCalendarTime@ {\em t} converts {\em t} to a local time, modified by +the current timezone and daylight savings time settings. @toUTCTime@ +{\em t} converts {\em t} into UTC time. @toClockTime@ {\em l} +converts {\em l} into the corresponding internal @ClockTime@. The +{\em wday}, {\em yday}, {\em tzname}, and {\em isdst} fields are +ignored. + +\begin{code} +toCalendarTime :: ClockTime -> CalendarTime +toCalendarTime (TOD sec@(J# a# s# d#) psec) = unsafePerformIO $ + allocWords (``sizeof(struct tm)''::Int) >>= \ res -> + allocChars 32 >>= \ zoneNm -> + _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm >>= \ () -> + _ccall_ toLocalTime (I# s#) (ByteArray bottom d#) res + >>= \ tm -> + if tm == (``NULL''::Addr) + then error "Time.toCalendarTime: out of range" + else + _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm >>= \ sec -> + _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm >>= \ min -> + _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm >>= \ hour -> + _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm >>= \ mday -> + _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm >>= \ mon -> + _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm >>= \ year -> + _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm >>= \ wday -> + _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm >>= \ yday -> + _casm_ ``%r = ((struct tm *)%0)->tm_isdst;'' tm >>= \ isdst -> + _ccall_ ZONE tm >>= \ zone -> + _ccall_ GMTOFF tm >>= \ tz -> + let + tzname = unpackCString zone + in + return (CalendarTime (1900+year) mon mday hour min sec psec + (toEnum wday) yday tzname tz (isdst /= 0)) + +toUTCTime :: ClockTime -> CalendarTime +toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformIO ( + allocWords (``sizeof(struct tm)''::Int) >>= \ res -> + allocChars 32 >>= \ zoneNm -> + _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm >>= \ () -> + _ccall_ toUTCTime (I# s#) (ByteArray bottom d#) res + >>= \ tm -> + if tm == (``NULL''::Addr) + then error "Time.toUTCTime: out of range" + else + _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm >>= \ sec -> + _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm >>= \ min -> + _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm >>= \ hour -> + _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm >>= \ mday -> + _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm >>= \ mon -> + _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm >>= \ year -> + _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm >>= \ wday -> + _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm >>= \ yday -> + return (CalendarTime (1900+year) mon mday hour min sec psec + (toEnum wday) yday "UTC" 0 False) + ) + +toClockTime :: CalendarTime -> ClockTime +toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz isdst) = + if psec < 0 || psec > 999999999999 then + error "Time.toClockTime: picoseconds out of range" + else if tz < -43200 || tz > 43200 then + error "Time.toClockTime: timezone offset out of range" + else + unsafePerformIO ( + allocWords (``sizeof(time_t)'') >>= \ res -> + _ccall_ toClockSec year mon mday hour min sec isDst res + >>= \ ptr@(A# ptr#) -> + if ptr /= ``NULL'' then + return (TOD (int2Integer# (indexIntOffAddr# ptr# 0#)) psec) + else + error "Time.toClockTime: can't perform conversion" + ) + where + isDst = if isdst then (1::Int) else 0 + +bottom :: (Int,Int) +bottom = error "Time.bottom" + + +-- (copied from PosixUtil, for now) +-- Allocate a mutable array of characters with no indices. + +allocChars :: Int -> IO (MutableByteArray RealWorld ()) +allocChars (I# size#) = IO $ \ s# -> + case newCharArray# size# s# of + StateAndMutableByteArray# s2# barr# -> + IOok s2# (MutableByteArray bot barr#) + where + bot = error "Time.allocChars" + +-- Allocate a mutable array of words with no indices + +allocWords :: Int -> IO (MutableByteArray RealWorld ()) +allocWords (I# size#) = IO $ \ s# -> + case newIntArray# size# s# of + StateAndMutableByteArray# s2# barr# -> + IOok s2# (MutableByteArray bot barr#) + where + bot = error "Time.allocWords" + +\end{code} + +\begin{code} +calendarTimeToString :: CalendarTime -> String +calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" + +formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String +formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec + wday yday tzname _ _) = + doFmt fmt + where doFmt ('%':c:cs) = decode c ++ doFmt cs + doFmt (c:cs) = c : doFmt cs + doFmt "" = "" + to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h + decode 'A' = fst (wDays l !! fromEnum wday) + decode 'a' = snd (wDays l !! fromEnum wday) + decode 'B' = fst (months l !! fromEnum mon) + decode 'b' = snd (months l !! fromEnum mon) + decode 'h' = snd (months l !! fromEnum mon) + decode 'C' = show2 (year `quot` 100) + decode 'c' = doFmt (dateTimeFmt l) + decode 'D' = doFmt "%m/%d/%y" + decode 'd' = show2 day + decode 'e' = show2' day + decode 'H' = show2 hour + decode 'I' = show2 (to12 hour) + decode 'j' = show3 yday + decode 'k' = show2' hour + decode 'l' = show2' (to12 hour) + decode 'M' = show2 min + decode 'm' = show2 (fromEnum mon+1) + decode 'n' = "\n" + decode 'p' = (if hour < 12 then fst else snd) (amPm l) + decode 'R' = doFmt "%H:%M" + decode 'r' = doFmt (time12Fmt l) + decode 'T' = doFmt "%H:%M:%S" + decode 't' = "\t" + decode 'S' = show2 sec + decode 's' = show2 sec -- Implementation-dependent, sez the lib doc.. + decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) + decode 'u' = show (let n = fromEnum wday in + if n == 0 then 7 else n) + decode 'V' = + let (week, days) = + (yday + 7 - if fromEnum wday > 0 then + fromEnum wday - 1 else 6) `divMod` 7 + in show2 (if days >= 4 then + week+1 + else if week == 0 then 53 else week) + + decode 'W' = + show2 ((yday + 7 - if fromEnum wday > 0 then + fromEnum wday - 1 else 6) `div` 7) + decode 'w' = show (fromEnum wday) + decode 'X' = doFmt (timeFmt l) + decode 'x' = doFmt (dateFmt l) + decode 'Y' = show year + decode 'y' = show2 (year `rem` 100) + decode 'Z' = tzname + decode '%' = "%" + decode c = [c] + +show2, show2', show3 :: Int -> String +show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] + +show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x + +show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) +\end{code} diff --git a/ghc/lib/std/cbits/Makefile b/ghc/lib/std/cbits/Makefile new file mode 100644 index 0000000000..b330b627d5 --- /dev/null +++ b/ghc/lib/std/cbits/Makefile @@ -0,0 +1,30 @@ +# $Id: Makefile,v 1.1 1998/02/02 17:34:22 simonm Exp $ + +TOP = ../../.. +include $(TOP)/mk/boilerplate.mk +override WAYS= + +LIBRARY=libHS_cbits.a +INSTALL_LIBS+=$(LIBRARY) + +SRCS= $(wildcard *.lc) + +C_SRCS = $(SRCS:.lc=.c) +C_OBJS = $(C_SRCS:.c=.o) +LIBOBJS = $(C_OBJS) +SRC_CC_OPTS = -O -I$(GHC_INCLUDE_DIR) + +# +# Compile the files using the Haskell compiler (ghc really). +# +CC=$(HC) + +# +# Remove the intermediate .c files +# (the .o's will be removed automatically by default mk setup) +# +CLEAN_FILES += $(C_SRCS) + +SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) + +include $(TOP)/mk/target.mk diff --git a/ghc/lib/std/cbits/closeFile.lc b/ghc/lib/std/cbits/closeFile.lc new file mode 100644 index 0000000000..9f4c80eb8d --- /dev/null +++ b/ghc/lib/std/cbits/closeFile.lc @@ -0,0 +1,35 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[closeFile.lc]{hClose Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +closeFile(fp) +StgForeignObj fp; +{ + int rc; + + if (unlockFile(fileno((FILE *) fp))) { + /* If it has been unlocked, don't bother fclose()ing */ + return 0; + } + + while ((rc = fclose((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/createDirectory.lc b/ghc/lib/std/cbits/createDirectory.lc new file mode 100644 index 0000000000..759e99c998 --- /dev/null +++ b/ghc/lib/std/cbits/createDirectory.lc @@ -0,0 +1,58 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[createDirectory.lc]{createDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.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 +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; +} + +\end{code} diff --git a/ghc/lib/std/cbits/errno.lc b/ghc/lib/std/cbits/errno.lc new file mode 100644 index 0000000000..0eaa9d1ac9 --- /dev/null +++ b/ghc/lib/std/cbits/errno.lc @@ -0,0 +1,934 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[errno.lc]{GHC Error Number Conversion} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +int ghc_errno = 0; +int ghc_errtype = 0; + +char *ghc_errstr = NULL; + +/* Collect all of the grotty #ifdef's in one place. */ + +void cvtErrno(STG_NO_ARGS) +{ + switch(errno) { +#ifdef E2BIG + case E2BIG: + ghc_errno = GHC_E2BIG; + break; +#endif +#ifdef EACCES + case EACCES: + ghc_errno = GHC_EACCES; + break; +#endif +#ifdef EADDRINUSE + case EADDRINUSE: + ghc_errno = GHC_EADDRINUSE; + break; +#endif +#ifdef EADDRNOTAVAIL + case EADDRNOTAVAIL: + ghc_errno = GHC_EADDRNOTAVAIL; + break; +#endif +#ifdef EADV + case EADV: + ghc_errno = GHC_EADV; + break; +#endif +#ifdef EAFNOSUPPORT + case EAFNOSUPPORT: + ghc_errno = GHC_EAFNOSUPPORT; + break; +#endif +#ifdef EAGAIN + case EAGAIN: + ghc_errno = GHC_EAGAIN; + break; +#endif +#ifdef EALREADY + case EALREADY: + ghc_errno = GHC_EALREADY; + break; +#endif +#ifdef EBADF + case EBADF: + ghc_errno = GHC_EBADF; + break; +#endif +#ifdef EBADMSG + case EBADMSG: + ghc_errno = GHC_EBADMSG; + break; +#endif +#ifdef EBADRPC + case EBADRPC: + ghc_errno = GHC_EBADRPC; + break; +#endif +#ifdef EBUSY + case EBUSY: + ghc_errno = GHC_EBUSY; + break; +#endif +#ifdef ECHILD + case ECHILD: + ghc_errno = GHC_ECHILD; + break; +#endif +#ifdef ECOMM + case ECOMM: + ghc_errno = GHC_ECOMM; + break; +#endif +#ifdef ECONNABORTED + case ECONNABORTED: + ghc_errno = GHC_ECONNABORTED; + break; +#endif +#ifdef ECONNREFUSED + case ECONNREFUSED: + ghc_errno = GHC_ECONNREFUSED; + break; +#endif +#ifdef ECONNRESET + case ECONNRESET: + ghc_errno = GHC_ECONNRESET; + break; +#endif +#ifdef EDEADLK + case EDEADLK: + ghc_errno = GHC_EDEADLK; + break; +#endif +#ifdef EDESTADDRREQ + case EDESTADDRREQ: + ghc_errno = GHC_EDESTADDRREQ; + break; +#endif +#ifdef EDIRTY + case EDIRTY: + ghc_errno = GHC_EDIRTY; + break; +#endif +#ifdef EDOM + case EDOM: + ghc_errno = GHC_EDOM; + break; +#endif +#ifdef EDQUOT + case EDQUOT: + ghc_errno = GHC_EDQUOT; + break; +#endif +#ifdef EEXIST + case EEXIST: + ghc_errno = GHC_EEXIST; + break; +#endif +#ifdef EFAULT + case EFAULT: + ghc_errno = GHC_EFAULT; + break; +#endif +#ifdef EFBIG + case EFBIG: + ghc_errno = GHC_EFBIG; + break; +#endif +#ifdef EFTYPE + case EFTYPE: + ghc_errno = GHC_EFTYPE; + break; +#endif +#ifdef EHOSTDOWN + case EHOSTDOWN: + ghc_errno = GHC_EHOSTDOWN; + break; +#endif +#ifdef EHOSTUNREACH + case EHOSTUNREACH: + ghc_errno = GHC_EHOSTUNREACH; + break; +#endif +#ifdef EIDRM + case EIDRM: + ghc_errno = GHC_EIDRM; + break; +#endif +#ifdef EILSEQ + case EILSEQ: + ghc_errno = GHC_EILSEQ; + break; +#endif +#ifdef EINPROGRESS + case EINPROGRESS: + ghc_errno = GHC_EINPROGRESS; + break; +#endif +#ifdef EINTR + case EINTR: + ghc_errno = GHC_EINTR; + break; +#endif +#ifdef EINVAL + case EINVAL: + ghc_errno = GHC_EINVAL; + break; +#endif +#ifdef EIO + case EIO: + ghc_errno = GHC_EIO; + break; +#endif +#ifdef EISCONN + case EISCONN: + ghc_errno = GHC_EISCONN; + break; +#endif +#ifdef EISDIR + case EISDIR: + ghc_errno = GHC_EISDIR; + break; +#endif +#ifdef ELOOP + case ELOOP: + ghc_errno = GHC_ELOOP; + break; +#endif +#ifdef EMFILE + case EMFILE: + ghc_errno = GHC_EMFILE; + break; +#endif +#ifdef EMLINK + case EMLINK: + ghc_errno = GHC_EMLINK; + break; +#endif +#ifdef EMSGSIZE + case EMSGSIZE: + ghc_errno = GHC_EMSGSIZE; + break; +#endif +#ifdef EMULTIHOP + case EMULTIHOP: + ghc_errno = GHC_EMULTIHOP; + break; +#endif +#ifdef ENAMETOOLONG + case ENAMETOOLONG: + ghc_errno = GHC_ENAMETOOLONG; + break; +#endif +#ifdef ENETDOWN + case ENETDOWN: + ghc_errno = GHC_ENETDOWN; + break; +#endif +#ifdef ENETRESET + case ENETRESET: + ghc_errno = GHC_ENETRESET; + break; +#endif +#ifdef ENETUNREACH + case ENETUNREACH: + ghc_errno = GHC_ENETUNREACH; + break; +#endif +#ifdef ENFILE + case ENFILE: + ghc_errno = GHC_ENFILE; + break; +#endif +#ifdef ENOBUFS + case ENOBUFS: + ghc_errno = GHC_ENOBUFS; + break; +#endif +#ifdef ENODATA + case ENODATA: + ghc_errno = GHC_ENODATA; + break; +#endif +#ifdef ENODEV + case ENODEV: + ghc_errno = GHC_ENODEV; + break; +#endif +#ifdef ENOENT + case ENOENT: + ghc_errno = GHC_ENOENT; + break; +#endif +#ifdef ENOEXEC + case ENOEXEC: + ghc_errno = GHC_ENOEXEC; + break; +#endif +#ifdef ENOLCK + case ENOLCK: + ghc_errno = GHC_ENOLCK; + break; +#endif +#ifdef ENOLINK + case ENOLINK: + ghc_errno = GHC_ENOLINK; + break; +#endif +#ifdef ENOMEM + case ENOMEM: + ghc_errno = GHC_ENOMEM; + break; +#endif +#ifdef ENOMSG + case ENOMSG: + ghc_errno = GHC_ENOMSG; + break; +#endif +#ifdef ENONET + case ENONET: + ghc_errno = GHC_ENONET; + break; +#endif +#ifdef ENOPROTOOPT + case ENOPROTOOPT: + ghc_errno = GHC_ENOPROTOOPT; + break; +#endif +#ifdef ENOSPC + case ENOSPC: + ghc_errno = GHC_ENOSPC; + break; +#endif +#ifdef ENOSR + case ENOSR: + ghc_errno = GHC_ENOSR; + break; +#endif +#ifdef ENOSTR + case ENOSTR: + ghc_errno = GHC_ENOSTR; + break; +#endif +#ifdef ENOSYS + case ENOSYS: + ghc_errno = GHC_ENOSYS; + break; +#endif +#ifdef ENOTBLK + case ENOTBLK: + ghc_errno = GHC_ENOTBLK; + break; +#endif +#ifdef ENOTCONN + case ENOTCONN: + ghc_errno = GHC_ENOTCONN; + break; +#endif +#ifdef ENOTDIR + case ENOTDIR: + ghc_errno = GHC_ENOTDIR; + break; +#endif +#ifndef aix_TARGET_OS +/* AIX returns EEXIST where 4.3BSD used ENOTEMPTY. + * there is an ENOTEMPTY defined as the same as EEXIST, and + * therefore it won't work properly on a case statement. + * another option is to define _ALL_SOURCE for aix, which + * gives a different number for ENOTEMPTY. + * I haven't tried that. -- andre. + */ +#ifdef ENOTEMPTY + case ENOTEMPTY: + ghc_errno = GHC_ENOTEMPTY; + break; +#endif +#endif +#ifdef ENOTSOCK + case ENOTSOCK: + ghc_errno = GHC_ENOTSOCK; + break; +#endif +#ifdef ENOTTY + case ENOTTY: + ghc_errno = GHC_ENOTTY; + break; +#endif +#ifdef ENXIO + case ENXIO: + ghc_errno = GHC_ENXIO; + break; +#endif +#ifdef EOPNOTSUPP + case EOPNOTSUPP: + ghc_errno = GHC_EOPNOTSUPP; + break; +#endif +#ifdef EPERM + case EPERM: + ghc_errno = GHC_EPERM; + break; +#endif +#ifdef EPFNOSUPPORT + case EPFNOSUPPORT: + ghc_errno = GHC_EPFNOSUPPORT; + break; +#endif +#ifdef EPIPE + case EPIPE: + ghc_errno = GHC_EPIPE; + break; +#endif +#ifdef EPROCLIM + case EPROCLIM: + ghc_errno = GHC_EPROCLIM; + break; +#endif +#ifdef EPROCUNAVAIL + case EPROCUNAVAIL: + ghc_errno = GHC_EPROCUNAVAIL; + break; +#endif +#ifdef EPROGMISMATCH + case EPROGMISMATCH: + ghc_errno = GHC_EPROGMISMATCH; + break; +#endif +#ifdef EPROGUNAVAIL + case EPROGUNAVAIL: + ghc_errno = GHC_EPROGUNAVAIL; + break; +#endif +#ifdef EPROTO + case EPROTO: + ghc_errno = GHC_EPROTO; + break; +#endif +#ifdef EPROTONOSUPPORT + case EPROTONOSUPPORT: + ghc_errno = GHC_EPROTONOSUPPORT; + break; +#endif +#ifdef EPROTOTYPE + case EPROTOTYPE: + ghc_errno = GHC_EPROTOTYPE; + break; +#endif +#ifdef ERANGE + case ERANGE: + ghc_errno = GHC_ERANGE; + break; +#endif +#ifdef EREMCHG + case EREMCHG: + ghc_errno = GHC_EREMCHG; + break; +#endif +#ifdef EREMOTE + case EREMOTE: + ghc_errno = GHC_EREMOTE; + break; +#endif +#ifdef EROFS + case EROFS: + ghc_errno = GHC_EROFS; + break; +#endif +#ifdef ERPCMISMATCH + case ERPCMISMATCH: + ghc_errno = GHC_ERPCMISMATCH; + break; +#endif +#ifdef ERREMOTE + case ERREMOTE: + ghc_errno = GHC_ERREMOTE; + break; +#endif +#ifdef ESHUTDOWN + case ESHUTDOWN: + ghc_errno = GHC_ESHUTDOWN; + break; +#endif +#ifdef ESOCKTNOSUPPORT + case ESOCKTNOSUPPORT: + ghc_errno = GHC_ESOCKTNOSUPPORT; + break; +#endif +#ifdef ESPIPE + case ESPIPE: + ghc_errno = GHC_ESPIPE; + break; +#endif +#ifdef ESRCH + case ESRCH: + ghc_errno = GHC_ESRCH; + break; +#endif +#ifdef ESRMNT + case ESRMNT: + ghc_errno = GHC_ESRMNT; + break; +#endif +#ifdef ESTALE + case ESTALE: + ghc_errno = GHC_ESTALE; + break; +#endif +#ifdef ETIME + case ETIME: + ghc_errno = GHC_ETIME; + break; +#endif +#ifdef ETIMEDOUT + case ETIMEDOUT: + ghc_errno = GHC_ETIMEDOUT; + break; +#endif +#ifdef ETOOMANYREFS + case ETOOMANYREFS: + ghc_errno = GHC_ETOOMANYREFS; + break; +#endif +#ifdef ETXTBSY + case ETXTBSY: + ghc_errno = GHC_ETXTBSY; + break; +#endif +#ifdef EUSERS + case EUSERS: + ghc_errno = GHC_EUSERS; + break; +#endif +#if 0 +#ifdef EWOULDBLOCK + case EWOULDBLOCK: + ghc_errno = GHC_EWOULDBLOCK; + break; +#endif +#endif +#ifdef EXDEV + case EXDEV: + ghc_errno = GHC_EXDEV; + break; +#endif + default: + ghc_errno = errno; + break; + } +} + +void +stdErrno(STG_NO_ARGS) +{ + switch(ghc_errno) { + default: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "unexpected error"; + break; + case 0: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "no error"; + case GHC_E2BIG: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "argument list too long"; + break; + case GHC_EACCES: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "inadequate access permission"; + break; + case GHC_EADDRINUSE: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "address already in use"; + break; + case GHC_EADDRNOTAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "address not available"; + break; + case GHC_EADV: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "RFS advertise error"; + break; + case GHC_EAFNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "address family not supported by protocol family"; + break; + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "insufficient resources"; + break; + case GHC_EALREADY: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "operation already in progress"; + break; + case GHC_EBADF: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (EBADF)"; + break; + case GHC_EBADMSG: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "next message has wrong type"; + break; + case GHC_EBADRPC: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "invalid RPC request or response"; + break; + case GHC_EBUSY: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "device busy"; + break; + case GHC_ECHILD: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no child processes"; + break; + case GHC_ECOMM: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "no virtual circuit could be found"; + break; + case GHC_ECONNABORTED: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "aborted connection"; + break; + case GHC_ECONNREFUSED: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no listener on remote host"; + break; + case GHC_ECONNRESET: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "connection reset by peer"; + break; + case GHC_EDEADLK: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "resource deadlock avoided"; + break; + case GHC_EDESTADDRREQ: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "destination address required"; + break; + case GHC_EDIRTY: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "file system dirty"; + break; + case GHC_EDOM: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "argument too large"; + break; + case GHC_EDQUOT: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "quota exceeded"; + break; + case GHC_EEXIST: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "file already exists"; + break; + case GHC_EFAULT: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (EFAULT)"; + break; + case GHC_EFBIG: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "file too large"; + break; + case GHC_EFTYPE: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "inappropriate NFS file type or format"; + break; + case GHC_EHOSTDOWN: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "destination host down"; + break; + case GHC_EHOSTUNREACH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "remote host is unreachable"; + break; + case GHC_EIDRM: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "IPC identifier removed"; + break; + case GHC_EILSEQ: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "invalid wide character"; + break; + case GHC_EINPROGRESS: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "operation now in progress"; + break; + case GHC_EINTR: + ghc_errtype = ERR_INTERRUPTED; + ghc_errstr = "interrupted system call"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "invalid argument"; + break; + case GHC_EIO: + ghc_errtype = ERR_HARDWAREFAULT; + ghc_errstr = "unknown I/O fault"; + break; + case GHC_EISCONN: + ghc_errtype = ERR_ALREADYEXISTS; + ghc_errstr = "socket is already connected"; + break; + case GHC_EISDIR: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + break; + case GHC_ELOOP: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "too many symbolic links"; + break; + case GHC_EMFILE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "process file table full"; + break; + case GHC_EMLINK: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "too many links"; + break; + case GHC_EMSGSIZE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "message too long"; + break; + case GHC_EMULTIHOP: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "multi-hop RFS request"; + break; + case GHC_ENAMETOOLONG: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "filename too long"; + break; + case GHC_ENETDOWN: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "network is down"; + break; + case GHC_ENETRESET: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "remote host rebooted; connection lost"; + break; + case GHC_ENETUNREACH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "remote network is unreachable"; + break; + case GHC_ENFILE: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "system file table full"; + break; + case GHC_ENOBUFS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no buffer space available"; + break; + case GHC_ENODATA: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no message on the stream head read queue"; + break; + case GHC_ENODEV: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such device"; + break; + case GHC_ENOENT: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such file or directory"; + break; + case GHC_ENOEXEC: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not an executable file"; + break; + case GHC_ENOLCK: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no file locks available"; + break; + case GHC_ENOLINK: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "RFS link has been severed"; + break; + case GHC_ENOMEM: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "not enough virtual memory"; + break; + case GHC_ENOMSG: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no message of desired type"; + break; + case GHC_ENONET: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "host is not on a network"; + break; + case GHC_ENOPROTOOPT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "operation not supported by protocol"; + break; + case GHC_ENOSPC: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "no space left on device"; + break; + case GHC_ENOSR: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "out of stream resources"; + break; + case GHC_ENOSTR: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a stream device"; + break; + case GHC_ENOSYS: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "function not implemented"; + break; + case GHC_ENOTBLK: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a block device"; + break; + case GHC_ENOTCONN: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "socket is not connected"; + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a directory"; + break; + case GHC_ENOTEMPTY: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "directory not empty"; + break; + case GHC_ENOTSOCK: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "not a socket"; + break; + case GHC_ENOTTY: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "inappropriate ioctl for device"; + break; + case GHC_ENXIO: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such device or address"; + break; + case GHC_EOPNOTSUPP: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "operation not supported on socket"; + break; + case GHC_EPERM: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "privileged operation"; + break; + case GHC_EPFNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "protocol family not supported"; + break; + case GHC_EPIPE: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "broken pipe"; + break; + case GHC_EPROCLIM: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "too many processes"; + break; + case GHC_EPROCUNAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "unimplemented RPC procedure"; + break; + case GHC_EPROGMISMATCH: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "unsupported RPC program version"; + break; + case GHC_EPROGUNAVAIL: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "RPC program unavailable"; + break; + case GHC_EPROTO: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "error in streams protocol"; + break; + case GHC_EPROTONOSUPPORT: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "protocol not supported"; + break; + case GHC_EPROTOTYPE: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "wrong protocol for socket"; + break; + case GHC_ERANGE: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "result too large"; + break; + case GHC_EREMCHG: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "remote address changed"; + break; + case GHC_EREMOTE: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "too many levels of remote in path"; + break; + case GHC_EROFS: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "read-only file system"; + break; + case GHC_ERPCMISMATCH: + ghc_errtype = ERR_PROTOCOLERROR; + ghc_errstr = "RPC version is wrong"; + break; + case GHC_ERREMOTE: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "object is remote"; + break; + case GHC_ESHUTDOWN: + ghc_errtype = ERR_ILLEGALOPERATION; + ghc_errstr = "can't send after socket shutdown"; + break; + case GHC_ESOCKTNOSUPPORT: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "socket type not supported"; + break; + case GHC_ESPIPE: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a pipe"; + break; + case GHC_ESRCH: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no such process"; + break; + case GHC_ESRMNT: + ghc_errtype = ERR_UNSATISFIEDCONSTRAINTS; + ghc_errstr = "RFS resources still mounted by remote host(s)"; + break; + case GHC_ESTALE: + ghc_errtype = ERR_RESOURCEVANISHED; + ghc_errstr = "stale NFS file handle"; + break; + case GHC_ETIME: + ghc_errtype = ERR_TIMEEXPIRED; + ghc_errstr = "timer expired"; + break; + case GHC_ETIMEDOUT: + ghc_errtype = ERR_TIMEEXPIRED; + ghc_errstr = "connection timed out"; + break; + case GHC_ETOOMANYREFS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "too many references; can't splice"; + break; + case GHC_ETXTBSY: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "text file in-use"; + break; + case GHC_EUSERS: + ghc_errtype = ERR_RESOURCEEXHAUSTED; + ghc_errstr = "quota table full"; + break; + case GHC_EWOULDBLOCK: + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "operation would block"; + break; + case GHC_EXDEV: + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't make a cross-device link"; + break; + } +} + +\end{code} diff --git a/ghc/lib/std/cbits/fileEOF.lc b/ghc/lib/std/cbits/fileEOF.lc new file mode 100644 index 0000000000..cdd3eb20cf --- /dev/null +++ b/ghc/lib/std/cbits/fileEOF.lc @@ -0,0 +1,23 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileEOF.lc]{hIsEOF Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +fileEOF(fp) +StgForeignObj fp; +{ + if (fileLookAhead(fp) != EOF) + return 0; + else if (ghc_errtype == ERR_EOF) + return 1; + else + return -1; +} + +\end{code} diff --git a/ghc/lib/std/cbits/fileGetc.lc b/ghc/lib/std/cbits/fileGetc.lc new file mode 100644 index 0000000000..131c956364 --- /dev/null +++ b/ghc/lib/std/cbits/fileGetc.lc @@ -0,0 +1,38 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileGetc.lc]{hGetChar Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "error.h" + +StgInt +fileGetc(fp) +StgForeignObj fp; +{ + int c; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return EOF; + } + + /* Try to read a character */ + while ((c = getc((FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + } else if (c == EOF) { + cvtErrno(); + stdErrno(); + } + return c; +} + +\end{code} diff --git a/ghc/lib/std/cbits/fileLookAhead.lc b/ghc/lib/std/cbits/fileLookAhead.lc new file mode 100644 index 0000000000..91a172251d --- /dev/null +++ b/ghc/lib/std/cbits/fileLookAhead.lc @@ -0,0 +1,27 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileLookAhead.lc]{hLookAhead Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +fileLookAhead(fp) +StgForeignObj fp; +{ + int c; + + if ((c = fileGetc(fp)) == EOF) { + return c; + } else if (ungetc(c, (FILE *) fp) == EOF) { + cvtErrno(); + stdErrno(); + return EOF; + } else + return c; +} + +\end{code} diff --git a/ghc/lib/std/cbits/filePosn.lc b/ghc/lib/std/cbits/filePosn.lc new file mode 100644 index 0000000000..7a0d7907b8 --- /dev/null +++ b/ghc/lib/std/cbits/filePosn.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[filePosn.lc]{hGetPosn and hSetPosn Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +getFilePosn(fp) +StgForeignObj fp; +{ + StgInt posn; + + while ((posn = ftell((FILE *) fp)) == -1) { + /* the possibility seems awfully remote */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return posn; +} + +/* The following is only called with a position that we've already visited */ + +StgInt +setFilePosn(fp, posn) +StgForeignObj fp; +StgInt posn; +{ + while (fseek((FILE *) fp, posn, SEEK_SET) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/filePutc.lc b/ghc/lib/std/cbits/filePutc.lc new file mode 100644 index 0000000000..4e6b85bb04 --- /dev/null +++ b/ghc/lib/std/cbits/filePutc.lc @@ -0,0 +1,32 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[filePuc.lc]{hPutChar Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" +#include "error.h" + +StgInt +filePutc(fp, c) +StgForeignObj fp; +StgInt c; +{ + int rc; + + /* Try to read a character */ + while ((rc = putc((int) c, (FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + + if (rc == EOF) { + cvtErrno(); + stdErrno(); + return -1; + } + + return 0; +} + +\end{code} diff --git a/ghc/lib/std/cbits/fileSize.lc b/ghc/lib/std/cbits/fileSize.lc new file mode 100644 index 0000000000..34348feedf --- /dev/null +++ b/ghc/lib/std/cbits/fileSize.lc @@ -0,0 +1,45 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[fileSize.lc]{hfileSize Runtime Support} + +\begin{code} + +#include "rtsdefs.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 +fileSize(fp, result) +StgForeignObj fp; +StgByteArray result; +{ + struct stat sb; + + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISREG(sb.st_mode)) { + /* result will be word aligned */ + *(off_t *) result = sb.st_size; + return 0; + } else { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "not a regular file"; + return -1; + } +} + +\end{code} diff --git a/ghc/lib/std/cbits/floatExtreme.h b/ghc/lib/std/cbits/floatExtreme.h new file mode 100644 index 0000000000..e073985706 --- /dev/null +++ b/ghc/lib/std/cbits/floatExtreme.h @@ -0,0 +1,13 @@ +#ifndef FLOATEXTREME_H +#define FLOATEXTREME_H + +StgInt isDoubleNaN PROTO((StgDouble)); +StgInt isDoubleInfinite PROTO((StgDouble)); +StgInt isDoubleDenormalized PROTO((StgDouble)); +StgInt isDoubleNegativeZero PROTO((StgDouble)); +StgInt isFloatNaN PROTO((StgFloat)); +StgInt isFloatInfinite PROTO((StgFloat)); +StgInt isFloatDenormalized PROTO((StgFloat)); +StgInt isFloatNegativeZero PROTO((StgFloat)); + +#endif /* FLOATEXTREME_H */ diff --git a/ghc/lib/std/cbits/floatExtreme.lc b/ghc/lib/std/cbits/floatExtreme.lc new file mode 100644 index 0000000000..3dbecdeee5 --- /dev/null +++ b/ghc/lib/std/cbits/floatExtreme.lc @@ -0,0 +1,174 @@ +% +% +% + +Stubs to check for extremities of (IEEE) floats, +the tests have been (artfully) lifted from the hbc-0.9999.3 (lib/fltcode.c) +source. + +ToDo: + - avoid hard-wiring the fact that on an + Alpha we repr. a StgFloat as a double. + (introduce int equivalent of {ASSIGN,PK}_FLT? ) + +\begin{code} + +#include "rtsdefs.h" +#include "ieee-flpt.h" +#include "floatExtreme.h" + +#ifdef BIGENDIAN +#define L 1 +#define H 0 +#else +#define L 0 +#define H 1 +#endif + +#ifdef IEEE_FLOATING_POINT + +StgInt +isDoubleNaN(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int hx,lx; + int r; + + u.d = d; + hx = u.i[H]; + lx = u.i[L]; + hx &= 0x7fffffff; + hx |= (unsigned int)(lx|(-lx))>>31; + hx = 0x7ff00000 - hx; + r = (int)((unsigned int)(hx))>>31; + return (r); +} + +StgInt +isDoubleInfinite(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int hx,lx; + + u.d = d; + hx = u.i[H]; + lx = u.i[L]; + hx &= 0x7fffffff; + hx ^= 0x7ff00000; + hx |= lx; + return (hx == 0); +} + +StgInt +isDoubleDenormalized(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int high, iexp; + + u.d = d; + high = u.i[H]; + iexp = high & (0x7ff << 20); + return (iexp == 0); +} + +StgInt +isDoubleNegativeZero(d) +StgDouble d; +{ + union { double d; int i[2]; } u; + int high, iexp; + + u.d = d; + return (u.i[H] == 0x80000000 && u.i[L] == 0); +} + +/* Same tests, this time for StgFloats. */ + +StgInt +isFloatNaN(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleNaN(f)); +#else + union { StgFloat f; int i; } u; + int r; + u.f = f; + + u.i &= 0x7fffffff; + u.i = 0x7f800000 - u.i; + r = (int)(((unsigned int)(u.i))>>31); + return (r); +#endif +} + +StgInt +isFloatInfinite(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleInfinite(f)); +#else + int ix; + union { StgFloat f; int i; } u; + u.f = f; + + u.i &= 0x7fffffff; + u.i ^= 0x7f800000; + return (u.i == 0); +#endif +} + +StgInt +isFloatDenormalized(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleDenormalized(f)); +#else + int iexp; + union { StgFloat f; int i; } u; + u.f = f; + + iexp = u.i & (0xff << 23); + return (iexp == 0); +#endif +} + +StgInt +isFloatNegativeZero(f) +StgFloat f; +{ +#if !defined(alpha_TARGET_OS) + /* StgFloat = double on alphas */ + return (isDoubleNegativeZero(f)); +#else + union { StgFloat f; int i; } u; + u.f = f; + + return (u.i == (int)0x80000000); +#endif +} + + +#else + +StgInt isDoubleNaN(d) StgDouble d; { return 0; } +StgInt isDoubleInfinite(d) StgDouble d; { return 0; } +StgInt isDoubleDenormalized(d) StgDouble d; { return 0; } +StgInt isDoubleNegativeZero(d) StgDouble d; { return 0; } +StgInt isFloatNaN(f) StgFloat f; { return 0; } +StgInt isFloatInfinite(f) StgFloat f; { return 0; } +StgInt isFloatDenormalized(f) StgFloat f; { return 0; } +StgInt isFloatNegativeZero(f) StgFloat f; { return 0; } + +#endif + + +\end{code} diff --git a/ghc/lib/std/cbits/flushFile.lc b/ghc/lib/std/cbits/flushFile.lc new file mode 100644 index 0000000000..6cfd484e74 --- /dev/null +++ b/ghc/lib/std/cbits/flushFile.lc @@ -0,0 +1,30 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[flushFile.lc]{hFlush Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +flushFile(fp) +StgForeignObj fp; +{ + int rc; + + while ((rc = fflush((FILE *) fp)) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return rc; + } + } + return 0; +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/freeFile.lc b/ghc/lib/std/cbits/freeFile.lc new file mode 100644 index 0000000000..1ac3d52661 --- /dev/null +++ b/ghc/lib/std/cbits/freeFile.lc @@ -0,0 +1,52 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1997 +% +\subsection[freeFile.lc]{Giving up files} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +/* sigh, the FILEs attached to the standard descriptors are + handled differently. We don't want them freed via the + ForeignObj finaliser, as we probably want to use these + before we *really* shut down (dumping stats etc.) +*/ +void freeStdFile(fp) +StgForeignObj fp; +{ return; } + +void freeFile(fp) +StgForeignObj fp; +{ + int rc; + + if ( fp == NULL || (rc = unlockFile(fileno((FILE *)fp))) ) { + /* If the file handle has been explicitly closed + * (via closeFile()) or freed, we will have given + * up our process lock, so we silently return here. + */ + return; + } + + /* + * The finaliser for the FILEs embedded in Handles. The RTS + * assumes that the finaliser runs without problems, so all + * we can do here is fclose(), and hope nothing went wrong. + * + * Assume fclose() flushes output stream. + */ + + rc = fclose((FILE *)fp); + /* Error or no error, we don't care.. */ + + /* + if ( rc == EOF ) { + fprintf(stderr. "Warning: file close ran into trouble\n"); + } + */ + + return; +} +\end{code} diff --git a/ghc/lib/std/cbits/getBufferMode.lc b/ghc/lib/std/cbits/getBufferMode.lc new file mode 100644 index 0000000000..cb0b9840d2 --- /dev/null +++ b/ghc/lib/std/cbits/getBufferMode.lc @@ -0,0 +1,52 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[getBufferMode.lc]{hIs...Buffered Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_SYS_STAT_H +#include <sys/stat.h> +#endif + +/* + * We try to guess what the default buffer mode is going to be based + * on the type of file we're attached to. + */ + +#define GBM_NB (0) +#define GBM_LB (-1) +#define GBM_BB (-2) +#define GBM_ERR (-3) + +StgInt +getBufferMode(fp) +StgForeignObj fp; +{ + struct stat sb; + + /* Try to find out the file type */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return GBM_ERR; + } + } + /* Terminals are line-buffered by default */ + if (S_ISCHR(sb.st_mode) && isatty(fileno((FILE *) fp)) == 1) + return GBM_LB; + /* Default size block buffering for the others */ + else + return GBM_BB; +} + +\end{code} diff --git a/ghc/lib/std/cbits/getCPUTime.lc b/ghc/lib/std/cbits/getCPUTime.lc new file mode 100644 index 0000000000..d3d7b2a489 --- /dev/null +++ b/ghc/lib/std/cbits/getCPUTime.lc @@ -0,0 +1,107 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCPUTime.lc]{getCPUTime Runtime Support} + +\begin{code} + +#ifndef _AIX +#define NON_POSIX_SOURCE /*needed for solaris2 only?*/ +#endif + +/* how is this to work given we have not read platform.h yet? */ +#ifdef hpux_TARGET_OS +#define _INCLUDE_HPUX_SOURCE +#endif + +#include "rtsdefs.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_SYS_TIMES_H +#include <sys/times.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS +#include <sys/resource.h> +#endif + +#ifdef HAVE_SYS_TIMEB_H +#include <sys/timeb.h> +#endif + +#ifdef hpux_TARGET_OS +#include <sys/syscall.h> +#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b) +#define HAVE_GETRUSAGE +#endif + +StgInt +clockTicks () +{ + return ( +#if defined(CLK_TCK) + CLK_TCK +#else + sysconf(_SC_CLK_TCK) +#endif + ); +} + +/* + * Our caller wants a pointer to four StgInts, + * user seconds, user nanoseconds, system seconds, system nanoseconds. + * Yes, the timerval has unsigned components, but nanoseconds take only + * 30 bits, and our CPU usage would have to be over 68 years for the + * seconds to overflow 31 bits. + */ + +StgByteArray +getCPUTime(StgByteArray cpuStruct) +{ + StgInt *cpu=(StgInt *)cpuStruct; + +#if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS + struct rusage t; + + getrusage(RUSAGE_SELF, &t); + cpu[0] = t.ru_utime.tv_sec; + cpu[1] = 1000 * t.ru_utime.tv_usec; + cpu[2] = t.ru_stime.tv_sec; + cpu[3] = 1000 * t.ru_stime.tv_usec; + +#else +# if defined(HAVE_TIMES) + struct tms t; +# if defined(CLK_TCK) +# define ticks CLK_TCK +# else + long ticks; + ticks = sysconf(_SC_CLK_TCK); +# endif + + times(&t); + cpu[0] = t.tms_utime / ticks; + cpu[1] = (t.tms_utime - cpu[0] * ticks) * (1000000000 / ticks); + cpu[2] = t.tms_stime / ticks; + cpu[3] = (t.tms_stime - cpu[2] * ticks) * (1000000000 / ticks); + +# else + return NULL; +# endif +#endif + return (StgByteArray) cpuStruct; +} + +\end{code} + diff --git a/ghc/lib/std/cbits/getClockTime.lc b/ghc/lib/std/cbits/getClockTime.lc new file mode 100644 index 0000000000..b6f42e6c28 --- /dev/null +++ b/ghc/lib/std/cbits/getClockTime.lc @@ -0,0 +1,77 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getClockTime.lc]{getClockTime Runtime Support} + +\begin{code} + +#ifndef _AIX +#define NON_POSIX_SOURCE /* gettimeofday */ +#endif + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_GETCLOCK + +# ifdef HAVE_SYS_TIMERS_H +# define POSIX_4D9 1 +# include <sys/timers.h> +# endif + +#else +# ifdef HAVE_GETTIMEOFDAY + +# ifdef HAVE_SYS_TIME_H +# include <sys/time.h> +# endif + +# else + +# ifdef HAVE_TIME_H +# include <time.h> +# endif + +# endif +#endif + +StgInt +getClockTime(StgByteArray sec, StgByteArray nsec) +{ +#ifdef HAVE_GETCLOCK + struct timespec tp; + + if (getclock(TIMEOFDAY, &tp) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = tp.tv_sec; + ((unsigned long int *)nsec)[0] = tp.tv_nsec; + return 0; +#else +#ifdef HAVE_GETTIMEOFDAY + struct timeval tp; + + if (gettimeofday(&tp, NULL) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = tp.tv_sec; + ((unsigned long int *)nsec)[0] = tp.tv_usec * 1000; + return 0; +#else + time_t t; + if ((t = time(NULL)) == (time_t) -1) { + cvtErrno(); + stdErrno(); + return -1; + } + ((unsigned long int *)sec)[0] = t; + ((unsigned long int *)nsec)[0] = 0; + return 0; +#endif +#endif +} +\end{code} diff --git a/ghc/lib/std/cbits/getCurrentDirectory.lc b/ghc/lib/std/cbits/getCurrentDirectory.lc new file mode 100644 index 0000000000..4da895aacc --- /dev/null +++ b/ghc/lib/std/cbits/getCurrentDirectory.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getCurrentDirectory.lc]{getCurrentDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifndef PATH_MAX +#ifdef MAXPATHLEN +#define PATH_MAX MAXPATHLEN +#else +#define PATH_MAX 1024 +#endif +#endif + +StgAddr +getCurrentDirectory(STG_NO_ARGS) +{ + 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; +} + +\end{code} diff --git a/ghc/lib/std/cbits/getDirectoryContents.lc b/ghc/lib/std/cbits/getDirectoryContents.lc new file mode 100644 index 0000000000..025aae9751 --- /dev/null +++ b/ghc/lib/std/cbits/getDirectoryContents.lc @@ -0,0 +1,124 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[getDirectoryContents.lc]{getDirectoryContents Runtime Support} + +\begin{code} + +#include "rtsdefs.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; + + /* 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; + } + if ((entries[count] = malloc(strlen(d->d_name))) == 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); + 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; + } + } + } +} + +\end{code} diff --git a/ghc/lib/std/cbits/getLock.lc b/ghc/lib/std/cbits/getLock.lc new file mode 100644 index 0000000000..1ed0dbf7ee --- /dev/null +++ b/ghc/lib/std/cbits/getLock.lc @@ -0,0 +1,140 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[getLock.lc]{stdin/stout/stderr Runtime Support} + +\begin{code} + +#include "rtsdefs.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_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#ifndef FD_SETSIZE +#define FD_SETSIZE 256 +#endif + +typedef struct { + dev_t device; + ino_t inode; + int fd; +} Lock; + +static Lock readLock[FD_SETSIZE]; +static Lock writeLock[FD_SETSIZE]; + +static int readLocks = 0; +static int writeLocks = 0; + +int +lockFile(fd, exclusive) +int fd; +int exclusive; +{ + int i; + struct stat sb; + + while (fstat(fd, &sb) < 0) { + if (errno != EINTR) { + return -1; + } + } + + /* Only lock regular files */ + if (!S_ISREG(sb.st_mode)) + return 0; + + for (i = 0; i < writeLocks; i++) + if (writeLock[i].inode == sb.st_ino && writeLock[i].device == sb.st_dev) { + errno = EAGAIN; + return -1; + } + + if (!exclusive) { + i = readLocks++; + readLock[i].device = sb.st_dev; + readLock[i].inode = sb.st_ino; + readLock[i].fd = fd; + return 0; + } + + for (i = 0; i < readLocks; i++) + if (readLock[i].inode == sb.st_ino && readLock[i].device == sb.st_dev) { + errno = EAGAIN; + return -1; + } + + i = writeLocks++; + writeLock[i].device = sb.st_dev; + writeLock[i].inode = sb.st_ino; + writeLock[i].fd = fd; + return 0; +} + +int +unlockFile(fd) +int fd; +{ + int i, rc; + + for (i = 0; i < readLocks; i++) + if (readLock[i].fd == fd) { + while (++i < readLocks) + readLock[i - 1] = readLock[i]; + readLocks--; + return 0; + } + + for (i = 0; i < writeLocks; i++) + if (writeLock[i].fd == fd) { + while (++i < writeLocks) + writeLock[i - 1] = writeLock[i]; + writeLocks--; + return 0; + } + /* Signal that we did not find an entry */ + return 1; +} + +StgInt +getLock(fp, exclusive) +StgForeignObj fp; +StgInt exclusive; +{ + if (lockFile(fileno((FILE *) fp), exclusive) < 0) { + if (errno == EBADF) + return 0; + else { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EACCES: + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "file is locked"; + break; + } + (void) fclose((FILE *) fp); + return -1; + } + } + return 1; +} + +\end{code} diff --git a/ghc/lib/std/cbits/inputReady.lc b/ghc/lib/std/cbits/inputReady.lc new file mode 100644 index 0000000000..8baa582971 --- /dev/null +++ b/ghc/lib/std/cbits/inputReady.lc @@ -0,0 +1,126 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[inputReady.lc]{hReady Runtime Support} + +\begin{code} + +/* select and supporting types is not */ +#ifndef _AIX +#define NON_POSIX_SOURCE +#endif + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef _AIX +/* this is included from sys/types.h only if _BSD is defined. */ +/* Since it is not, I include it here. - andre */ +#include <sys/select.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +StgInt +inputReady(fp, nsecs) +StgForeignObj fp; +StgInt nsecs; +{ + int flags, c, fd, maxfd, ready; + fd_set rfd; + struct timeval tv; + + if (feof((FILE *) fp)) + return 0; + + fd = fileno((FILE *)fp); + + /* Get the original file status flags */ + while ((flags = fcntl(fd, F_GETFL)) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + + /* If it's not already non-blocking, make it so */ + if (!(flags & O_NONBLOCK)) { + while (fcntl(fd, F_SETFL, flags | O_NONBLOCK) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + /* Now try to get a character */ + FD_ZERO(&rfd); + FD_SET(fd, &rfd); + /* select() will consider the descriptor set in the range of 0 to (maxfd-1) */ + maxfd = fd + 1; + tv.tv_usec = 0; + tv.tv_sec = nsecs; + while ((ready = select(maxfd, &rfd, NULL, NULL, &tv)) < 0 ) { + if (errno != EINTR ) { + cvtErrno(); + stdErrno(); + ready = -1; + break; + } + } + /* + while ((c = getc((FILE *) fp)) == EOF && errno == EINTR) + clearerr((FILE *) fp); + */ + + /* If we made it non-blocking for this, switch it back */ + if (!(flags & O_NONBLOCK)) { + while (fcntl(fd, F_SETFL, flags) < 0) { + /* still highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + } + /* 1 => Input ready, 0 => time expired (-1 error) */ + return (ready); + + /* + if (c == EOF) { + if (errno == EAGAIN || feof((FILE *) fp)) { + clearerr((FILE *) fp); + return 0; + } else { + cvtErrno(); + stdErrno(); + return -1; + } + } else if (ungetc(c, (FILE *) fp) == EOF) { + cvtErrno(); + stdErrno(); + return -1; + } else + return 1; + */ +} + +\end{code} diff --git a/ghc/lib/std/cbits/openFile.lc b/ghc/lib/std/cbits/openFile.lc new file mode 100644 index 0000000000..4b92aca8b5 --- /dev/null +++ b/ghc/lib/std/cbits/openFile.lc @@ -0,0 +1,217 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[openFile.lc]{openFile Runtime Support} + +\begin{code} + +#include "rtsdefs.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_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +StgAddr +openFile(file, how) +StgByteArray file; +StgByteArray how; +{ + FILE *fp; + int fd; + int oflags; + int exclusive; + int created = 0; + struct stat sb; + + /* + * Since we aren't supposed to succeed when we're opening for writing and + * there's another writer, we can't just do an fopen() for "w" mode. + */ + + switch (how[0]) { + case 'a': + oflags = O_WRONLY | O_NOCTTY | O_APPEND; + exclusive = 1; + break; + case 'w': + oflags = O_WRONLY | O_NOCTTY; + exclusive = 1; + break; + case 'r': + oflags = how[1] == '+' ? O_RDWR | O_NOCTTY : O_RDONLY | O_NOCTTY; + exclusive = 0; + break; + default: + fprintf(stderr, "openFile: unknown mode `%s'\n", how); + EXIT(EXIT_FAILURE); + } + + /* First try to open without creating */ + while ((fd = open(file, oflags, 0666)) < 0) { + if (errno == ENOENT) { + if (how[0] == 'r' && how[1] == '\0') { + /* For ReadMode, just bail out now */ + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "file does not exist"; + return NULL; + } else { + /* If it is a dangling symlink, break off now, too. */ + struct stat st; + if ( lstat(file,&st) == 0) { + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "dangling symlink"; + return NULL; + } + } + /* Now try to create it */ + while ((fd = open(file, oflags | O_CREAT | O_EXCL, 0666)) < 0) { + if (errno == EEXIST) { + /* Race detected; go back and open without creating it */ + break; + } else 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 file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + if (fd >= 0) { + created = 1; + break; + } + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + + /* Make sure that we aren't looking at a directory */ + + while (fstat(fd, &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "file is a directory"; + /* We can't have created it in this case. */ + (void) close(fd); + + return NULL; + } + /* Use our own personal locking */ + + if (lockFile(fd, exclusive) < 0) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EACCES: + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "file is locked"; + break; + } + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + + /* + * Write mode is supposed to truncate the file. Unfortunately, our pal + * ftruncate() is non-POSIX, so we truncate with a second open, which may fail. + */ + + if (how[0] == 'w') { + int fd2; + + oflags |= O_TRUNC; + while ((fd2 = open(file, oflags, 0666)) < 0) { + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_EAGAIN: + ghc_errtype = ERR_RESOURCEBUSY; + ghc_errstr = "enforced lock prevents truncation"; + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return NULL; + } + } + close(fd2); + } + errno = 0; /* Just in case fdopen() is lame */ + while ((fp = fdopen(fd, how)) == NULL) { + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(file); + (void) close(fd); + return NULL; + } + } + + return (StgAddr) fp; +} + +\end{code} diff --git a/ghc/lib/std/cbits/readFile.lc b/ghc/lib/std/cbits/readFile.lc new file mode 100644 index 0000000000..0cc9c2c7b9 --- /dev/null +++ b/ghc/lib/std/cbits/readFile.lc @@ -0,0 +1,102 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[readFile.lc]{hGetContents Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#define EOT 4 + +StgInt +readBlock(buf, fp, size) +StgAddr buf; +StgForeignObj fp; +StgInt size; +{ + int count; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while ((count = fread(buf, 1, size, (FILE *) fp)) == 0) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + return count; +} + +StgInt +readLine(buf, fp, size) +StgAddr buf; +StgForeignObj fp; +StgInt size; +{ + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while (fgets(buf, size, (FILE *) fp) == NULL) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + return strlen(buf); +} + +StgInt +readChar(fp) +StgForeignObj fp; +{ + int c; + + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } + + while ((c = getc((FILE *) fp)) == EOF) { + if (feof((FILE *) fp)) { + ghc_errtype = ERR_EOF; + ghc_errstr = ""; + return -1; + } else if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + clearerr((FILE *) fp); + } + + if (isatty(fileno((FILE *) fp)) && c == EOT) + return EOF; + else + return c; +} + +\end{code} diff --git a/ghc/lib/std/cbits/removeDirectory.lc b/ghc/lib/std/cbits/removeDirectory.lc new file mode 100644 index 0000000000..3347fd7c09 --- /dev/null +++ b/ghc/lib/std/cbits/removeDirectory.lc @@ -0,0 +1,57 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[removeDirectory.lc]{removeDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.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; +} + +\end{code} diff --git a/ghc/lib/std/cbits/removeFile.lc b/ghc/lib/std/cbits/removeFile.lc new file mode 100644 index 0000000000..095b6215b5 --- /dev/null +++ b/ghc/lib/std/cbits/removeFile.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[removeFile.lc]{removeFile Runtime Support} + +\begin{code} + +#include "rtsdefs.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(path) +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; +} + +\end{code} diff --git a/ghc/lib/std/cbits/renameDirectory.lc b/ghc/lib/std/cbits/renameDirectory.lc new file mode 100644 index 0000000000..2a41186bfe --- /dev/null +++ b/ghc/lib/std/cbits/renameDirectory.lc @@ -0,0 +1,48 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[renameDirectory.lc]{renameDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.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; +} +\end{code} diff --git a/ghc/lib/std/cbits/renameFile.lc b/ghc/lib/std/cbits/renameFile.lc new file mode 100644 index 0000000000..2bcb9c0e04 --- /dev/null +++ b/ghc/lib/std/cbits/renameFile.lc @@ -0,0 +1,132 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[renameFile.lc]{renameFile Runtime Support} + +\begin{code} + +#include "rtsdefs.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(opath, npath) +StgByteArray opath; +StgByteArray npath; +{ + struct stat sb; + int fd; + int created = 0; + + /* 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; + } + + /* Ensure a non-directory destination */ + + /* First try to open without creating */ + while ((fd = open(npath, O_RDONLY | O_NOCTTY, 0)) < 0) { + if (errno == ENOENT) { + /* Now try to create it */ + while ((fd = open(npath, O_RDONLY | O_NOCTTY | O_CREAT | O_EXCL, 0)) < 0) { + if (errno == EEXIST) { + /* Race detected; go back and open without creating it */ + break; + } else 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 file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return -1; + } + } + if (fd >= 0) { + created = 1; + break; + } + } else if (errno != EINTR) { + cvtErrno(); + switch (ghc_errno) { + default: + stdErrno(); + break; + case GHC_ENOTDIR: + ghc_errtype = ERR_NOSUCHTHING; + ghc_errstr = "no path to file"; + break; + case GHC_EINVAL: + ghc_errtype = ERR_PERMISSIONDENIED; + ghc_errstr = "unsupported owner or group"; + break; + } + return -1; + } + } + + /* Make sure that we aren't looking at a directory */ + + while (fstat(fd, &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + if (created) + (void) unlink(npath); + (void) close(fd); + return -1; + } + } + if (S_ISDIR(sb.st_mode)) { + ghc_errtype = ERR_INAPPROPRIATETYPE; + ghc_errstr = "destination is a directory"; + /* We can't have created it in this case. */ + (void) close(fd); + return -1; + } + + while(rename(opath, npath) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + if (created) + (void) unlink(npath); + (void) close(fd); + return -1; + } + } + + close(fd); + return 0; +} +\end{code} diff --git a/ghc/lib/std/cbits/seekFile.lc b/ghc/lib/std/cbits/seekFile.lc new file mode 100644 index 0000000000..48c0cf7d3b --- /dev/null +++ b/ghc/lib/std/cbits/seekFile.lc @@ -0,0 +1,135 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[seekFile.lc]{hSeek and hIsSeekable Runtime Support} + +\begin{code} + +#include "rtsdefs.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 +seekFile(fp, whence, size, d) +StgForeignObj fp; +StgInt whence; +StgInt size; +StgByteArray d; +{ + struct stat sb; + long int offset; + + /* + * We need to snatch the offset out of an MP_INT. The bits are there sans sign, + * which we pick up from our size parameter. If abs(size) is greater than 1, + * this integer is just too big. + */ + + switch (size) { + case -1: + offset = -*(StgInt *) d; + break; + case 0: + offset = 0; + break; + case 1: + offset = *(StgInt *) d; + break; + default: + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "offset out of range"; + return -1; + } + + /* Try to find out the file type & size for a physical file */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + if (S_ISREG(sb.st_mode)) { + /* Verify that we are not seeking beyond end-of-file */ + int posn; + + switch (whence) { + case SEEK_SET: + posn = offset; + break; + case SEEK_CUR: + while ((posn = ftell((FILE *) fp)) == -1) { + /* the possibility seems awfully remote */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + posn += offset; + break; + case SEEK_END: + posn = sb.st_size + offset; + break; + } + if (posn > sb.st_size) { + ghc_errtype = ERR_INVALIDARGUMENT; + ghc_errstr = "seek position beyond end of file"; + return -1; + } + } else if (S_ISFIFO(sb.st_mode)) { + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a pipe"; + return -1; + } else { + ghc_errtype = ERR_UNSUPPORTEDOPERATION; + ghc_errstr = "can't seek on a device"; + return -1; + } + while (fseek((FILE *) fp, offset, whence) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +StgInt +seekFileP(fp) +StgForeignObj fp; +{ + struct stat sb; + + /* Try to find out the file type */ + while (fstat(fileno((FILE *) fp), &sb) < 0) { + /* highly unlikely */ + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + /* Regular files are okay */ + if (S_ISREG(sb.st_mode)) { + return 1; + } + /* For now, everything else is not */ + else { + return 0; + } +} + +\end{code} + + + diff --git a/ghc/lib/std/cbits/setBuffering.lc b/ghc/lib/std/cbits/setBuffering.lc new file mode 100644 index 0000000000..0169b50ce2 --- /dev/null +++ b/ghc/lib/std/cbits/setBuffering.lc @@ -0,0 +1,123 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[setBuffering.lc]{hSetBuffering Runtime Support} + +\begin{code} + +#include "rtsdefs.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_TERMIOS_H +#include <termios.h> +#endif + +#ifdef HAVE_FCNTL_H +#include <fcntl.h> +#endif + +#define SB_NB (0) +#define SB_LB (-1) +#define SB_BB (-2) + +StgInt +setBuffering(fp, size) +StgForeignObj fp; +StgInt size; +{ + int flags; + int input; + struct termios tio; + + while ((flags = fcntl(fileno((FILE *) fp), F_GETFL)) < 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + flags &= O_ACCMODE; + input = flags == O_RDONLY || flags == O_RDWR; + + switch (size) { + case SB_NB: + if (setvbuf((FILE *) fp, NULL, _IONBF, 0L) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + if (input && isatty(fileno((FILE *) fp))) { + + /* + * Try to switch to CBREAK mode, or whatever they call it these days. + */ + + if (tcgetattr(fileno((FILE *) fp), &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + tio.c_lflag &= ~ICANON; + tio.c_cc[VMIN] = 1; + tio.c_cc[VTIME] = 0; + if (tcsetattr(fileno((FILE *) fp), TCSANOW, &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; + break; + case SB_LB: + if (setvbuf((FILE *) fp, NULL, _IOLBF, BUFSIZ) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + break; + case SB_BB: + + /* + * We should actually peek at the buffer size in the stat struct, if there + * is one. Something to occupy us later, when we're bored. + */ + size = BUFSIZ; + /* fall through */ + default: + if (setvbuf((FILE *) fp, NULL, _IOFBF, size) != 0) { + cvtErrno(); + stdErrno(); + return -1; + } + break; + } + if (input && isatty(fileno((FILE *) fp))) { + + /* + * Try to switch back to cooked mode. + */ + + if (tcgetattr(fileno((FILE *) fp), &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + tio.c_lflag |= ICANON; + if (tcsetattr(fileno((FILE *) fp), TCSANOW, &tio) < 0) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/lib/std/cbits/setCurrentDirectory.lc b/ghc/lib/std/cbits/setCurrentDirectory.lc new file mode 100644 index 0000000000..96fdf59fa9 --- /dev/null +++ b/ghc/lib/std/cbits/setCurrentDirectory.lc @@ -0,0 +1,25 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[setCurrentDirectory.lc]{setCurrentDirectory Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +setCurrentDirectory(path) +StgByteArray path; +{ + while (chdir(path) != 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + return 0; +} + +\end{code} diff --git a/ghc/lib/std/cbits/showTime.lc b/ghc/lib/std/cbits/showTime.lc new file mode 100644 index 0000000000..08adcd50f4 --- /dev/null +++ b/ghc/lib/std/cbits/showTime.lc @@ -0,0 +1,51 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[showTime.lc]{ClockTime.showsPrec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif + +StgAddr +showTime(I_ size, StgByteArray d, StgByteArray buf) +{ + time_t t; + struct tm *tm; + + switch(size) { + default: + return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range"); + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return + (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: out of range"); + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return (StgAddr) strcpy(buf, "ClockTime.show{LibTime}: out of range"); + break; + } + tm = localtime(&t); + if (tm != NULL && strftime(buf, 32 /*Magic number*/, "%a %b %d %T %Z %Y", tm) > 0) + return (StgAddr)buf; + return (StgAddr)strcpy(buf, "ClockTime.show{LibTime}: internal error"); +} +\end{code} diff --git a/ghc/lib/std/cbits/stgio.h b/ghc/lib/std/cbits/stgio.h new file mode 100644 index 0000000000..2c5eab247d --- /dev/null +++ b/ghc/lib/std/cbits/stgio.h @@ -0,0 +1,133 @@ +#ifndef STGIO_H +#define STGIO_H + +/* Decls for routines in ghc/lib/cbits/ only used there. + * This file is used when compiling the Haskell library + * that _ccalls_ those routines; and when compiling those + * routines (to check consistency). + */ + +/* closeFile.lc */ +StgInt closeFile PROTO((StgForeignObj)); + +/* createDirectory.lc */ +StgInt createDirectory PROTO((StgByteArray)); + +/* env.lc */ +char * strDup PROTO((const char *)); +int setenviron PROTO((char **)); +int copyenv (STG_NO_ARGS); +int _setenv PROTO((char *)); +int delenv PROTO((char *)); + +/* errno.lc */ +extern int ghc_errno; +extern int ghc_errtype; +void cvtErrno(STG_NO_ARGS); +void stdErrno(STG_NO_ARGS); + +/* execvpe.lc */ +int execvpe PROTO((char *, char **, char **)); + +/* fileEOF.lc */ +StgInt fileEOF PROTO((StgForeignObj)); +/* fileGetc.lc */ +StgInt fileGetc PROTO((StgForeignObj)); + +/* fileLookAhead.lc */ +StgInt fileLookAhead PROTO((StgForeignObj)); + +/* filePosn.lc */ +StgInt getFilePosn PROTO((StgForeignObj)); +StgInt setFilePosn PROTO((StgForeignObj, StgInt)); + +/* filePutc.lc */ +StgInt filePutc PROTO((StgForeignObj, StgInt)); + +/* fileSize.lc */ +StgInt fileSize PROTO((StgForeignObj, StgByteArray)); + +/* flushFile.lc */ +StgInt flushFile PROTO((StgForeignObj)); + +/* freeFile.lc */ +void freeStdFile PROTO((StgForeignObj)); +void freeFile PROTO((StgForeignObj)); + +/* getBufferMode.lc */ +StgInt getBufferMode PROTO((StgForeignObj)); + +/* getClockTime.lc */ +StgInt getClockTime PROTO((StgByteArray, StgByteArray)); +StgAddr showTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toClockSec PROTO((I_, I_, I_, I_, I_, I_, I_, StgByteArray)); +StgAddr toLocalTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toUTCTime PROTO((I_, StgByteArray, StgByteArray)); + +/* getCPUTime.lc */ +StgByteArray getCPUTime PROTO((StgByteArray)); +StgInt clockTicks(); + +/* getCurrentDirectory.lc */ +StgAddr getCurrentDirectory(STG_NO_ARGS); + +/* getDirectoryContents.lc */ +StgAddr getDirectoryContents PROTO((StgByteArray)); + +/* getLock.lc */ +int lockFile PROTO((int, int)); +int unlockFile PROTO((int)); +StgInt getLock PROTO((StgForeignObj, StgInt)); + +/* inputReady.lc */ +StgInt inputReady PROTO((StgForeignObj,StgInt)); + +/* openFile.lc */ +StgAddr openFile PROTO((StgByteArray, StgByteArray)); + +/* readFile.lc */ +StgInt readBlock PROTO((StgAddr, StgForeignObj, StgInt)); +StgInt readLine PROTO((StgAddr, StgForeignObj, StgInt)); +StgInt readChar PROTO((StgForeignObj)); + +/* removeDirectory.lc */ +StgInt removeDirectory PROTO((StgByteArray)); + +/* removeFile.lc */ +StgInt removeFile PROTO((StgByteArray)); + +/* renameDirectory.lc */ +StgInt renameDirectory PROTO((StgByteArray, StgByteArray)); + +/* renameFile.lc */ +StgInt renameFile PROTO((StgByteArray, StgByteArray)); + +/* seekFile.lc */ +StgInt seekFile PROTO((StgForeignObj, StgInt, StgInt, StgByteArray)); +StgInt seekFileP PROTO((StgForeignObj)); + +/* setBuffering.lc */ +StgInt setBuffering PROTO((StgForeignObj, StgInt)); + +/* setCurrentDirectory.lc */ +StgInt setCurrentDirectory PROTO((StgByteArray)); + +/* showTime.lc */ +StgAddr showTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* system.lc */ +StgInt systemCmd PROTO((StgByteArray)); + +/* toLocalTime.lc */ +StgAddr toLocalTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* toUTCTime.lc */ +StgAddr toUTCTime PROTO((StgInt, StgByteArray, StgByteArray)); + +/* toClockSec.lc */ +StgAddr toClockSec PROTO((StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgInt, StgByteArray)); + +/* writeFile.lc */ +StgInt writeFile PROTO((StgAddr, StgForeignObj, StgInt)); + +#endif /* ! STGIO_H */ diff --git a/ghc/lib/std/cbits/system.lc b/ghc/lib/std/cbits/system.lc new file mode 100644 index 0000000000..013f111ba6 --- /dev/null +++ b/ghc/lib/std/cbits/system.lc @@ -0,0 +1,65 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[system.lc]{system Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +#ifdef HAVE_SYS_WAIT_H +#include <sys/wait.h> +#endif + +#ifdef HAVE_VFORK_H +#include <vfork.h> +#endif + +#ifdef HAVE_VFORK +#define fork vfork +#endif + +StgInt +systemCmd(cmd) +StgByteArray cmd; +{ + int pid; + int wstat; + + switch(pid = fork()) { + case -1: + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + case 0: + /* the child */ + execl("/bin/sh", "sh", "-c", cmd, NULL); + _exit(127); + } + + while (waitpid(pid, &wstat, 0) < 0) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + } + + if (WIFEXITED(wstat)) + return WEXITSTATUS(wstat); + else if (WIFSIGNALED(wstat)) { + ghc_errtype = ERR_INTERRUPTED; + ghc_errstr = "system command interrupted"; + } + else { + /* This should never happen */ + ghc_errtype = ERR_OTHERERROR; + ghc_errstr = "internal error (process neither exited nor signalled)"; + } + return -1; +} + +\end{code} diff --git a/ghc/lib/std/cbits/timezone.h b/ghc/lib/std/cbits/timezone.h new file mode 100644 index 0000000000..46b907f269 --- /dev/null +++ b/ghc/lib/std/cbits/timezone.h @@ -0,0 +1,47 @@ +#ifndef TIMEZONE_H +#define TIMEZONE_H + +#define _OSF_SOURCE + +#if TIME_WITH_SYS_TIME +# include <sys/time.h> +# include <time.h> +#else +# if HAVE_SYS_TIME_H +# include <sys/time.h> +# else +# include <time.h> +# endif +#endif + +#if HAVE_TM_ZONE +#define ZONE(x) (((struct tm *)x)->tm_zone) +#define SETZONE(x,z) (((struct tm *)x)->tm_zone = z) +#define GMTOFF(x) (((struct tm *)x)->tm_gmtoff) +#else /* ! HAVE_TM_ZONE */ +# if HAVE_TZNAME || cygwin32_TARGET_OS +#if cygwin32_TARGET_OS +extern char *tzname; +#else +extern char *tzname[2]; +#endif +# define ZONE(x) (((struct tm *)x)->tm_isdst ? tzname[1] : tzname[0]) +# define SETZONE(x,z) +# else /* ! HAVE_TZNAME */ +/* We're in trouble. If you should end up here, please report this as a bug. */ +# error Dont know how to get at timezone name on your OS. +# endif /* ! HAVE_TZNAME */ +/* Get the offset in secs from UTC, if (struct tm) doesn't supply it. */ + +extern TYPE_TIMEZONE timezone; + +# if HAVE_ALTZONE +extern time_t altzone; +# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? altzone : timezone) +# else /* ! HAVE_ALTZONE */ +/* Assume that DST offset is 1 hour ... */ +# define GMTOFF(x) (((struct tm *)x)->tm_isdst ? (timezone - 3600) : timezone) +# endif /* ! HAVE_ALTZONE */ +#endif /* ! HAVE_TM_ZONE */ + +#endif /* TIMEZONE_H */ diff --git a/ghc/lib/std/cbits/toClockSec.lc b/ghc/lib/std/cbits/toClockSec.lc new file mode 100644 index 0000000000..3107ae37e3 --- /dev/null +++ b/ghc/lib/std/cbits/toClockSec.lc @@ -0,0 +1,41 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toClockSec.lc]{toClockSec Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +StgAddr +toClockSec(I_ year, I_ mon, I_ mday, I_ hour, I_ min, I_ sec, I_ isdst, StgByteArray res) +{ + struct tm tm; + time_t t; + + tm.tm_year = year - 1900; + tm.tm_mon = mon; + tm.tm_mday = mday; + tm.tm_hour = hour; + tm.tm_min = min; + tm.tm_sec = sec; + tm.tm_isdst = isdst; + +#ifdef HAVE_MKTIME + t = mktime(&tm); +#else +#ifdef HAVE_TIMELOCAL + t = timelocal(&tm); +#else + t = (time_t) -1; +#endif +#endif + if (t == (time_t) -1) + return NULL; + + *(time_t *)res = t; + return res; +} +\end{code} diff --git a/ghc/lib/std/cbits/toLocalTime.lc b/ghc/lib/std/cbits/toLocalTime.lc new file mode 100644 index 0000000000..11a1e30d9b --- /dev/null +++ b/ghc/lib/std/cbits/toLocalTime.lc @@ -0,0 +1,67 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toLocalTime.lc]{toCalendarTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +StgAddr +toLocalTime(I_ size, StgByteArray d, StgByteArray res) +{ + struct tm *tm,*tmp=(struct tm *)res; + time_t t; + + switch(size) { + default: + return NULL; + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return NULL; + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return NULL; + break; + } + tm = localtime(&t); + + if (tm == NULL) + return NULL; + + /* + localtime() may return a ptr to statically allocated storage, + so to make toLocalTime reentrant, we manually copy + the structure into the (struct tm *) passed in. + */ + tmp->tm_sec = tm->tm_sec; + tmp->tm_min = tm->tm_min; + tmp->tm_hour = tm->tm_hour; + tmp->tm_mday = tm->tm_mday; + tmp->tm_mon = tm->tm_mon; + tmp->tm_year = tm->tm_year; + tmp->tm_wday = tm->tm_wday; + tmp->tm_yday = tm->tm_yday; + tmp->tm_isdst = tm->tm_isdst; + /* + If you don't have tm_zone in (struct tm), but + you get at it via the shared tmzone[], you'll + lose. Same goes for the tm_gmtoff field. + + */ +#if HAVE_TM_ZONE + strcpy(tmp->tm_zone,tm->tm_zone); + tmp->tm_gmtoff = tm->tm_gmtoff; +#endif + + return (StgAddr)res; +} +\end{code} diff --git a/ghc/lib/std/cbits/toUTCTime.lc b/ghc/lib/std/cbits/toUTCTime.lc new file mode 100644 index 0000000000..86f449e286 --- /dev/null +++ b/ghc/lib/std/cbits/toUTCTime.lc @@ -0,0 +1,72 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995 +% +\subsection[toUTCTime.lc]{toUTCTime Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "timezone.h" +#include "stgio.h" + +#ifdef cygwin32_TARGET_OS +extern char *_tzname; +char *tzname; +#endif + +StgAddr +toUTCTime(I_ size, StgByteArray d, StgByteArray res) +{ + time_t t; + struct tm *tm,*tmp=(struct tm *)res; + + switch(size) { + default: + return NULL; + case 0: + t = 0; + break; + case -1: + t = - (time_t) ((StgInt *)d)[0]; + if (t > 0) + return NULL; + break; + case 1: + t = (time_t) ((StgInt *)d)[0]; + if (t < 0) + return NULL; + break; + } + tm = gmtime(&t); + + if (tm == NULL) + return NULL; + + /* + gmtime() may return a ptr to statically allocated storage, + so to make toUTCTime reentrant, we manually copy + the structure into the (struct tm *) passed in. + */ + tmp->tm_sec = tm->tm_sec; + tmp->tm_min = tm->tm_min; + tmp->tm_hour = tm->tm_hour; + tmp->tm_mday = tm->tm_mday; + tmp->tm_mon = tm->tm_mon; + tmp->tm_year = tm->tm_year; + tmp->tm_wday = tm->tm_wday; + tmp->tm_yday = tm->tm_yday; + tmp->tm_isdst = tm->tm_isdst; + /* + If you don't have tm_zone in (struct tm), but + you get at it via the shared tmzone[], you'll + lose. Same goes for the tm_gmtoff field. + + */ +#if HAVE_TM_ZONE + strcpy(tmp->tm_zone,tm->tm_zone); + tmp->tm_gmtoff = tm->tm_gmtoff; +#endif + + return (StgAddr)res; +} +\end{code} diff --git a/ghc/lib/std/cbits/writeFile.lc b/ghc/lib/std/cbits/writeFile.lc new file mode 100644 index 0000000000..71c7b0df17 --- /dev/null +++ b/ghc/lib/std/cbits/writeFile.lc @@ -0,0 +1,38 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1994 +% +\subsection[writeFile.lc]{hPutStr Runtime Support} + +\begin{code} + +#include "rtsdefs.h" +#include "stgio.h" + +StgInt +writeFile(buf, fp, bytes) +StgAddr buf; +StgForeignObj fp; +StgInt bytes; +{ + int count; + char *p = (char *) buf; + + if (bytes == 0) + return 0; + + /* Disallow short writes */ + while ((count = fwrite(p, 1, bytes, (FILE *) fp)) < bytes) { + if (errno != EINTR) { + cvtErrno(); + stdErrno(); + return -1; + } + bytes -= count; + p += count; + clearerr((FILE *) fp); + } + + return 0; +} + +\end{code} |