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