[project @ 1999-02-18 17:55:40 by simonm]

[ghc-hetmet.git] / ghc / compiler / utils / FastString.lhs

diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs
index 1635997..b0a12b1 100644 (file)
--- a/ghc/compiler/utils/FastString.lhs
+++ b/ghc/compiler/utils/FastString.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1997
+% (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
 %
 \section{Fast strings}
 
@@ -39,6 +39,7 @@ module FastString
         tailFS,                    -- :: FastString -> FastString
        concatFS,           -- :: [FastString] -> FastString
         consFS,             -- :: Char -> FastString -> FastString
+       indexFS,            -- :: FastString -> Int -> Char
 
         hPutFS             -- :: Handle -> FastString -> IO ()
        ) where
@@ -48,24 +49,61 @@ module FastString
 #define COMPILING_FAST_STRING
 #include "HsVersions.h"
 
+#if __GLASGOW_HASKELL__ < 301
 import PackBase
+import STBase          ( StateAndPtr#(..) )
+import IOHandle                ( filePtr, readHandle, writeHandle )
+import IOBase          ( Handle__(..), IOError(..), IOErrorType(..),
+                         IOResult(..), IO(..),
+                         constructError
+                       )
+#else
+import PrelPack
+#if __GLASGOW_HASKELL__ < 400
+import PrelST          ( StateAndPtr#(..) )
+#endif
+
+#if __GLASGOW_HASKELL__ <= 303
+import PrelHandle      ( readHandle, 
+# if __GLASGOW_HASKELL__ < 303
+                         filePtr,
+# endif
+                         writeHandle
+                       )
+#endif
+
+import PrelIOBase      ( Handle__(..), IOError(..), IOErrorType(..),
+#if __GLASGOW_HASKELL__ < 400
+                         IOResult(..), 
+#endif
+                         IO(..),
+#if __GLASGOW_HASKELL__ >= 303
+                         Handle__Type(..),
+#endif
+                         constructError
+                       )
+#endif
+
 import PrimPacked
 import GlaExts
-import Addr    ( Addr(..) )
-import STBase  ( StateAndPtr#(..) )
-import ArrBase ( MutableArray(..) )
-import Foreign ( ForeignObj(..) )
-import IOExts  ( IOArray(..), newIOArray,
-                 IORef, newIORef, readIORef, writeIORef
-               )
+import Addr            ( Addr(..) )
+import MutableArray    ( MutableArray(..) )
+
+-- ForeignObj is now exported abstractly.
+#if __GLASGOW_HASKELL__ >= 303
+import qualified PrelForeign as Foreign  ( ForeignObj(..) )
+#else
+import Foreign         ( ForeignObj(..) )
+#endif
+
+import IOExts          ( IORef, newIORef, readIORef, writeIORef )
 import IO
-import IOHandle        ( filePtr, readHandle, writeHandle )
-import IOBase  ( Handle__(..), IOError(..), IOErrorType(..),
-                 IOResult(..), IO(..),
-                 constructError
-               )
 
 #define hASH_TBL_SIZE 993
+
+#if __GLASGOW_HASKELL__ >= 400
+#define IOok STret
+#endif
 \end{code} 
 
 @FastString@s are packed representations of strings
@@ -102,10 +140,6 @@ instance Ord FastString where
             | otherwise        =  y
     compare a b = cmpFS a b
 
-instance Text FastString  where
-    showsPrec p ps@(FastString u# _ _) r = showsPrec p (unpackFS ps) r
-    showsPrec p ps r = showsPrec p (unpackFS ps) r
-
 getByteArray# :: FastString -> ByteArray#
 getByteArray# (FastString _ _ ba#) = ba#
 
@@ -143,6 +177,18 @@ headFS f@(FastString _ l# ba#) =
 headFS f@(CharStr a# l#) = 
  if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f)
 
+indexFS :: FastString -> Int -> Char
+indexFS f i@(I# i#) =
+ case f of
+   FastString _ l# ba#
+     | l# ># 0# && l# ># i#  -> C# (indexCharArray# ba# i#)
+     | otherwise            -> error (msg (I# l#))
+   CharStr a# l#
+     | l# ># 0# && l# ># i#  -> C# (indexCharOffAddr# a# i#)
+     | otherwise            -> error (msg (I# l#))
+ where
+  msg l =  "indexFS: out of range: " ++ show (l,i)
+
 tailFS :: FastString -> FastString
 tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
 
@@ -188,12 +234,21 @@ string_table =
 lookupTbl :: FastStringTable -> Int# -> IO [FastString]
 lookupTbl (FastStringTable _ arr#) i# =
   IO ( \ s# ->
+#if __GLASGOW_HASKELL__ < 400
   case readArray# arr# i# s# of { StateAndPtr# s2# r ->
   IOok s2# r })
+#else
+  readArray# arr# i# s#)
+#endif
 
 updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
 updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
- IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> IOok s2# () }) >>
+ IO (\ s# -> case writeArray# arr# i# ls s# of { s2# -> 
+#if __GLASGOW_HASKELL__ < 400
+       IOok s2# () })  >>
+#else
+       (# s2#, () #) }) >>
+#endif
  writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
 
 mkFastString# :: Addr# -> Int# -> FastString
@@ -454,23 +509,24 @@ Outputting @FastString@s is quick, just block copying the chunk (using
 
 \begin{code}
 hPutFS :: Handle -> FastString -> IO ()
+#if __GLASGOW_HASKELL__ <= 302
 hPutFS handle (FastString _ l# ba#) =
  if l# ==# 0# then
     return ()
  else
-    _readHandle handle                             >>= \ htype ->
+    readHandle handle                              >>= \ htype ->
     case htype of 
       ErrorHandle ioError ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is closed")
       SemiClosedHandle _ _ ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is closed")
       ReadHandle _ _ _ ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
       other -> 
           let fp = filePtr htype in
@@ -485,19 +541,19 @@ hPutFS handle (CharStr a# l#) =
  if l# ==# 0# then
     return ()
  else
-    _readHandle handle                             >>= \ htype ->
+    readHandle handle                              >>= \ htype ->
     case htype of 
       ErrorHandle ioError ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
           fail ioError
       ClosedHandle ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is closed")
       SemiClosedHandle _ _ ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is closed")
       ReadHandle _ _ _ ->
-         _writeHandle handle htype                 >>
+         writeHandle handle htype                  >>
          fail MkIOError(handle,IllegalOperation,"handle is not open for writing")
       other -> 
           let fp = filePtr htype in
@@ -509,5 +565,20 @@ hPutFS handle (CharStr a# l#) =
               constructError "hPutFS"          >>= \ err ->
              fail err
 
+
+#else
+hPutFS handle (FastString _ l# ba#)
+  | l# ==# 0#  = return ()
+  | otherwise  = hPutBufBA handle (ByteArray bottom ba#) (I# l#)
+ where
+  bottom = error "hPutFS.ba"
+
 --ToDo: avoid silly code duplic.
+
+hPutFS handle (CharStr a# l#)
+  | l# ==# 0#  = return ()
+  | otherwise  = hPutBuf handle (A# a#) (I# l#)
+
+
+#endif
 \end{code}