X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLex.lhs;h=d559150c85db71f9c50b776e1ed9d62a367b8375;hb=dc659a71aa421b903eff7011c49aaf68a583f875;hp=344849d2cde6160e99662ab64ce1c8442f9e800c;hpb=b9312420f355a3b6f24f3bd732300d9e03f59268;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 344849d..d559150 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -16,7 +16,6 @@ An example that provokes the error is -------------------------------------------------------- \begin{code} -{-# OPTIONS -#include "hs_ctype.h" #-} module Lex ( srcParseErr, @@ -33,7 +32,8 @@ module Lex ( #include "HsVersions.h" -import Char ( toUpper ) +import Char ( toUpper, isDigit, chr, ord ) +import Ratio ( (%) ) import PrelNames ( mkTupNameStr ) import ForeignCall ( Safety(..) ) @@ -47,18 +47,11 @@ import Outputable import FastString import StringBuffer -import GlaExts import Ctype -import Char ( chr, ord ) -import Bits ( Bits(..) ) -- non-std - -#if __GLASGOW_HASKELL__ >= 503 -import GHC.Read ( readRational__ ) -- Glasgow non-std -#else -import PrelRead ( readRational__ ) -- Glasgow non-std -#endif -import Int ( Int32 ) +import GLAEXTS +import DATA_BITS ( Bits(..) ) +import DATA_INT ( Int32 ) \end{code} %************************************************************************ @@ -130,6 +123,7 @@ data Token | ITccallconv | ITdotnet | ITccall (Bool,Bool,Safety) -- (is_dyn, is_casm, may_gc) + | ITmdo | ITspecialise_prag -- Pragmas | ITsource_prag @@ -139,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 @@ -176,31 +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) - | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x - | ITsplitipvarid 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 @@ -212,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 ), @@ -223,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 ), @@ -273,47 +292,77 @@ 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 ), - ( "safe", ITsafe ), - ( "threadsafe", ITthreadsafe ), - ( "unsafe", ITunsafe ), - ( "with", ITwith ), - ( "stdcall", ITstdcallconv), - ( "ccall", ITccallconv), - ( "dotnet", ITdotnet), - ("_ccall_", ITccall (False, False, PlayRisky)), - ("_ccall_GC_", ITccall (False, False, PlaySafe False)), - ("_casm_", ITccall (False, True, PlayRisky)), - ("_casm_GC_", ITccall (False, True, PlaySafe False)) + 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) - ,("*", ITstar) - ,(".", 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} ----------------------------------------------------------------------------- @@ -372,7 +421,7 @@ lexer cont buf s@(PState{ -- processing if necessary). '{'# | lookAhead# buf 1# `eqChar#` '-'# -> if lookAhead# buf 2# `eqChar#` '#'# then - 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 @@ -511,58 +560,86 @@ lexToken cont exts buf = case currentChar# buf of -- special symbols ---------------------------------------------------- - '('# | glaExtsEnabled exts && 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 IToparen (incCurrentPos buf) - ')'# -> cont ITcparen (incLexeme buf) + ')'# -> cont ITcparen (incCurrentPos buf) '['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# -> - cont ITopabrack (setCurrentPos# buf 2#) - | otherwise -> - cont ITobrack (incLexeme buf) - ']'# -> cont ITcbrack (incLexeme buf) - ','# -> cont ITcomma (incLexeme buf) - ';'# -> cont ITsemi (incLexeme buf) + 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 '}'# | glaExtsEnabled exts -> cont ITccurlybar - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + (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 - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + (addToCurrentPos buf 2#) + _ -> lex_sym cont exts (incCurrentPos buf) '#'# -> case lookAhead# buf 1# of ')'# | glaExtsEnabled exts - -> cont ITcubxparen (setCurrentPos# buf 2#) + -> 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) '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'# - -> lex_cstring cont (setCurrentPos# buf 2#) + -> lex_cstring cont (addToCurrentPos buf 2#) | otherwise - -> cont ITbackquote (incLexeme buf) + -> cont ITbackquote (incCurrentPos buf) '{'# -> -- for Emacs: -} case lookAhead# buf 1# of '|'# | glaExtsEnabled exts - -> cont ITocurlybar (setCurrentPos# buf 2#) + -> cont ITocurlybar (addToCurrentPos buf 2#) '-'# -> case lookAhead# buf 2# of - '#'# -> 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 exts [] (incLexeme buf) - '\''# -> lex_char (char_end cont) exts (incLexeme 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 @@ -571,7 +648,7 @@ lexToken cont exts buf = -> 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 @@ -580,14 +657,21 @@ lexToken cont exts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) - '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> - lex_ip ITdupipvarid cont (incLexeme buf) + '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- ?x implicit parameter + specialPrefixId ITdupipvarid cont exts (incCurrentPos buf) '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> - lex_ip ITsplitipvarid cont (incLexeme buf) + 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 buf + | is_symbol c -> lex_sym cont exts buf | is_upper c -> lex_con cont exts buf - | is_ident c -> lex_id 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. @@ -614,27 +698,31 @@ lex_prag cont 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 - '#'# | glaExtsEnabled exts -> 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 exts s buf' | is_space next_ch - -> lex_stringgap cont exts 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) exts buf lex_stringgap cont exts s buf - = let buf' = incLexeme buf in + = let buf' = incCurrentPos buf in case currentChar# buf of '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf' st{loc = incSrcLine loc} @@ -647,21 +735,21 @@ 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 exts buf = case currentChar# buf of - '\\'# -> lex_escape (cont exts) (incLexeme buf) - c | is_any c -> cont exts (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 exts c buf = case currentChar# buf of - '\''# -> let buf' = incLexeme buf in + '\''# -> let buf' = incCurrentPos buf in case currentChar# buf' of '#'# | glaExtsEnabled exts - -> cont (ITprimchar c) (incLexeme buf') + -> 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' @@ -675,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 @@ -697,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 } @@ -768,40 +856,91 @@ lex_num cont exts 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 - '-'# | is_digit (lookAhead# buf3 1#) - -> expandWhile# is_digit (incLexeme buf3) - '+'# | is_digit (lookAhead# buf3 1#) - -> 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 - '#'# | glaExtsEnabled exts -> 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 exts 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 +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 - '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme 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.) @@ -811,17 +950,26 @@ after_lexnum cont exts 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 ip_constr 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 (ip_constr (tailFS lexeme)) buf' where lexeme = lexemeToFastString buf' +-} lex_id cont exts buf = let buf1 = expandWhile# is_ident buf in @@ -835,30 +983,29 @@ lex_id cont exts buf = let lexeme = lexemeToFastString buf' in case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of { - Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $ + Just kwd_token -> --trace ("hkeywd: "++unpackFS(lexeme)) $ cont kwd_token buf'; Nothing -> let var_token = cont (ITvarid lexeme) buf' in - if not (glaExtsEnabled exts) - 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' @@ -876,7 +1023,7 @@ lex_con cont exts 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 @@ -886,7 +1033,7 @@ lex_con cont exts buf = case currentChar# all_buf of '.'# -> maybe_qualified cont exts all_lexeme - (incLexeme all_buf) just_a_conid + (incCurrentPos all_buf) just_a_conid _ -> just_a_conid }} @@ -896,22 +1043,22 @@ maybe_qualified cont exts mod buf just_a_conid = 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 '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of - ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) + ','# -> 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#) + '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (addToCurrentPos buf 2#) _ -> lex_id3 cont exts mod buf just_a_conid _ -> lex_id3 cont exts mod buf just_a_conid @@ -973,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 = @@ -1074,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 () @@ -1159,43 +1306,55 @@ popContext = \ buf s@(PState{ context = ctx, loc = loc }) -> glaExtsBit, ffiBit, parrBit :: Int glaExtsBit = 0 -ffiBit = 1 -- FIXME: not used yet; still part of `glaExtsBit' +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, -- commented out to avoid warnings - parrEF :: Bool -- while not used yet + ffiEF :: Bool, + withEF :: Bool, + parrEF :: Bool, + arrowsEF :: Bool } -- 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 - bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts --- .|. ffiBit `setBitIf` ffiEF exts - .|. parrBit `setBitIf` parrEF exts - -- - setBitIf :: Int -> Bool -> Int32 - b `setBitIf` cond | cond = bit b - | otherwise = 0 +mkPState loc exts = + PState { + loc = loc, + extsBitmap = case (fromIntegral bitmap) of {I# bits -> bits}, + bol = 0#, + atbol = 1#, + context = [] + } + where + 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 -----------------------------------------------------------------------------