X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLexer.x;h=264b7249bb18216aac556a8255db980503c5e7c3;hb=dbaa3bb30eaf9d806357e41435dab32695c47842;hp=855c27e89aa2a17ac88130f02457f8e6e713429f;hpb=2bde7a3ed00cf16175b19d104895b5155332ed1d;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 855c27e..264b724 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -22,7 +22,7 @@ { module Lexer ( - Token(..), Token__(..), lexer, ExtFlags(..), mkPState, showPFailed, + Token(..), Token__(..), lexer, mkPState, showPFailed, P(..), ParseResult(..), setSrcLocFor, getSrcLoc, failMsgP, failLocMsgP, srcParseFail, popContext, pushCurrentContext, @@ -38,6 +38,7 @@ import FastString import FastTypes import SrcLoc import UniqFM +import CmdLineOpts import Ctype import Util ( maybePrefixMatch ) @@ -122,6 +123,7 @@ $white_no_nl+ ; { \n ; ^\# (line)? { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently () { do_bol } } @@ -185,27 +187,40 @@ $white_no_nl+ ; -- "special" symbols +<0,glaexts> { + "[:" / { ifExtension parrEnabled } { token ITopabrack } + ":]" / { ifExtension parrEnabled } { token ITcpabrack } +} + +<0,glaexts> { + "[|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } + "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } + "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } + "|]" / { ifExtension thEnabled } { token ITcloseQuote } + \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } + "$(" / { ifExtension thEnabled } { token ITparenEscape } +} + +<0,glaexts> { + "(|" / { ifExtension arrowsEnabled } { special IToparenbar } + "|)" / { ifExtension arrowsEnabled } { special ITcparenbar } +} + +<0,glaexts> { + \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } + \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid } +} + { "(#" { token IToubxparen } "#)" { token ITcubxparen } - - "[:" { token ITopabrack } - ":]" { token ITcpabrack } - "{|" { token ITocurlybar } "|}" { token ITccurlybar } - - "[|" { token ITopenExpQuote } - "[e|" { token ITopenExpQuote } - "[p|" { token ITopenPatQuote } - "[d|" { layout_token ITopenDecQuote } - "[t|" { token ITopenTypQuote } - "|]" { token ITcloseQuote } } <0,glaexts> { - "(|" / { \b _ _ _ -> arrowsEnabled b} { special IToparenbar } - "|)" / { \b _ _ _ -> arrowsEnabled b} { special ITcparenbar } \( { special IToparen } \) { special ITcparen } \[ { special ITobrack } @@ -218,13 +233,6 @@ $white_no_nl+ ; \} { close_brace } } - { - \? @varid { skip_one_varid ITdupipvarid } - \% @varid { skip_one_varid ITsplitipvarid } - \$ @varid { skip_one_varid ITidEscape } - "$(" { token ITparenEscape } -} - <0,glaexts> { @qual @varid { check_qvarid } @qual @conid { idtoken qconid } @@ -241,7 +249,7 @@ $white_no_nl+ ; { @qual @varid "#"+ { idtoken qvarid } - @qual (@conid "#"+ | "()") { idtoken qconid } + @qual @conid "#"+ { idtoken qconid } @varid "#"+ { varid } @conid "#"+ { idtoken conid } } @@ -280,9 +288,6 @@ $white_no_nl+ ; \" { lex_string_tok } } - "``" (([$graphic $whitechar] # \') | \' ([$graphic $whitechar] # \'))* - "''" { clitlit } - { -- work around bug in Alex 2.0 #if __GLASGOW_HASKELL__ < 503 @@ -333,7 +338,6 @@ data Token__ | ITstdcallconv | ITccallconv | ITdotnet - | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) | ITmdo | ITspecialise_prag -- Pragmas @@ -408,7 +412,6 @@ data Token__ | ITprimint Integer | ITprimfloat Rational | ITprimdouble Rational - | ITlitlit FastString -- MetaHaskell extension tokens | ITopenExpQuote -- [| or [e| @@ -496,9 +499,9 @@ reservedWordsFM = listToUFM $ ( "forall", ITforall, bit glaExtsBit), ( "mdo", ITmdo, bit glaExtsBit), - ( "reifyDecl", ITreifyDecl, bit glaExtsBit), - ( "reifyType", ITreifyType, bit glaExtsBit), - ( "reifyFixity",ITreifyFixity, bit glaExtsBit), + ( "reifyDecl", ITreifyDecl, bit thBit), + ( "reifyType", ITreifyType, bit thBit), + ( "reifyFixity",ITreifyFixity, bit thBit), ( "foreign", ITforeign, bit ffiBit), ( "export", ITexport, bit ffiBit), @@ -514,17 +517,7 @@ reservedWordsFM = listToUFM $ ( "with", ITwith, bit withBit), ( "rec", ITrec, bit arrowsBit), - ( "proc", ITproc, bit arrowsBit), - - -- On death row - ("_ccall_", ITccall (False, False, PlayRisky), - bit glaExtsBit), - ("_ccall_GC_", ITccall (False, False, PlaySafe False), - bit glaExtsBit), - ("_casm_", ITccall (False, True, PlayRisky), - bit glaExtsBit), - ("_casm_GC_", ITccall (False, True, PlaySafe False), - bit glaExtsBit) + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM = listToUFM $ @@ -592,6 +585,8 @@ pop_and act loc end buf len = do popLexState; act loc end buf len notFollowedBy char _ _ _ (_,buf) = atEnd buf || currentChar buf /= char +ifExtension pred bits _ _ _ = pred bits + {- nested comments require traversing by hand, they can't be parsed using regular expressions. @@ -739,10 +734,6 @@ parseInteger buf len radix to_int where go i x | i == len = x | otherwise = go (i+1) (x * radix + toInteger (to_int (lookAhead buf i))) -clitlit :: Action -clitlit loc end buf len = - return (T loc end (ITlitlit $! lexemeToFastString (stepOnBy 2 buf) (len-4))) - -- ----------------------------------------------------------------------------- -- Layout processing @@ -1198,6 +1189,8 @@ ffiBit = 1 parrBit = 2 withBit = 3 arrowsBit = 4 +thBit = 5 +ipBit = 6 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool glaExtsEnabled flags = testBit flags glaExtsBit @@ -1205,23 +1198,13 @@ ffiEnabled flags = testBit flags ffiBit withEnabled flags = testBit flags withBit parrEnabled flags = testBit flags parrBit arrowsEnabled flags = testBit flags arrowsBit - --- convenient record-based bitmap for the interface to the rest of the world --- --- NB: `glasgowExtsEF' implies `ffiEF' (see `mkPState' below) --- -data ExtFlags = ExtFlags { - glasgowExtsEF :: Bool, - ffiEF :: Bool, - withEF :: Bool, - parrEF :: Bool, - arrowsEF :: Bool - } +thEnabled flags = testBit flags thBit +ipEnabled flags = testBit flags ipBit -- create a parse state -- -mkPState :: StringBuffer -> SrcLoc -> ExtFlags -> PState -mkPState buf loc exts = +mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState +mkPState buf loc flags = PState { buffer = buf, last_loc = loc, @@ -1233,12 +1216,13 @@ mkPState buf loc exts = -- we begin in the layout state if toplev_layout is set } where - bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts - .|. ffiBit `setBitIf` (ffiEF exts - || glasgowExtsEF exts) - .|. withBit `setBitIf` withEF exts - .|. parrBit `setBitIf` parrEF exts - .|. arrowsBit `setBitIf` arrowsEF exts + bitmap = glaExtsBit `setBitIf` dopt Opt_GlasgowExts flags + .|. ffiBit `setBitIf` dopt Opt_FFI flags + .|. withBit `setBitIf` dopt Opt_With flags + .|. parrBit `setBitIf` dopt Opt_PArr flags + .|. arrowsBit `setBitIf` dopt Opt_Arrows flags + .|. thBit `setBitIf` dopt Opt_TH flags + .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b