[project @ 1998-08-24 19:13:18 by sof]

New module containing misc functions for going to/from C strings/sequences

diff --git a/ghc/lib/misc/CString.lhs b/ghc/lib/misc/CString.lhs
new file mode 100644 (file)
index 0000000..26b775e
--- /dev/null
+++ b/ghc/lib/misc/CString.lhs
@@ -0,0 +1,188 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
+%
+\section{Working with C strings}
+
+A collection of lower-level functions to help converting between
+C strings and Haskell Strings (packed or otherwise).
+
+A more user-friendly Haskell interface to packed string representation
+is the PackedString interface.
+
+\begin{code}
+module CString 
+       (
+         unpackCString      -- :: Addr -> [Char]
+       , unpackNBytes       -- :: Addr -> Int -> [Char]
+       , unpackNBytesST     -- :: Addr -> Int -> ST s [Char]
+       , unpackNBytesAccST  -- :: Addr -> Int -> [Char] -> ST s [Char]
+       , unpackCString#     -- :: Addr# -> [Char]       **
+       , unpackNBytes#      -- :: Addr# -> Int# -> [Char] **
+       , unpackNBytesST#    -- :: Addr# -> Int# -> ST s [Char]
+
+           -- terrrible names...
+       , unpackCStringIO     -- :: Addr -> IO String
+       , unpackCStringLenIO  -- :: Addr -> Int -> IO String
+       , unpackNBytesIO      -- :: Addr -> Int -> IO [Char]
+       , unpackNBytesAccIO   -- :: Addr -> Int -> [Char] -> IO [Char]
+       , unpackNBytesBAIO    -- :: ByteArray Int -> Int -> IO [Char]
+       , unpackNBytesAccBAIO -- :: ByteArray Int -> Int -> [Char] -> IO [Char]
+
+       , packString         -- :: [Char] -> ByteArray Int
+       , packStringST       -- :: [Char] -> ST s (ByteArray Int)
+       , packStringIO       -- :: [Char] -> IO (ByteArray Int)
+       , packNBytesST       -- :: Int -> [Char] -> ByteArray Int
+       , packCString#       -- :: [Char] -> ByteArray#
+
+       , unpackCStringBA    -- :: ByteArray Int -> [Char]
+       , unpackNBytesBA     -- :: ByteArray Int -> Int  -> [Char]
+       , unpackCStringBA#   -- :: ByteArray#    -> Int# -> [Char]
+       , unpackNBytesBA#    -- :: ByteArray#    -> Int# -> [Char]
+
+         -- unmarshaling (char*) vectors.
+       , unvectorize        -- :: Addr -> Int -> IO [String]
+       , vectorize          -- :: [[Char]] -> IO (ByteArray Int)
+
+
+       , allocChars         -- :: Int -> IO (MutableByteArray RealWorld Int)
+       , allocWords         -- :: Int -> IO (MutableByteArray RealWorld Int)
+       , freeze             -- :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
+       , strcpy             -- :: Addr -> IO String
+
+       ) where
+
+import PrelPack
+import GlaExts
+import Addr
+import PrelIOBase ( IO(..), IOResult(..))
+import PrelArr ( StateAndMutableByteArray#(..), 
+                StateAndByteArray#(..)
+              )
+
+\end{code}
+
+\begin{code}
+packStringIO :: [Char] -> IO (ByteArray Int)
+packStringIO str = stToIO (packStringST str)
+\end{code}
+
+\begin{code}
+unpackCStringIO :: Addr -> IO String
+unpackCStringIO addr
+ | addr == ``NULL'' = return ""
+ | otherwise        = unpack 0#
+  where
+    unpack nh = do
+       ch <- readCharOffAddr addr (I# nh)
+       if ch == '\0'
+        then return []
+       else do
+          ls <- unpack (nh +# 1#)
+          return (ch : ls)
+
+-- unpack 'len' chars
+unpackCStringLenIO :: Addr -> Int -> IO String
+unpackCStringLenIO addr l@(I# len#)
+ | len# <# 0#  = fail (userError ("CString.unpackCStringLenIO: negative length (" ++ show l ++ ")"))
+ | len# ==# 0# = return ""
+ | otherwise   = unpack [] (len# -# 1#)
+  where
+    unpack acc 0# = do
+       ch <- readCharOffAddr addr (I# 0#)
+       return (ch:acc)
+    unpack acc nh = do
+       ch <- readCharOffAddr addr (I# nh)
+       unpack (ch:acc) (nh -# 1#)
+
+unpackNBytesIO     :: Addr -> Int -> IO [Char]
+unpackNBytesIO a l = stToIO (unpackNBytesST a l)
+
+unpackNBytesAccIO  :: Addr -> Int -> [Char] -> IO [Char]
+unpackNBytesAccIO a l acc = stToIO (unpackNBytesAccST a l acc)
+
+unpackNBytesBAIO     :: ByteArray Int -> Int -> IO [Char]
+unpackNBytesBAIO ba l = unpackNBytesAccBAIO ba l []
+
+-- note: no bounds checking!
+unpackNBytesAccBAIO :: ByteArray Int -> Int -> [Char] -> IO [Char]
+unpackNBytesAccBAIO ba 0  rest = return rest
+unpackNBytesAccBAIO  (ByteArray _ ba) (I# len#) rest = unpack rest (len# -# 1#)
+  where
+    unpack acc i# 
+      | i# <# 0#   = return acc
+      | otherwise  = 
+        case indexCharArray# ba i# of
+          ch -> unpack (C# ch : acc) (i# -# 1#)
+
+\end{code}
+
+Turn a NULL-terminated vector of null-terminated strings into a string list
+(ToDo: create a module of common marshaling functions)
+
+\begin{code}
+unvectorize :: Addr -> Int -> IO [String]
+unvectorize ptr n
+  | str == ``NULL'' = return []
+  | otherwise = do
+       x  <- unpackCStringIO str
+       xs <- unvectorize ptr (n+1)
+       return (x : xs)
+  where
+   str = indexAddrOffAddr ptr n
+
+\end{code}
+
+ Turn a string list into a NULL-terminated vector of null-terminated
+strings No indices...I hate indices.  Death to Ix.
+
+\begin{code}
+vectorize :: [String] -> IO (ByteArray Int)
+vectorize xs = do
+  arr <- allocWords (len + 1)
+  fill arr 0 xs
+  freeze arr
+ where
+    len :: Int
+    len = length xs
+
+    fill :: MutableByteArray RealWorld Int -> Int -> [String] -> IO ()
+    fill arr n [] =
+       _casm_ ``((PP_)%0)[%1] = NULL;'' arr n
+    fill arr n (x:xs) =
+       packStringIO x                      >>= \ barr ->
+        _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr
+                                           >>= \ () ->
+       fill arr (n+1) xs
+
+\end{code}
+
+Allocating chunks of memory in the Haskell heap, leaving
+out the bounds - use with care.
+
+\begin{code}
+-- Allocate a mutable array of characters with no indices.
+allocChars :: Int -> IO (MutableByteArray RealWorld Int)
+allocChars (I# size#) = IO $ \ s# ->
+    case newCharArray# size# s# of
+      StateAndMutableByteArray# s2# barr# ->
+       IOok s2# (MutableByteArray (I# 1#, I# size#) barr#)
+
+allocWords :: Int -> IO (MutableByteArray RealWorld Int)
+allocWords (I# size#) = IO $ \ s# ->
+    case newIntArray# size# s# of
+      StateAndMutableByteArray# s2# barr# ->
+       IOok s2# (MutableByteArray (I# 1#, I# size#) barr#)
+
+-- Freeze these index-free mutable arrays
+freeze :: MutableByteArray RealWorld Int -> IO (ByteArray Int)
+freeze (MutableByteArray ixs arr#) = IO $ \ s# ->
+    case unsafeFreezeByteArray# arr# s# of
+      StateAndByteArray# s2# frozen# ->
+       IOok s2# (ByteArray ixs frozen#)
+
+-- Copy a null-terminated string from outside the heap to
+-- Haskellized nonsense inside the heap
+strcpy :: Addr -> IO String
+strcpy str = unpackCStringIO str
+
+\end{code}