From b6407eca09eb2525e212b8ce6d24c3a1db84ba03 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Mon, 29 Jun 1998 14:11:09 +0000
Subject: [PATCH] [project @ 1998-06-29 14:11:09 by sof] New functions:
 isCString, psToCString

---
 ghc/lib/misc/PackedString.lhs |   28 +++++++++++++++++++++++++++-
 1 file changed, 27 insertions(+), 1 deletion(-)

diff --git a/ghc/lib/misc/PackedString.lhs b/ghc/lib/misc/PackedString.lhs
index 2277bc1..b53d1d9 100644
--- a/ghc/lib/misc/PackedString.lhs
+++ b/ghc/lib/misc/PackedString.lhs
@@ -21,6 +21,8 @@ module PackedString (
 
 	psToByteArray,       -- :: PackedString  -> ByteArray Int
 	psToByteArrayST,     -- :: PackedString  -> ST s (ByteArray Int)
+	psToCString,	     -- :: PackedString  -> Addr
+        isCString,	     -- :: PackedString  -> Bool
 
 	unpackPS,    -- :: PackedString -> [Char]
 {-LATER:
@@ -73,7 +75,7 @@ module PackedString (
     ) where
 
 import GlaExts
-import PrelBase ( showList__ ) -- ToDo: better
+import PrelBase ( showList__  ) -- ToDo: better
 import Addr
 
 import PrelArr  ( StateAndMutableByteArray#(..) , StateAndByteArray#(..) )
@@ -275,6 +277,30 @@ psToByteArray (CPS addr len#)
     in
     case byte_array_form of { PS bytes _ _ ->
     ByteArray (0, len - 1) bytes }
+
+-- isCString is useful when passing PackedStrings to the
+-- outside world, and need to figure out whether you can
+-- pass it as an Addr or ByteArray.
+--
+isCString :: PackedString -> Bool
+isCString (CPS _ _ ) = True
+isCString _	     = False
+
+psToCString :: PackedString -> Addr
+psToCString (CPS addr _) = (A# addr)
+psToCString (PS bytes n# has_null) = 
+  unsafePerformIO $ do
+    stuff <- _ccall_ malloc ((I# n#) * (``sizeof(char)''))
+    let
+     fill_in n# i#
+      | n# ==# 0# = return ()
+      | otherwise = do
+         let ch#  = indexCharArray# bytes i#
+         writeCharOffAddr stuff (I# i#) (C# ch#)
+         fill_in (n# -# 1#) (i# +# 1#)
+    fill_in n# 0#
+    return stuff    
+
 \end{code}
 
 %************************************************************************
-- 
1.7.10.4