--------------------------------------------------------
\begin{code}
-
module Lex (
- ifaceParseErr, srcParseErr,
+ srcParseErr,
-- Monad for parser
Token(..), lexer, ParseResult(..), PState(..),
- checkVersion, ExtFlags(..), mkPState,
+ 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 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,
import StringBuffer
import GlaExts
import Ctype
-import Char ( chr, ord )
-import PrelRead ( readRational__ ) -- Glasgow non-std
-import PrelBits ( Bits(..) ) -- non-std
+
+import Bits ( Bits(..) ) -- non-std
+import Int ( Int32 )
\end{code}
%************************************************************************
| 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
- | ITstrict StrictSig
- | ITrules
- | ITcprinfo
- | ITdeprecated
- | IT__scc
- | ITsccAllCafs
| ITspecialise_prag -- Pragmas
| ITsource_prag
| ITdarrow
| ITminus
| ITbang
+ | ITstar
| ITdot
| ITbiglam -- GHC-extension symbols
| 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
| 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 ),
]
haskellKeywordsFM = listToUFM $
- map (\ (x,y) -> (_PK_ x,y))
+ map (\ (x,y) -> (mkFastString x,y))
[( "_", ITunderscore ),
( "as", ITas ),
( "case", ITcase ),
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 _ = 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", ITunsafe ),
- ( "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),
-
- ("__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),
+ ( "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),
+ ( "with", ITwith, bit withBit),
+ ( "stdcall", ITstdcallconv, bit ffiBit),
+ ( "ccall", ITccallconv, bit ffiBit),
+ ( "dotnet", ITdotnet, bit ffiBit),
+ ("_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))
+ map (\ (x,y) -> (mkFastString x,y))
[ ("..", ITdotdot)
,("::", ITdcolon)
,("=", ITequal)
,("=>", ITdarrow)
,("-", ITminus)
,("!", ITbang)
+ ,("*", ITstar)
,(".", ITdot) -- sadly, for 'forall a . t'
]
\end{code}
-- 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_ident (stepOverLexeme buf1) of { buf2->
let lexeme = mkFastString -- ToDo: too slow
| otherwise
-> cont ITbackquote (incLexeme buf)
- '{'# -> -- look for "{-##" special iface pragma -- for Emacs: -}
+ '{'# -> -- for Emacs: -}
case lookAhead# buf 1# of
'|'# | glaExtsEnabled exts
-> cont ITocurlybar (setCurrentPos# buf 2#)
'-'# -> case lookAhead# buf 2# of
- '#'# -> case lookAhead# buf 3# of
- '#'# ->
- lexPragma
- cont
- (\ cont lexeme buf' -> cont (ITpragma lexeme) buf')
- 0#
- (stepOnBy# (stepOverLexeme buf) 4#)
- _ -> lex_prag cont (setCurrentPos# buf 3#)
+ '#'# -> lex_prag cont (setCurrentPos# buf 3#)
_ -> cont ITocurly (incLexeme buf)
_ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
'\"'#{-"-} -> lex_string cont exts [] (incLexeme buf)
'\''# -> lex_char (char_end cont) exts (incLexeme buf)
- -- strictness and cpr pragmas and __scc treated specially.
- '_'# | 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'# ->
- 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 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 exts) buf' is_hexdigit 16 hex
= case currentChar# buf of
'"'#{-"-} ->
let buf' = incLexeme buf
- s' = mkFastStringNarrow (map chr (reverse s))
+ s' = mkFastString (map chr (reverse s))
in case currentChar# buf' of
'#'# | glaExtsEnabled exts -> if all (<= 0xFF) s
then cont (ITprimstring s') (incLexeme 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
- '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('
-
- '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#)
-
- _ -> (reverse acc, buf)
-
- 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 =
- case currentChar# buf of
- 'C'# -> cont ITsccAllCafs (incLexeme buf)
- other -> cont ITscc buf
-
-----------------------------------------------------------------------------
-- Numbers
do_exponent
= let buf3 = incLexeme buf2 in
case currentChar# buf3 of
- '-'# -> expandWhile# is_digit (incLexeme buf3)
- '+'# -> expandWhile# is_digit (incLexeme buf3)
+ '-'# | 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
'#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme 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.)
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 (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
}}}
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
- ']'# -> cont (ITqconid (mod,SLIT("[]"))) (setCurrentPos# buf 2#)
+ ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (setCurrentPos# buf 2#)
_ -> just_a_conid
'('# -> -- Special case for (,,,)
','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#)
just_a_conid
_ -> just_a_conid
- ')'# -> cont (ITqconid (mod,SLIT("()"))) (setCurrentPos# buf 2#)
+ ')'# -> cont (ITqconid (mod,FSLIT("()"))) (setCurrentPos# buf 2#)
','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
+ '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (setCurrentPos# buf 2#)
_ -> lex_id3 cont exts mod buf just_a_conid
_ -> lex_id3 cont exts mod buf just_a_conid
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
| 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}
-----------------------------------------------------------------------------
-'lexPragma' rips along really fast, looking for a '##-}',
-indicating the end of the pragma we're skipping
-
-\begin{code}
-lexPragma cont contf inStr buf =
- case currentChar# buf of
- '#'# | inStr ==# 0# ->
- case lookAhead# buf 1# of { '#'# ->
- case lookAhead# buf 2# of { '-'# ->
- case lookAhead# buf 3# of { '}'# ->
- 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.
- 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}
-
------------------------------------------------------------------------------
\begin{code}
data LayoutContext
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!)
-
- 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-})
-
-
-- 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'
+ffiBit = 1
parrBit = 2
+withBit = 3
glaExtsEnabled, ffiEnabled, parrEnabled :: Int# -> Bool
-glaExtsEnabled flags = testBit (I# flags) glaExtsBit
-ffiEnabled flags = testBit (I# flags) ffiBit
-parrEnabled flags = testBit (I# flags) parrBit
+glaExtsEnabled flags = testBit (toInt32 flags) glaExtsBit
+ffiEnabled flags = testBit (toInt32 flags) ffiBit
+withEnabled flags = testBit (toInt32 flags) withBit
+parrEnabled flags = testBit (toInt32 flags) parrBit
+
+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
}
-- 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
-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]
+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
+ --
+ setBitIf :: Int -> Bool -> Int32
+ b `setBitIf` cond | cond = bit b
+ | otherwise = 0
-----------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff