X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Futils%2FStringBuffer.lhs;h=1f6e615578982eed7a37f289da2e18fdf720a661;hb=111cee3f1ad93816cb828e38b38521d85c3bcebb;hp=1a5476063bbb48947851055b218c486f9d1da2e6;hpb=904f158f9fe208b8154029dff655a6eab4b2828e;p=ghc-hetmet.git diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index 1a54760..1f6e615 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -6,7 +6,7 @@ Buffers for scanning string input stored in external arrays. \begin{code} -{-# OPTIONS -fno-prune-tydecls -#include "../lib/std/cbits/stgio.h" #-} +{-# OPTIONS -fno-prune-tydecls #-} module StringBuffer ( StringBuffer, @@ -71,24 +71,32 @@ import Foreign import ST import Char ( chr ) +-- urk! +#include "../lib/std/cbits/stgerror.h" + #if __GLASGOW_HASKELL__ >= 303 -import IO ( openFile, slurpFile ) +import IO ( openFile +#if __GLASGOW_HASKELL__ < 407 + , slurpFile -- comes from PrelHandle or IOExts now +#endif + ) import PrelIOBase import PrelHandle import Addr -#include "../lib/std/cbits/error.h" --- urk! #else import IO ( openFile, hFileSize, hClose, IOMode(..) ) +import Addr #endif #if __GLASGOW_HASKELL__ < 301 -import IOBase ( IOError(..), IOErrorType(..) ) +import IOBase ( Handle, IOError(..), IOErrorType(..), + constructErrorAndFail ) import IOHandle ( readHandle, writeHandle, filePtr ) import PackBase ( unpackCStringBA ) #else # if __GLASGOW_HASKELL__ <= 302 -import PrelIOBase ( IOError(..), IOErrorType(..) ) +import PrelIOBase ( Handle, IOError(..), IOErrorType(..), + constructErrorAndFail ) import PrelHandle ( readHandle, writeHandle, filePtr ) # endif import PrelPack ( unpackCStringBA ) @@ -121,18 +129,19 @@ instance Text StringBuffer where \begin{code} hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer -hGetStringBuffer expand_tabs fname = -#if __GLASGOW_HASKELL__ >= 303 - (if expand_tabs - then slurpFileExpandTabs fname - else slurpFile fname) - >>= \ (a , read) -> - let (A# a#) = a - (I# read#) = read - in - _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' a (I# (read# -# 1#)) >>= \ () -> - return (StringBuffer a# read# 0# 0#) -#else +hGetStringBuffer expand_tabs fname = do + (a, read) <- if expand_tabs + then slurpFileExpandTabs fname + else slurpFile fname + + let (A# a#) = a; (I# read#) = read + + -- 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 @@ -155,10 +164,7 @@ hGetStringBuffer expand_tabs fname = if read# ==# 0# then -- EOF or some other error fail (userError ("hGetStringBuffer: failed to slurp in interface file "++fname)) else - -- Add a sentinel NUL - _casm_ `` ((char *)%0)[(int)%1]=(char)0; '' arr (I# (read# -# 1#)) >>= \ () -> - return (StringBuffer a# read# 0# 0#) - + return (arr, I# read#) #endif unsafeWriteBuffer :: StringBuffer -> Int# -> Char# -> StringBuffer @@ -180,13 +186,28 @@ We guess the size of the buffer required as 20% extra for expanded tabs, and enlarge it if necessary. \begin{code} -slurpFileExpandTabs :: FilePath -> IO (Addr, Int) +#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 bracket (openFile fname ReadMode) (hClose) (\ 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 @@ -196,29 +217,36 @@ 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 wantReadableHandle "hGetChar" handle $ \ handle_ -> - let - fo = haFO__ handle_ - + let fo = haFO__ handle_ in +#else + readHandle handle >>= \ handle_ -> + let fo = filePtr handle_ in +#endif + let (I# chunk_sz) = sz_i tAB_SIZE = 8# - slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO Int + slurpFile :: Int# -> Int# -> Addr -> Int# -> Int# -> IO (Addr, Int) slurpFile c off chunk chunk_sz max_off = slurp c off where - slurp :: Int# -> Int# -> IO Int + slurp :: Int# -> Int# -> IO (Addr, Int) slurp c off | off >=# max_off = do let new_sz = chunk_sz *# 2# chunk' <- reAllocMem chunk (I# new_sz) - slurpFile c off chunk' new_sz (new_sz -# tAB_SIZE) + slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#)) slurp c off = do intc <- mayBlock fo (_ccall_ fileGetc fo) if intc == ((-1)::Int) - then do errtype <- _ccall_ getErrType__ + then do errtype <- getErrType if errtype == (ERR_EOF :: Int) - then return (I# off) + then return (chunk, I# off) else constructErrorAndFail "slurpFile" else case chr intc of '\t' -> tabIt c off @@ -227,7 +255,7 @@ trySlurp handle sz_i chunk = | otherwise = c +# 1# slurp c' (off +# 1#) - tabIt :: Int# -> Int# -> IO Int + tabIt :: Int# -> Int# -> IO (Addr, Int) -- can't run out of buffer in here, because we reserved an -- extra tAB_SIZE bytes at the end earlier. tabIt c off = do @@ -240,27 +268,42 @@ trySlurp handle sz_i chunk = in do -- allow space for a full tab at the end of the buffer - -- (that's what the max_off thing is for) - rc <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# tAB_SIZE) + -- (that's what the max_off thing is for), + -- and add 1 to allow room for the final sentinel \NUL at + -- the end of the file. + (chunk', rc) <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# (tAB_SIZE +# 1#)) +#if __GLASGOW_HASKELL__ < 404 writeHandle handle handle_ +#endif if rc < (0::Int) then constructErrorAndFail "slurpFile" - else return (chunk, rc) + else return (chunk', rc+1 {-room for sentinel-}) reAllocMem :: Addr -> Int -> IO Addr reAllocMem ptr sz = do chunk <- _ccall_ realloc ptr sz if chunk == nullAddr - then constructErrorAndFail "reAllocMem" +#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 then constructErrorAndFail "allocMem" else return chunk +#endif \end{code} Lookup @@ -376,16 +419,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}