projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Improvements to record puns, wildcards
[ghc-hetmet.git]
/
compiler
/
parser
/
Lexer.x
diff --git
a/compiler/parser/Lexer.x
b/compiler/parser/Lexer.x
index
fb7a535
..
30fc4b6
100644
(file)
--- a/
compiler/parser/Lexer.x
+++ b/
compiler/parser/Lexer.x
@@
-46,6
+46,7
@@
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
module Lexer (
Token(..), lexer, pragState, mkPState, PState(..),
P(..), ParseResult(..), getSrcLoc,
+ getPState,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
failLocMsgP, failSpanMsgP, srcParseFail,
getMessages,
popContext, pushCurrentContext, setLastToken, setSrcLoc,
@@
-57,7
+58,6
@@
module Lexer (
import Bag
import ErrUtils
import Bag
import ErrUtils
-import Maybe
import Outputable
import StringBuffer
import FastString
import Outputable
import StringBuffer
import FastString
@@
-65,12
+65,13
@@
import SrcLoc
import UniqFM
import DynFlags
import Ctype
import UniqFM
import DynFlags
import Ctype
-import Util ( maybePrefixMatch, readRational )
+import Util ( readRational )
import Control.Monad
import Data.Bits
import Data.Char
import Data.List
import Control.Monad
import Data.Bits
import Data.Char
import Data.List
+import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ratio
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Ratio
@@
-224,8
+225,8
@@
$tab+ { warn Opt_WarnTabs (text "Tab character") }
<0,option_prags> \n { begin bol }
<0,option_prags> \n { begin bol }
-"{-#" $whitechar* (line|LINE) / { notFollowedByPragmaChar }
- { begin line_prag2 }
+"{-#" $whitechar* $pragmachar+ / { known_pragma linePrags }
+ { dispatch_pragmas linePrags }
-- single-line line pragmas, of the form
-- # <line> "<file>" <extra-stuff> \n
-- single-line line pragmas, of the form
-- # <line> "<file>" <extra-stuff> \n
@@
-453,7
+454,6
@@
data Token
| ITstdcallconv
| ITccallconv
| ITprimcallconv
| ITstdcallconv
| ITccallconv
| ITprimcallconv
- | ITdotnet
| ITmdo
| ITfamily
| ITgroup
| ITmdo
| ITfamily
| ITgroup
@@
-663,7
+663,6
@@
reservedWordsFM = listToUFM $
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "prim", ITprimcallconv, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit),
( "prim", ITprimcallconv, bit ffiBit),
- ( "dotnet", ITdotnet, bit ffiBit),
( "rec", ITrec, bit arrowsBit),
( "proc", ITproc, bit arrowsBit)
( "rec", ITrec, bit arrowsBit),
( "proc", ITproc, bit arrowsBit)
@@
-758,10
+757,6
@@
notFollowedBySymbol :: AlexAccPred Int
notFollowedBySymbol _ _ _ (AI _ _ buf)
= nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
notFollowedBySymbol _ _ _ (AI _ _ buf)
= nextCharIs buf (`notElem` "!#$%&*+./<=>?@\\^|-~")
-notFollowedByPragmaChar :: AlexAccPred Int
-notFollowedByPragmaChar _ _ _ (AI _ _ buf)
- = nextCharIs buf (\c -> not (isAlphaNum c || c == '_'))
-
-- We must reject doc comments as being ordinary comments everywhere.
-- In some cases the doc comment will be selected as the lexeme due to
-- maximal munch, but not always, because the nested comment rule is
-- We must reject doc comments as being ordinary comments everywhere.
-- In some cases the doc comment will be selected as the lexeme due to
-- maximal munch, but not always, because the nested comment rule is
@@
-1223,7
+1218,7
@@
lex_char_tok :: Action
-- Here we are basically parsing character literals, such as 'x' or '\n'
-- but, when Template Haskell is on, we additionally spot
-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
-- Here we are basically parsing character literals, such as 'x' or '\n'
-- but, when Template Haskell is on, we additionally spot
-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively,
--- but WIHTOUT CONSUMING the x or T part (the parser does that).
+-- but WITHOUT CONSUMING the x or T part (the parser does that).
-- So we have to do two characters of lookahead: when we see 'x we need to
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
-- So we have to do two characters of lookahead: when we see 'x we need to
-- see if there's a trailing quote
lex_char_tok span _buf _len = do -- We've seen '
@@
-1323,7
+1318,7
@@
lex_escape = do
Just (c3,i3) ->
let str = [c1,c2,c3] in
case [ (c,rest) | (p,c) <- silly_escape_chars,
Just (c3,i3) ->
let str = [c1,c2,c3] in
case [ (c,rest) | (p,c) <- silly_escape_chars,
- Just rest <- [maybePrefixMatch p str] ] of
+ Just rest <- [stripPrefix p str] ] of
(escape_char,[]):_ -> do
setInput i3
return escape_char
(escape_char,[]):_ -> do
setInput i3
return escape_char
@@
-1519,6
+1514,9
@@
failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str)
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
failSpanMsgP :: SrcSpan -> SDoc -> P a
failSpanMsgP span msg = P $ \_ -> PFailed span msg
+getPState :: P PState
+getPState = P $ \s -> POk s s
+
extension :: (Int -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! extsBitmap s)
extension :: (Int -> Bool) -> P Bool
extension p = P $ \s -> POk s (p $! extsBitmap s)
@@
-1907,6
+1905,8
@@
lexTokenStream buf loc dflags = unP go initState
L _ ITeof -> return []
_ -> liftM (ltok:) go
L _ ITeof -> return []
_ -> liftM (ltok:) go
+linePrags = Map.singleton "line" (begin line_prag2)
+
fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
("options_ghc", lex_string_prag IToptions_prag),
("options_haddock", lex_string_prag ITdocOptions),
fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),
("options_ghc", lex_string_prag IToptions_prag),
("options_haddock", lex_string_prag ITdocOptions),
@@
-1945,14
+1945,14
@@
dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToStr
Nothing -> lexError "unknown pragma"
known_pragma :: Map String Action -> AlexAccPred Int
Nothing -> lexError "unknown pragma"
known_pragma :: Map String Action -> AlexAccPred Int
-known_pragma prags q r len (AI s t buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
- && (notFollowedByPragmaChar q r len (AI s t buf))
+known_pragma prags _ _ len (AI _ _ buf) = (isJust $ Map.lookup (clean_pragma (lexemeToString (offsetBytes (- len) buf) len)) prags)
+ && (nextCharIs buf (\c -> not (isAlphaNum c || c == '_')))
clean_pragma :: String -> String
clean_pragma prag = canon_ws (map toLower (unprefix prag))
clean_pragma :: String -> String
clean_pragma prag = canon_ws (map toLower (unprefix prag))
- where unprefix prag' = (case stripPrefix "{-#" prag' of
- Just rest -> rest
- Nothing -> prag')
+ where unprefix prag' = case stripPrefix "{-#" prag' of
+ Just rest -> rest
+ Nothing -> prag'
canonical prag' = case prag' of
"noinline" -> "notinline"
"specialise" -> "specialize"
canonical prag' = case prag' of
"noinline" -> "notinline"
"specialise" -> "specialize"