Skip to content
Snippets Groups Projects
Commit d9de62d5 authored by Simon Marlow's avatar Simon Marlow
Browse files

[project @ 1997-08-12 12:18:01 by simonm] 

Support new version of Happy.  The interface file parsers now require the
version of Happy in the tree to compile.
parent 81fc648d
No related merge requests found
Hide whitespace changes
Inline Side-by-side
ghc/compiler/reader/Lex.lhs
+ 127
− 126
View file @ d9de62d5
...@@ -210,14 +210,13 @@ data IfaceToken ...@@ -210,14 +210,13 @@ data IfaceToken
| ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour) | ITqvarsym (FAST_STRING,FAST_STRING,IfaceFlavour)
| ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour) | ITqconsym (FAST_STRING,FAST_STRING,IfaceFlavour)
| ITidinfo [IfaceToken] -- lazily return the stream of tokens for | ITtysig StringBuffer (Maybe StringBuffer)
-- the info attached to an id. -- lazily return the stream of tokens for
| ITtysig [IfaceToken] -- lazily return the stream of tokens for
-- the info attached to an id. -- the info attached to an id.
-- Stuff for reading unfoldings -- Stuff for reading unfoldings
| ITarity | ITstrict | ITarity
| ITunfold Bool -- True <=> there's an INLINE pragma on this Id | ITunfold Bool -- True <=> there's an INLINE pragma on this Id
| ITdemand [Demand] | ITbottom | ITstrict [Demand] | ITbottom
| ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof | ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof
| ITcoerce_in | ITcoerce_out | ITatsign | ITcoerce_in | ITcoerce_out | ITatsign
| ITccall (Bool,Bool) -- (is_casm, may_gc) | ITccall (Bool,Bool) -- (is_casm, may_gc)
...@@ -226,6 +225,7 @@ data IfaceToken ...@@ -226,6 +225,7 @@ data IfaceToken
| ITinteger Integer | ITdouble Double | ITinteger Integer | ITdouble Double
| ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit | ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit
| ITunknown String -- Used when the lexer can't make sense of it | ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
deriving Text -- debugging deriving Text -- debugging
instance Text CostCentre -- cheat! instance Text CostCentre -- cheat!
...@@ -239,8 +239,8 @@ instance Text CostCentre -- cheat! ...@@ -239,8 +239,8 @@ instance Text CostCentre -- cheat!
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
lexIface :: StringBuffer -> [IfaceToken] lexIface :: (IfaceToken -> IfM a) -> IfM a
lexIface buf = lexIface cont buf =
_scc_ "Lexer" _scc_ "Lexer"
-- if bufferExhausted buf then -- if bufferExhausted buf then
-- [] -- []
...@@ -248,49 +248,49 @@ lexIface buf = ...@@ -248,49 +248,49 @@ lexIface buf =
-- _trace ("Lexer: "++[C# (currentChar# buf)]) $ -- _trace ("Lexer: "++[C# (currentChar# buf)]) $
case currentChar# buf of case currentChar# buf of
-- whitespace and comments, ignore. -- whitespace and comments, ignore.
' '# -> lexIface (stepOn buf) ' '# -> lexIface cont (stepOn buf)
'\t'# -> lexIface (stepOn buf) '\t'# -> lexIface cont (stepOn buf)
'\n'# -> lexIface (stepOn buf) '\n'# -> \line -> lexIface cont (stepOn buf) (line+1)
-- Numbers and comments -- Numbers and comments
'-'# -> '-'# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
'-'# -> lex_comment (stepOnBy# buf 2#) '-'# -> lex_comment cont (stepOnBy# buf 2#)
c -> c ->
if isDigit (C# c) if isDigit (C# c)
then lex_num (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf)) then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
else lex_id buf else lex_id cont buf
-- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake? -- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake?
-- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs -- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
'('# -> '('# ->
case prefixMatch (stepOn buf) "..)" of case prefixMatch (stepOn buf) "..)" of
Just buf' -> ITdotdot : lexIface (stepOverLexeme buf') Just buf' -> cont ITdotdot (stepOverLexeme buf')
Nothing -> Nothing ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
','# -> lex_tuple Nothing (stepOnBy# buf 2#) ','# -> lex_tuple cont Nothing (stepOnBy# buf 2#)
')'# -> ITconid SLIT("()") : lexIface (stepOnBy# buf 2#) ')'# -> cont (ITconid SLIT("()")) (stepOnBy# buf 2#)
_ -> IToparen : lexIface (stepOn buf) _ -> cont IToparen (stepOn buf)
'{'# -> ITocurly : lexIface (stepOn buf) '{'# -> cont ITocurly (stepOn buf)
'}'# -> ITccurly : lexIface (stepOn buf) '}'# -> cont ITccurly (stepOn buf)
')'# -> ITcparen : lexIface (stepOn buf) ')'# -> cont ITcparen (stepOn buf)
'['# -> '['# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
']'# -> ITconid SLIT("[]") : lexIface (stepOnBy# buf 2#) ']'# -> cont (ITconid SLIT("[]")) (stepOnBy# buf 2#)
_ -> ITobrack : lexIface (stepOn buf) _ -> cont ITobrack (stepOn buf)
']'# -> ITcbrack : lexIface (stepOn buf) ']'# -> cont ITcbrack (stepOn buf)
','# -> ITcomma : lexIface (stepOn buf) ','# -> cont ITcomma (stepOn buf)
':'# -> case lookAhead# buf 1# of ':'# -> case lookAhead# buf 1# of
':'# -> ITdcolon : lexIface (stepOnBy# buf 2#) ':'# -> cont ITdcolon (stepOnBy# buf 2#)
_ -> lex_id (incLexeme buf) _ -> lex_id cont (incLexeme buf)
';'# -> ITsemi : lexIface (stepOn buf) ';'# -> cont ITsemi (stepOn buf)
'\"'# -> case untilEndOfString# (stepOn buf) of '\"'# -> case untilEndOfString# (stepOn buf) of
buf' -> buf' ->
-- the string literal does *not* include the dquotes -- the string literal does *not* include the dquotes
case lexemeToFastString buf' of case lexemeToFastString buf' of
v -> ITstring v : lexIface (stepOn (stepOverLexeme buf')) v -> cont (ITstring v) (stepOn (stepOverLexeme buf'))
'\''# -> -- '\''# -> --
-- untilEndOfChar# extends the current lexeme until -- untilEndOfChar# extends the current lexeme until
...@@ -301,46 +301,46 @@ lexIface buf = ...@@ -301,46 +301,46 @@ lexIface buf =
-- --
case untilEndOfChar# (stepOn buf) of case untilEndOfChar# (stepOn buf) of
buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of buf' -> case reads ('\'':lexemeToString (incLexeme buf')) of
[ (ch, rest)] -> ITchar ch : lexIface (stepOverLexeme (incLexeme buf')) [ (ch, rest)] -> cont (ITchar ch) (stepOverLexeme (incLexeme buf'))
-- ``thingy'' form for casm -- ``thingy'' form for casm
'`'# -> '`'# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
'`'# -> lex_cstring (stepOnBy# buf 2#) -- remove the `` and go. '`'# -> lex_cstring cont (stepOnBy# buf 2#) -- remove the `` and go.
_ -> lex_id (incLexeme buf) -- add ` to lexeme and assume _ -> lex_id cont (incLexeme buf) -- add ` to lexeme and assume
-- scanning an id of some sort. -- scanning an id of some sort.
-- Keywords -- Keywords
'_'# -> '_'# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
'S'# -> case lookAhead# buf 2# of 'S'# -> case lookAhead# buf 2# of
'_'# -> ITstrict : '_'# ->
lex_demand (stepOnUntil (not . isSpace) lex_demand cont (stepOnUntil (not . isSpace)
(stepOnBy# buf 3#)) -- past _S_ (stepOnBy# buf 3#)) -- past _S_
's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of
Just buf' -> lex_scc (stepOnUntil (not . isSpace) (stepOverLexeme buf')) Just buf' -> lex_scc cont (stepOnUntil (not . isSpace) (stepOverLexeme buf'))
Nothing -> lex_keyword (stepOnBy# buf 1#) -- drop the '_' and assume Nothing -> lex_keyword cont (stepOnBy# buf 1#) -- drop the '_' and assume
-- it is a keyword. -- it is a keyword.
_ -> lex_keyword (stepOn buf) _ -> lex_keyword cont (stepOn buf)
'\NUL'# -> '\NUL'# ->
if bufferExhausted (stepOn buf) then if bufferExhausted (stepOn buf) then
[] cont ITeof buf
else else
lex_id buf lex_id cont buf
c -> c ->
if isDigit (C# c) then if isDigit (C# c) then
lex_num (id) (ord# c -# ord# '0'#) (incLexeme buf) lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
else else
lex_id buf lex_id cont buf
-- where -- where
lex_comment buf = lex_comment cont buf =
-- _trace ("comment: "++[C# (currentChar# buf)]) $ -- _trace ("comment: "++[C# (currentChar# buf)]) $
case untilChar# buf '\n'# of {buf' -> lexIface (stepOverLexeme buf')} case untilChar# buf '\n'# of {buf' -> lexIface cont (stepOverLexeme buf')}
------------------ ------------------
lex_demand buf = lex_demand cont buf =
-- _trace ("demand: "++[C# (currentChar# buf)]) $ -- _trace ("demand: "++[C# (currentChar# buf)]) $
case read_em [] buf of { (ls,buf') -> ITdemand ls : lexIface (stepOverLexeme buf')} case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
where where
-- code snatched from Demand.lhs -- code snatched from Demand.lhs
read_em acc buf = read_em acc buf =
...@@ -363,43 +363,42 @@ lex_demand buf = ...@@ -363,43 +363,42 @@ lex_demand buf =
(stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest (stuff, rest) -> read_em (WwUnpack new_or_data wrapper_unpacks stuff : acc) rest
------------------ ------------------
lex_scc buf = lex_scc cont buf =
-- _trace ("scc: "++[C# (currentChar# buf)]) $ -- _trace ("scc: "++[C# (currentChar# buf)]) $
case currentChar# buf of case currentChar# buf of
'"'# -> '"'# ->
-- YUCK^2 -- YUCK^2
case prefixMatch (stepOn buf) "NO_CC\"" of case prefixMatch (stepOn buf) "NO_CC\"" of
Just buf' -> ITscc noCostCentre : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc noCostCentre) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "CURRENT_CC\"" of case prefixMatch (stepOn buf) "CURRENT_CC\"" of
Just buf' -> ITscc useCurrentCostCentre : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc useCurrentCostCentre) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "OVERHEAD\"" of case prefixMatch (stepOn buf) "OVERHEAD\"" of
Just buf' -> ITscc overheadCostCentre : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc overheadCostCentre) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "DONT_CARE\"" of case prefixMatch (stepOn buf) "DONT_CARE\"" of
Just buf' -> ITscc dontCareCostCentre : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc dontCareCostCentre) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "SUBSUMED\"" of case prefixMatch (stepOn buf) "SUBSUMED\"" of
Just buf' -> ITscc subsumedCosts : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc subsumedCosts) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "CAFs_in_...\"" of case prefixMatch (stepOn buf) "CAFs_in_...\"" of
Just buf' -> ITscc preludeCafsCostCentre : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc preludeCafsCostCentre) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "CC_CAFs_in_..." of case prefixMatch (stepOn buf) "CC_CAFs_in_..." of
Just buf' -> Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of case untilChar# (stepOverLexeme buf') '\"'# of
buf'' -> ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_): buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
lexIface (stepOn (stepOverLexeme buf''))
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "DICTs_in_...\"" of case prefixMatch (stepOn buf) "DICTs_in_...\"" of
Just buf' -> ITscc (preludeDictsCostCentre True) : lexIface (stepOverLexeme buf') Just buf' -> cont (ITscc (preludeDictsCostCentre True)) (stepOverLexeme buf')
Nothing -> Nothing ->
case prefixMatch (stepOn buf) "CC_DICTs_in_..." of case prefixMatch (stepOn buf) "CC_DICTs_in_..." of
Just buf' -> Just buf' ->
case untilChar# (stepOverLexeme buf') '\"'# of case untilChar# (stepOverLexeme buf') '\"'# of
buf'' -> ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True): buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True))
lexIface (stepOn (stepOverLexeme buf'')) (stepOn (stepOverLexeme buf''))
Nothing -> Nothing ->
let let
match_user_cc buf = match_user_cc buf =
...@@ -430,16 +429,17 @@ lex_scc buf = ...@@ -430,16 +429,17 @@ lex_scc buf =
case prefixMatch (stepOn buf) "CAF:" of case prefixMatch (stepOn buf) "CAF:" of
Just buf' -> Just buf' ->
case match_user_cc (stepOverLexeme buf') of case match_user_cc (stepOverLexeme buf') of
(cc, buf'') -> ITscc (cafifyCC cc) : lexIface buf'' (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf''
Nothing -> Nothing ->
case match_user_cc (stepOn buf) of case match_user_cc (stepOn buf) of
(cc, buf'') -> ITscc cc : lexIface buf'' (cc, buf'') -> cont (ITscc cc) buf''
c -> ITunknown [C# c] : lexIface (stepOn buf) c -> cont (ITunknown [C# c]) (stepOn buf)
----------- -----------
lex_num :: (Int -> Int) -> Int# -> StringBuffer -> [IfaceToken] lex_num :: (IfaceToken -> IfM a) ->
lex_num minus acc# buf = (Int -> Int) -> Int# -> IfM a
lex_num cont minus acc# buf =
-- _trace ("lex_num: "++[C# (currentChar# buf)]) $ -- _trace ("lex_num: "++[C# (currentChar# buf)]) $
case scanNumLit (I# acc#) buf of case scanNumLit (I# acc#) buf of
(acc',buf') -> (acc',buf') ->
...@@ -451,59 +451,60 @@ lex_num minus acc# buf = ...@@ -451,59 +451,60 @@ lex_num minus acc# buf =
case expandWhile (isDigit) (incLexeme buf') of case expandWhile (isDigit) (incLexeme buf') of
buf'' -> -- points to first non digit char buf'' -> -- points to first non digit char
case reads (lexemeToString buf'') of case reads (lexemeToString buf'') of
[(v,_)] -> ITdouble v : lexIface (stepOverLexeme buf'') [(v,_)] -> cont (ITdouble v) (stepOverLexeme buf'')
_ -> ITinteger (fromInt (minus acc')) : lexIface (stepOverLexeme buf') _ -> cont (ITinteger (fromInt (minus acc'))) (stepOverLexeme buf')
-- case reads (lexemeToString buf') of -- case reads (lexemeToString buf') of
-- [(i,_)] -> ITinteger i : lexIface (stepOverLexeme buf') -- [(i,_)] -> cont (ITinteger i) (stepOverLexeme buf')
------------ ------------
lex_keyword buf = lex_keyword cont buf =
-- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $ -- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $
case currentChar# buf of case currentChar# buf of
':'# -> case lookAhead# buf 1# of ':'# -> case lookAhead# buf 1# of
'_'# -> -- a binding, type (and other id-info) follows, '_'# -> -- a binding, type (and other id-info) follows,
-- to make the parser ever so slightly, we push -- to make the parser ever so slightly, we push
-- --
lex_decl (stepOnBy# buf 2#) lex_decl cont (stepOnBy# buf 2#)
v# -> ITunknown (['_',':',C# v#]) : lexIface (stepOnBy# buf 2#) v# -> cont (ITunknown (['_',':',C# v#])) (stepOnBy# buf 2#)
_ -> _ ->
case expandWhile (is_kwd_char) buf of case expandWhile (is_kwd_char) buf of
buf' -> buf' ->
let kw = lexemeToFastString buf' in let kw = lexemeToFastString buf' in
-- _trace ("kw: "++lexemeToString buf') $ -- _trace ("kw: "++lexemeToString buf') $
case lookupUFM ifaceKeywordsFM kw of case lookupUFM ifaceKeywordsFM kw of
Nothing -> ITunknown (_UNPK_ kw) : -- (minor) sigh Nothing -> cont (ITunknown (_UNPK_ kw)) -- (minor) sigh
lexIface (stepOverLexeme buf') (stepOverLexeme buf')
Just xx -> xx : lexIface (stepOverLexeme buf') Just xx -> cont xx (stepOverLexeme buf')
lex_decl buf = lex_decl cont buf =
case doDiscard False buf of -- spin until ;; is found case doDiscard False buf of -- spin until ;; is found
buf' -> buf' ->
{- _trace (show (lexemeToString buf')) $ -} {- _trace (show (lexemeToString buf')) $ -}
case currentChar# buf' of case currentChar# buf' of
'\n'# -> -- newline, no id info. '\n'# -> -- newline, no id info.
ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
lexIface (stepOverLexeme buf') (stepOverLexeme buf')
'\r'# -> -- just to be sure for those Win* boxes.. '\r'# -> -- just to be sure for those Win* boxes..
ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
lexIface (stepOverLexeme buf') (stepOverLexeme buf')
'\NUL'# -> '\NUL'# ->
ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))) : cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
lexIface (stepOverLexeme buf') (stepOverLexeme buf')
c -> -- run all over the id info c -> -- run all over the id info
case doDiscard False (stepOverLexeme buf') of -- spin until ;; is found (outside a string!) case doDiscard False (stepOverLexeme buf') of -- spin until ;; is found (outside a string!)
buf'' -> buf'' ->
--_trace ((C# c):show (lexemeToString (decLexeme buf'))) $ --_trace ((C# c):show (lexemeToString (decLexeme buf'))) $
--_trace (show (lexemeToString (decLexeme buf''))) $ --_trace (show (lexemeToString (decLexeme buf''))) $
ITtysig (lexIface (lexemeToBuffer (decLexeme buf'))): let idinfo =
let ls = lexIface (stepOverLexeme buf'') in if opt_IgnoreIfacePragmas then
if opt_IgnoreIfacePragmas then Nothing
ls else
else Just (lexemeToBuffer (decLexeme buf''))
let is = lexIface (lexemeToBuffer (decLexeme buf'')) in
--_trace (show is) $ --_trace (show is) $
ITidinfo is : ls in
cont (ITtysig (lexemeToBuffer (decLexeme buf')) idinfo)
(stepOverLexeme buf'')
-- ToDo: hammer! -- ToDo: hammer!
is_kwd_char c@(C# c#) = is_kwd_char c@(C# c#) =
...@@ -518,22 +519,22 @@ is_kwd_char c@(C# c#) = ...@@ -518,22 +519,22 @@ is_kwd_char c@(C# c#) =
----------- -----------
lex_cstring buf = lex_cstring cont buf =
-- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $ -- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $
case expandUntilMatch buf "\'\'" of case expandUntilMatch buf "\'\'" of
buf' -> ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))) : buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
lexIface (stepOverLexeme buf') (stepOverLexeme buf')
----------- -----------
lex_tuple module_dot buf = lex_tuple cont module_dot buf =
-- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $ -- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $
go 2 buf go 2 buf
where where
go n buf = go n buf =
case currentChar# buf of case currentChar# buf of
','# -> go (n+1) (stepOn buf) ','# -> go (n+1) (stepOn buf)
')'# -> end_lex_id module_dot (ITconid (mkTupNameStr n)) (stepOn buf) ')'# -> end_lex_id cont module_dot (ITconid (mkTupNameStr n)) (stepOn buf)
_ -> ITunknown ("tuple " ++ show n) : lexIface buf _ -> cont (ITunknown ("tuple " ++ show n)) buf
-- Similarly ' itself is ok inside an identifier, but not at the start -- Similarly ' itself is ok inside an identifier, but not at the start
...@@ -631,56 +632,56 @@ lex_id cs = ...@@ -631,56 +632,56 @@ lex_id cs =
-} -}
lex_id buf = lex_id cont buf =
-- _trace ("lex_id: "++[C# (currentChar# buf)]) $ -- _trace ("lex_id: "++[C# (currentChar# buf)]) $
case expandWhile (is_mod_char) buf of case expandWhile (is_mod_char) buf of
buf' -> buf' ->
case currentChar# buf' of case currentChar# buf' of
'.'# -> munch buf' HiFile '.'# -> munch buf' HiFile
'!'# -> munch buf' HiBootFile '!'# -> munch buf' HiBootFile
_ -> lex_id2 Nothing buf' _ -> lex_id2 cont Nothing buf'
where where
munch buf' hif = munch buf' hif =
if not (emptyLexeme buf') then if not (emptyLexeme buf') then
-- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $ -- _trace ("lex_id: "++(C# (currentChar# (stepOverLexeme buf'))):show (lexemeToFastString buf')) $
case lexemeToFastString buf' of case lexemeToFastString buf' of
l@(FastString u# l# ba#) -> lex_id2 (Just (FastString u# l# ba#, hif)) l@(FastString u# l# ba#) -> lex_id2 cont (Just (FastString u# l# ba#, hif))
(stepOn (stepOverLexeme buf')) (stepOn (stepOverLexeme buf'))
else else
lex_id2 Nothing buf' lex_id2 cont Nothing buf'
-- Dealt with the Module.part -- Dealt with the Module.part
lex_id2 module_dot buf = lex_id2 cont module_dot buf =
-- _trace ("lex_id2: "++[C# (currentChar# buf)]) $ -- _trace ("lex_id2: "++[C# (currentChar# buf)]) $
case currentChar# buf of case currentChar# buf of
'['# -> '['# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
']'# -> end_lex_id module_dot (ITconid SLIT("[]")) (stepOnBy# buf 2#) ']'# -> end_lex_id cont module_dot (ITconid SLIT("[]")) (stepOnBy# buf 2#)
_ -> lex_id3 module_dot buf _ -> lex_id3 cont module_dot buf
'('# -> '('# ->
case lookAhead# buf 1# of case lookAhead# buf 1# of
')'# -> end_lex_id module_dot (ITconid SLIT("()")) (stepOnBy# buf 2#) ')'# -> end_lex_id cont module_dot (ITconid SLIT("()")) (stepOnBy# buf 2#)
','# -> lex_tuple module_dot (stepOnBy# buf 2#) ','# -> lex_tuple cont module_dot (stepOnBy# buf 2#)
_ -> lex_id3 module_dot buf _ -> lex_id3 cont module_dot buf
':'# -> lex_id3 module_dot (incLexeme buf) ':'# -> lex_id3 cont module_dot (incLexeme buf)
_ -> lex_id3 module_dot buf _ -> lex_id3 cont module_dot buf
-- Dealt with [], (), : special cases -- Dealt with [], (), : special cases
lex_id3 module_dot buf = lex_id3 cont module_dot buf =
-- _trace ("lex_id3: "++[C# (currentChar# buf)]) $ -- _trace ("lex_id3: "++[C# (currentChar# buf)]) $
case expandWhile (is_id_char) buf of case expandWhile (is_id_char) buf of
buf' -> buf' ->
case module_dot of case module_dot of
Just _ -> Just _ ->
end_lex_id module_dot (mk_var_token lexeme) (stepOverLexeme buf') end_lex_id cont module_dot (mk_var_token lexeme) (stepOverLexeme buf')
Nothing -> Nothing ->
case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of
Just kwd_token -> kwd_token : lexIface new_buf Just kwd_token -> cont kwd_token new_buf
Nothing -> mk_var_token lexeme : lexIface new_buf Nothing -> cont (mk_var_token lexeme) new_buf
where where
lexeme = lexemeToFastString buf' lexeme = lexemeToFastString buf'
new_buf = stepOverLexeme buf' new_buf = stepOverLexeme buf'
...@@ -694,7 +695,6 @@ lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs ...@@ -694,7 +695,6 @@ lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs
lex_id2 module_dot xs cs = lex_id3 module_dot xs cs lex_id2 module_dot xs cs = lex_id3 module_dot xs cs
-} -}
-- Dealt with [], (), : special cases -- Dealt with [], (), : special cases
{- {-
...@@ -734,15 +734,15 @@ mk_var_token pk_str = ...@@ -734,15 +734,15 @@ mk_var_token pk_str =
n = _PK_ xs n = _PK_ xs
-} -}
end_lex_id Nothing token buf = token : lexIface buf end_lex_id cont Nothing token buf = cont token buf
end_lex_id (Just (m,hif)) token buf = end_lex_id cont (Just (m,hif)) token buf =
case token of case token of
ITconid n -> ITqconid (m,n,hif) : lexIface buf ITconid n -> cont (ITqconid (m,n,hif)) buf
ITvarid n -> ITqvarid (m,n,hif) : lexIface buf ITvarid n -> cont (ITqvarid (m,n,hif)) buf
ITconsym n -> ITqconsym (m,n,hif) : lexIface buf ITconsym n -> cont (ITqconsym (m,n,hif)) buf
ITvarsym n -> ITqvarsym (m,n,hif) : lexIface buf ITvarsym n -> cont (ITqvarsym (m,n,hif)) buf
ITbang -> ITqvarsym (m,SLIT("!"),hif) : lexIface buf ITbang -> cont (ITqvarsym (m,SLIT("!"),hif)) buf
_ -> ITunknown (show token) : lexIface buf _ -> cont (ITunknown (show token)) buf
------------ ------------
ifaceKeywordsFM :: UniqFM IfaceToken ifaceKeywordsFM :: UniqFM IfaceToken
...@@ -862,21 +862,22 @@ end{code} ...@@ -862,21 +862,22 @@ end{code}
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
type IfM a = MaybeErr a Error type IfM a = StringBuffer -> Int -> MaybeErr a Error
returnIf :: a -> IfM a returnIf :: a -> IfM a
thenIf :: IfM a -> (a -> IfM b) -> IfM b returnIf a s l = Succeeded a
happyError :: Int -> [IfaceToken] -> IfM a
returnIf a = Succeeded a thenIf :: IfM a -> (a -> IfM b) -> IfM b
m `thenIf` k = \s l ->
thenIf (Succeeded a) k = k a case m s l of
thenIf (Failed err) _ = Failed err Succeeded a -> k a s l
Failed err -> Failed err
happyError ln toks = Failed (ifaceParseErr ln toks) happyError :: IfM a
happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-})
----------------------------------------------------------------- -----------------------------------------------------------------
ifaceParseErr ln toks sty ifaceParseErr l toks sty
= hsep [ptext SLIT("Interface-file parse error: line"), int ln, ptext SLIT("toks="), text (show (take 10 toks))] = hsep [ptext SLIT("Interface-file parse error: line"), int l, ptext SLIT("toks="), text (show (take 10 toks))]
\end{code} \end{code}
ghc/compiler/rename/ParseIface.y
+ 16
− 20
View file @ d9de62d5
...@@ -28,16 +28,12 @@ import ParseType ( parseType ) ...@@ -28,16 +28,12 @@ import ParseType ( parseType )
import ParseUnfolding ( parseUnfolding ) import ParseUnfolding ( parseUnfolding )
import Maybes import Maybes
-----------------------------------------------------------------
parseIface ls = parseIToks (lexIface ls)
-----------------------------------------------------------------
} }
%name parseIToks %name parseIface
%tokentype { IfaceToken } %tokentype { IfaceToken }
%monad { IfM }{ thenIf }{ returnIf } %monad { IfM }{ thenIf }{ returnIf }
%lexer { lexIface } { ITeof }
%token %token
INTERFACE { ITinterface } INTERFACE { ITinterface }
...@@ -85,12 +81,10 @@ parseIface ls = parseIToks (lexIface ls) ...@@ -85,12 +81,10 @@ parseIface ls = parseIToks (lexIface ls)
QVARSYM { ITqvarsym $$ } QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ } QCONSYM { ITqconsym $$ }
IDINFO_PART { ITidinfo $$ } TYPE_PART { ITtysig _ _ }
TYPE_PART { ITtysig $$ }
ARITY_PART { ITarity } ARITY_PART { ITarity }
STRICT_PART { ITstrict } STRICT_PART { ITstrict $$ }
UNFOLD_PART { ITunfold $$ } UNFOLD_PART { ITunfold $$ }
DEMAND { ITdemand $$ }
BOTTOM { ITbottom } BOTTOM { ITbottom }
LAM { ITlam } LAM { ITlam }
BIGLAM { ITbiglam } BIGLAM { ITbiglam }
...@@ -238,16 +232,18 @@ topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI ...@@ -238,16 +232,18 @@ topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI
{ TyD (TyData NewType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) } { TyD (TyData NewType $2 $3 $4 $5 $6 noDataPragmas mkIfaceSrcLoc) }
| CLASS decl_context tc_name tv_bndr csigs SEMI | CLASS decl_context tc_name tv_bndr csigs SEMI
{ ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) } { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
| var_name TYPE_PART id_info | var_name TYPE_PART
{ {
let case $2 of
(Succeeded tp) = parseType $2 ITtysig sig idinfo_part ->
in let info =
SigD (IfaceSig $1 tp $3 mkIfaceSrcLoc) } case idinfo_part of
Nothing -> []
id_info :: { [HsIdInfo RdrName] } Just s ->
id_info : { [] } let { (Succeeded id_info) = parseUnfolding s } in id_info
| IDINFO_PART { let { (Succeeded id_info) = parseUnfolding $1 } in id_info} (Succeeded tp) = parseType sig
in
SigD (IfaceSig $1 tp info mkIfaceSrcLoc) }
decl_context :: { RdrNameContext } decl_context :: { RdrNameContext }
decl_context : { [] } decl_context : { [] }
...@@ -410,7 +406,7 @@ tc_name : tc_occ { Unqual $1 } ...@@ -410,7 +406,7 @@ tc_name : tc_occ { Unqual $1 }
tv_name :: { RdrName } tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) } tv_name : VARID { Unqual (TvOcc $1) }
| VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} } | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
tv_names :: { [RdrName] } tv_names :: { [RdrName] }
: { [] } : { [] }
......
ghc/compiler/rename/ParseType.y
+ 5
− 4
View file @ d9de62d5
...@@ -31,11 +31,11 @@ import Maybes ( MaybeErr(..) ) ...@@ -31,11 +31,11 @@ import Maybes ( MaybeErr(..) )
------------------------------------------------------------------ ------------------------------------------------------------------
parseType :: [IfaceToken] -> MaybeErr RdrNameHsType (PprStyle -> Doc) parseType :: StringBuffer -> MaybeErr RdrNameHsType (PprStyle -> Doc)
parseType ls = parseType ls =
let let
res = res =
case parseT ls of case parseT ls 1 of
v@(Succeeded _) -> v v@(Succeeded _) -> v
Failed err -> panic (show (err PprDebug)) Failed err -> panic (show (err PprDebug))
in in
...@@ -45,7 +45,8 @@ parseType ls = ...@@ -45,7 +45,8 @@ parseType ls =
%name parseT %name parseT
%tokentype { IfaceToken } %tokentype { IfaceToken }
%monad { IfM }{ thenIf }{ returnIf } %monad { IfM }{ thenIf }{ returnIf }
%lexer { lexIface } { ITeof }
%token %token
FORALL { ITforall } FORALL { ITforall }
...@@ -128,7 +129,7 @@ akind :: { Kind } ...@@ -128,7 +129,7 @@ akind :: { Kind }
tv_name :: { RdrName } tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) } tv_name : VARID { Unqual (TvOcc $1) }
| VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} } | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
tv_names :: { [RdrName] } tv_names :: { [RdrName] }
: { [] } : { [] }
......
ghc/compiler/rename/ParseUnfolding.y
+ 6
− 6
View file @ d9de62d5
...@@ -35,7 +35,7 @@ import Maybes ( MaybeErr(..) ) ...@@ -35,7 +35,7 @@ import Maybes ( MaybeErr(..) )
parseUnfolding ls = parseUnfolding ls =
let let
res = res =
case parseUnfold ls of case parseUnfold ls 1 of -- Todo: correct line number
v@(Succeeded _) -> v v@(Succeeded _) -> v
-- ill-formed unfolding, crash and burn. -- ill-formed unfolding, crash and burn.
Failed err -> panic (show (err PprDebug)) Failed err -> panic (show (err PprDebug))
...@@ -45,7 +45,8 @@ parseUnfolding ls = ...@@ -45,7 +45,8 @@ parseUnfolding ls =
%name parseUnfold %name parseUnfold
%tokentype { IfaceToken } %tokentype { IfaceToken }
%monad { IfM }{ thenIf }{ returnIf } %monad { IfM }{ thenIf }{ returnIf }
%lexer { lexIface } { ITeof }
%token %token
PRAGMAS_PART { ITpragmas } PRAGMAS_PART { ITpragmas }
...@@ -83,9 +84,8 @@ parseUnfolding ls = ...@@ -83,9 +84,8 @@ parseUnfolding ls =
QCONSYM { ITqconsym $$ } QCONSYM { ITqconsym $$ }
ARITY_PART { ITarity } ARITY_PART { ITarity }
STRICT_PART { ITstrict } DEMAND { ITstrict $$ }
UNFOLD_PART { ITunfold $$ } UNFOLD_PART { ITunfold $$ }
DEMAND { ITdemand $$ }
BOTTOM { ITbottom } BOTTOM { ITbottom }
LAM { ITlam } LAM { ITlam }
BIGLAM { ITbiglam } BIGLAM { ITbiglam }
...@@ -122,7 +122,7 @@ id_info : { [] } ...@@ -122,7 +122,7 @@ id_info : { [] }
id_info_item :: { HsIdInfo RdrName } id_info_item :: { HsIdInfo RdrName }
id_info_item : ARITY_PART arity_info { HsArity $2 } id_info_item : ARITY_PART arity_info { HsArity $2 }
| STRICT_PART strict_info { HsStrictness $2 } | strict_info { HsStrictness $1 }
| BOTTOM { HsStrictness HsBottom } | BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 } | UNFOLD_PART core_expr { HsUnfold $1 $2 }
...@@ -339,7 +339,7 @@ akind :: { Kind } ...@@ -339,7 +339,7 @@ akind :: { Kind }
tv_name :: { RdrName } tv_name :: { RdrName }
tv_name : VARID { Unqual (TvOcc $1) } tv_name : VARID { Unqual (TvOcc $1) }
| VARSYM { Unqual (TvOcc $1) {- Allow $t2 as a tyvar -} } | VARSYM { Unqual (TvOcc $1) {- Allow t2 as a tyvar -} }
tv_names :: { [RdrName] } tv_names :: { [RdrName] }
: { [] } : { [] }
......
ghc/compiler/rename/RnIfaces.lhs
+ 1
− 1
View file @ d9de62d5
...@@ -961,7 +961,7 @@ readIface file_path ...@@ -961,7 +961,7 @@ readIface file_path
--traceRn (hcat[ptext SLIT("Opening...."), text file_path]) `thenRn_` --traceRn (hcat[ptext SLIT("Opening...."), text file_path]) `thenRn_`
case read_result of case read_result of
Right contents -> Right contents ->
case parseIface contents of case parseIface contents 1 of
Failed err -> Failed err ->
--traceRn (ptext SLIT("parse err")) `thenRn_` --traceRn (ptext SLIT("parse err")) `thenRn_`
failWithRn Nothing err failWithRn Nothing err
......
ghc/compiler/utils/StringBuffer.lhs
+ 4
− 0
View file @ d9de62d5
...@@ -92,7 +92,11 @@ data StringBuffer ...@@ -92,7 +92,11 @@ data StringBuffer
\end{code} \end{code}
\begin{code} \begin{code}
instance Text StringBuffer where
showsPrec _ s = showString ""
\end{code}
\begin{code}
hGetStringBuffer :: FilePath -> IO StringBuffer hGetStringBuffer :: FilePath -> IO StringBuffer
hGetStringBuffer fname = hGetStringBuffer fname =
-- trace ("Renamer: opening " ++ fname) $ -- trace ("Renamer: opening " ++ fname) $
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment