X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=d6b2322725485da647fafa227370a808253679a2;hp=2d4a225b7b8dd826979147640821ce099348bc9d;hb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hpb=7217f562ed08b7ef8a702065d437f7b6366aea88 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 2d4a225..d6b2322 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -51,9 +51,11 @@ module Lexer ( failLocMsgP, failSpanMsgP, srcParseFail, getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, + incrBracketDepth, decrBracketDepth, getParserBrakDepth, lexTokenStream ) where @@ -324,6 +326,15 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } } <0> { + "<[" / { ifExtension hetMetEnabled `alexAndPred` notFollowedBySymbol } + { special ITopenBrak } + "]>" / { ifExtension hetMetEnabled } { special ITcloseBrak } + "~~" / { ifExtension hetMetEnabled } { special ITescape } + "%%" / { ifExtension hetMetEnabled } { special ITdoublePercent } + "~~$" / { ifExtension hetMetEnabled } { special ITescapeDollar } +} + +<0> { \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } @@ -484,6 +495,8 @@ data Token | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag | ITdotdot -- reserved symbols | ITcolon @@ -510,8 +523,8 @@ data Token | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParr - | ITcpabrack -- :], for parallel arrays with -XParr + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -569,6 +582,13 @@ data Token | ITLarrowtail -- -<< | ITRarrowtail -- >>- + -- Heterogeneous Metaprogramming extension + | ITopenBrak -- <[ + | ITcloseBrak -- ]> + | ITescape -- ~~ + | ITescapeDollar -- ~~$ + | ITdoublePercent -- %% + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -1522,7 +1542,8 @@ data PState = PState { alr_expecting_ocurly :: Maybe ALRLayout, -- Have we just had the '}' for a let block? If so, than an 'in' -- token doesn't need to close anything: - alr_justClosedExplicitLetBlock :: Bool + alr_justClosedExplicitLetBlock :: Bool, + code_type_bracket_depth :: Int } -- last_loc and last_len are used when generating error messages, -- and in pushCurrentContext only. Sigh, if only Happy passed the @@ -1589,6 +1610,13 @@ setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () setSrcLoc :: SrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () +incrBracketDepth :: P () +incrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)+1}) () +decrBracketDepth :: P () +decrBracketDepth = P $ \s -> POk (s{code_type_bracket_depth = (code_type_bracket_depth s)-1}) () +getParserBrakDepth :: P Int +getParserBrakDepth = P $ \s -> POk s (code_type_bracket_depth s) + getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc @@ -1670,6 +1698,11 @@ getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (AI l b) setInput :: AlexInput -> P () setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1684,6 +1717,15 @@ popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + setAlrLastLoc :: SrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () @@ -1707,6 +1749,13 @@ setJustClosedExplicitLetBlock b setNextToken :: Located Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + popPendingImplicitToken :: P (Maybe (Located Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> @@ -1724,7 +1773,7 @@ setAlrExpectingOCurly :: Maybe ALRLayout -> P () setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap stored in an unboxed -- integer genericsBit :: Int @@ -1776,6 +1825,8 @@ relaxedLayoutBit :: Int relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True @@ -1785,6 +1836,8 @@ parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool arrowsEnabled flags = testBit flags arrowsBit +hetMetEnabled :: Int -> Bool +hetMetEnabled flags = testBit flags hetMetBit thEnabled :: Int -> Bool thEnabled flags = testBit flags thBit ipEnabled :: Int -> Bool @@ -1846,17 +1899,19 @@ mkPState flags buf loc = alr_last_loc = noSrcSpan, alr_context = [], alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False + alr_justClosedExplicitLetBlock = False, + code_type_bracket_depth = 0 } where bitmap = genericsBit `setBitIf` xopt Opt_Generics flags .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_PArr flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. parrBit `setBitIf` xopt Opt_ParallelArrays flags + .|. arrowsBit `setBitIf` xopt Opt_Arrows flags + .|. hetMetBit `setBitIf` xopt Opt_ModalTypes flags .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags + .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags + .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags + .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags .|. haddockBit `setBitIf` dopt Opt_Haddock flags @@ -2253,13 +2308,14 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2278,6 +2334,7 @@ clean_pragma prag = canon_ws (map toLower (unprefix prag)) canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s))