X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLexer.x;h=997a7d7d88aafb7a81a32e47a3e7957a934c6d73;hb=38ef36af81c7fe05f12ead2bb3613cff208d81fe;hp=0f2e23e42f130acbb78c3df5794f0ad4d87a247b;hpb=5cbc33c27b1f762f79682117836350f6c2eae23f;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index 0f2e23e..997a7d7 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 } } @@ -157,7 +159,7 @@ $white_no_nl+ ; -- Haskell-style line pragmas, of the form -- {-# LINE "" #-} $digit+ { set_line line_prag2a } - \" $graphic* \" { set_file line_prag2b } + \" [$graphic \ ]* \" { set_file line_prag2b } "#-}" { pop } <0,glaexts> { @@ -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|" { 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 } @@ -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 @@ -329,11 +334,9 @@ data Token__ | ITsafe | ITthreadsafe | ITunsafe - | ITwith | ITstdcallconv | ITccallconv | ITdotnet - | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) | ITmdo | ITspecialise_prag -- Pragmas @@ -408,7 +411,6 @@ data Token__ | ITprimint Integer | ITprimfloat Rational | ITprimdouble Rational - | ITlitlit FastString -- MetaHaskell extension tokens | ITopenExpQuote -- [| or [e| @@ -452,7 +454,6 @@ isSpecial ITdynamic = True isSpecial ITsafe = True isSpecial ITthreadsafe = True isSpecial ITunsafe = True -isSpecial ITwith = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True isSpecial ITmdo = True @@ -496,9 +497,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), @@ -511,20 +512,8 @@ reservedWordsFM = listToUFM $ ( "ccall", ITccallconv, bit ffiBit), ( "dotnet", ITdotnet, bit ffiBit), - ( "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 $ @@ -561,8 +550,9 @@ type Action = SrcLoc -> SrcLoc -> StringBuffer -> Int -> P Token special :: Token__ -> Action special tok loc end _buf len = return (T loc end tok) -token :: Token__ -> Action +token, layout_token :: Token__ -> Action token t loc end buf len = return (T loc end t) +layout_token t loc end buf len = pushLexState layout >> return (T loc end t) idtoken :: (StringBuffer -> Int -> Token__) -> Action idtoken f loc end buf len = return (T loc end $! (f buf len)) @@ -591,6 +581,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. @@ -738,10 +730,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 @@ -770,6 +758,7 @@ maybe_layout ITmdo = pushLexState layout_do maybe_layout ITof = pushLexState layout maybe_layout ITlet = pushLexState layout maybe_layout ITwhere = pushLexState layout +maybe_layout ITrec = pushLexState layout maybe_layout _ = return () -- Pushing a new implicit layout context. If the indentation of the @@ -1194,32 +1183,22 @@ glaExtsBit, ffiBit, parrBit :: Int glaExtsBit = 0 ffiBit = 1 parrBit = 2 -withBit = 3 arrowsBit = 4 +thBit = 5 +ipBit = 6 glaExtsEnabled, ffiEnabled, parrEnabled :: Int -> Bool glaExtsEnabled flags = testBit flags glaExtsBit 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, @@ -1231,12 +1210,12 @@ 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 + .|. 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