X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fparser%2FLexer.x;h=eab9419369d527311ffa41a74b236329891bff96;hp=3a001bd08eeeb341c47c9f5e36c309e9488985cf;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=a3a7bba7445be24db313f89eb558b3c0fd55ed6e diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 3a001bd..eab9419 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -51,7 +51,7 @@ module Lexer ( getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, getLexState, popLexState, pushLexState, - extension, standaloneDerivingEnabled, bangPatEnabled, + extension, bangPatEnabled, datatypeContextsEnabled, addWarning, lexTokenStream ) where @@ -66,6 +66,7 @@ import UniqFM import DynFlags import Module import Ctype +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) import Util ( readRational ) import Control.Monad @@ -139,7 +140,7 @@ haskell :- -- everywhere: skip whitespace and comments $white_no_nl+ ; -$tab+ { warn Opt_WarnTabs (text "Tab character") } +$tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out -- pragmas, "{-#", so that we don't accidentally treat them as comments. @@ -285,7 +286,7 @@ $tab+ { warn Opt_WarnTabs (text "Tab character") } -- Haddock comments -<0> { +<0,option_prags> { "-- " $docsym / { ifExtension haddockEnabled } { multiline_doc_comment } "{-" \ ? $docsym / { ifExtension haddockEnabled } { nested_doc_comment } } @@ -451,6 +452,7 @@ data Token | ITdynamic | ITsafe | ITthreadsafe + | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv @@ -462,8 +464,7 @@ data Token | ITusing -- Pragmas - | ITinline_prag Bool -- True <=> INLINE, False <=> NOINLINE - | ITinline_conlike_prag Bool -- same + | ITinline_prag InlineSpec RuleMatchInfo | ITspec_prag -- SPECIALISE | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag @@ -596,6 +597,7 @@ isSpecial ITlabel = True isSpecial ITdynamic = True isSpecial ITsafe = True isSpecial ITthreadsafe = True +isSpecial ITinterruptible = True isSpecial ITunsafe = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True @@ -658,6 +660,7 @@ reservedWordsFM = listToUFM $ ( "dynamic", ITdynamic, bit ffiBit), ( "safe", ITsafe, bit ffiBit), ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove + ( "interruptible", ITinterruptible, bit ffiBit), ( "unsafe", ITunsafe, bit ffiBit), ( "stdcall", ITstdcallconv, bit ffiBit), ( "ccall", ITccallconv, bit ffiBit), @@ -701,7 +704,6 @@ reservedSymsFM = listToUFM $ explicitForallEnabled i) ,("→", ITrarrow, unicodeSyntaxEnabled) ,("←", ITlarrow, unicodeSyntaxEnabled) - ,("⋯", ITdotdot, unicodeSyntaxEnabled) ,("⤙", ITlarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) ,("⤚", ITrarrowtail, \i -> unicodeSyntaxEnabled i && arrowsEnabled i) @@ -1350,11 +1352,13 @@ readNum2 is_digit base conv i = do where read i input = do case alexGetChar' input of Just (c,input') | is_digit c -> do - read (i*base + conv c) input' + let i' = i*base + conv c + if i' > 0x10ffff + then setInput input >> lexError "numeric escape sequence out of range" + else read i' input' _other -> do - if i >= 0 && i <= 0x10FFFF - then do setInput input; return (chr i) - else lit_error input + setInput input; return (chr i) + silly_escape_chars :: [(String, Char)] silly_escape_chars = [ @@ -1736,8 +1740,8 @@ unicodeSyntaxBit :: Int unicodeSyntaxBit = 14 -- the forall symbol, arrow symbols, etc unboxedTuplesBit :: Int unboxedTuplesBit = 15 -- (# and #) -standaloneDerivingBit :: Int -standaloneDerivingBit = 16 -- standalone instance deriving declarations +datatypeContextsBit :: Int +datatypeContextsBit = 16 transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int @@ -1781,8 +1785,8 @@ unicodeSyntaxEnabled :: Int -> Bool unicodeSyntaxEnabled flags = testBit flags unicodeSyntaxBit unboxedTuplesEnabled :: Int -> Bool unboxedTuplesEnabled flags = testBit flags unboxedTuplesBit -standaloneDerivingEnabled :: Int -> Bool -standaloneDerivingEnabled flags = testBit flags standaloneDerivingBit +datatypeContextsEnabled :: Int -> Bool +datatypeContextsEnabled flags = testBit flags datatypeContextsBit qqEnabled :: Int -> Bool qqEnabled flags = testBit flags qqBit -- inRulePrag :: Int -> Bool @@ -1799,30 +1803,14 @@ alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit -- PState for parsing options pragmas -- pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState -pragState dynflags buf loc = - PState { - buffer = buf, - messages = emptyMessages, - dflags = dynflags, - last_loc = mkSrcSpan loc loc, - last_len = 0, - loc = loc, - extsBitmap = 0, - context = [], - lex_state = [bol, option_prags, 0], - alr_pending_implicit_tokens = [], - alr_next_token = Nothing, - alr_last_loc = noSrcSpan, - alr_context = [], - alr_expecting_ocurly = Nothing, - alr_justClosedExplicitLetBlock = False - } - +pragState dynflags buf loc = (mkPState dynflags buf loc) { + lex_state = [bol, option_prags, 0] + } -- create a parse state -- -mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState -mkPState buf loc flags = +mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState +mkPState flags buf loc = PState { buffer = buf, dflags = flags, @@ -1833,7 +1821,6 @@ mkPState buf loc flags = extsBitmap = fromIntegral bitmap, context = [], lex_state = [bol, 0], - -- we begin in the layout state if toplev_layout is set alr_pending_implicit_tokens = [], alr_next_token = Nothing, alr_last_loc = noSrcSpan, @@ -1842,29 +1829,29 @@ mkPState buf loc flags = alr_justClosedExplicitLetBlock = False } where - bitmap = genericsBit `setBitIf` dopt Opt_Generics flags - .|. ffiBit `setBitIf` dopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` dopt Opt_PArr flags - .|. arrowsBit `setBitIf` dopt Opt_Arrows flags - .|. thBit `setBitIf` dopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` dopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` dopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` dopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` dopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` dopt Opt_TypeFamilies flags + 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 + .|. thBit `setBitIf` xopt Opt_TemplateHaskell 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 - .|. magicHashBit `setBitIf` dopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` dopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` dopt Opt_RecursiveDo flags - .|. recBit `setBitIf` dopt Opt_DoRec flags - .|. recBit `setBitIf` dopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` dopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` dopt Opt_UnboxedTuples flags - .|. standaloneDerivingBit `setBitIf` dopt Opt_StandaloneDeriving flags - .|. transformComprehensionsBit `setBitIf` dopt Opt_TransformListComp flags + .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags + .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags + .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags + .|. recBit `setBitIf` xopt Opt_DoRec flags + .|. recBit `setBitIf` xopt Opt_Arrows flags + .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags + .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags + .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags + .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. newQualOpsBit `setBitIf` dopt Opt_NewQualifiedOperators flags - .|. alternativeLayoutRuleBit `setBitIf` dopt Opt_AlternativeLayoutRule flags + .|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators flags + .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b @@ -1981,7 +1968,9 @@ alternativeLayoutRuleToken t mExpectingOCurly <- getAlrExpectingOCurly justClosedExplicitLetBlock <- getJustClosedExplicitLetBlock setJustClosedExplicitLetBlock False - let thisLoc = getLoc t + dflags <- getDynFlags + let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags + thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc newLine = (lastLoc == noSrcSpan) || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) @@ -2040,6 +2029,30 @@ alternativeLayoutRuleToken t do setPendingImplicitTokens [t] setALRContext ls return (L thisLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITwhere, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + thisLoc + (transitionalAlternativeLayoutWarning + "`where' clause at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) + -- This next case is to handle a transitional issue: + (ITvbar, ALRLayout _ col : ls, _) + | newLine && thisCol == col && transitional -> + do addWarning Opt_WarnAlternativeLayoutRuleTransitional + thisLoc + (transitionalAlternativeLayoutWarning + "`|' at the same depth as implicit layout block") + setALRContext ls + setNextToken t + -- Note that we use lastLoc, as we may need to close + -- more layouts, or give a semicolon + return (L lastLoc ITccurly) (_, ALRLayout _ col : ls, _) | newLine && thisCol == col -> do setNextToken t @@ -2050,10 +2063,8 @@ alternativeLayoutRuleToken t -- Note that we use lastLoc, as we may need to close -- more layouts, or give a semicolon return (L lastLoc ITccurly) - (u, _, _) - | isALRopen u -> - do setALRContext (ALRNoLayout (containsCommas u) False : context) - return t + -- We need to handle close before open, as 'then' is both + -- an open and a close (u, _, _) | isALRclose u -> case context of @@ -2062,13 +2073,24 @@ alternativeLayoutRuleToken t setNextToken t return (L thisLoc ITccurly) ALRNoLayout _ isLet : ls -> - do setALRContext ls + do let ls' = if isALRopen u + then ALRNoLayout (containsCommas u) False : ls + else ls + setALRContext ls' when isLet $ setJustClosedExplicitLetBlock True return t [] -> - -- XXX This is an error in John's code, but - -- it looks reachable to me at first glance - return t + do let ls = if isALRopen u + then [ALRNoLayout (containsCommas u) False] + else ls + setALRContext ls + -- XXX This is an error in John's code, but + -- it looks reachable to me at first glance + return t + (u, _, _) + | isALRopen u -> + do setALRContext (ALRNoLayout (containsCommas u) False : context) + return t (ITin, ALRLayout ALRLayoutLet _ : ls, _) -> do setALRContext ls setPendingImplicitTokens [t] @@ -2090,9 +2112,15 @@ alternativeLayoutRuleToken t -- the other ITwhere case omitted; general case below covers it (_, _, _) -> return t +transitionalAlternativeLayoutWarning :: String -> SDoc +transitionalAlternativeLayoutWarning msg + = text "transitional layout will not be accepted in the future:" + $$ text msg + isALRopen :: Token -> Bool isALRopen ITcase = True isALRopen ITif = True +isALRopen ITthen = True isALRopen IToparen = True isALRopen ITobrack = True isALRopen ITocurly = True @@ -2104,6 +2132,7 @@ isALRopen _ = False isALRclose :: Token -> Bool isALRclose ITof = True isALRclose ITthen = True +isALRclose ITelse = True isALRclose ITcparen = True isALRclose ITcbrack = True isALRclose ITccurly = True @@ -2166,7 +2195,8 @@ reportLexError loc1 loc2 buf str lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState - where initState = mkPState buf loc (dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream) + where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream + initState = mkPState dflags' buf loc go = do ltok <- lexer return case ltok of @@ -2189,8 +2219,11 @@ ignoredPrags = Map.fromList (map ignored pragmas) pragmas = options_pragmas ++ ["cfiles", "contract"] oneWordPrags = Map.fromList([("rules", rulePrag), - ("inline", token (ITinline_prag True)), - ("notinline", token (ITinline_prag False)), + ("inline", token (ITinline_prag Inline FunLike)), + ("inlinable", token (ITinline_prag Inlinable FunLike)), + ("inlineable", token (ITinline_prag Inlinable FunLike)), + -- Spelling variant + ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), ("warning", token ITwarning_prag), @@ -2201,8 +2234,8 @@ oneWordPrags = Map.fromList([("rules", rulePrag), ("unpack", token ITunpack_prag), ("ann", token ITann_prag)]) -twoWordPrags = Map.fromList([("inline conlike", token (ITinline_conlike_prag True)), - ("notinline conlike", token (ITinline_conlike_prag False)), +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))])