#include "HsVersions.h"
-import Char ( ord, isSpace, toUpper )
+import Char ( isSpace, toUpper )
import List ( isSuffixOf )
-import IdInfo ( InlinePragInfo(..), CprInfo(..) )
-import Name ( isLowerISO, isUpperISO )
+import IdInfo ( InlinePragInfo(..) )
import PrelNames ( mkTupNameStr )
-import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
+import CmdLineOpts ( opt_HiVersion, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
-import UniqFM ( UniqFM, listToUFM, lookupUFM)
+import UniqFM ( listToUFM, lookupUFM )
import BasicTypes ( NewOrData(..), Boxity(..) )
import SrcLoc ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
replaceSrcLine, mkSrcLoc )
-import Maybes ( MaybeErr(..) )
import ErrUtils ( Message )
import Outputable
import FastString
import StringBuffer
import GlaExts
-import ST ( runST )
import Ctype
-import Char ( chr )
-import Addr
+import Char ( chr, ord )
import PrelRead ( readRational__ ) -- Glasgow non-std
\end{code}
| ITint64_lit
| ITrational_lit
| ITaddr_lit
+ | ITlabel_lit
| ITlit_lit
| ITstring_lit
| ITtypeapp
| ITpragma StringBuffer
- | ITchar Char
+ | ITchar Int
| ITstring FAST_STRING
- | ITinteger Integer
+ | ITinteger Integer
| ITrational Rational
- | ITprimchar Char
+ | ITprimchar Int
| ITprimstring FAST_STRING
| ITprimint Integer
| ITprimfloat Rational
("__word64", ITword64_lit),
("__rational", ITrational_lit),
("__addr", ITaddr_lit),
+ ("__label", ITlabel_lit),
("__litlit", ITlit_lit),
("__string", ITstring_lit),
("__a", ITtypeapp),
if next `eqChar#` '-'# then trundle (n +# 1#)
else if is_symbol next || n <# 2#
then is_a_token
- else case untilChar# (stepOnBy# buf n) '\n'# of
- { buf' -> tab y bol atbol (stepOverLexeme buf')
- }
+ else tab y bol atbol
+ (stepOnUntilChar# (stepOnBy# buf n) '\n'#)
in trundle 1#
-- comments and pragmas. We deal with LINE pragmas here,
let lexeme = mkFastString -- ToDo: too slow
(map toUpper (lexemeToString buf2)) in
case lookupUFM pragmaKeywordsFM lexeme of
- Just ITline_prag -> line_prag (lexer cont) buf2 s'
+ Just ITline_prag ->
+ line_prag skip_to_end buf2 s'
Just other -> is_a_token
- Nothing -> skip_to_end (stepOnBy# buf 2#)
+ Nothing -> skip_to_end (stepOnBy# buf 2#) s'
}}
-
- else skip_to_end (stepOnBy# buf 2#)
+
+ else skip_to_end (stepOnBy# buf 2#) s'
where
- skip_to_end buf = nested_comment (lexer cont) buf s'
+ skip_to_end = nested_comment (lexer cont)
+
+ -- special GHC extension: we grok cpp-style #line pragmas
+ '#'# | lexemeIndex buf ==# bol -> -- the '#' must be in column 0
+ line_prag next_line (stepOn buf) s'
+ where
+ next_line buf = lexer cont (stepOnUntilChar# buf '\n'#)
-- tabs have been expanded beforehand
c | is_space c -> tab y bol atbol (stepOn buf)
| otherwise = lexToken cont glaexts buf s'
-- {-# LINE .. #-} pragmas. yeuch.
-line_prag cont buf =
+line_prag cont buf s@PState{loc=loc} =
case expandWhile# is_space buf of { buf1 ->
case scanNumLit 0 (stepOverLexeme buf1) of { (line,buf2) ->
-- subtract one: the line number refers to the *following* line.
let real_line = line - 1 in
case fromInteger real_line of { i@(I# l) ->
+ -- ToDo, if no filename then we skip the newline.... d'oh
case expandWhile# is_space buf2 of { buf3 ->
case currentChar# buf3 of
'\"'#{-"-} ->
case untilEndOfString# (stepOn (stepOverLexeme buf3)) of { buf4 ->
- let file = lexemeToFastString buf4 in
- \s@PState{loc=loc} -> skipToEnd buf4 s{loc = mkSrcLoc file i}
+ let
+ file = lexemeToFastString buf4
+ new_buf = stepOn (stepOverLexeme buf4)
+ in
+ if nullFastString file
+ then cont new_buf s{loc = replaceSrcLine loc l}
+ else cont new_buf s{loc = mkSrcLoc file i}
}
- other -> \s@PState{loc=loc} -> skipToEnd buf3 s{loc = replaceSrcLine loc l}
+ _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l}
}}}}
- where
- skipToEnd buf = nested_comment cont buf
nested_comment :: P a -> P a
nested_comment cont buf = loop buf
_ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf)
-- strings/characters -------------------------------------------------
- '\"'#{-"-} -> lex_string cont glaexts "" (incLexeme buf)
+ '\"'#{-"-} -> lex_string cont glaexts [] (incLexeme buf)
'\''# -> lex_char (char_end cont) glaexts (incLexeme buf)
-- strictness and cpr pragmas and __scc treated specially.
lex_string cont glaexts s buf
= case currentChar# buf of
'"'#{-"-} ->
- let buf' = incLexeme buf; s' = mkFastString (reverse s) in
+ let buf' = incLexeme buf; s' = mkFastStringInt (reverse s) in
case currentChar# buf' of
- '#'# | flag glaexts -> cont (ITprimstring s') (incLexeme buf')
+ '#'# | 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'
-- ignore \& in a string, deal with string gaps
lex_next_string cont s glaexts c buf = lex_string cont glaexts (c:s) buf
-lex_char :: (Int# -> Char -> P a) -> Int# -> P a
+lex_char :: (Int# -> Int -> P a) -> Int# -> P a
lex_char cont glaexts buf
= case currentChar# buf of
'\\'# -> lex_escape (cont glaexts) (incLexeme buf)
- c | is_any c -> cont glaexts (C# c) (incLexeme buf)
+ c | is_any c -> cont glaexts (I# (ord# c)) (incLexeme buf)
other -> charError buf
char_end cont glaexts c buf
lex_escape cont buf
= let buf' = incLexeme buf in
case currentChar# buf of
- 'a'# -> cont '\a' buf'
- 'b'# -> cont '\b' buf'
- 'f'# -> cont '\f' buf'
- 'n'# -> cont '\n' buf'
- 'r'# -> cont '\r' buf'
- 't'# -> cont '\t' buf'
- 'v'# -> cont '\v' buf'
- '\\'# -> cont '\\' buf'
- '"'# -> cont '\"' buf'
- '\''# -> cont '\'' buf'
+ 'a'# -> cont (ord '\a') buf'
+ 'b'# -> cont (ord '\b') buf'
+ 'f'# -> cont (ord '\f') buf'
+ 'n'# -> cont (ord '\n') buf'
+ 'r'# -> cont (ord '\r') buf'
+ 't'# -> cont (ord '\t') buf'
+ 'v'# -> cont (ord '\v') buf'
+ '\\'# -> cont (ord '\\') buf'
+ '"'# -> cont (ord '\"') buf'
+ '\''# -> cont (ord '\'') buf'
'^'# -> let c = currentChar# buf' in
if c `geChar#` '@'# && c `leChar#` '_'#
- then cont (C# (chr# (ord# c -# ord# '@'#))) (incLexeme buf')
+ then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf')
else charError buf'
'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex
_ -> case [ (c,buf2) | (p,c) <- silly_escape_chars,
Just buf2 <- [prefixMatch buf p] ] of
- (c,buf2):_ -> cont c buf2
+ (c,buf2):_ -> cont (ord c) buf2
[] -> charError buf'
-after_charnum cont i buf
- = let int = fromInteger i in
- if i >= 0 && i <= 255
- then cont (chr int) buf
+after_charnum cont i buf
+ = if i >= 0 && i <= 0x7FFFFFFF
+ then cont (fromInteger i) buf
else charError buf
readNum cont buf is_digit base conv = read buf 0
where lexeme = lexemeToFastString buf'
lex_id cont glaexts buf =
- case expandWhile# is_ident buf of { buf1 ->
+ let buf1 = expandWhile# is_ident buf in
+ seq buf1 $
case (if flag glaexts
then expandWhile# (eqChar# '#'#) buf1 -- slurp trailing hashes
cont kwd_token buf';
Nothing ->
- let var_token = cont (mk_var_token lexeme) buf' in
+ let var_token = cont (ITvarid lexeme) buf' in
if not (flag glaexts)
then var_token
Just kwd_token -> cont kwd_token buf';
Nothing -> var_token
- }}}}
+ }}}
lex_sym cont buf =
case expandWhile# is_symbol buf of
_ -> just_a_conid
'-'# -> case lookAhead# buf 1# of
- '>'# -> cont (ITqconid (mod,SLIT("->"))) (setCurrentPos# buf 2#)
+ '>'# -> 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
| otherwise = ITvarsym pk_str
where
(C# f) = _HEAD_ pk_str
- tl = _TAIL_ pk_str
mk_qvar_token m token =
case mk_var_token token of
projects / ghc-hetmet.git / blobdiff