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