X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FStringBuffer.lhs;h=dfe061e76a58fc1f9cccc439148b641f24a5bc91;hb=bc5c802181b513216bc88f0d1ec9574157ee05fe;hp=84bfeb334bad6904793ccb204fe8d3ec823dce1b;hpb=6697c8de8348d7297c6f0561e96ce7767bf323bc;p=ghc-hetmet.git

diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs
index 84bfeb3..dfe061e 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
@@ -66,51 +70,36 @@ module StringBuffer
 #include "HsVersions.h"
 
 import GlaExts
+#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
-#if __GLASGOW_HASKELL__ < 407
-                        , slurpFile   -- comes from PrelHandle or IOExts now
-#endif
-                        )
+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 )
+import PrelCError	( throwErrnoIfMinus1RetryMayBlock )
+import PrelConc		( threadWaitRead )
 #endif
 
+import Exception	( bracket )
 import PrimPacked
 import FastString
-import Char 		(isDigit)
+import Char 		( isDigit )
 \end{code} 
 
 \begin{code}
@@ -132,7 +121,13 @@ 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
 
@@ -140,33 +135,6 @@ hGetStringBuffer expand_tabs fname = do
    _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
-
 unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer
 unsafeWriteBuffer s@(StringBuffer a _ _ _) i# ch# =
  unsafePerformIO (
@@ -176,6 +144,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
@@ -186,20 +182,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
@@ -217,15 +201,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
@@ -242,13 +223,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#
@@ -275,34 +269,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
    chunk <- _ccall_ malloc sz
-#if __GLASGOW_HASKELL__ < 303
-   if chunk == nullAddr 
-      then fail (userError "allocMem")
-      else return chunk
-#else
    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