import Char ( isSpace, toUpper )
import List ( isSuffixOf )
-import IdInfo ( InlinePragInfo(..) )
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import ForeignCall ( Safety(..) )
-import NewDemand ( StrictSig(..), Demand(..), Keepity(..),
- DmdResult(..), Deferredness(..), mkTopDmdType )
+import NewDemand ( StrictSig(..), Demand(..), Demands(..),
+ DmdResult(..), mkTopDmdType, evalDmd, lazyDmd )
import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
| ITarity
| ITspecialise
| ITnocaf
- | ITunfold InlinePragInfo
+ | ITunfold
| ITstrict StrictSig
| ITrules
| ITcprinfo
| ITqvarsym (FAST_STRING,FAST_STRING)
| ITqconsym (FAST_STRING,FAST_STRING)
- | ITipvarid FAST_STRING -- GHC extension: implicit param: ?x
+ | ITdupipvarid FAST_STRING -- GHC extension: implicit param: ?x
+ | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x
| ITpragma StringBuffer
("__C", ITnocaf),
("__R", ITrules),
("__D", ITdeprecated),
- ("__U", ITunfold NoInlinePragInfo),
+ ("__U", ITunfold),
("__ccall", ITccall (False, False, PlayRisky)),
("__ccall_GC", ITccall (False, False, PlaySafe)),
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'# ->
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 (flag glaexts) ->
+ 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
_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.
lexToken :: (Token -> P a) -> Int# -> P a
lexToken cont glaexts buf =
- -- trace "lexToken" $
+-- trace "lexToken" $
case currentChar# buf of
-- special symbols ----------------------------------------------------
'-'# -> case lookAhead# buf 2# of
'#'# -> case lookAhead# buf 3# of
'#'# ->
- let (lexeme, buf')
- = doDiscard 0# (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 (ITunknown "\NUL") (stepOn buf)
'?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
- lex_ip cont (incLexeme buf)
+ lex_ip ITdupipvarid cont (incLexeme buf)
+ '%'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+ lex_ip ITsplitipvarid 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
lex_demand cont buf =
case read_em [] buf of { (ls,buf') ->
case currentChar# buf' of
- 'X'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf')
- 'M'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme 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 (Lazy : acc) (stepOn buf)
- 'A'# -> read_em (Abs : acc) (stepOn buf)
- 'V'# -> read_em (Eval : 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)
+ '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_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
+ '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#)
- do_unpack2 keepity defer acc buf
- = case read_em [] buf of
- (stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest
+ _ -> (reverse acc, buf)
- do_call 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 (Call dmd : acc) rest
+ ([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest) -- Skip ')'
------------------
lex_scc cont buf =
-----------------------------------------------------------------------------
-- identifiers, symbols etc.
-lex_ip cont buf =
+lex_ip ip_constr cont buf =
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 =
let buf1 = expandWhile# is_ident buf in
\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
'#'# | 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
'\\'# -> -- escaping something..
if odd_slashes buf True (negateInt# 2#)
then -- odd number of slashes, " is escaped.
- doDiscard inStr (incLexeme buf)
+ lexPragma cont contf inStr (incLexeme buf)
else -- even number of slashes, \ is escaped.
- doDiscard not_inStr (incLexeme buf)
- _ -> doDiscard not_inStr (incLexeme buf)
+ 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 { '\''# ->
- doDiscard inStr (setCurrentPos# buf 3#);
- _ -> doDiscard inStr (incLexeme buf) };
- _ -> doDiscard inStr (incLexeme buf) }
+ 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
- _ -> doDiscard inStr (incLexeme buf)
+ _ -> lexPragma cont contf inStr (incLexeme buf)
\end{code}
projects / ghc-hetmet.git / blobdiff