X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=d6b2322725485da647fafa227370a808253679a2;hp=111821594d57965ed1528c9a1d0044a36f3f9274;hb=9176377bf7d989919fe7d27cad1f56bd9c4e7b6b;hpb=82a769cba9297d362b5e5ce2d1983e37b6057873 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 1118215..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 } } @@ -369,10 +380,8 @@ $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- ToDo: - move `var` and (sym) into lexical syntax? -- - remove backquote from $special? <0> { - @qual @varsym / { ifExtension oldQualOps } { idtoken qvarsym } - @qual @consym / { ifExtension oldQualOps } { idtoken qconsym } - @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym } - @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym } + @qual @varsym { idtoken qvarsym } + @qual @consym { idtoken qconsym } @varsym { varsym } @consym { consym } } @@ -486,6 +495,8 @@ data Token | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag | ITdotdot -- reserved symbols | ITcolon @@ -512,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 @@ -571,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 @@ -1524,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 @@ -1591,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 @@ -1672,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} () @@ -1686,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}) () @@ -1709,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 } -> @@ -1726,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 @@ -1770,8 +1817,6 @@ inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included -newQualOpsBit :: Int -newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec alternativeLayoutRuleBit :: Int @@ -1780,6 +1825,8 @@ relaxedLayoutBit :: Int relaxedLayoutBit = 24 nondecreasingIndentationBit :: Int nondecreasingIndentationBit = 25 +hetMetBit :: Int +hetMetBit = 31 always :: Int -> Bool always _ = True @@ -1789,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 @@ -1817,10 +1866,6 @@ qqEnabled flags = testBit flags qqBit -- inRulePrag flags = testBit flags inRulePragBit rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -newQualOps :: Int -> Bool -newQualOps flags = testBit flags newQualOpsBit -oldQualOps :: Int -> Bool -oldQualOps flags = not (newQualOps flags) alternativeLayoutRule :: Int -> Bool alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit relaxedLayout :: Int -> Bool @@ -1854,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 @@ -1878,7 +1925,6 @@ mkPState flags buf loc = .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators flags .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags .|. relaxedLayoutBit `setBitIf` xopt Opt_RelaxedLayout flags .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags @@ -2262,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 @@ -2287,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))