X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLex.lhs;h=d559150c85db71f9c50b776e1ed9d62a367b8375;hb=cd0f89a0bf35c36575ea89d7c7599473a3600683;hp=5e82b5318b0ae03e8a7fb0a89534cd5b67498e53;hpb=198ee273db2c8ff68874a7af139f0a2a56a812e8;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 5e82b53..d559150 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -16,14 +16,13 @@ An example that provokes the error is -------------------------------------------------------- \begin{code} - module Lex ( - ifaceParseErr, srcParseErr, + srcParseErr, -- Monad for parser Token(..), lexer, ParseResult(..), PState(..), - checkVersion, + ExtFlags(..), mkPState, StringBuffer, P, thenP, thenP_, returnP, mapP, failP, failMsgP, @@ -33,15 +32,11 @@ module Lex ( #include "HsVersions.h" -import Char ( isSpace, toUpper ) -import List ( isSuffixOf ) +import Char ( toUpper, isDigit, chr, ord ) +import Ratio ( (%) ) -import IdInfo ( InlinePragInfo(..) ) import PrelNames ( mkTupNameStr ) -import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) import ForeignCall ( Safety(..) ) -import NewDemand ( StrictSig(..), Demand(..), Keepity(..), - DmdResult(..), Deferredness(..), mkTopDmdType ) import UniqFM ( listToUFM, lookupUFM ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, @@ -52,10 +47,11 @@ import Outputable import FastString import StringBuffer -import GlaExts import Ctype -import Char ( chr, ord ) -import PrelRead ( readRational__ ) -- Glasgow non-std + +import GLAEXTS +import DATA_BITS ( Bits(..) ) +import DATA_INT ( Int32 ) \end{code} %************************************************************************ @@ -119,46 +115,15 @@ data Token | ITexport | ITlabel | ITdynamic + | ITsafe + | ITthreadsafe | ITunsafe | ITwith | ITstdcallconv | ITccallconv | ITdotnet - - | ITinterface -- interface keywords - | IT__export - | ITdepends - | IT__forall - | ITletrec - | ITcoerce - | ITinlineMe - | ITinlineCall | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) - | ITdefaultbranch - | ITbottom - | ITinteger_lit - | ITfloat_lit - | ITword_lit - | ITword64_lit - | ITint64_lit - | ITrational_lit - | ITaddr_lit - | ITlabel_lit - | ITlit_lit - | ITstring_lit - | ITtypeapp - | ITusage - | ITfuall - | ITarity - | ITspecialise - | ITnocaf - | ITunfold InlinePragInfo - | ITstrict StrictSig - | ITrules - | ITcprinfo - | ITdeprecated - | IT__scc - | ITsccAllCafs + | ITmdo | ITspecialise_prag -- Pragmas | ITsource_prag @@ -168,9 +133,11 @@ data Token | ITdeprecated_prag | ITline_prag | ITscc_prag + | ITcore_prag -- hdaume: core annotations | ITclose_prag | ITdotdot -- reserved symbols + | ITcolon | ITdcolon | ITequal | ITlam @@ -182,6 +149,7 @@ data Token | ITdarrow | ITminus | ITbang + | ITstar | ITdot | ITbiglam -- GHC-extension symbols @@ -192,6 +160,8 @@ data Token | ITccurlybar -- |}, for type applications | ITvccurly | ITobrack + | ITopabrack -- [:, for parallel arrays with -fparr + | ITcpabrack -- :], for parallel arrays with -fparr | ITcbrack | IToparen | ITcparen @@ -202,30 +172,53 @@ data Token | ITunderscore | ITbackquote - | ITvarid FAST_STRING -- identifiers - | ITconid FAST_STRING - | ITvarsym FAST_STRING - | ITconsym FAST_STRING - | ITqvarid (FAST_STRING,FAST_STRING) - | ITqconid (FAST_STRING,FAST_STRING) - | ITqvarsym (FAST_STRING,FAST_STRING) - | ITqconsym (FAST_STRING,FAST_STRING) + | ITvarid FastString -- identifiers + | ITconid FastString + | ITvarsym FastString + | ITconsym FastString + | ITqvarid (FastString,FastString) + | ITqconid (FastString,FastString) + | ITqvarsym (FastString,FastString) + | ITqconsym (FastString,FastString) - | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x + | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITsplitipvarid FastString -- GHC extension: implicit param: %x | ITpragma StringBuffer | ITchar Int - | ITstring FAST_STRING + | ITstring FastString | ITinteger Integer | ITrational Rational | ITprimchar Int - | ITprimstring FAST_STRING + | ITprimstring FastString | ITprimint Integer | ITprimfloat Rational | ITprimdouble Rational - | ITlitlit FAST_STRING + | ITlitlit FastString + + -- MetaHaskell extension tokens + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITreifyType + | ITreifyDecl + | ITreifyFixity + + -- Arrow notation extension + | ITproc + | ITrec + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token @@ -237,7 +230,7 @@ Keyword Lists \begin{code} pragmaKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [( "SPECIALISE", ITspecialise_prag ), ( "SPECIALIZE", ITspecialise_prag ), ( "SOURCE", ITsource_prag ), @@ -248,11 +241,12 @@ pragmaKeywordsFM = listToUFM $ ( "RULES", ITrules_prag ), ( "RULEZ", ITrules_prag ), -- american spelling :-) ( "SCC", ITscc_prag ), + ( "CORE", ITcore_prag ), -- hdaume: core annotation ( "DEPRECATED", ITdeprecated_prag ) ] haskellKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) + map (\ (x,y) -> (mkFastString x,y)) [( "_", ITunderscore ), ( "as", ITas ), ( "case", ITcase ), @@ -292,91 +286,83 @@ isSpecial ITforall = True isSpecial ITexport = True isSpecial ITlabel = True isSpecial ITdynamic = True +isSpecial ITsafe = True +isSpecial ITthreadsafe = True isSpecial ITunsafe = True isSpecial ITwith = True isSpecial ITccallconv = True isSpecial ITstdcallconv = True +isSpecial ITmdo = True isSpecial _ = False --- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP) +-- the bitmap provided as the third component indicates whether the +-- corresponding extension keyword is valid under the extension options +-- provided to the compiler; if the extension corresponding to *any* of the +-- bits set in the bitmap is enabled, the keyword is valid (this setup +-- facilitates using a keyword in two different extensions that can be +-- activated independently) +-- ghcExtensionKeywordsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) - [ ( "forall", ITforall ), - ( "foreign", ITforeign ), - ( "export", ITexport ), - ( "label", ITlabel ), - ( "dynamic", ITdynamic ), - ( "unsafe", ITunsafe ), - ( "with", ITwith ), - ( "stdcall", ITstdcallconv), - ( "ccall", ITccallconv), - ( "dotnet", ITdotnet), - ("_ccall_", ITccall (False, False, PlayRisky)), - ("_ccall_GC_", ITccall (False, False, PlaySafe)), - ("_casm_", ITccall (False, True, PlayRisky)), - ("_casm_GC_", ITccall (False, True, PlaySafe)), - - -- interface keywords - ("__interface", ITinterface), - ("__export", IT__export), - ("__depends", ITdepends), - ("__forall", IT__forall), - ("__letrec", ITletrec), - ("__coerce", ITcoerce), - ("__inline_me", ITinlineMe), - ("__inline_call", ITinlineCall), - ("__depends", ITdepends), - ("__DEFAULT", ITdefaultbranch), - ("__bot", ITbottom), - ("__integer", ITinteger_lit), - ("__float", ITfloat_lit), - ("__int64", ITint64_lit), - ("__word", ITword_lit), - ("__word64", ITword64_lit), - ("__rational", ITrational_lit), - ("__addr", ITaddr_lit), - ("__label", ITlabel_lit), - ("__litlit", ITlit_lit), - ("__string", ITstring_lit), - ("__a", ITtypeapp), - ("__u", ITusage), - ("__fuall", ITfuall), - ("__A", ITarity), - ("__P", ITspecialise), - ("__C", ITnocaf), - ("__R", ITrules), - ("__D", ITdeprecated), - ("__U", ITunfold NoInlinePragInfo), - - ("__ccall", ITccall (False, False, PlayRisky)), - ("__ccall_GC", ITccall (False, False, PlaySafe)), - ("__dyn_ccall", ITccall (True, False, PlayRisky)), - ("__dyn_ccall_GC", ITccall (True, False, PlaySafe)), - ("__casm", ITccall (False, True, PlayRisky)), - ("__dyn_casm", ITccall (True, True, PlayRisky)), - ("__casm_GC", ITccall (False, True, PlaySafe)), - ("__dyn_casm_GC", ITccall (True, True, PlaySafe)), - - ("/\\", ITbiglam) + map (\(x, y, z) -> (mkFastString x, (y, z))) + [ ( "forall", ITforall, bit glaExtsBit), + ( "mdo", ITmdo, bit glaExtsBit), + ( "reifyDecl", ITreifyDecl, bit glaExtsBit), + ( "reifyType", ITreifyType, bit glaExtsBit), + ( "reifyFixity",ITreifyFixity, bit glaExtsBit), + + ( "foreign", ITforeign, bit ffiBit), + ( "export", ITexport, bit ffiBit), + ( "label", ITlabel, bit ffiBit), + ( "dynamic", ITdynamic, bit ffiBit), + ( "safe", ITsafe, bit ffiBit), + ( "threadsafe", ITthreadsafe, bit ffiBit), + ( "unsafe", ITunsafe, bit ffiBit), + ( "stdcall", ITstdcallconv, bit ffiBit), + ( "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) ] - haskellKeySymsFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) - [ ("..", ITdotdot) - ,("::", ITdcolon) - ,("=", ITequal) - ,("\\", ITlam) - ,("|", ITvbar) - ,("<-", ITlarrow) - ,("->", ITrarrow) - ,("@", ITat) - ,("~", ITtilde) - ,("=>", ITdarrow) - ,("-", ITminus) - ,("!", ITbang) - ,(".", ITdot) -- sadly, for 'forall a . t' + map (\ (x,y,z) -> (mkFastString x,(y,z))) + [ ("..", ITdotdot, Nothing) + ,(":", ITcolon, Nothing) -- (:) is a reserved op, + -- meaning only list cons + ,("::", ITdcolon, Nothing) + ,("=", ITequal, Nothing) + ,("\\", ITlam, Nothing) + ,("|", ITvbar, Nothing) + ,("<-", ITlarrow, Nothing) + ,("->", ITrarrow, Nothing) + ,("@", ITat, Nothing) + ,("~", ITtilde, Nothing) + ,("=>", ITdarrow, Nothing) + ,("-", ITminus, Nothing) + ,("!", ITbang, Nothing) + + ,("*", ITstar, Just (bit glaExtsBit)) -- For data T (a::*) = MkT + ,(".", ITdot, Just (bit glaExtsBit)) -- For 'forall a . t' + + ,("-<", ITlarrowtail, Just (bit arrowsBit)) + ,(">-", ITrarrowtail, Just (bit arrowsBit)) + ,("-<<", ITLarrowtail, Just (bit arrowsBit)) + ,(">>-", ITRarrowtail, Just (bit arrowsBit)) ] + \end{code} ----------------------------------------------------------------------------- @@ -384,7 +370,8 @@ The lexical analyser Lexer state: - - (glaexts) lexing an interface file or -fglasgow-exts + - (exts) lexing a source with extensions, eg, an interface file or + with -fglasgow-exts - (bol) pointer to beginning of line (for column calculations) - (buf) pointer to beginning of token - (buf) pointer to current char @@ -394,7 +381,7 @@ Lexer state: lexer :: (Token -> P a) -> P a lexer cont buf s@(PState{ loc = loc, - glasgow_exts = glaexts, + extsBitmap = exts, bol = bol, atbol = atbol, context = ctx @@ -406,7 +393,7 @@ lexer cont buf s@(PState{ where line = srcLocLine loc - tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $ + tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $ case currentChar# buf of '\NUL'# -> @@ -434,12 +421,14 @@ lexer cont buf s@(PState{ -- processing if necessary). '{'# | lookAhead# buf 1# `eqChar#` '-'# -> if lookAhead# buf 2# `eqChar#` '#'# then - if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else - case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1-> + case expandWhile# is_space (addToCurrentPos buf 3#) of { buf1-> case expandWhile# is_ident (stepOverLexeme buf1) of { buf2-> let lexeme = mkFastString -- ToDo: too slow (map toUpper (lexemeToString buf2)) in case lookupUFM pragmaKeywordsFM lexeme of + -- ignore RULES pragmas when -fglasgow-exts is off + Just ITrules_prag | not (glaExtsEnabled exts) -> + skip_to_end (stepOnBy# buf 2#) s' Just ITline_prag -> line_prag skip_to_end buf2 s' Just other -> is_a_token @@ -448,13 +437,19 @@ lexer cont buf s@(PState{ else skip_to_end (stepOnBy# buf 2#) s' where - skip_to_end = nested_comment (lexer cont) + skip_to_end = skipNestedComment (lexer cont) -- special GHC extension: we grok cpp-style #line pragmas '#'# | lexemeIndex buf ==# bol -> -- the '#' must be in column 0 - case expandWhile# is_space (stepOn buf) of { buf1 -> - if is_digit (currentChar# buf1) - then line_prag next_line buf1 s' + let buf1 | lookAhead# buf 1# `eqChar#` 'l'# && + lookAhead# buf 2# `eqChar#` 'i'# && + lookAhead# buf 3# `eqChar#` 'n'# && + lookAhead# buf 4# `eqChar#` 'e'# = stepOnBy# buf 5# + | otherwise = stepOn buf + in + case expandWhile# is_space buf1 of { buf2 -> + if is_digit (currentChar# buf2) + then line_prag next_line buf2 s' else is_a_token } where @@ -469,7 +464,7 @@ lexer cont buf s@(PState{ atbol = atbol} is_a_token | atbol /=# 0# = lexBOL cont buf s' - | otherwise = lexToken cont glaexts buf s' + | otherwise = lexToken cont exts buf s' -- {-# LINE .. #-} pragmas. yeuch. line_prag cont buf s@PState{loc=loc} = @@ -494,26 +489,34 @@ line_prag cont buf s@PState{loc=loc} = _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l} }}}} -nested_comment :: P a -> P a -nested_comment cont buf = loop buf +skipNestedComment :: P a -> P a +skipNestedComment cont buf state = skipNestedComment' (loc state) cont buf state + +skipNestedComment' :: SrcLoc -> P a -> P a +skipNestedComment' orig_loc cont buf = loop buf where loop buf = case currentChar# buf of - '\NUL'# | bufferExhausted (stepOn buf) -> - lexError "unterminated `{-'" buf -- -} - '-'# | lookAhead# buf 1# `eqChar#` '}'# -> - cont (stepOnBy# buf 2#) + '-'# | lookAhead# buf 1# `eqChar#` '}'# -> cont (stepOnBy# buf 2#) '{'# | lookAhead# buf 1# `eqChar#` '-'# -> - nested_comment (nested_comment cont) (stepOnBy# buf 2#) + skipNestedComment + (skipNestedComment' orig_loc cont) + (stepOnBy# buf 2#) '\n'# -> \ s@PState{loc=loc} -> let buf' = stepOn buf in - nested_comment cont buf' - s{loc = incSrcLine loc, bol = currentIndex# buf', - atbol = 1#} + loop buf' s{loc = incSrcLine loc, + bol = currentIndex# buf', + atbol = 1#} + + -- pass the original SrcLoc to lexError so that the error is + -- reported at the line it was originally on, not the line at + -- the end of the file. + '\NUL'# | bufferExhausted (stepOn buf) -> + \s -> lexError "unterminated `{-'" buf s{loc=orig_loc} -- -} - _ -> nested_comment cont (stepOn buf) + _ -> loop (stepOn buf) -- When we are lexing the first token of a line, check whether we need to -- insert virtual semicolons or close braces due to layout. @@ -521,7 +524,7 @@ nested_comment cont buf = loop buf lexBOL :: (Token -> P a) -> P a lexBOL cont buf s@(PState{ loc = loc, - glasgow_exts = glaexts, + extsBitmap = exts, bol = bol, atbol = atbol, context = ctx @@ -533,7 +536,7 @@ lexBOL cont buf s@(PState{ --trace ("col = " ++ show (I# col) ++ ", layout: inserting ';'") $ cont ITsemi buf s{atbol = 0#} else - lexToken cont glaexts buf s{atbol = 0#} + lexToken cont exts buf s{atbol = 0#} where col = currentIndex# buf -# bol @@ -552,86 +555,100 @@ lexBOL cont buf s@(PState{ lexToken :: (Token -> P a) -> Int# -> P a -lexToken cont glaexts buf = - -- trace "lexToken" $ +lexToken cont exts buf = +-- trace "lexToken" $ case currentChar# buf of -- special symbols ---------------------------------------------------- - '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'# - -> cont IToubxparen (setCurrentPos# buf 2#) + '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# && + -- Unboxed tules: '(#' but not '(##' + not (lookAhead# buf 2# `eqChar#` '#'#) + -> cont IToubxparen (addToCurrentPos buf 2#) + -- Arrow notation extension: '(|' but not '(||' + | arrowsEnabled exts && lookAhead# buf 1# `eqChar#` '|'# && + not (lookAhead# buf 2# `eqChar#` '|'#) + -> cont IToparenbar (addToCurrentPos buf 2#) | otherwise - -> cont IToparen (incLexeme buf) - - ')'# -> cont ITcparen (incLexeme buf) - '['# -> cont ITobrack (incLexeme buf) - ']'# -> cont ITcbrack (incLexeme buf) - ','# -> cont ITcomma (incLexeme buf) - ';'# -> cont ITsemi (incLexeme buf) + -> cont IToparen (incCurrentPos buf) + + ')'# -> cont ITcparen (incCurrentPos buf) + '['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# -> + cont ITopabrack (addToCurrentPos buf 2#) + ------- MetaHaskell Extensions, looking for [| [e| [t| [p| and [d| + | glaExtsEnabled exts && + ((lookAhead# buf 1# ) `eqChar#` '|'# ) -> + cont ITopenExpQuote (addToCurrentPos buf 2# ) + | glaExtsEnabled exts && + (let c = (lookAhead# buf 1# ) + in eqChar# c 'e'# || eqChar# c 't'# || eqChar# c 'd'# || eqChar# c 'p'#) && + ((lookAhead# buf 2#) `eqChar#` '|'#) -> + let quote 'e'# = ITopenExpQuote + quote 'p'# = ITopenPatQuote + quote 'd'# = ITopenDecQuote + quote 't'# = ITopenTypQuote + in cont (quote (lookAhead# buf 1#)) (addToCurrentPos buf 3# ) + | otherwise -> + cont ITobrack (incCurrentPos buf) + + ']'# -> cont ITcbrack (incCurrentPos buf) + ','# -> cont ITcomma (incCurrentPos buf) + ';'# -> cont ITsemi (incCurrentPos buf) '}'# -> \ s@PState{context = ctx} -> case ctx of - (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'} + (_:ctx') -> cont ITccurly (incCurrentPos buf) s{context=ctx'} _ -> lexError "too many '}'s" buf s '|'# -> case lookAhead# buf 1# of - '}'# | flag glaexts -> cont ITccurlybar - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + '}'# | glaExtsEnabled exts -> cont ITccurlybar + (addToCurrentPos buf 2#) + -- MetaHaskell extension + ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#) + -- arrow notation extension + ')'# | arrowsEnabled exts -> cont ITcparenbar + (addToCurrentPos buf 2#) + other -> lex_sym cont exts (incCurrentPos buf) + ':'# -> case lookAhead# buf 1# of + ']'# | parrEnabled exts -> cont ITcpabrack + (addToCurrentPos buf 2#) + _ -> lex_sym cont exts (incCurrentPos buf) '#'# -> case lookAhead# buf 1# of - ')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#) + ')'# | glaExtsEnabled exts + -> cont ITcubxparen (addToCurrentPos buf 2#) '-'# -> case lookAhead# buf 2# of - '}'# -> cont ITclose_prag (setCurrentPos# buf 3#) - _ -> lex_sym cont (incLexeme buf) - _ -> lex_sym cont (incLexeme buf) + '}'# -> cont ITclose_prag (addToCurrentPos buf 3#) + _ -> lex_sym cont exts (incCurrentPos buf) + _ -> lex_sym cont exts (incCurrentPos buf) - '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'# - -> lex_cstring cont (setCurrentPos# buf 2#) + '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'# + -> lex_cstring cont (addToCurrentPos buf 2#) | otherwise - -> cont ITbackquote (incLexeme buf) + -> cont ITbackquote (incCurrentPos buf) - '{'# -> -- look for "{-##" special iface pragma + '{'# -> -- for Emacs: -} case lookAhead# buf 1# of - '|'# | flag glaexts - -> cont ITocurlybar (setCurrentPos# buf 2#) + '|'# | glaExtsEnabled exts + -> cont ITocurlybar (addToCurrentPos buf 2#) '-'# -> case lookAhead# buf 2# of - '#'# -> case lookAhead# buf 3# of - '#'# -> - let (lexeme, buf') - = doDiscard 0# (stepOnBy# (stepOverLexeme buf) 4#) in - cont (ITpragma lexeme) buf' - _ -> lex_prag cont (setCurrentPos# buf 3#) - _ -> cont ITocurly (incLexeme buf) - _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) + '#'# -> lex_prag cont (addToCurrentPos buf 3#) + _ -> cont ITocurly (incCurrentPos buf) + _ -> (layoutOff `thenP_` cont ITocurly) (incCurrentPos buf) + + + -- strings/characters ------------------------------------------------- - '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf) - '\''# -> lex_char (char_end cont) glaexts (incLexeme buf) - - -- strictness and cpr pragmas and __scc treated specially. - '_'# | flag glaexts -> - case lookAhead# buf 1# of - '_'# -> case lookAhead# buf 2# of - 'S'# -> - lex_demand cont (stepOnUntil (not . isSpace) - (stepOnBy# buf 3#)) -- past __S - 'M'# -> - cont ITcprinfo (stepOnBy# buf 3#) -- past __M - - 's'# -> - case prefixMatch (stepOnBy# buf 3#) "cc" of - Just buf' -> lex_scc cont (stepOverLexeme buf') - Nothing -> lex_id cont glaexts buf - _ -> lex_id cont glaexts buf - _ -> lex_id cont glaexts buf + '\"'#{-"-} -> lex_string cont exts [] (incCurrentPos buf) + '\''# -> lex_char (char_end cont) exts (incCurrentPos buf) -- Hexadecimal and octal constants '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2 - -> readNum (after_lexnum cont glaexts) buf' is_hexdigit 16 hex + -> readNum (after_lexnum cont exts) buf' is_hexdigit 16 hex | (ch `eqChar#` 'o'# || ch `eqChar#` 'O'#) && is_octdigit ch2 - -> readNum (after_lexnum cont glaexts) buf' is_octdigit 8 oct_or_dec + -> readNum (after_lexnum cont exts) buf' is_octdigit 8 oct_or_dec where ch = lookAhead# buf 1# ch2 = lookAhead# buf 2# - buf' = setCurrentPos# buf 2# + buf' = addToCurrentPos buf 2# '\NUL'# -> if bufferExhausted (stepOn buf) then @@ -640,12 +657,21 @@ lexToken cont glaexts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) - '?'# | flag glaexts && is_lower (lookAhead# buf 1#) -> - lex_ip cont (incLexeme buf) - c | is_digit c -> lex_num cont glaexts 0 buf - | is_symbol c -> lex_sym cont buf - | is_upper c -> lex_con cont glaexts buf - | is_ident c -> lex_id cont glaexts buf + '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- ?x implicit parameter + specialPrefixId ITdupipvarid cont exts (incCurrentPos buf) + '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> + specialPrefixId ITsplitipvarid cont exts (incCurrentPos buf) + + ---------------- MetaHaskell Extensions for quotation escape + '$'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- $x variable escape + specialPrefixId ITidEscape cont exts (addToCurrentPos buf 1#) + '$'# | glaExtsEnabled exts && -- $( f x ) expression escape + ((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#) + + c | is_digit c -> lex_num cont exts 0 buf + | is_symbol c -> lex_sym cont exts buf + | is_upper c -> lex_con cont exts buf + | is_lower c -> lex_id cont exts buf | otherwise -> lexError "illegal character" buf -- Int# is unlifted, and therefore faster than Bool for flags. @@ -669,57 +695,61 @@ lex_prag cont buf ------------------------------------------------------------------------------- -- Strings & Chars -lex_string cont glaexts s buf +lex_string cont exts s buf = case currentChar# buf of '"'#{-"-} -> - let buf' = incLexeme buf - s' = mkFastStringNarrow (map chr (reverse s)) + let buf' = incCurrentPos buf in case currentChar# buf' of - '#'# | flag glaexts -> if all (<= 0xFF) s - then cont (ITprimstring s') (incLexeme buf') - else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf' - _ -> cont (ITstring s') buf' + '#'# | glaExtsEnabled exts -> + if any (> 0xFF) s + then lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf' + else let s' = mkFastStringNarrow (map chr (reverse s)) in + -- always a narrow string/byte array + cont (ITprimstring s') (incCurrentPos buf') + + _other -> let s' = mkFastString (map chr (reverse s)) + in cont (ITstring s') buf' -- ignore \& in a string, deal with string gaps '\\'# | next_ch `eqChar#` '&'# - -> lex_string cont glaexts s buf' + -> lex_string cont exts s buf' | is_space next_ch - -> lex_stringgap cont glaexts s (incLexeme buf) + -> lex_stringgap cont exts s (incCurrentPos buf) where next_ch = lookAhead# buf 1# - buf' = setCurrentPos# buf 2# + buf' = addToCurrentPos buf 2# - _ -> lex_char (lex_next_string cont s) glaexts buf + _ -> lex_char (lex_next_string cont s) exts buf -lex_stringgap cont glaexts s buf - = let buf' = incLexeme buf in +lex_stringgap cont exts s buf + = let buf' = incCurrentPos buf in case currentChar# buf of - '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont glaexts s buf' + '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf' st{loc = incSrcLine loc} - '\\'# -> lex_string cont glaexts s buf' - c | is_space c -> lex_stringgap cont glaexts s buf' + '\\'# -> lex_string cont exts s buf' + c | is_space c -> lex_stringgap cont exts s buf' other -> charError buf' -lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf +lex_next_string cont s exts c buf = lex_string cont exts (c:s) buf lex_char :: (Int# -> Int -> P a) -> Int# -> P a -lex_char cont glaexts buf +lex_char cont exts buf = case currentChar# buf of - '\\'# -> lex_escape (cont glaexts) (incLexeme buf) - c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf) + '\\'# -> lex_escape (cont exts) (incCurrentPos buf) + c | is_any c -> cont exts (I# (ord# c)) (incCurrentPos buf) other -> charError buf -char_end cont glaexts c buf +char_end cont exts c buf = case currentChar# buf of - '\''# -> let buf' = incLexeme buf in + '\''# -> let buf' = incCurrentPos buf in case currentChar# buf' of - '#'# | flag glaexts - -> cont (ITprimchar c) (incLexeme buf') + '#'# | glaExtsEnabled exts + -> cont (ITprimchar c) (incCurrentPos buf') _ -> cont (ITchar c) buf' _ -> charError buf lex_escape cont buf - = let buf' = incLexeme buf in + = let buf' = incCurrentPos buf in case currentChar# buf of 'a'# -> cont (ord '\a') buf' 'b'# -> cont (ord '\b') buf' @@ -733,7 +763,7 @@ lex_escape cont buf '\''# -> cont (ord '\'') buf' '^'# -> let c = currentChar# buf' in if c `geChar#` '@'# && c `leChar#` '_'# - then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf') + then cont (I# (ord# c -# ord# '@'#)) (incCurrentPos buf') else charError buf' 'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex @@ -755,7 +785,7 @@ readNum cont buf is_digit base conv = read buf 0 where read buf i = case currentChar# buf of { c -> if is_digit c - then read (incLexeme buf) (i*base + (toInteger (I# (conv c)))) + then read (incCurrentPos buf) (i*base + (toInteger (I# (conv c)))) else cont i buf } @@ -814,54 +844,11 @@ silly_escape_chars = [ ("DEL", '\DEL') ] -------------------------------------------------------------------------------- - -lex_demand cont buf = - case read_em [] buf of { (ls,buf') -> - case currentChar# buf' of - 'b'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf') - 'm'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme buf') - _ -> cont (ITstrict (StrictSig (mkTopDmdType ls TopRes))) buf' - } - where - read_em acc buf = - case currentChar# buf of - 'L'# -> read_em (Lazy : acc) (stepOn buf) - 'A'# -> read_em (Abs : acc) (stepOn buf) - 'V'# -> read_em (Eval : acc) (stepOn buf) - 'X'# -> read_em (Err : acc) (stepOn buf) - 'B'# -> read_em (Bot : acc) (stepOn buf) - ')'# -> (reverse acc, stepOn buf) - 'C'# -> do_call acc (stepOnBy# buf 2#) - 'U'# -> do_unpack1 Drop Now acc (stepOnBy# buf 1#) - 'S'# -> do_unpack1 Keep Now acc (stepOnBy# buf 1#) - _ -> (reverse acc, buf) - - do_unpack1 keepity defer acc buf - = case currentChar# buf of - '*'# -> do_unpack1 keepity Defer acc (stepOnBy# buf 1#) - '('# -> do_unpack2 keepity defer acc (stepOnBy# buf 1#) - _ -> read_em (Seq keepity defer [] : acc) buf - - do_unpack2 keepity defer acc buf - = case read_em [] buf of - (stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest - - do_call acc buf - = case read_em [] buf of - ([dmd], rest) -> read_em (Call dmd : acc) rest - ------------------- -lex_scc cont buf = - case currentChar# buf of - 'C'# -> cont ITsccAllCafs (incLexeme buf) - other -> cont ITscc buf - ----------------------------------------------------------------------------- -- Numbers lex_num :: (Token -> P a) -> Int# -> Integer -> P a -lex_num cont glaexts acc buf = +lex_num cont exts acc buf = case scanNumLit acc buf of (acc',buf') -> case currentChar# buf' of @@ -869,37 +856,90 @@ lex_num cont glaexts acc buf = -- this case is not optimised at all, as the -- presence of floating point numbers in interface -- files is not that common. (ToDo) - case expandWhile# is_digit (incLexeme buf') of + case expandWhile# is_digit (incCurrentPos buf') of buf2 -> -- points to first non digit char - - let l = case currentChar# buf2 of - 'E'# -> do_exponent - 'e'# -> do_exponent - _ -> buf2 - - do_exponent - = let buf3 = incLexeme buf2 in - case currentChar# buf3 of - '-'# -> expandWhile# is_digit (incLexeme buf3) - '+'# -> expandWhile# is_digit (incLexeme buf3) - x | is_digit x -> expandWhile# is_digit buf3 - _ -> buf2 - - v = readRational__ (lexemeToString l) - - in case currentChar# l of -- glasgow exts only - '#'# | flag glaexts -> let l' = incLexeme l in - case currentChar# l' of - '#'# -> cont (ITprimdouble v) (incLexeme l') - _ -> cont (ITprimfloat v) l' - _ -> cont (ITrational v) l - - _ -> after_lexnum cont glaexts acc' buf' + case currentChar# buf2 of + 'E'# -> float_exponent cont exts buf2 + 'e'# -> float_exponent cont exts buf2 + _ -> float_done cont exts buf2 + + -- numbers like '9e4' are floats + 'E'# -> float_exponent cont exts buf' + 'e'# -> float_exponent cont exts buf' + _ -> after_lexnum cont exts acc' buf' -- it's an integer -after_lexnum cont glaexts i buf +float_exponent cont exts buf2 = + let buf3 = incCurrentPos buf2 + buf4 = case currentChar# buf3 of + '-'# | is_digit (lookAhead# buf3 1#) + -> expandWhile# is_digit (incCurrentPos buf3) + '+'# | is_digit (lookAhead# buf3 1#) + -> expandWhile# is_digit (incCurrentPos buf3) + x | is_digit x -> expandWhile# is_digit buf3 + _ -> buf2 + in + float_done cont exts buf4 + +float_done cont exts buf = + case currentChar# buf of -- glasgow exts only + '#'# | glaExtsEnabled exts -> + let buf' = incCurrentPos buf in + case currentChar# buf' of + '#'# -> cont (ITprimdouble v) (incCurrentPos buf') + _ -> cont (ITprimfloat v) buf' + _ -> cont (ITrational v) buf + where + v = readRational__ (lexemeToString buf) + +after_lexnum cont exts i buf = case currentChar# buf of - '#'# | flag glaexts -> cont (ITprimint i) (incLexeme buf) - _ -> cont (ITinteger i) buf + '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incCurrentPos buf) + _ -> cont (ITinteger i) buf + +readRational :: ReadS Rational -- NB: doesn't handle leading "-" +readRational r = do + (n,d,s) <- readFix r + (k,t) <- readExp s + return ((n%1)*10^^(k-d), t) + where + readFix r = do + (ds,s) <- lexDecDigits r + (ds',t) <- lexDotDigits s + return (read (ds++ds'), length ds', t) + + readExp (e:s) | e `elem` "eE" = readExp' s + readExp s = return (0,s) + + readExp' ('+':s) = readDec s + readExp' ('-':s) = do + (k,t) <- readDec s + return (-k,t) + readExp' s = readDec s + + readDec s = do + (ds,r) <- nonnull isDigit s + return (foldl1 (\n d -> n * 10 + d) [ ord d - ord '0' | d <- ds ], + r) + + lexDecDigits = nonnull isDigit + + lexDotDigits ('.':s) = return (span isDigit s) + lexDotDigits s = return ("",s) + + nonnull p s = do (cs@(_:_),t) <- return (span p s) + return (cs,t) + +readRational__ :: String -> Rational -- NB: *does* handle a leading "-" +readRational__ top_s + = case top_s of + '-' : xs -> - (read_me xs) + xs -> read_me xs + where + read_me s + = case (do { (x,"") <- readRational s ; return x }) of + [x] -> x + [] -> error ("readRational__: no parse:" ++ top_s) + _ -> error ("readRational__: ambiguous parse:" ++ top_s) ----------------------------------------------------------------------------- -- C "literal literal"s (i.e. things like ``NULL'', ``stdout'' etc.) @@ -910,53 +950,62 @@ after_lexnum cont glaexts i buf lex_cstring cont buf = case expandUntilMatch (stepOverLexeme buf) "\'\'" of Just buf' -> cont (ITlitlit (lexemeToFastString - (setCurrentPos# buf' (negateInt# 2#)))) + (addToCurrentPos buf' (negateInt# 2#)))) (mergeLexemes buf buf') Nothing -> lexError "unterminated ``" buf ----------------------------------------------------------------------------- -- identifiers, symbols etc. -lex_ip cont buf = +-- used for identifiers with special prefixes like +-- ?x (implicit parameters), $x (MetaHaskell escapes) and #x +-- we've already seen the prefix char, so look for an id, and wrap +-- the new "ip_constr" around the lexeme returned + +specialPrefixId ip_constr cont exts buf = lex_id newcont exts buf + where newcont (ITvarid lexeme) buf2 = cont (ip_constr (tailFS lexeme)) buf2 + newcont token buf2 = cont token buf2 +{- case expandWhile# is_ident buf of - buf' -> cont (ITipvarid lexeme) buf' - where lexeme = lexemeToFastString buf' + buf' -> cont (ip_constr (tailFS lexeme)) buf' + where lexeme = lexemeToFastString buf' +-} -lex_id cont glaexts buf = +lex_id cont exts buf = let buf1 = expandWhile# is_ident buf in seq buf1 $ - case (if flag glaexts + case (if glaExtsEnabled exts then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes else buf1) of { buf' -> + seq buf' $ let lexeme = lexemeToFastString buf' in - case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { - Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $ + case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { + Just kwd_token -> --trace ("hkeywd: "++unpackFS(lexeme)) $ cont kwd_token buf'; Nothing -> let var_token = cont (ITvarid lexeme) buf' in - if not (flag glaexts) - then var_token - else - case lookupUFM ghcExtensionKeywordsFM lexeme of { - Just kwd_token -> cont kwd_token buf'; - Nothing -> var_token + Just (kwd_token, validExts) + | validExts .&. (toInt32 exts) /= 0 -> cont kwd_token buf'; + _ -> var_token }}} -lex_sym cont buf = +lex_sym cont exts buf = -- trace "lex_sym" $ case expandWhile# is_symbol buf of buf' -> case lookupUFM haskellKeySymsFM lexeme of { - Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $ - cont kwd_token buf' ; - Nothing -> --trace ("sym: "++unpackFS lexeme) $ - cont (mk_var_token lexeme) buf' + Just (kwd_token, Nothing) + -> cont kwd_token buf' ; + Just (kwd_token, Just validExts) + | validExts .&. toInt32 exts /= 0 + -> cont kwd_token buf' ; + other -> cont (mk_var_token lexeme) buf' } where lexeme = lexemeToFastString buf' @@ -965,16 +1014,16 @@ lex_sym cont buf = -- The argument buf is the StringBuffer representing the lexeme -- identified so far, where the next character is upper-case. -lex_con cont glaexts buf = +lex_con cont exts buf = -- trace ("con: "{-++unpackFS lexeme-}) $ let empty_buf = stepOverLexeme buf in - case expandWhile# is_ident empty_buf of { buf1 -> - case slurp_trailing_hashes buf1 glaexts of { con_buf -> + case expandWhile# is_ident empty_buf of { buf1 -> + case slurp_trailing_hashes buf1 exts of { con_buf -> let all_buf = mergeLexemes buf con_buf con_lexeme = lexemeToFastString con_buf - mod_lexeme = lexemeToFastString (decLexeme buf) + mod_lexeme = lexemeToFastString (decCurrentPos buf) all_lexeme = lexemeToFastString all_buf just_a_conid @@ -983,41 +1032,41 @@ lex_con cont glaexts buf = in case currentChar# all_buf of - '.'# -> maybe_qualified cont glaexts all_lexeme - (incLexeme all_buf) just_a_conid + '.'# -> maybe_qualified cont exts all_lexeme + (incCurrentPos all_buf) just_a_conid _ -> just_a_conid }} -maybe_qualified cont glaexts mod buf just_a_conid = +maybe_qualified cont exts mod buf just_a_conid = -- trace ("qid: "{-++unpackFS lexeme-}) $ case currentChar# buf of '['# -> -- Special case for [] case lookAhead# buf 1# of - ']'# -> cont (ITqconid (mod,SLIT("[]"))) (setCurrentPos# buf 2#) + ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (addToCurrentPos buf 2#) _ -> just_a_conid '('# -> -- Special case for (,,,) -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)" case lookAhead# buf 1# of - '#'# | flag glaexts -> case lookAhead# buf 2# of - ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) + '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of + ','# -> lex_ubx_tuple cont mod (addToCurrentPos buf 3#) just_a_conid _ -> just_a_conid - ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#) - ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid + ')'# -> cont (ITqconid (mod,FSLIT("()"))) (addToCurrentPos buf 2#) + ','# -> lex_tuple cont mod (addToCurrentPos buf 2#) just_a_conid _ -> just_a_conid '-'# -> case lookAhead# buf 1# of - '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#) - _ -> lex_id3 cont glaexts mod buf just_a_conid + '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (addToCurrentPos buf 2#) + _ -> lex_id3 cont exts mod buf just_a_conid - _ -> lex_id3 cont glaexts mod buf just_a_conid + _ -> lex_id3 cont exts mod buf just_a_conid -lex_id3 cont glaexts mod buf just_a_conid +lex_id3 cont exts mod buf just_a_conid | is_upper (currentChar# buf) = - lex_con cont glaexts buf + lex_con cont exts buf | is_symbol (currentChar# buf) = let @@ -1044,14 +1093,14 @@ lex_id3 cont glaexts mod buf just_a_conid then just_a_conid else - case slurp_trailing_hashes buf1 glaexts of { buf' -> + case slurp_trailing_hashes buf1 exts of { buf' -> let lexeme = lexemeToFastString buf' new_buf = mergeLexemes buf buf' is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf in - case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { + case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { Nothing -> is_a_qvarid ; Just kwd_token | isSpecial kwd_token -- special ids (as, qualified, hiding) shouldn't be @@ -1060,9 +1109,9 @@ lex_id3 cont glaexts mod buf just_a_conid -> just_a_conid -- avoid M.where etc. }}} -slurp_trailing_hashes buf glaexts - | flag glaexts = expandWhile# (`eqChar#` '#'#) buf - | otherwise = buf +slurp_trailing_hashes buf exts + | glaExtsEnabled exts = expandWhile# (`eqChar#` '#'#) buf + | otherwise = buf mk_var_token pk_str @@ -1071,7 +1120,7 @@ mk_var_token pk_str | f `eqChar#` ':'# = ITconsym pk_str | otherwise = ITvarsym pk_str where - (C# f) = _HEAD_ pk_str + (C# f) = headFS pk_str -- tl = _TAIL_ pk_str mk_qvar_token m token = @@ -1111,51 +1160,6 @@ lex_ubx_tuple cont mod buf back_off = \end{code} ----------------------------------------------------------------------------- -doDiscard rips along really fast, looking for a '##-}', -indicating the end of the pragma we're skipping - -\begin{code} -doDiscard inStr buf = - case currentChar# buf of - '#'# | inStr ==# 0# -> - case lookAhead# buf 1# of { '#'# -> - case lookAhead# buf 2# of { '-'# -> - case lookAhead# buf 3# of { '}'# -> - (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#)); - _ -> doDiscard inStr (incLexeme buf) }; - _ -> doDiscard inStr (incLexeme buf) }; - _ -> doDiscard inStr (incLexeme buf) } - - '"'# -> - let - odd_slashes buf flg i# = - case lookAhead# buf i# of - '\\'# -> odd_slashes buf (not flg) (i# -# 1#) - _ -> flg - - not_inStr = if inStr ==# 0# then 1# else 0# - in - case lookAhead# buf (negateInt# 1#) of --backwards, actually - '\\'# -> -- escaping something.. - if odd_slashes buf True (negateInt# 2#) - then -- odd number of slashes, " is escaped. - doDiscard inStr (incLexeme buf) - else -- even number of slashes, \ is escaped. - doDiscard not_inStr (incLexeme buf) - _ -> doDiscard not_inStr (incLexeme buf) - - '\''# | inStr ==# 0# -> - case lookAhead# buf 1# of { '"'# -> - case lookAhead# buf 2# of { '\''# -> - doDiscard inStr (setCurrentPos# buf 3#); - _ -> doDiscard inStr (incLexeme buf) }; - _ -> doDiscard inStr (incLexeme buf) } - - _ -> doDiscard inStr (incLexeme buf) - -\end{code} - ------------------------------------------------------------------------------ \begin{code} data LayoutContext @@ -1167,11 +1171,11 @@ data ParseResult a | PFailed Message data PState = PState { - loc :: SrcLoc, - glasgow_exts :: Int#, - bol :: Int#, - atbol :: Int#, - context :: [LayoutContext] + loc :: SrcLoc, + extsBitmap :: Int#, -- bitmap that determines permitted extensions + bol :: Int#, + atbol :: Int#, + context :: [LayoutContext] } type P a = StringBuffer -- Input string @@ -1217,7 +1221,7 @@ setSrcLocP new_loc p buf s = POk _ a -> POk s a PFailed e -> PFailed e -getSrcFile :: P FAST_STRING +getSrcFile :: P FastString getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc) pushContext :: LayoutContext -> P () @@ -1296,45 +1300,61 @@ popContext = \ buf s@(PState{ context = ctx, loc = loc }) -> (_:tl) -> POk s{ context = tl } () [] -> PFailed (srcParseErr buf loc) -{- - Note that if the name of the file we're processing ends - with `hi-boot', we accept it on faith as having the right - version. This is done so that .hi-boot files that comes - with hsc don't have to be updated before every release, - *and* it allows us to share .hi-boot files with versions - of hsc that don't have .hi version checking (e.g., ghc-2.10's) - - If the version number is 0, the checking is also turned off. - (needed to deal with GHC.hi only!) +-- for reasons of efficiency, flags indicating language extensions (eg, +-- -fglasgow-exts or -fparr) are represented by a bitmap stored in an unboxed +-- integer + +glaExtsBit, ffiBit, parrBit :: Int +glaExtsBit = 0 +ffiBit = 1 +parrBit = 2 +withBit = 3 +arrowsBit = 4 + +glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool +glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit +ffiEnabled flags = testBit (toInt32 flags) ffiBit +withEnabled flags = testBit (toInt32 flags) withBit +parrEnabled flags = testBit (toInt32 flags) parrBit +arrowsEnabled flags = testBit (toInt32 flags) arrowsBit + +toInt32 :: Int# -> Int32 +toInt32 x# = fromIntegral (I# x#) + +-- 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 + } - Once we can assume we're compiling with a version of ghc that - supports interface file checking, we can drop the special - pleading --} -checkVersion :: Maybe Integer -> P () -checkVersion mb@(Just v) buf s@(PState{loc = loc}) - | (v==0) || (v == fromInt opt_HiVersion) || opt_NoHiCheck = POk s () - | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-}) -checkVersion mb@Nothing buf s@(PState{loc = loc}) - | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s () - | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-}) - ------------------------------------------------------------------ - -ifaceParseErr :: StringBuffer -> SrcLoc -> Message -ifaceParseErr s l - = hsep [ppr l, ptext SLIT("Interface file parse error; on input `"), - text (lexemeToString s), char '\''] - -ifaceVersionErr hi_vers l toks - = hsep [ppr l, ptext SLIT("Interface file version error;"), - ptext SLIT("Expected"), int opt_HiVersion, - ptext SLIT("found "), pp_version] +-- create a parse state +-- +mkPState :: SrcLoc -> ExtFlags -> PState +mkPState loc exts = + PState { + loc = loc, + extsBitmap = case (fromIntegral bitmap) of {I# bits -> bits}, + bol = 0#, + atbol = 1#, + context = [] + } where - pp_version = - case hi_vers of - Nothing -> ptext SLIT("pre ghc-3.02 version") - Just v -> ptext SLIT("version") <+> integer v + bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts + .|. ffiBit `setBitIf` (ffiEF exts + || glasgowExtsEF exts) + .|. withBit `setBitIf` withEF exts + .|. parrBit `setBitIf` parrEF exts + .|. arrowsBit `setBitIf` arrowsEF exts + -- + setBitIf :: Int -> Bool -> Int32 + b `setBitIf` cond | cond = bit b + | otherwise = 0 -----------------------------------------------------------------------------