ghc/compiler/utils/StringBuffer.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
   3 %
   4 \section{String buffers}
   5
   6 Buffers for scanning string input stored in external arrays.
   7
   8 \begin{code}
   9
  10 {-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
  11
  12 module StringBuffer
  13        (
  14         StringBuffer,
  15
  16          -- creation/destruction
  17         hGetStringBuffer,     -- :: FilePath     -> IO StringBuffer
  18         stringToStringBuffer, -- :: String       -> IO StringBuffer
  19         freeStringBuffer,     -- :: StringBuffer -> IO ()
  20
  21          -- Lookup
  22         currentChar,      -- :: StringBuffer -> Char
  23         currentChar#,     -- :: StringBuffer -> Char#
  24         indexSBuffer,     -- :: StringBuffer -> Int -> Char
  25         indexSBuffer#,    -- :: StringBuffer -> Int# -> Char#
  26          -- relative lookup, i.e, currentChar = lookAhead 0
  27         lookAhead,        -- :: StringBuffer -> Int  -> Char
  28         lookAhead#,       -- :: StringBuffer -> Int# -> Char#
  29
  30         -- offsets
  31         currentIndex#,    -- :: StringBuffer -> Int#
  32         lexemeIndex,      -- :: StringBuffer -> Int#
  33
  34          -- moving the end point of the current lexeme.
  35         addToCurrentPos,   -- :: StringBuffer -> Int# -> StringBuffer
  36         incCurrentPos,    -- :: StringBuffer -> StringBuffer
  37         decCurrentPos,    -- :: StringBuffer -> StringBuffer
  38
  39          -- move the start and end lexeme pointer on by x units.
  40         stepOn,           -- :: StringBuffer -> StringBuffer
  41         stepOnBy#,        -- :: StringBuffer -> Int# -> StringBuffer
  42         stepOnTo#,        -- :: StringBuffer -> Int# -> StringBuffer
  43         stepOnUntil,      -- :: (Char -> Bool) -> StringBuffer -> StringBuffer
  44         stepOnUntilChar#, -- :: StringBuffer -> Char# -> StringBuffer
  45         stepOverLexeme,   -- :: StringBuffer   -> StringBuffer
  46         scanNumLit,       -- :: Int -> StringBuffer -> (Int, StringBuffer)
  47         squeezeLexeme,    -- :: StringBuffer -> Int# -> StringBuffer
  48         mergeLexemes,     -- :: StringBuffer -> StringBuffer -> StringBuffer
  49         expandWhile,      -- :: (Char  -> Bool) -> StringBuffer -> StringBuffer
  50         expandWhile#,     -- :: (Char# -> Bool) -> StringBuffer -> StringBuffer
  51         expandUntilMatch, -- :: StrinBuffer -> String -> StringBuffer
  52          -- at or beyond end of buffer?
  53         bufferExhausted,  -- :: StringBuffer -> Bool
  54         emptyLexeme,      -- :: StringBuffer -> Bool
  55
  56          -- matching
  57         prefixMatch,       -- :: StringBuffer -> String -> Bool
  58         untilEndOfString#, -- :: StringBuffer -> Int#
  59
  60          -- conversion
  61         lexemeToString,     -- :: StringBuffer -> String
  62         lexemeToFastString, -- :: StringBuffer -> FastString
  63        ) where
  64
  65 #include "HsVersions.h"
  66
  67
  68 #if __GLASGOW_HASKELL__ < 502
  69 import Panic            ( panic )
  70 #else
  71 #if __GLASGOW_HASKELL__ < 503
  72 import Ptr              ( Ptr(..) )
  73 #else
  74 import GHC.Ptr          ( Ptr(..) )
  75 #endif
  76 #endif
  77
  78 #if __GLASGOW_HASKELL__  < 501
  79 import Char             ( chr )
  80 #elif __GLASGOW_HASKELL__ < 503
  81 import PrelIO           ( hGetcBuffered )
  82 #else
  83 import GHC.IO           ( hGetcBuffered )
  84 #endif
  85
  86 import PrimPacked
  87 import FastString
  88
  89 import GLAEXTS
  90
  91 import Foreign
  92
  93 #if __GLASGOW_HASKELL__ >= 502
  94 import CString ( newCString )
  95 #endif
  96
  97 import IO               ( openFile, isEOFError )
  98 import EXCEPTION        ( bracket )
  99
 100 #if __GLASGOW_HASKELL__ < 503
 101 import PrelIOBase
 102 import PrelHandle
 103 #else
 104 import GHC.IOBase
 105 import GHC.Handle
 106 #endif
 107
 108 import Char             ( isDigit )
 109 \end{code}
 110
 111 \begin{code}
 112 data StringBuffer
 113  = StringBuffer
 114      Addr#
 115      Int#         -- length
 116      Int#         -- lexeme start
 117      Int#         -- current pos
 118 \end{code}
 119
 120 \begin{code}
 121 instance Show StringBuffer where
 122         showsPrec _ s = showString "<stringbuffer>"
 123 \end{code}
 124
 125 \begin{code}
 126 hGetStringBuffer :: FilePath -> IO StringBuffer
 127 hGetStringBuffer fname = do
 128    (a, read) <- slurpFileExpandTabs fname
 129
 130         -- urk! slurpFile gives us a buffer that doesn't have room for
 131         -- the sentinel.  Assume it has a final newline for now, and overwrite
 132         -- that with the sentinel.  slurpFileExpandTabs (below) leaves room
 133         -- for the sentinel.
 134    let  (Ptr a#) = a;
 135         (I# read#) = read;
 136         end# = read# -# 1#
 137
 138    -- add sentinel '\NUL'
 139    writeCharOffPtr a (I# end#) '\0'
 140
 141    return (StringBuffer a# end# 0# 0#)
 142 \end{code}
 143
 144 -----------------------------------------------------------------------------
 145 -- Turn a String into a StringBuffer
 146
 147 \begin{code}
 148 stringToStringBuffer :: String -> IO StringBuffer
 149 freeStringBuffer :: StringBuffer -> IO ()
 150
 151 #if __GLASGOW_HASKELL__ >= 502
 152 stringToStringBuffer str = do
 153   let sz@(I# sz#) = length str
 154   Ptr a# <- newCString str
 155   return (StringBuffer a# sz# 0# 0#)
 156
 157 freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
 158 #else
 159 stringToStringBuffer = panic "stringToStringBuffer: not implemented"
 160 freeStringBuffer sb  = return ()
 161 #endif
 162
 163 \end{code}
 164
 165 -----------------------------------------------------------------------------
 166 This very disturbing bit of code is used for expanding the tabs in a
 167 file before we start parsing it.  Expanding the tabs early makes the
 168 lexer a lot simpler: we only have to record the beginning of the line
 169 in order to be able to calculate the column offset of the current
 170 token.
 171
 172 We guess the size of the buffer required as 20% extra for
 173 expanded tabs, and enlarge it if necessary.
 174
 175 \begin{code}
 176 #if __GLASGOW_HASKELL__ < 501
 177 getErrType :: IO Int
 178 getErrType =  _ccall_ getErrType__
 179 #endif
 180
 181 slurpFileExpandTabs :: FilePath -> IO (Ptr (),Int)
 182 slurpFileExpandTabs fname = do
 183   bracket (openFile fname ReadMode) (hClose)
 184    (\ handle ->
 185      do sz <- hFileSize handle
 186         if sz > toInteger (maxBound::Int)
 187           then ioError (userError "slurpFile: file too big")
 188           else do
 189             let sz_i = fromInteger sz
 190             if sz_i == 0
 191                         -- empty file: just allocate a buffer containing '\0'
 192                 then do chunk <- allocMem 1
 193                         writeCharOffPtr chunk 0 '\0'
 194                         return (chunk, 0)
 195                 else do let sz_i' = (sz_i * 12) `div` 10 -- add 20% for tabs
 196                         chunk <- allocMem sz_i'
 197                         trySlurp handle sz_i' chunk
 198    )
 199
 200 trySlurp :: Handle -> Int -> Ptr () -> IO (Ptr (), Int)
 201 trySlurp handle sz_i chunk =
 202 #if __GLASGOW_HASKELL__ < 501
 203   wantReadableHandle "hGetChar" handle $ \ handle_ ->
 204   let fo = haFO__ handle_ in
 205 #else
 206   wantReadableHandle "hGetChar" handle $
 207       \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBufferMode=mode } ->
 208 #endif
 209   let
 210         (I# chunk_sz) = sz_i
 211
 212         tAB_SIZE = 8#
 213
 214         slurpFile :: Int# -> Int# -> Ptr () -> Int# -> Int# -> IO (Ptr (), Int)
 215         slurpFile c off chunk chunk_sz max_off = slurp c off
 216          where
 217
 218           slurp :: Int# -> Int# -> IO (Ptr (), Int)
 219           slurp c off | off >=# max_off = do
 220                 let new_sz = chunk_sz *# 2#
 221                 chunk' <- reAllocMem chunk (I# new_sz)
 222                 slurpFile c off chunk' new_sz (new_sz -# (tAB_SIZE +# 1#))
 223           slurp c off = do
 224 #if __GLASGOW_HASKELL__ < 501
 225                 intc <- mayBlock fo (_ccall_ fileGetc fo)
 226                 if intc == ((-1)::Int)
 227                   then do errtype <- getErrType
 228                           if errtype == (19{-ERR_EOF-} :: Int)
 229                             then return (chunk, I# off)
 230                             else constructErrorAndFail "slurpFile"
 231                   else case chr intc of
 232 #else
 233                 buf <- readIORef ref
 234                 ch <- (if not (bufferEmpty buf)
 235                       then hGetcBuffered fd ref buf
 236                       else do
 237 #if __GLASGOW_HASKELL__ >= 503
 238                               new_buf <- fillReadBuffer fd True False buf
 239 #else
 240                               new_buf <- fillReadBuffer fd True buf
 241 #endif
 242                               hGetcBuffered fd ref new_buf)
 243                     `catch` \e -> if isEOFError e
 244                         then return '\xFFFF'
 245                         else ioError e
 246                 case ch of
 247                          '\xFFFF' -> return (chunk, I# off)
 248 #endif
 249                          '\t' -> tabIt c off
 250                          ch   -> do  writeCharOffPtr chunk (I# off) ch
 251                                      let c' | ch == '\n' = 0#
 252                                             | otherwise  = c +# 1#
 253                                      slurp c' (off +# 1#)
 254
 255           tabIt :: Int# -> Int# -> IO (Ptr (), Int)
 256           -- can't run out of buffer in here, because we reserved an
 257           -- extra tAB_SIZE bytes at the end earlier.
 258           tabIt c off = do
 259                 writeCharOffPtr chunk (I# off) ' '
 260                 let c' = c +# 1#
 261                     off' = off +# 1#
 262                 if c' `remInt#` tAB_SIZE ==# 0#
 263                         then slurp c' off'
 264                         else tabIt c' off'
 265   in do
 266
 267         -- allow space for a full tab at the end of the buffer
 268         -- (that's what the max_off thing is for),
 269         -- and add 1 to allow room for the final sentinel \NUL at
 270         -- the end of the file.
 271   (chunk', rc) <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# (tAB_SIZE +# 1#))
 272   return (chunk', rc+1 {- room for sentinel -})
 273
 274
 275 reAllocMem :: Ptr () -> Int -> IO (Ptr ())
 276 reAllocMem ptr sz = do
 277    chunk <- c_realloc ptr sz
 278    if chunk == nullPtr
 279       then fail "reAllocMem"
 280       else return chunk
 281
 282 allocMem :: Int -> IO (Ptr ())
 283 allocMem sz = do
 284    chunk <- c_malloc sz
 285    if chunk == nullPtr
 286 #if __GLASGOW_HASKELL__ < 501
 287       then constructErrorAndFail "allocMem"
 288 #else
 289       then ioException (IOError Nothing ResourceExhausted "malloc"
 290                                         "out of memory" Nothing)
 291 #endif
 292       else return chunk
 293
 294 #if __GLASGOW_HASKELL__ <= 408
 295 c_malloc sz = do A# a <- c_malloc' sz; return (Ptr a)
 296 foreign import ccall "malloc" unsafe
 297   c_malloc' :: Int -> IO Addr
 298
 299 c_realloc (Ptr a) sz = do A# a <- c_realloc' (A# a) sz; return (Ptr a)
 300 foreign import ccall "realloc" unsafe
 301   c_realloc' :: Addr -> Int -> IO Addr
 302 #else
 303 foreign import ccall "malloc" unsafe
 304   c_malloc :: Int -> IO (Ptr a)
 305
 306 foreign import ccall "realloc" unsafe
 307   c_realloc :: Ptr a -> Int -> IO (Ptr a)
 308 #endif
 309 \end{code}
 310
 311 Lookup
 312
 313 \begin{code}
 314 currentChar  :: StringBuffer -> Char
 315 currentChar sb = case currentChar# sb of c -> C# c
 316
 317 lookAhead :: StringBuffer -> Int  -> Char
 318 lookAhead sb (I# i#) = case lookAhead# sb i# of c -> C# c
 319
 320 indexSBuffer :: StringBuffer -> Int -> Char
 321 indexSBuffer sb (I# i#) = case indexSBuffer# sb i# of c -> C# c
 322
 323 currentChar# :: StringBuffer -> Char#
 324 indexSBuffer# :: StringBuffer -> Int# -> Char#
 325 lookAhead# :: StringBuffer -> Int# -> Char#
 326 currentChar# (StringBuffer fo# _ _ current#) = indexCharOffAddr# fo# current#
 327 indexSBuffer# (StringBuffer fo# _ _ _) i# = indexCharOffAddr# fo# i#
 328
 329  -- relative lookup, i.e, currentChar = lookAhead 0
 330 lookAhead# (StringBuffer fo# _ _ c#) i# = indexCharOffAddr# fo# (c# +# i#)
 331
 332 currentIndex# :: StringBuffer -> Int#
 333 currentIndex# (StringBuffer fo# _ _ c#) = c#
 334
 335 lexemeIndex :: StringBuffer -> Int#
 336 lexemeIndex (StringBuffer fo# _ c# _) = c#
 337 \end{code}
 338
 339  moving the start point of the current lexeme.
 340
 341 \begin{code}
 342  -- moving the end point of the current lexeme.
 343 addToCurrentPos :: StringBuffer -> Int# -> StringBuffer
 344 addToCurrentPos (StringBuffer fo l# s# c#) i# =
 345  StringBuffer fo l# s# (c# +# i#)
 346
 347 -- augmenting the current lexeme by one.
 348 incCurrentPos :: StringBuffer -> StringBuffer
 349 incCurrentPos (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# +# 1#)
 350
 351 decCurrentPos :: StringBuffer -> StringBuffer
 352 decCurrentPos (StringBuffer fo l# s# c#) = StringBuffer fo l# s# (c# -# 1#)
 353
 354 \end{code}
 355
 356 -- move the start and end point of the buffer on by
 357 -- x units.
 358
 359 \begin{code}
 360 stepOn :: StringBuffer -> StringBuffer
 361 stepOn (StringBuffer fo l# s# c#) = StringBuffer fo l# (s# +# 1#) (s# +# 1#) -- assume they're the same.
 362
 363 stepOnBy# :: StringBuffer -> Int# -> StringBuffer
 364 stepOnBy# (StringBuffer fo# l# s# c#) i# =
 365  case s# +# i# of
 366   new_s# -> StringBuffer fo# l# new_s# new_s#
 367
 368 -- jump to pos.
 369 stepOnTo# :: StringBuffer -> Int# -> StringBuffer
 370 stepOnTo# (StringBuffer fo l _ _) s# = StringBuffer fo l s# s#
 371
 372 squeezeLexeme :: StringBuffer -> Int# -> StringBuffer
 373 squeezeLexeme (StringBuffer fo l s# c#) i# = StringBuffer fo l (s# +# i#) c#
 374
 375 mergeLexemes :: StringBuffer -> StringBuffer -> StringBuffer
 376 mergeLexemes (StringBuffer fo l s# _) (StringBuffer _ _ _ c#)
 377    = StringBuffer fo l s# c#
 378
 379 stepOnUntil :: (Char -> Bool) -> StringBuffer -> StringBuffer
 380
 381 stepOnUntil pred (StringBuffer fo l# s# c#) =
 382  loop c#
 383   where
 384    loop c# =
 385     case indexCharOffAddr# fo c# of
 386      ch# | pred (C# ch#) -> StringBuffer fo l# c# c#
 387          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 388          | otherwise     -> loop (c# +# 1#)
 389
 390 stepOverLexeme :: StringBuffer -> StringBuffer
 391 stepOverLexeme (StringBuffer fo l s# c#) = StringBuffer fo l c# c#
 392
 393 expandWhile :: (Char -> Bool) -> StringBuffer -> StringBuffer
 394 expandWhile pred (StringBuffer fo l# s# c#) =
 395  loop c#
 396   where
 397    loop c# =
 398     case indexCharOffAddr# fo c# of
 399      ch# | pred (C# ch#) -> loop (c# +# 1#)
 400          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# l# l# -- EOB, return immediately.
 401          | otherwise     -> StringBuffer fo l# s# c#
 402
 403 expandWhile# :: (Char# -> Bool) -> StringBuffer -> StringBuffer
 404 expandWhile# pred (StringBuffer fo l# s# c#) =
 405  loop c#
 406   where
 407    loop c# =
 408     case indexCharOffAddr# fo c# of
 409      ch# | pred ch# -> loop (c# +# 1#)
 410          | ch# `eqChar#` '\NUL'# && c# >=# l# -> StringBuffer fo l# s# c# -- EOB, return immediately.
 411          | otherwise     -> StringBuffer fo l# s# c#
 412
 413 scanNumLit :: Integer -> StringBuffer -> (Integer,StringBuffer)
 414 scanNumLit acc (StringBuffer fo l# s# c#) =
 415  loop acc c#
 416   where
 417    loop acc c# =
 418     case indexCharOffAddr# fo c# of
 419      ch# | isDigit (C# ch#) -> loop (acc*10 + (toInteger (I# (ord# ch# -# ord# '0'#)))) (c# +# 1#)
 420          | ch# `eqChar#` '\NUL'# && c# >=# l# -> (acc, StringBuffer fo l# s# c#) -- EOB, return immediately.
 421          | otherwise        -> (acc,StringBuffer fo l# s# c#)
 422
 423
 424 expandUntilMatch :: StringBuffer -> String -> Maybe StringBuffer
 425 expandUntilMatch (StringBuffer fo l# s# c#) str =
 426   loop c# str
 427   where
 428    loop c# [] = Just (StringBuffer fo l# s# c#)
 429    loop c# ((C# x#):xs) =
 430     case indexCharOffAddr# fo c# of
 431       ch# | ch# `eqChar#` '\NUL'# && c# >=# l# -> Nothing
 432           | ch# `eqChar#` x# -> loop (c# +# 1#) xs
 433           | otherwise        -> loop (c# +# 1#) str
 434
 435 \end{code}
 436
 437 \begin{code}
 438    -- at or beyond end of buffer?
 439 bufferExhausted :: StringBuffer -> Bool
 440 bufferExhausted (StringBuffer fo l# _ c#) = c# >=# l#
 441
 442 emptyLexeme :: StringBuffer -> Bool
 443 emptyLexeme (StringBuffer fo l# s# c#) = s# ==# c#
 444
 445  -- matching
 446 prefixMatch :: StringBuffer -> String -> Maybe StringBuffer
 447 prefixMatch (StringBuffer fo l# s# c#) str =
 448   loop c# str
 449   where
 450    loop c# [] = Just (StringBuffer fo l# s# c#)
 451    loop c# ((C# x#):xs)
 452      | indexCharOffAddr# fo c# `eqChar#` x#
 453      = loop (c# +# 1#) xs
 454      | otherwise
 455      = Nothing
 456
 457 untilEndOfString# :: StringBuffer -> StringBuffer
 458 untilEndOfString# (StringBuffer fo l# s# c#) =
 459  loop c#
 460  where
 461   getch# i# = indexCharOffAddr# fo i#
 462
 463   loop c# =
 464    case getch# c# of
 465     '\"'# ->
 466       case getch# (c# -# 1#) of
 467         '\\'# ->
 468                   -- looks like an escaped something or other to me,
 469                   -- better count the number of "\\"s that are immediately
 470                   -- preceeding to decide if the " is escaped.
 471               let
 472                odd_slashes flg i# =
 473                 case getch# i# of
 474                  '\\'# -> odd_slashes (not flg) (i# -# 1#)
 475                  _     -> flg
 476               in
 477               if odd_slashes True (c# -# 2#) then
 478                   -- odd number, " is ecaped.
 479                   loop (c# +# 1#)
 480               else  -- a real end of string delimiter after all.
 481                   StringBuffer fo l# s# c#
 482         _ -> StringBuffer fo l# s# c#
 483     '\NUL'# ->
 484         if c# >=# l# then -- hit sentinel, this doesn't look too good..
 485            StringBuffer fo l# l# l#
 486         else
 487            loop (c# +# 1#)
 488     _ -> loop (c# +# 1#)
 489
 490
 491 stepOnUntilChar# :: StringBuffer -> Char# -> StringBuffer
 492 stepOnUntilChar# (StringBuffer fo l# s# c#) x# =
 493  loop c#
 494  where
 495   loop c#
 496    | c# >=# l# || indexCharOffAddr# fo c# `eqChar#` x#
 497    = StringBuffer fo l# c# c#
 498    | otherwise
 499    = loop (c# +# 1#)
 500
 501          -- conversion
 502 lexemeToString :: StringBuffer -> String
 503 lexemeToString (StringBuffer fo len# start_pos# current#) =
 504  if start_pos# ==# current# then
 505     ""
 506  else
 507     let len = I# (current# -# start_pos#) in
 508     unpackNBytesBA (copySubStr fo (I# start_pos#) len) len
 509
 510 lexemeToFastString :: StringBuffer -> FastString
 511 lexemeToFastString (StringBuffer fo l# start_pos# current#) =
 512  if start_pos# ==# current# then
 513     mkFastString ""
 514  else
 515     mkFastSubString fo (I# start_pos#) (I# (current# -# start_pos#))
 516 \end{code}