--------------------------------------------------------
\begin{code}
-{-# OPTIONS -#include "hs_ctype.h" #-}
+
module Lex (
ifaceParseErr, srcParseErr,
import IdInfo ( InlinePragInfo(..) )
import PrelNames ( mkTupNameStr )
import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
-import Demand ( Demand(..) {- instance Read -} )
+import ForeignCall ( Safety(..) )
+import NewDemand ( StrictSig(..), Demand(..), Keepity(..),
+ DmdResult(..), Deferredness(..), mkTopDmdType )
import UniqFM ( listToUFM, lookupUFM )
-import BasicTypes ( NewOrData(..), Boxity(..) )
+import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
replaceSrcLine, mkSrcLoc )
| ITwith
| ITstdcallconv
| ITccallconv
+ | ITdotnet
| ITinterface -- interface keywords
| IT__export
| 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
| ITspecialise
| ITnocaf
| ITunfold InlinePragInfo
- | ITstrict ([Demand], Bool)
+ | ITstrict StrictSig
| ITrules
| ITcprinfo
| ITdeprecated
( "with", ITwith ),
( "stdcall", ITstdcallconv),
( "ccall", ITccallconv),
- ("_ccall_", ITccall (False, False, False)),
- ("_ccall_GC_", ITccall (False, False, True)),
- ("_casm_", ITccall (False, True, False)),
- ("_casm_GC_", ITccall (False, True, True)),
+ ( "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),
("__D", ITdeprecated),
("__U", ITunfold NoInlinePragInfo),
- ("__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)
]
})
-- 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
lex_char cont glaexts buf
= case currentChar# buf of
'\\'# -> lex_escape (cont glaexts) (incLexeme buf)
- c | is_string c -> cont glaexts (I# (ord# c)) (incLexeme buf)
+ c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf)
other -> charError buf
char_end cont glaexts c buf
(c,buf2):_ -> cont (ord c) buf2
[] -> charError buf'
-after_charnum cont i buf = cont (fromInteger i) 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
where read buf i
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'
+ 'X'# -> 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)
+ '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)
- '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#)
+ '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_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
+ 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 =
let lexeme = lexemeToFastString buf' in
- case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
cont kwd_token buf';
Nothing ->
where lexeme = lexemeToFastString buf'
-lex_con cont glaexts buf =
- -- trace ("con: "{-++unpackFS lexeme-}) $
- 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 glaexts 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 ->
+
+ 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 glaexts all_lexeme
+ (incLexeme all_buf) just_a_conid
_ -> just_a_conid
-
- where
- just_a_conid = 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 =
- -- trace ("quid: "{-++unpackFS lexeme-}) $
+ }}
+
+
+maybe_qualified cont glaexts mod buf just_a_conid =
+ -- trace ("qid: "{-++unpackFS lexeme-}) $
case currentChar# buf of
'['# -> -- Special case for []
case lookAhead# buf 1# of
'-'# -> 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
+
lex_id3 cont glaexts mod buf just_a_conid
+ | is_upper (currentChar# buf) =
+ lex_con cont glaexts buf
+
| is_symbol (currentChar# buf) =
let
start_new_lexeme = stepOverLexeme buf
new_buf = mergeLexemes buf buf'
is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
in
- case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
Nothing -> is_a_qvarid ;
Just kwd_token | isSpecial kwd_token -- special ids (as, qualified, hiding) shouldn't be
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
-
+ 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} ()
projects / ghc-hetmet.git / blobdiff