X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLex.lhs;h=06fe82f43cf8b5f1da2279d9c7c0d4135e2af9a1;hb=10fcd78ccde892feccda3f5eacd221c1de75feea;hp=39b2358d08b0d33d212bb7b39041900aea8a21f3;hpb=69a603fbd27cb7286f154ee7d113e2dbcc0f80c0;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index 39b2358..06fe82f 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -16,54 +16,46 @@ An example that provokes the error is -------------------------------------------------------- \begin{code} -{-# OPTIONS -#include "ctypes.h" #-} module Lex ( - ifaceParseErr, + ifaceParseErr, srcParseErr, -- Monad for parser Token(..), lexer, ParseResult(..), PState(..), - checkVersion, + checkVersion, ExtFlags(..), mkPState, StringBuffer, P, thenP, thenP_, returnP, mapP, failP, failMsgP, - getSrcLocP, getSrcFile, + getSrcLocP, setSrcLocP, getSrcFile, layoutOn, layoutOff, pushContext, popContext ) where #include "HsVersions.h" -import Char ( ord, isSpace, toUpper ) +import Char ( isSpace, toUpper ) import List ( isSuffixOf ) -import IdInfo ( InlinePragInfo(..), CprInfo(..) ) -import Name ( isLowerISO, isUpperISO ) -import PrelMods ( mkTupNameStr, mkUbxTupNameStr ) -import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck ) -import Demand ( Demand(..) {- instance Read -} ) -import UniqFM ( UniqFM, listToUFM, lookupUFM) -import BasicTypes ( NewOrData(..) ) +import PrelNames ( mkTupNameStr ) +import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck ) +import ForeignCall ( Safety(..) ) +import NewDemand ( StrictSig(..), Demand(..), Demands(..), + DmdResult(..), mkTopDmdType, evalDmd, lazyDmd ) +import UniqFM ( listToUFM, lookupUFM ) +import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine, replaceSrcLine, mkSrcLoc ) -import Maybes ( MaybeErr(..) ) import ErrUtils ( Message ) import Outputable import FastString import StringBuffer import GlaExts -import ST ( runST ) - -#if __GLASGOW_HASKELL__ >= 303 -import Bits -import Word -#endif - -import Char ( chr ) -import Addr +import Ctype +import Char ( chr, ord ) import PrelRead ( readRational__ ) -- Glasgow non-std +import PrelBits ( Bits(..) ) -- non-std \end{code} %************************************************************************ @@ -120,14 +112,19 @@ data Token | ITthen | ITtype | ITwhere - | ITscc + | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) | ITforall -- GHC extension keywords | ITforeign | ITexport | ITlabel | ITdynamic + | ITsafe | ITunsafe + | ITwith + | ITstdcallconv + | ITccallconv + | ITdotnet | ITinterface -- interface keywords | IT__export @@ -137,25 +134,30 @@ data Token | ITcoerce | ITinlineMe | ITinlineCall - | ITccall (Bool,Bool,Bool) -- (is_dyn, is_casm, may_gc) + | 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 - | ITonce - | ITmany + | ITusage + | ITfuall | ITarity | ITspecialise | ITnocaf - | ITunfold InlinePragInfo - | ITstrict ([Demand], Bool) + | ITunfold + | ITstrict StrictSig | ITrules - | ITcprinfo (CprInfo) + | ITcprinfo + | ITdeprecated | IT__scc | ITsccAllCafs @@ -164,7 +166,9 @@ data Token | ITinline_prag | ITnoinline_prag | ITrules_prag + | ITdeprecated_prag | ITline_prag + | ITscc_prag | ITclose_prag | ITdotdot -- reserved symbols @@ -185,8 +189,12 @@ data Token | ITocurly -- special symbols | ITccurly + | ITocurlybar -- {|, for type applications + | ITccurlybar -- |}, for type applications | ITvccurly | ITobrack + | ITopabrack -- [:, for parallel arrays with -fparr + | ITcpabrack -- :], for parallel arrays with -fparr | ITcbrack | IToparen | ITcparen @@ -206,14 +214,17 @@ data Token | ITqvarsym (FAST_STRING,FAST_STRING) | ITqconsym (FAST_STRING,FAST_STRING) + | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x + | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x + | ITpragma StringBuffer - | ITchar Char + | ITchar Int | ITstring FAST_STRING - | ITinteger Integer + | ITinteger Integer | ITrational Rational - | ITprimchar Char + | ITprimchar Int | ITprimstring FAST_STRING | ITprimint Integer | ITprimfloat Rational @@ -222,7 +233,7 @@ data Token | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token - deriving Text -- debugging + deriving Show -- debugging \end{code} ----------------------------------------------------------------------------- @@ -239,7 +250,9 @@ pragmaKeywordsFM = listToUFM $ ( "NOTINLINE", ITnoinline_prag ), ( "LINE", ITline_prag ), ( "RULES", ITrules_prag ), - ( "RULEZ", ITrules_prag ) -- american spelling :-) + ( "RULEZ", ITrules_prag ), -- american spelling :-) + ( "SCC", ITscc_prag ), + ( "DEPRECATED", ITdeprecated_prag ) ] haskellKeywordsFM = listToUFM $ @@ -269,9 +282,28 @@ haskellKeywordsFM = listToUFM $ ( "then", ITthen ), ( "type", ITtype ), ( "where", ITwhere ), - ( "_scc_", ITscc ) + ( "_scc_", ITscc ) -- ToDo: remove ] +isSpecial :: Token -> Bool +-- If we see M.x, where x is a keyword, but +-- is special, we treat is as just plain M.x, +-- not as a keyword. +isSpecial ITas = True +isSpecial IThiding = True +isSpecial ITqualified = True +isSpecial ITforall = True +isSpecial ITexport = True +isSpecial ITlabel = True +isSpecial ITdynamic = True +isSpecial ITsafe = True +isSpecial ITunsafe = True +isSpecial ITwith = True +isSpecial ITccallconv = True +isSpecial ITstdcallconv = True +isSpecial _ = False + +-- IMPORTANT: Keep this in synch with ParseIface.y's var_fs production! (SUP) ghcExtensionKeywordsFM = listToUFM $ map (\ (x,y) -> (_PK_ x,y)) [ ( "forall", ITforall ), @@ -279,11 +311,16 @@ ghcExtensionKeywordsFM = listToUFM $ ( "export", ITexport ), ( "label", ITlabel ), ( "dynamic", ITdynamic ), + ( "safe", ITunsafe ), ( "unsafe", ITunsafe ), - ("_ccall_", ITccall (False, False, False)), - ("_ccall_GC_", ITccall (False, False, True)), - ("_casm_", ITccall (False, True, False)), - ("_casm_GC_", ITccall (False, True, True)), + ( "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), @@ -299,27 +336,32 @@ ghcExtensionKeywordsFM = listToUFM $ ("__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), - ("__o", ITonce), - ("__m", ITmany), + ("__u", ITusage), + ("__fuall", ITfuall), ("__A", ITarity), ("__P", ITspecialise), ("__C", ITnocaf), ("__R", ITrules), - ("__u", ITunfold NoInlinePragInfo), + ("__D", ITdeprecated), + ("__U", ITunfold), - ("__ccall", ITccall (False, False, False)), - ("__ccall_GC", ITccall (False, False, True)), - ("__dyn_ccall", ITccall (True, False, False)), - ("__dyn_ccall_GC", ITccall (True, False, True)), - ("__casm", ITccall (False, True, False)), - ("__dyn_casm", ITccall (True, True, False)), - ("__casm_GC", ITccall (False, True, True)), - ("__dyn_casm_GC", ITccall (True, True, True)), + ("__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) ] @@ -348,7 +390,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 @@ -358,14 +401,15 @@ 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 }) -- first, start a new lexeme and lose all the whitespace - = tab line bol atbol (stepOverLexeme buf) + = _scc_ "Lexer" + tab line bol atbol (stepOverLexeme buf) where line = srcLocLine loc @@ -387,17 +431,15 @@ lexer cont buf s@(PState{ if next `eqChar#` '-'# then trundle (n +# 1#) else if is_symbol next || n <# 2# then is_a_token - else case untilChar# (stepOnBy# buf n) '\n'# of - { buf' -> tab y bol atbol (stepOverLexeme buf') - } + else tab y bol atbol + (stepOnUntilChar# (stepOnBy# buf n) '\n'#) in trundle 1# -- comments and pragmas. We deal with LINE pragmas here, -- and throw out any unrecognised pragmas as comments. Any -- pragmas we know about are dealt with later (after any layout -- processing if necessary). - - '{'# | lookAhead# buf 1# `eqChar#` '-'# -> + '{'# | 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-> @@ -405,14 +447,34 @@ lexer cont buf s@(PState{ let lexeme = mkFastString -- ToDo: too slow (map toUpper (lexemeToString buf2)) in case lookupUFM pragmaKeywordsFM lexeme of - Just ITline_prag -> line_prag (lexer cont) buf2 s' + -- 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 - Nothing -> skip_to_end (stepOnBy# buf 2#) + Nothing -> skip_to_end (stepOnBy# buf 2#) s' }} - - else skip_to_end (stepOnBy# buf 2#) + + else skip_to_end (stepOnBy# buf 2#) s' where - skip_to_end buf = nested_comment (lexer cont) buf s' + skip_to_end = skipNestedComment (lexer cont) + + -- special GHC extension: we grok cpp-style #line pragmas + '#'# | lexemeIndex buf ==# bol -> -- the '#' must be in column 0 + 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 + next_line buf = lexer cont (stepOnUntilChar# buf '\n'#) -- tabs have been expanded beforehand c | is_space c -> tab y bol atbol (stepOn buf) @@ -423,48 +485,59 @@ 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 = +line_prag cont buf s@PState{loc=loc} = case expandWhile# is_space buf of { buf1 -> case scanNumLit 0 (stepOverLexeme buf1) of { (line,buf2) -> -- subtract one: the line number refers to the *following* line. let real_line = line - 1 in case fromInteger real_line of { i@(I# l) -> + -- ToDo, if no filename then we skip the newline.... d'oh case expandWhile# is_space buf2 of { buf3 -> case currentChar# buf3 of '\"'#{-"-} -> case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 -> - let file = lexemeToFastString buf4 in - \s@PState{loc=loc} -> skipToEnd buf4 s{loc = mkSrcLoc file i} + let + file = lexemeToFastString buf4 + new_buf = stepOn (stepOverLexeme buf4) + in + if nullFastString file + then cont new_buf s{loc = replaceSrcLine loc l} + else cont new_buf s{loc = mkSrcLoc file i} } - other -> \s@PState{loc=loc} -> skipToEnd buf3 s{loc = replaceSrcLine loc l} + _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l} }}}} - where - skipToEnd buf = nested_comment cont buf -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#} - _ -> nested_comment cont (stepOn buf) + -- 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} -- -} + + _ -> 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. @@ -472,7 +545,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 @@ -484,7 +557,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 @@ -503,78 +576,93 @@ lexBOL cont buf s@(PState{ lexToken :: (Token -> P a) -> Int# -> P a -lexToken cont glaexts buf = - --trace "lexToken" $ - _scc_ "Lexer" +lexToken cont exts buf = +-- trace "lexToken" $ case currentChar# buf of -- special symbols ---------------------------------------------------- - '('# | flag glaexts && lookAhead# buf 1# `eqChar#` '#'# + '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# -> cont IToubxparen (setCurrentPos# buf 2#) | otherwise -> cont IToparen (incLexeme buf) ')'# -> cont ITcparen (incLexeme buf) - '['# -> cont ITobrack (incLexeme 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) - '}'# -> \ s@PState{context = ctx} -> case ctx of (_:ctx') -> cont ITccurly (incLexeme 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) + ':'# -> case lookAhead# buf 1# of + ']'# | parrEnabled exts -> cont ITcpabrack + (setCurrentPos# buf 2#) + _ -> lex_sym cont (incLexeme buf) + + '#'# -> case lookAhead# buf 1# of - ')'# | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#) + ')'# | glaExtsEnabled exts + -> cont ITcubxparen (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of '}'# -> cont ITclose_prag (setCurrentPos# buf 3#) _ -> lex_sym cont (incLexeme buf) _ -> lex_sym cont (incLexeme buf) - '`'# | flag glaexts && lookAhead# buf 1# `eqChar#` '`'# + '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'# -> lex_cstring cont (setCurrentPos# buf 2#) | otherwise -> cont ITbackquote (incLexeme buf) - '{'# -> -- look for "{-##" special iface pragma - case lookAhead# buf 1# of + '{'# -> -- look for "{-##" special iface pragma -- for Emacs: -} + case lookAhead# buf 1# of + '|'# | glaExtsEnabled exts + -> cont ITocurlybar (setCurrentPos# buf 2#) '-'# -> case lookAhead# buf 2# of '#'# -> case lookAhead# buf 3# of - '#'# -> - let (lexeme, buf') - = doDiscard False (stepOnBy# (stepOverLexeme buf) 4#) in - cont (ITpragma lexeme) buf' + '#'# -> + lexPragma + cont + (\ cont lexeme buf' -> cont (ITpragma lexeme) buf') + 0# + (stepOnBy# (stepOverLexeme buf) 4#) _ -> lex_prag cont (setCurrentPos# buf 3#) - _ -> cont ITocurly (incLexeme buf) - _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) + _ -> cont ITocurly (incLexeme buf) + _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) -- strings/characters ------------------------------------------------- - '\"'#{-"-} -> lex_string cont glaexts "" (incLexeme buf) - '\''# -> lex_char (char_end cont) glaexts (incLexeme buf) + '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf) + '\''# -> lex_char (char_end cont) exts (incLexeme buf) -- strictness and cpr pragmas and __scc treated specially. - '_'# | flag glaexts -> + '_'# | glaExtsEnabled exts -> case lookAhead# buf 1# of '_'# -> case lookAhead# buf 2# of 'S'# -> lex_demand cont (stepOnUntil (not . isSpace) (stepOnBy# buf 3#)) -- past __S 'M'# -> - lex_cpr cont (stepOnUntil (not . isSpace) - (stepOnBy# buf 3#)) -- past __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 + Nothing -> lex_id cont exts buf + _ -> lex_id cont exts buf + _ -> lex_id cont exts 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# @@ -586,10 +674,14 @@ lexToken cont glaexts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) - c | is_digit c -> lex_num cont glaexts 0 buf + '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> + lex_ip ITdupipvarid cont (incLexeme buf) + '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> + lex_ip ITsplitipvarid cont (incLexeme buf) + c | is_digit c -> lex_num cont exts 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 + | is_upper c -> lex_con cont exts buf + | is_ident c -> lex_id cont exts buf | otherwise -> lexError "illegal character" buf -- Int# is unlifted, and therefore faster than Bool for flags. @@ -613,48 +705,51 @@ 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' = mkFastString (reverse s) in - case currentChar# buf' of - '#'# | flag glaexts -> cont (ITprimstring s') (incLexeme buf') + let buf' = incLexeme buf + s' = mkFastStringNarrow (map chr (reverse s)) + 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' -- ignore \& in a string, deal with string gaps '\\'# | next_ch `eqChar#` '&'# - -> lex_string cont glaexts s (setCurrentPos# buf 2#) + -> lex_string cont exts s buf' | is_space next_ch - -> lex_stringgap cont glaexts s buf' + -> lex_stringgap cont exts s (incLexeme buf) where next_ch = lookAhead# buf 1# buf' = setCurrentPos# 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 +lex_stringgap cont exts s buf = let buf' = incLexeme 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# -> Char -> P a) -> Int# -> P a -lex_char cont glaexts buf +lex_char :: (Int# -> Int -> P a) -> Int# -> P a +lex_char cont exts buf = case currentChar# buf of - '\\'# -> lex_escape (cont glaexts) (incLexeme buf) - c | is_any c -> cont glaexts (C# c) (incLexeme buf) + '\\'# -> lex_escape (cont exts) (incLexeme buf) + c | is_any c -> cont exts (I# (ord# c)) (incLexeme 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 case currentChar# buf' of - '#'# | flag glaexts + '#'# | glaExtsEnabled exts -> cont (ITprimchar c) (incLexeme buf') _ -> cont (ITchar c) buf' _ -> charError buf @@ -662,19 +757,19 @@ char_end cont glaexts c buf lex_escape cont buf = let buf' = incLexeme buf in case currentChar# buf of - 'a'# -> cont '\a' buf' - 'b'# -> cont '\b' buf' - 'f'# -> cont '\f' buf' - 'n'# -> cont '\n' buf' - 'r'# -> cont '\r' buf' - 't'# -> cont '\t' buf' - 'v'# -> cont '\v' buf' - '\\'# -> cont '\\' buf' - '"'# -> cont '\"' buf' - '\''# -> cont '\'' buf' + 'a'# -> cont (ord '\a') buf' + 'b'# -> cont (ord '\b') buf' + 'f'# -> cont (ord '\f') buf' + 'n'# -> cont (ord '\n') buf' + 'r'# -> cont (ord '\r') buf' + 't'# -> cont (ord '\t') buf' + 'v'# -> cont (ord '\v') buf' + '\\'# -> cont (ord '\\') buf' + '"'# -> cont (ord '\"') buf' + '\''# -> cont (ord '\'') buf' '^'# -> let c = currentChar# buf' in if c `geChar#` '@'# && c `leChar#` '_'# - then cont (C# (chr# (ord# c -# ord# '@'#))) (incLexeme buf') + then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf') else charError buf' 'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex @@ -684,13 +779,12 @@ lex_escape cont buf _ -> case [ (c,buf2) | (p,c) <- silly_escape_chars, Just buf2 <- [prefixMatch buf p] ] of - (c,buf2):_ -> cont c buf2 + (c,buf2):_ -> cont (ord c) buf2 [] -> charError buf' -after_charnum cont i buf - = let int = fromInteger i in - if i >= 0 && i <= 255 - then cont (chr int) buf +after_charnum cont i buf + = if i >= 0 && i <= 0x10FFFF + then cont (fromInteger i) buf else charError buf readNum cont buf is_digit base conv = read buf 0 @@ -703,8 +797,8 @@ readNum cont buf is_digit base conv = read buf 0 is_hexdigit c = is_digit c - || (c `geChar#` 'a'# && c `leChar#` 'h'#) - || (c `geChar#` 'A'# && c `leChar#` 'H'#) + || (c `geChar#` 'a'# && c `leChar#` 'f'#) + || (c `geChar#` 'A'# && c `leChar#` 'F'#) hex c | is_digit c = ord# c -# ord# '0'# | otherwise = ord# (to_lower c) -# ord# 'a'# +# 10# @@ -761,46 +855,44 @@ silly_escape_chars = [ lex_demand cont buf = case read_em [] buf of { (ls,buf') -> case currentChar# buf' of - 'B'# -> cont (ITstrict (ls, True )) (incLexeme buf') - _ -> cont (ITstrict (ls, False)) buf' + '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 - -- code snatched from Demand.lhs read_em acc buf = case currentChar# buf of - 'L'# -> read_em (WwLazy False : acc) (stepOn buf) - 'A'# -> read_em (WwLazy True : acc) (stepOn buf) - 'S'# -> read_em (WwStrict : acc) (stepOn buf) - 'P'# -> read_em (WwPrim : acc) (stepOn buf) - 'E'# -> read_em (WwEnum : acc) (stepOn buf) - ')'# -> (reverse acc, stepOn buf) - 'U'# -> do_unpack DataType True acc (stepOnBy# buf 2#) - 'u'# -> do_unpack DataType False acc (stepOnBy# buf 2#) - 'N'# -> do_unpack NewType True acc (stepOnBy# buf 2#) - 'n'# -> do_unpack NewType False acc (stepOnBy# buf 2#) - _ -> (reverse acc, buf) + 'T'# -> read_em (Top : acc) (stepOn buf) + 'L'# -> read_em (lazyDmd : acc) (stepOn buf) + 'A'# -> read_em (Abs : acc) (stepOn buf) + 'V'# -> read_em (evalDmd : acc) (stepOn buf) -- Temporary, until + -- we've recompiled prelude etc + 'C'# -> do_unary Call acc (stepOnBy# buf 2#) -- Skip 'C(' - do_unpack new_or_data wrapper_unpacks acc buf - = case read_em [] buf of - (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest + 'U'# -> do_seq1 Eval acc (stepOnBy# buf 1#) + 'D'# -> do_seq1 Defer acc (stepOnBy# buf 1#) + 'S'# -> do_seq1 (Box . Eval) acc (stepOnBy# buf 1#) -lex_cpr cont buf = - case read_em [] buf of { (cpr_inf,buf') -> - ASSERT ( null (tail cpr_inf) ) - cont (ITcprinfo $ head cpr_inf) buf' - } - where - -- code snatched from lex_demand above - read_em acc buf = - case currentChar# buf of - '-'# -> read_em (NoCPRInfo : acc) (stepOn buf) - '('# -> do_unpack acc (stepOn buf) - ')'# -> (reverse acc, stepOn buf) _ -> (reverse acc, buf) - do_unpack acc buf - = case read_em [] buf of - (stuff, rest) -> read_em ((CPRInfo stuff) : acc) rest + do_seq1 fn acc buf + = case currentChar# buf of + '('# -> do_seq2 fn acc (stepOnBy# buf 1#) + _ -> read_em (fn (Poly Abs) : acc) buf + + do_seq2 fn acc buf + = case read_em [] buf of { (dmds, buf) -> + case currentChar# buf of + ')'# -> read_em (fn (Prod dmds) : acc) + (stepOn buf) + '*'# -> ASSERT( length dmds == 1 ) + read_em (fn (Poly (head dmds)) : acc) + (stepOnBy# buf 2#) -- Skip '*)' + } + + do_unary fn acc buf + = case read_em [] buf of + ([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest) -- Skip ')' ------------------ lex_scc cont buf = @@ -812,7 +904,7 @@ lex_scc cont 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 @@ -839,18 +931,18 @@ lex_num cont glaexts acc buf = v = readRational__ (lexemeToString l) in case currentChar# l of -- glasgow exts only - '#'# | flag glaexts -> let l' = incLexeme l in + '#'# | 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 glaexts acc' buf' + _ -> after_lexnum cont exts acc' buf' -after_lexnum cont glaexts i 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) (incLexeme buf) + _ -> cont (ITinteger i) buf ----------------------------------------------------------------------------- -- C "literal literal"s (i.e. things like ``NULL'', ``stdout'' etc.) @@ -860,43 +952,24 @@ after_lexnum cont glaexts i buf lex_cstring cont buf = case expandUntilMatch (stepOverLexeme buf) "\'\'" of - buf' -> cont (ITlitlit (lexemeToFastString + Just buf' -> cont (ITlitlit (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#)))) - (mergeLexemes buf buf') - ------------------------------------------------------------------------------- --- Character Classes - -is_ident, is_symbol, is_any, is_upper, is_digit :: Char# -> Bool - -{-# INLINE is_ctype #-} -#if __GLASGOW_HASKELL__ >= 303 -is_ctype :: Word8 -> Char# -> Bool -is_ctype mask = \c -> - (indexWord8OffAddr (``char_types'' :: Addr) (ord (C# c)) .&. mask) /= 0 -#else -is_ctype :: Int -> Char# -> Bool -is_ctype (I# mask) = \c -> - let (A# ctype) = ``char_types'' :: Addr - flag_word = int2Word# (ord# (indexCharOffAddr# ctype (ord# c))) - in - (flag_word `and#` (int2Word# mask)) `neWord#` (int2Word# 0#) -#endif - -is_ident = is_ctype 1 -is_symbol = is_ctype 2 -is_any = is_ctype 4 -is_space = is_ctype 8 -is_upper = is_ctype 16 -is_digit = is_ctype 32 + (mergeLexemes buf buf') + Nothing -> lexError "unterminated ``" buf ----------------------------------------------------------------------------- -- identifiers, symbols etc. -lex_id cont glaexts buf = - case expandWhile# is_ident buf of { buf1 -> +lex_ip ip_constr cont buf = + case expandWhile# is_ident buf of + buf' -> cont (ip_constr (tailFS lexeme)) buf' + where lexeme = lexemeToFastString buf' - case (if flag glaexts +lex_id cont exts buf = + let buf1 = expandWhile# is_ident buf in + seq buf1 $ + + case (if glaExtsEnabled exts then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes else buf1) of { buf' -> @@ -907,9 +980,9 @@ lex_id cont glaexts buf = cont kwd_token buf'; Nothing -> - let var_token = cont (mk_var_token lexeme) buf' in + let var_token = cont (ITvarid lexeme) buf' in - if not (flag glaexts) + if not (glaExtsEnabled exts) then var_token else @@ -917,9 +990,10 @@ lex_id cont glaexts buf = Just kwd_token -> cont kwd_token buf'; Nothing -> var_token - }}}} + }}} lex_sym cont buf = + -- trace "lex_sym" $ case expandWhile# is_symbol buf of buf' -> case lookupUFM haskellKeySymsFM lexeme of { Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $ @@ -930,22 +1004,36 @@ lex_sym cont buf = where lexeme = lexemeToFastString buf' -lex_con cont glaexts buf = - case expandWhile# is_ident buf of { buf1 -> - case slurp_trailing_hashes buf1 glaexts of { buf' -> +-- lex_con recursively collects components of a qualified identifer. +-- The argument buf is the StringBuffer representing the lexeme +-- identified so far, where the next character is upper-case. - case currentChar# buf' of - '.'# -> munch +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 exts of { con_buf -> + + let all_buf = mergeLexemes buf con_buf + + con_lexeme = lexemeToFastString con_buf + mod_lexeme = lexemeToFastString (decLexeme buf) + all_lexeme = lexemeToFastString all_buf + + just_a_conid + | emptyLexeme buf = cont (ITconid con_lexeme) all_buf + | otherwise = cont (ITqconid (mod_lexeme,con_lexeme)) all_buf + in + + case currentChar# all_buf of + '.'# -> maybe_qualified cont exts all_lexeme + (incLexeme all_buf) just_a_conid _ -> just_a_conid - - where - just_a_conid = --trace ("con: "++unpackFS lexeme) $ - cont (ITconid lexeme) buf' - lexeme = lexemeToFastString buf' - munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid - }} - -lex_qid 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 @@ -955,7 +1043,7 @@ lex_qid cont glaexts mod buf 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 + '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) just_a_conid _ -> just_a_conid @@ -964,15 +1052,21 @@ lex_qid cont glaexts mod buf 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 - _ -> lex_id3 cont glaexts mod buf just_a_conid + '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#) + _ -> lex_id3 cont exts mod buf just_a_conid + + _ -> lex_id3 cont exts mod buf just_a_conid + + +lex_id3 cont exts mod buf just_a_conid + | is_upper (currentChar# buf) = + lex_con cont exts buf -lex_id3 cont glaexts mod buf just_a_conid | is_symbol (currentChar# buf) = let start_new_lexeme = stepOverLexeme buf in + -- trace ("lex_id31 "{-++unpackFS lexeme-}) $ case expandWhile# is_symbol start_new_lexeme of { buf' -> let lexeme = lexemeToFastString buf' @@ -987,44 +1081,44 @@ lex_id3 cont glaexts mod buf just_a_conid let start_new_lexeme = stepOverLexeme buf in + -- trace ("lex_id32 "{-++unpackFS lexeme-}) $ case expandWhile# is_ident start_new_lexeme of { buf1 -> if emptyLexeme buf1 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' + 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 { - Just kwd_token -> just_a_conid; -- avoid M.where etc. - Nothing -> is_a_qvarid - -- TODO: special ids (as, qualified, hiding) shouldn't be - -- recognised as keywords here. ie. M.as is a qualified varid. - }}} + Nothing -> is_a_qvarid ; + Just kwd_token | isSpecial kwd_token -- special ids (as, qualified, hiding) shouldn't be + -> is_a_qvarid -- recognised as keywords here. + | otherwise + -> 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 | is_upper f = ITconid pk_str - -- _[A-Z] is treated as a constructor in interface files. - | f `eqChar#` '_'# && not (_NULL_ tl) - && (case _HEAD_ tl of { C# g -> is_upper g }) = ITconid pk_str | is_ident f = ITvarid pk_str | f `eqChar#` ':'# = ITconsym pk_str | otherwise = ITvarsym pk_str where (C# f) = _HEAD_ pk_str - tl = _TAIL_ pk_str + -- tl = _TAIL_ pk_str mk_qvar_token m token = +-- trace ("mk_qvar ") $ case mk_var_token token of ITconid n -> ITqconid (m,n) ITvarid n -> ITqvarid (m,n) @@ -1043,7 +1137,7 @@ lex_tuple cont mod buf back_off = go n buf = case currentChar# buf of ','# -> go (n+1) (stepOn buf) - ')'# -> cont (ITqconid (mod, snd (mkTupNameStr n))) (stepOn buf) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Boxed n))) (stepOn buf) _ -> back_off lex_ubx_tuple cont mod buf back_off = @@ -1053,46 +1147,60 @@ lex_ubx_tuple cont mod buf back_off = case currentChar# buf of ','# -> go (n+1) (stepOn buf) '#'# -> case lookAhead# buf 1# of - ')'# -> cont (ITqconid (mod, snd (mkUbxTupNameStr n))) + ')'# -> cont (ITqconid (mod, snd (mkTupNameStr Unboxed n))) (stepOnBy# buf 2#) _ -> back_off _ -> back_off \end{code} ----------------------------------------------------------------------------- -doDiscard rips along really fast, looking for a '#-}', +'lexPragma' rips along really fast, looking for a '##-}', indicating the end of the pragma we're skipping \begin{code} -doDiscard inStr buf = +lexPragma cont contf inStr buf = case currentChar# buf of - '#'# | not inStr -> + '#'# | 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) } + contf cont (lexemeToBuffer buf) + (stepOverLexeme (setCurrentPos# buf 4#)); + _ -> lexPragma cont contf inStr (incLexeme buf) }; + _ -> lexPragma cont contf inStr (incLexeme buf) }; + _ -> lexPragma cont contf 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) - _ -> case inStr of -- forced to avoid build-up - True -> doDiscard False (incLexeme buf) - False -> doDiscard True (incLexeme buf) - _ -> doDiscard inStr (incLexeme buf) + if odd_slashes buf True (negateInt# 2#) + then -- odd number of slashes, " is escaped. + lexPragma cont contf inStr (incLexeme buf) + else -- even number of slashes, \ is escaped. + lexPragma cont contf not_inStr (incLexeme buf) + _ -> lexPragma cont contf not_inStr (incLexeme buf) + + '\''# | inStr ==# 0# -> + case lookAhead# buf 1# of { '"'# -> + case lookAhead# buf 2# of { '\''# -> + lexPragma cont contf inStr (setCurrentPos# buf 3#); + _ -> lexPragma cont contf inStr (incLexeme buf) }; + _ -> lexPragma cont contf inStr (incLexeme buf) } + + -- a sign that the input is ill-formed, since pragmas are + -- assumed to always be properly closed (in .hi files). + '\NUL'# -> trace "lexPragma: unexpected end-of-file" $ + cont (ITunknown "\NUL") buf + + _ -> lexPragma cont contf inStr (incLexeme buf) \end{code} @@ -1108,11 +1216,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 @@ -1151,12 +1259,16 @@ lexError str buf s@PState{ loc = loc } getSrcLocP :: P SrcLoc getSrcLocP buf s@(PState{ loc = loc }) = POk s loc +-- use a temporary SrcLoc for the duration of the argument +setSrcLocP :: SrcLoc -> P a -> P a +setSrcLocP new_loc p buf s = + case p buf s{ loc=new_loc } of + POk _ a -> POk s a + PFailed e -> PFailed e + getSrcFile :: P FAST_STRING getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc) -getContext :: P [LayoutContext] -getContext buf s@(PState{ context = ctx }) = POk s ctx - pushContext :: LayoutContext -> P () pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} () @@ -1228,10 +1340,10 @@ layoutOff buf s@(PState{ context = ctx }) = POk s{ context = NoLayout:ctx } () popContext :: P () -popContext = \ buf s@(PState{ context = ctx }) -> +popContext = \ buf s@(PState{ context = ctx, loc = loc }) -> case ctx of (_:tl) -> POk s{ context = tl } () - [] -> panic "Lex.popContext: empty context" + [] -> PFailed (srcParseErr buf loc) {- Note that if the name of the file we're processing ends @@ -1256,6 +1368,48 @@ checkVersion mb@Nothing buf s@(PState{loc = loc}) | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile loc)) = POk s () | otherwise = PFailed (ifaceVersionErr mb loc ([]::[Token]){-Todo-}) + +-- 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 -- FIXME: not used yet; still part of `glaExtsBit' +parrBit = 2 + +glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool +glaExtsEnabled flags = testBit (I# flags) glaExtsBit +ffiEnabled flags = testBit (I# flags) ffiBit +parrEnabled flags = testBit (I# flags) parrBit + +-- convenient record-based bitmap for the interface to the rest of the world +-- +data ExtFlags = ExtFlags { + glasgowExtsEF :: Bool, +-- ffiEF :: Bool, -- commented out to avoid warnings + parrEF :: Bool -- while not used yet + } + +-- create a parse state +-- +mkPState :: SrcLoc -> ExtFlags -> PState +mkPState loc exts = PState { + loc = loc, + extsBitmap = case bitmap of {I# bits -> bits}, + bol = 0#, + atbol = 1#, + context = [] + } + where + bitmap = glaExtsBit `setBitIf` glasgowExtsEF exts +-- .|. ffiBit `setBitIf` ffiEF exts + .|. parrBit `setBitIf` parrEF exts + -- + b `setBitIf` cond | cond = bit b + | otherwise = 0 + + ----------------------------------------------------------------- ifaceParseErr :: StringBuffer -> SrcLoc -> Message @@ -1273,4 +1427,17 @@ ifaceVersionErr hi_vers l toks Nothing -> ptext SLIT("pre ghc-3.02 version") Just v -> ptext SLIT("version") <+> integer v +----------------------------------------------------------------------------- + +srcParseErr :: StringBuffer -> SrcLoc -> Message +srcParseErr s l + = hcat [ppr l, + if null token + then ptext SLIT(": parse error (possibly incorrect indentation)") + else hcat [ptext SLIT(": parse error on input "), + char '`', text token, char '\''] + ] + where + token = lexemeToString s + \end{code}