X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FStringBuffer.lhs;h=f49449ec3967bf217b352b382aafe07fcc25f896;hb=1181f398e73359a2e6387364b4fe270d4cc78f36;hp=115d36c50946e94beec139c44fb4d02571c45519;hpb=2e7b61267f94f4e0bff083412816e643c8e2c281;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index 115d36c..f49449e 100644
--- a/ghc/compiler/utils/StringBuffer.lhs
+++ b/ghc/compiler/utils/StringBuffer.lhs
@@ -6,13 +6,17 @@
 Buffers for scanning string input stored in external arrays.
 
 \begin{code}
-{-# OPTIONS -fno-prune-tydecls #-}
+
+{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
+
 module StringBuffer
        (
         StringBuffer,
 
-	 -- creation
-        hGetStringBuffer,  -- :: FilePath       -> IO StringBuffer
+	 -- creation/destruction
+        hGetStringBuffer,     -- :: FilePath     -> IO StringBuffer
+	stringToStringBuffer, -- :: String       -> IO StringBuffer
+	freeStringBuffer,     -- :: StringBuffer -> IO ()
 
          -- Lookup
 	currentChar,      -- :: StringBuffer -> Char
@@ -37,6 +41,7 @@ module StringBuffer
         stepOnBy#,        -- :: StringBuffer -> Int# -> StringBuffer
         stepOnTo#,        -- :: StringBuffer -> Int# -> StringBuffer
         stepOnUntil,      -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
+	stepOnUntilChar#, -- :: StringBuffer -> Char# -> StringBuffer
         stepOverLexeme,   -- :: StringBuffer   -> StringBuffer
 	scanNumLit,       -- :: Int -> StringBuffer -> (Int, StringBuffer)
 	squeezeLexeme,	  -- :: StringBuffer -> Int# -> StringBuffer
@@ -51,7 +56,6 @@ module StringBuffer
 	 -- matching
         prefixMatch,       -- :: StringBuffer -> String -> Bool
 	untilEndOfString#, -- :: StringBuffer -> Int#
-	untilChar#,        -- :: StringBuffer -> Char# -> Int#
 
          -- conversion
         lexemeToString,     -- :: StringBuffer -> String
@@ -66,47 +70,34 @@ module StringBuffer
 #include "HsVersions.h"
 
 import GlaExts
-import Addr 		( Addr(..) )
+#if __GLASGOW_HASKELL__ < 411
+import PrelAddr 	( Addr(..) )
+#else
+import Addr		( Addr(..) )
+#endif
 import Foreign
-import ST
 import Char		( chr )
+import Panic		( panic )
 
--- urk!
-#include "../lib/std/cbits/stgerror.h"
-
-#if __GLASGOW_HASKELL__ >= 303
-import IO		( openFile, slurpFile )
+import IO		( openFile  )
+import IOExts		( slurpFile )
 import PrelIOBase
 import PrelHandle
 import Addr
-#else
-import IO		( openFile, hFileSize, hClose, IOMode(..) )
-import Addr
+#if __GLASGOW_HASKELL__ >= 411
+import Ptr		( Ptr(..) )
 #endif
 
-#if __GLASGOW_HASKELL__ < 301
-import IOBase		( Handle, IOError(..), IOErrorType(..),
-			  constructErrorAndFail )
-import IOHandle		( readHandle, writeHandle, filePtr )
-import PackBase 	( unpackCStringBA )
-#else
-# if __GLASGOW_HASKELL__ <= 302
-import PrelIOBase	( Handle, IOError(..), IOErrorType(..), 
-			  constructErrorAndFail )
-import PrelHandle	( readHandle, writeHandle, filePtr )
-# endif
 import PrelPack		( unpackCStringBA )
-#endif
 
-#if __GLASGOW_HASKELL__ < 402
-import Util 		( bracket )
-#else
-import Exception	( bracket )
+#if __GLASGOW_HASKELL__ >= 501
+import PrelIO		( hGetcBuffered )
 #endif
 
+import Exception	( bracket )
 import PrimPacked
 import FastString
-import Char 		(isDigit)
+import Char 		( isDigit )
 \end{code} 
 
 \begin{code}
@@ -119,7 +110,7 @@ data StringBuffer
 \end{code}
 
 \begin{code}
-instance Text StringBuffer where
+instance Show StringBuffer where
 	showsPrec _ s = showString ""
 \end{code}
 
@@ -128,40 +119,25 @@ hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer
 hGetStringBuffer expand_tabs fname = do
    (a, read) <- if expand_tabs 
 				then slurpFileExpandTabs fname 
+#if __GLASGOW_HASKELL__ < 411
 				else slurpFile fname
+#else
+				else do
+				    (Ptr a#, read) <- slurpFile fname
+				    return (A# a#, read)
+#endif
 
-   let (A# a#) = a;  (I# read#) = read
+	-- urk! slurpFile gives us a buffer that doesn't have room for
+	-- the sentinel.  Assume it has a final newline for now, and overwrite
+	-- that with the sentinel.  slurpFileExpandTabs (below) leaves room
+	-- for the sentinel.
+   let  (A# a#) = a;  
+	(I# read#) = read;
+	end# = read# -# 1#
 
          -- add sentinel '\NUL'
-   _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# (read# -# 1#))
-   return (StringBuffer a# read# 0# 0#)
-
-#if __GLASGOW_HASKELL__ < 303
-slurpFile fname =
-    openFile fname ReadMode >>= \ hndl ->
-    hFileSize hndl          >>= \ len ->
-    let len_i = fromInteger len in
-      -- Allocate an array for system call to store its bytes into.
-      -- ToDo: make it robust
---    trace (show ((len_i::Int)+1)) $
-    _casm_ `` %r=(char *)malloc(sizeof(char)*(int)%0); '' (len_i::Int)  >>= \ arr@(A# a#) ->
-    if addr2Int# a# ==# 0# then
-       fail (userError ("hGetStringBuffer: Could not allocate "++show len_i ++ " bytes"))
-    else
-    readHandle hndl        >>= \ hndl_ ->
-    writeHandle hndl hndl_ >>
-     let ptr = filePtr hndl_ in
-#if __GLASGOW_HASKELL__ <= 302
-     _ccall_ fread arr (1::Int) len_i (ptr::ForeignObj)               >>= \  (I# read#) ->
-#else
-     _ccall_ fread arr (1::Int) len_i (ptr::Addr)                     >>= \  (I# read#) ->
-#endif
-     hClose hndl		     >>
-     if read# ==# 0# then -- EOF or some other error
-        fail (userError ("hGetStringBuffer: failed to slurp in interface file "++fname))
-     else
-	return (arr, I# read#)
-#endif
+   _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' (A# a#) (I# end#)
+   return (StringBuffer a# end# 0# 0#)
 
 unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer
 unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
@@ -172,6 +148,34 @@ unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
 \end{code}
 
 -----------------------------------------------------------------------------
+-- Turn a String into a StringBuffer
+
+\begin{code}
+stringToStringBuffer :: String -> IO StringBuffer
+freeStringBuffer :: StringBuffer -> IO ()
+
+#if __GLASGOW_HASKELL__ >= 411
+stringToStringBuffer str =
+  do let sz@(I# sz#) = length str
+     (Ptr a#) <- mallocBytes (sz+1)
+     fill_in str (A# a#)
+     writeCharOffAddr (A# a#) sz '\0'		-- sentinel
+     return (StringBuffer a# sz# 0# 0#)
+ where
+  fill_in [] _ = return ()
+  fill_in (c:cs) a = do
+    writeCharOffAddr a 0 c 
+    fill_in cs (a `plusAddr` 1)
+
+freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
+#else
+stringToStringBuffer = panic "stringToStringBuffer: not implemented"
+freeStringBuffer sb  = return ()
+#endif
+
+\end{code}
+
+-----------------------------------------------------------------------------
 This very disturbing bit of code is used for expanding the tabs in a
 file before we start parsing it.  Expanding the tabs early makes the
 lexer a lot simpler: we only have to record the beginning of the line
@@ -182,20 +186,8 @@ We guess the size of the buffer required as 20% extra for
 expanded tabs, and enlarge it if necessary.
 
 \begin{code}
-#if __GLASGOW_HASKELL__ < 303
-mayBlock fo thing = thing
-
-writeCharOffAddr :: Addr -> Int -> Char -> IO ()
-writeCharOffAddr addr off c
-  = _casm_ ``*((char *)%0+(int)%1)=(char)%2;'' addr off c
-#endif
-
 getErrType :: IO Int
-#if __GLASGOW_HASKELL__ < 303
-getErrType = _casm_ ``%r = ghc_errtype;''
-#else
 getErrType =  _ccall_ getErrType__
-#endif
 
 slurpFileExpandTabs :: FilePath -> IO (Addr,Int)
 slurpFileExpandTabs fname = do
@@ -203,7 +195,7 @@ slurpFileExpandTabs fname = do
    (\ handle ->
      do sz <- hFileSize handle
         if sz > toInteger (maxBound::Int) 
-	  then IOERROR (userError "slurpFile: file too big")
+	  then ioError (userError "slurpFile: file too big")
           else do
       	    let sz_i = fromInteger sz
       	        sz_i' = (sz_i * 12) `div` 10		-- add 20% for tabs
@@ -213,15 +205,12 @@ slurpFileExpandTabs fname = do
 
 trySlurp :: Handle -> Int -> Addr -> IO (Addr, Int)
 trySlurp handle sz_i chunk =
-#if __GLASGOW_HASKELL__ == 303
-  wantReadableHandle "hGetChar" handle >>= \ handle_ ->
-  let fo = haFO__ handle_ in
-#elif __GLASGOW_HASKELL__ > 303
+#if __GLASGOW_HASKELL__ < 501
   wantReadableHandle "hGetChar" handle $ \ handle_ ->
   let fo = haFO__ handle_ in
 #else
-  readHandle handle        >>= \ handle_ ->
-  let fo = filePtr handle_ in
+  wantReadableHandle "hGetChar" handle $ 
+      \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBufferMode=mode } ->
 #endif
   let
 	(I# chunk_sz) = sz_i
@@ -238,13 +227,26 @@ trySlurp handle sz_i chunk =
 	     	chunk' <- reAllocMem chunk (I# new_sz)
 	     	slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#))
     	  slurp c off = do
+#if __GLASGOW_HASKELL__ < 501
     		intc <- mayBlock fo (_ccall_ fileGetc fo)
     		if intc == ((-1)::Int)
      		  then do errtype <- getErrType
-			  if errtype == (ERR_EOF :: Int)
+			  if errtype == (19{-ERR_EOF-} :: Int)
 			    then return (chunk, I# off)
 			    else constructErrorAndFail "slurpFile"
      		  else case chr intc of
+#else
+		buf <- readIORef ref
+		ch <- (if not (bufferEmpty buf)
+		      then hGetcBuffered fd ref buf
+		      else do new_buf <- fillReadBuffer fd True buf
+		              hGetcBuffered fd ref new_buf)
+		    `catch` \e -> if isEOFError e
+			then return '\xFFFF'
+			else ioError e
+		case ch of
+			 '\xFFFF' -> return (chunk, I# off)
+#endif
 			 '\t' -> tabIt c off
 			 ch   -> do  writeCharOffAddr chunk (I# off) ch
 				     let c' | ch == '\n' = 0#
@@ -271,35 +273,27 @@ trySlurp handle sz_i chunk =
 #if __GLASGOW_HASKELL__ < 404
   writeHandle handle handle_
 #endif
-  if rc < (0::Int)
-	then constructErrorAndFail "slurpFile"
-	else return (chunk', rc+1 {-room for sentinel-})
+  return (chunk', rc+1 {- room for sentinel -})
 
 
 reAllocMem :: Addr -> Int -> IO Addr
 reAllocMem ptr sz = do
    chunk <- _ccall_ realloc ptr sz
    if chunk == nullAddr 
-#if __GLASGOW_HASKELL__ >= 400
       then fail "reAllocMem"
-#else
-      then fail (userError "reAllocMem")
-#endif
       else return chunk
 
 allocMem :: Int -> IO Addr
 allocMem sz = do
-#if __GLASGOW_HASKELL__ < 303
    chunk <- _ccall_ malloc sz
    if chunk == nullAddr 
-      then fail (userError "allocMem")
-      else return chunk
-#else
-   chunk <- _ccall_ allocMemory__ sz
-   if chunk == nullAddr 
+#if __GLASGOW_HASKELL__ < 501
       then constructErrorAndFail "allocMem"
-      else return chunk
+#else
+      then ioException (IOError Nothing ResourceExhausted "malloc"
+					"out of memory" Nothing)
 #endif
+      else return chunk
 \end{code}
 
 Lookup
@@ -415,16 +409,16 @@ scanNumLit acc (StringBuffer fo l# s# c#) =
          | otherwise        -> (acc,StringBuffer fo l# s# c#)
 
 
-expandUntilMatch :: StringBuffer -> String -> StringBuffer
+expandUntilMatch :: StringBuffer -> String -> Maybe StringBuffer
 expandUntilMatch (StringBuffer fo l# s# c#) str =
   loop c# str
   where
-   loop c# [] = StringBuffer fo l# s# c#
-   loop c# ((C# x#):xs)
-      | indexCharOffAddr# fo c# `eqChar#` x#
-      = loop (c# +# 1#) xs
-      | otherwise 
-      = loop (c# +# 1#) str
+   loop c# [] = Just (StringBuffer fo l# s# c#)
+   loop c# ((C# x#):xs) =
+    case indexCharOffAddr# fo c# of
+      ch# | ch# `eqChar#` '\NUL'# && c# >=# l# -> Nothing
+	  | ch# `eqChar#` x# -> loop (c# +# 1#) xs
+          | otherwise        -> loop (c# +# 1#) str
 	
 \end{code}
 
@@ -482,13 +476,13 @@ untilEndOfString# (StringBuffer fo l# s# c#) =
     _ -> loop (c# +# 1#)
 
 
-untilChar# :: StringBuffer -> Char# -> StringBuffer
-untilChar# (StringBuffer fo l# s# c#) x# = 
+stepOnUntilChar# :: StringBuffer -> Char# -> StringBuffer
+stepOnUntilChar# (StringBuffer fo l# s# c#) x# = 
  loop c# 
  where
   loop c#
    | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
-   = StringBuffer fo l# s# c#
+   = StringBuffer fo l# c# c#
    | otherwise
    = loop (c# +# 1#)
 
@@ -500,7 +494,7 @@ lexemeToString (StringBuffer fo _ start_pos# current#) =
  else
     unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)))
     
-lexemeToByteArray :: StringBuffer -> _ByteArray Int
+lexemeToByteArray :: StringBuffer -> ByteArray Int
 lexemeToByteArray (StringBuffer fo _ start_pos# current#) = 
  if start_pos# ==# current# then
     error "lexemeToByteArray"