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