+--------------------------------------------------------
+[Jan 98]
+There's a known bug in here:
+
+ If an interface file ends prematurely, Lex tries to
+ do headFS of an empty FastString.
+
+An example that provokes the error is
+
+ f _:_ _forall_ [a] <<<END OF FILE>>>
+--------------------------------------------------------
+
+
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Lexical analysis]{Lexical analysis}
\begin{code}
-#include "HsVersions.h"
-
module Lex (
isLexCon, isLexVar, isLexId, isLexSym,
mkTupNameStr, ifaceParseErr,
-- Monad for parser
- IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError,
+ IfaceToken(..), lexIface, IfM, thenIf, returnIf, getSrcLocIf,
+ checkVersion,
+ happyError,
StringBuffer
) where
+#include "HsVersions.h"
-IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper,isLower, isSpace, ord))
+import Char (isDigit, isAlphanum, isUpper,isLower, isSpace, ord )
+import List ( isSuffixOf )
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(Ubiq)
-IMPORT_DELOOPER(IdLoop) -- get the CostCentre type&constructors from here
-#else
import {-# SOURCE #-} CostCentre
-# if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char(..) )
-# endif
-#endif
-import CmdLineOpts ( opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoHiCheck )
import Demand ( Demand(..) {- instance Read -} )
import UniqFM ( UniqFM, listToUFM, lookupUFM)
import BasicTypes ( NewOrData(..), IfaceFlavour(..) )
+import SrcLoc ( SrcLoc, incSrcLine, srcLocFile )
-#if __GLASGOW_HASKELL__ >= 202
import Maybes ( MaybeErr(..) )
-#else
-import Maybes ( Maybe(..), MaybeErr(..) )
-#endif
-import Pretty
-
-
-
-import ErrUtils ( Error(..) )
-import Outputable ( Outputable(..), PprStyle(..) )
+import ErrUtils ( ErrMsg(..) )
+import Outputable
import Util ( nOfThem, panic )
import FastString
import StringBuffer
-
-#if __GLASGOW_HASKELL__ <= 201
-import PreludeGlaST
-#else
import GlaExts
-#endif
+import ST ( runST )
+
+import PrelRead ( readRational__ ) -- Glasgow non-std
\end{code}
%************************************************************************
of the information contained in the file turns out to be useful, so
delaying as much as possible of the scanning and parsing of an
interface file Makes Sense (Heap profiles of the compiler
-show at a reduction in heap usage by at least a factor of two,
+show a reduction in heap usage by at least a factor of two,
post-renamer).
Hence, the interface file lexer spots when value declarations are
| ITarity
| ITunfold Bool -- True <=> there's an INLINE pragma on this Id
| ITstrict [Demand] | ITbottom
+ | ITspecialise
| ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof
- | ITcoerce_in | ITcoerce_out | ITatsign
+ | ITcoerce | ITinline | ITatsign
| ITccall (Bool,Bool) -- (is_casm, may_gc)
| ITscc CostCentre
| ITchar Char | ITstring FAST_STRING
- | ITinteger Integer | ITdouble Double
+ | ITinteger Integer | ITrational Rational
| ITinteger_lit | ITfloat_lit | ITrational_lit | ITaddr_lit | ITlit_lit | ITstring_lit
| ITunknown String -- Used when the lexer can't make sense of it
| ITeof -- end of file token
-- whitespace and comments, ignore.
' '# -> lexIface cont (stepOn buf)
'\t'# -> lexIface cont (stepOn buf)
- '\n'# -> \line -> lexIface cont (stepOn buf) (line+1)
+ '\n'# -> \ loc -> lexIface cont (stepOn buf) (incSrcLine loc)
-- Numbers and comments
'-'# ->
_ -> cont ITobrack (stepOn buf)
']'# -> cont ITcbrack (stepOn buf)
','# -> cont ITcomma (stepOn buf)
- ':'# -> case lookAhead# buf 1# of
- ':'# -> cont ITdcolon (stepOnBy# buf 2#)
- _ -> lex_id cont (incLexeme buf)
';'# -> cont ITsemi (stepOn buf)
'\"'# -> case untilEndOfString# (stepOn buf) of
buf' ->
------------------
lex_demand cont buf =
--- _trace ("demand: "++[C# (currentChar# buf)]) $
case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
where
-- code snatched from Demand.lhs
read_em acc buf =
--- _trace ("read_em: "++[C# (currentChar# buf)]) $
case currentChar# buf of
'L'# -> read_em (WwLazy False : acc) (stepOn buf)
'A'# -> read_em (WwLazy True : acc) (stepOn buf)
------------------
lex_scc cont buf =
--- _trace ("scc: "++[C# (currentChar# buf)]) $
case currentChar# buf of
'"'# ->
-- YUCK^2
-- presence of floating point numbers in interface
-- files is not that common. (ToDo)
case expandWhile (isDigit) (incLexeme buf') of
- buf'' -> -- points to first non digit char
- case reads (lexemeToString buf'') of
- [(v,_)] -> cont (ITdouble v) (stepOverLexeme buf'')
+ buf2 -> -- points to first non digit char
+ let l = case currentChar# buf2 of
+ 'e'# -> let buf3 = incLexeme buf2 in
+ case currentChar# buf3 of
+ '-'# -> expandWhile (isDigit) (incLexeme buf3)
+ _ -> expandWhile (isDigit) buf3
+ _ -> buf2
+ in let v = readRational__ (lexemeToString l) in
+ cont (ITrational v) (stepOverLexeme l)
+
_ -> cont (ITinteger (fromInt (minus acc'))) (stepOverLexeme buf')
--- case reads (lexemeToString buf') of
--- [(i,_)] -> cont (ITinteger i) (stepOverLexeme buf')
+
------------
lex_keyword cont buf =
-----------
lex_cstring cont buf =
--- _trace ("lex_cstring: "++[C# (currentChar# buf)]) $
case expandUntilMatch buf "\'\'" of
buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
(stepOverLexeme buf')
-----------
lex_tuple cont module_dot buf =
--- _trace ("lex_tuple: "++[C# (currentChar# buf)]) $
go 2 buf
where
go n buf =
-- Similarly ' itself is ok inside an identifier, but not at the start
-id_arr :: _ByteArray Int
+-- id_arr is an array of bytes, indexed by characters,
+-- containing 0 if the character isn't a valid character from an identifier
+-- and 1 if it is. It's just a memo table for is_id_char.
+id_arr :: ByteArray Int
id_arr =
- unsafePerformPrimIO (
- newCharArray (0,255) `thenPrimIO` \ barr ->
+ runST (
+ newCharArray (0,255) >>= \ barr ->
let
- loop 256# = returnPrimIO ()
+ loop 256# = return ()
loop i# =
if isAlphanum (C# (chr# i#)) || is_sym (chr# i#) then
- writeCharArray barr (I# i#) '\1' `seqPrimIO`
+ writeCharArray barr (I# i#) '\1' >>
loop (i# +# 1#)
else
- writeCharArray barr (I# i#) '\0' `seqPrimIO`
+ writeCharArray barr (I# i#) '\0' >>
loop (i# +# 1#)
in
- loop 0# `seqPrimIO`
+ loop 0# >>
unsafeFreezeByteArray barr)
is_id_char (C# c#) =
let
- _ByteArray _ arr# = id_arr
+ ByteArray _ arr# = id_arr
in
case ord# (indexCharArray# arr# (ord# c#)) of
0# -> False
--OLD: is_id_char c@(C# c#) = isAlphanum c || is_sym c#
-is_sym c#=
+is_sym c# =
case c# of {
':'# -> True; '_'# -> True; '\''# -> True; '!'# -> True;
- '#'# -> True; '$'# -> True; ':'# -> True; '%'# -> True;
+ '#'# -> True; '$'# -> True; '%'# -> True;
'&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True;
'/'# -> True; '<'# -> True; '='# -> True; '>'# -> True;
'?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True;
--isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
-mod_arr :: _ByteArray Int
+-- mod_arr is an array of bytes, indexed by characters,
+-- containing 0 if the character isn't a valid character from a module name,
+-- and 1 if it is.
+mod_arr :: ByteArray Int
mod_arr =
- unsafePerformPrimIO (
- newCharArray (0,255) `thenPrimIO` \ barr ->
+ runST (
+ newCharArray (0,255) >>= \ barr ->
let
- loop 256# = returnPrimIO ()
+ loop 256# = return ()
loop i# =
if isAlphanum (C# (chr# i#)) || i# ==# (ord# '_'#) || i# ==# (ord# '\''#) then
- writeCharArray barr (I# i#) '\1' `seqPrimIO`
+ writeCharArray barr (I# i#) '\1' >>
loop (i# +# 1#)
else
- writeCharArray barr (I# i#) '\0' `seqPrimIO`
+ writeCharArray barr (I# i#) '\0' >>
loop (i# +# 1#)
in
- loop 0# `seqPrimIO`
+ loop 0# >>
unsafeFreezeByteArray barr)
is_mod_char (C# c#) =
let
- _ByteArray _ arr# = mod_arr
+ ByteArray _ arr# = mod_arr
in
case ord# (indexCharArray# arr# (ord# c#)) of
0# -> False
--isAlphanum c || c == '_' || c== '\'' --`elem` "_'"
-{-
-lex_id cs =
- case _scc_ "lex_id.span" my_span' (is_mod_char) cs of
- (xs, len, cs') ->
- case cs' of
- [] -> case xs of
- [] -> lex_id2 Nothing cs
- _ -> lex_id3 Nothing len xs cs
-
- '.':cs'' ->
- case xs of
- [] -> lex_id2 Nothing cs
- _ ->
- let
- pk_str = _PK_ (xs::String)
- len = lengthPS pk_str
- in
- if len==len+1 then
- error "Well, I never!"
- else
- lex_id2 (Just pk_str) cs''
- _ -> case xs of
- [] -> lex_id2 Nothing cs
- _ -> lex_id3 Nothing len xs cs'
-
--}
-
lex_id cont buf =
-- _trace ("lex_id: "++[C# (currentChar# buf)]) $
case expandWhile (is_mod_char) buf of
-- Dealt with [], (), : special cases
lex_id3 cont module_dot buf =
--- _trace ("lex_id3: "++[C# (currentChar# buf)]) $
case expandWhile (is_id_char) buf of
buf' ->
case module_dot of
new_buf = stepOverLexeme buf'
-{- OLD:
-lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs
-lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs
-lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs
-lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs
-lex_id2 module_dot xs cs = lex_id3 module_dot xs cs
--}
-
-- Dealt with [], (), : special cases
-
-{-
-lex_id3 module_dot len_xs xs cs =
- case my_span' (is_id_char) cs of
- (xs1,len_xs1,rest) ->
- case module_dot of
- Just m -> end_lex_id (Just m) (mk_var_token rxs) rest --OLD:_PK_ (reverse xs))) rest
- Nothing ->
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM rxs of
- Just kwd_token -> kwd_token : lexIface rest
- other -> token : lexIface cs end_lex_id Nothing (mk_var_token rxs) rest
- where
- rxs = packNChars (len_xs+len_xs1) (xs++xs1) -- OLD: _PK_ (reverse xs)
--}
mk_var_token pk_str =
let
f = _HEAD_ pk_str
else if isUpperISO f then ITconid pk_str
else ITvarsym pk_str
-{-
- mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n
- | f == ':' = ITconsym n
- | isAlpha f = ITvarid n
- | otherwise = ITvarsym n
- where
- n = _PK_ xs
--}
-
end_lex_id cont Nothing token buf = cont token buf
end_lex_id cont (Just (m,hif)) token buf =
case token of
,("declarations_", ITdeclarations)
,("pragmas_", ITpragmas)
,("forall_", ITforall)
- ,("U_", ITunfold False)
- ,("U!_", ITunfold True)
+ ,("u_", ITunfold False)
+ ,("U_", ITunfold True)
,("A_", ITarity)
- ,("coerce_in_", ITcoerce_in)
- ,("coerce_out_", ITcoerce_out)
+ ,("P_", ITspecialise)
+ ,("coerce_", ITcoerce)
+ ,("inline_", ITinline)
,("bot_", ITbottom)
,("integer_", ITinteger_lit)
,("rational_", ITrational_lit)
,("!", ITbang)
,("=>", ITdarrow)
,("=", ITequal)
+ ,("::", ITdcolon)
]
%************************************************************************
\begin{code}
-type IfM a = StringBuffer -> Int -> MaybeErr a Error
+type IfM a = StringBuffer -- Input string
+ -> SrcLoc
+ -> MaybeErr a ErrMsg
returnIf :: a -> IfM a
returnIf a s l = Succeeded a
Succeeded a -> k a s l
Failed err -> Failed err
+getSrcLocIf :: IfM SrcLoc
+getSrcLocIf s l = Succeeded l
+
happyError :: IfM a
happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-})
+
+{-
+ 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 -> IfM ()
+checkVersion mb@(Just v) s l
+ | (v==0) || (v == PROJECTVERSION) || opt_NoHiCheck = Succeeded ()
+ | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
+checkVersion mb@Nothing s l
+ | "hi-boot" `isSuffixOf` (_UNPK_ (srcLocFile l)) = Succeeded ()
+ | otherwise = Failed (ifaceVersionErr mb l ([]::[IfaceToken]){-Todo-})
+
-----------------------------------------------------------------
-ifaceParseErr l toks sty
- = hsep [ptext SLIT("Interface-file parse error: line"), int l, ptext SLIT("toks="), text (show (take 10 toks))]
+ifaceParseErr l toks
+ = hsep [ppr l, ptext SLIT("Interface-file parse error;"),
+ ptext SLIT("toks="), text (show (take 10 toks))]
+
+ifaceVersionErr hi_vers l toks
+ = hsep [ppr l, ptext SLIT("Interface file version error;"),
+ ptext SLIT("Expected"), int PROJECTVERSION,
+ ptext SLIT(" found "), pp_version]
+ where
+ pp_version =
+ case hi_vers of
+ Nothing -> ptext SLIT("pre ghc-3.02 version")
+ Just v -> ptext SLIT("version") <+> integer v
+
\end{code}
projects / ghc-hetmet.git / blobdiff