--------------------------------------------------------
\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,
#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,
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}
%************************************************************************
| 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
| ITdeprecated_prag
| ITline_prag
| ITscc_prag
+ | ITcore_prag -- hdaume: core annotations
| ITclose_prag
| ITdotdot -- reserved symbols
+ | ITcolon
| ITdcolon
| ITequal
| ITlam
| ITdarrow
| ITminus
| ITbang
+ | ITstar
| ITdot
| ITbiglam -- GHC-extension symbols
| ITccurlybar -- |}, for type applications
| ITvccurly
| ITobrack
+ | ITopabrack -- [:, for parallel arrays with -fparr
+ | ITcpabrack -- :], for parallel arrays with -fparr
| ITcbrack
| IToparen
| ITcparen
| 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
\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 ),
( "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 ),
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}
-----------------------------------------------------------------------------
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
lexer :: (Token -> P a) -> P a
lexer cont buf s@(PState{
loc = loc,
- glasgow_exts = glaexts,
+ extsBitmap = exts,
bol = bol,
atbol = atbol,
context = ctx
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'# ->
-- 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
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
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} =
_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.
lexBOL :: (Token -> P a) -> P a
lexBOL cont buf s@(PState{
loc = loc,
- glasgow_exts = glaexts,
+ extsBitmap = exts,
bol = bol,
atbol = atbol,
context = ctx
--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
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
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.
-------------------------------------------------------------------------------
-- 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'
'\''# -> 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
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
}
("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
-- 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.)
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'
-- 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
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
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
-> 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
| 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 =
\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
| 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
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 ()
(_: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
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff