From c13305e9c22b442df05f86b61c61351fb1e15956 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Mon, 25 Aug 1997 22:43:11 +0000
Subject: [PATCH] [project @ 1997-08-25 22:43:11 by sof] New base module for
 pack/unpack basic ops

---
 ghc/lib/ghc/PackBase.lhs |  296 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 296 insertions(+)
 create mode 100644 ghc/lib/ghc/PackBase.lhs

diff --git a/ghc/lib/ghc/PackBase.lhs b/ghc/lib/ghc/PackBase.lhs
new file mode 100644
index 0000000..8bcd701
--- /dev/null
+++ b/ghc/lib/ghc/PackBase.lhs
@@ -0,0 +1,296 @@
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1997
+%
+\section[PackBase]{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 PackBase 
+       (
+	-- (**) - 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]
+
+	unpackCStringFO,   -- :: ForeignObj    -> [Char]
+	unpackNBytesFO,    -- :: ForeignObj    -> Int  -> [Char]
+	unpackCStringFO#,  -- :: ForeignObj#   -> [Char]
+	unpackNBytesFO#,   -- :: ForeignObj#   -> Int# -> [Char]
+
+	unpackFoldrCString#,  -- **
+	unpackAppendCString#  -- **
+
+       ) where
+
+import PrelBase
+import {-# SOURCE #-} IOBase ( error )
+import PrelList ( length )
+import STBase
+import ArrBase
+import Foreign
+
+\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 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}
+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
+\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
+ 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 -> ST s (ByteArray Int)
+
+new_ps_array size = ST $ \ (S# s) ->
+    case (newCharArray# size s)	  of { StateAndMutableByteArray# s2# barr# ->
+    (MutableByteArray bot barr#, S# s2#)}
+  where
+    bot = error "new_ps_array"
+
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ (S# s#) ->
+    case writeCharArray# barr# n ch s#	of { s2#   ->
+    ((), S# s2#)}
+
+-- same as unsafeFreezeByteArray
+freeze_ps_array (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+    case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
+    (ByteArray ixs frozen#, S# s2#) }
+\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}
-- 
1.7.10.4