+ '_'# ->
+ case lookAhead# buf 1# of
+ 'S'# -> case lookAhead# buf 2# of
+ '_'# ->
+ lex_demand cont (stepOnUntil (not . isSpace)
+ (stepOnBy# buf 3#)) -- past _S_
+ 's'# -> case prefixMatch (stepOnBy# buf 2#) "cc_" of
+ Just buf' -> lex_scc cont (stepOnUntil (not . isSpace) (stepOverLexeme buf'))
+ Nothing -> lex_keyword cont (stepOnBy# buf 1#) -- drop the '_' and assume
+ -- it is a keyword.
+ _ -> lex_keyword cont (stepOn buf)
+
+ '\NUL'# ->
+ if bufferExhausted (stepOn buf) then
+ cont ITeof buf
+ else
+ lex_id cont buf
+ c ->
+ if isDigit (C# c) then
+ lex_num cont (id) (ord# c -# ord# '0'#) (incLexeme buf)
+ else
+ lex_id cont buf
+-- where
+lex_comment cont buf =
+-- _trace ("comment: "++[C# (currentChar# buf)]) $
+ case untilChar# buf '\n'# of {buf' -> lexIface cont (stepOverLexeme buf')}
+
+------------------
+lex_demand cont buf =
+ case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme 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)
+ ')'# -> (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#)
+ _ -> (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
+
+------------------
+lex_scc cont buf =
+ case currentChar# buf of
+ '"'# ->
+ -- YUCK^2
+ case prefixMatch (stepOn buf) "NO_CC\"" of
+ Just buf' -> cont (ITscc noCostCentre) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "CURRENT_CC\"" of
+ Just buf' -> cont (ITscc useCurrentCostCentre) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "OVERHEAD\"" of
+ Just buf' -> cont (ITscc overheadCostCentre) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "DONT_CARE\"" of
+ Just buf' -> cont (ITscc dontCareCostCentre) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "SUBSUMED\"" of
+ Just buf' -> cont (ITscc subsumedCosts) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "CAFs_in_...\"" of
+ Just buf' -> cont (ITscc preludeCafsCostCentre) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "CC_CAFs_in_..." of
+ Just buf' ->
+ case untilChar# (stepOverLexeme buf') '\"'# of
+ buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
+ Nothing ->
+ case prefixMatch (stepOn buf) "DICTs_in_...\"" of
+ Just buf' -> cont (ITscc (preludeDictsCostCentre True)) (stepOverLexeme buf')
+ Nothing ->
+ case prefixMatch (stepOn buf) "CC_DICTs_in_..." of
+ Just buf' ->
+ case untilChar# (stepOverLexeme buf') '\"'# of
+ buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True))
+ (stepOn (stepOverLexeme buf''))
+ Nothing ->
+ let
+ match_user_cc buf =
+ case untilChar# buf '/'# of
+ buf' ->
+ let mod_name = lexemeToFastString buf' in
+-- case untilChar# (stepOn (stepOverLexeme buf')) '/'# of
+-- buf'' ->
+-- let grp_name = lexemeToFastString buf'' in
+ case untilChar# (stepOn (stepOverLexeme buf')) '\"'# of
+ buf'' ->
+ -- The label may contain arbitrary characters, so it
+ -- may have been escaped etc., hence we `read' it in to get
+ -- rid of these meta-chars in the string and then pack it (again.)
+ -- ToDo: do the same for module name (single quotes allowed in m-names).
+ -- BTW, the code in this module is totally gruesome..
+ let upk_label = _UNPK_ (lexemeToFastString buf'') in
+ case reads ('"':upk_label++"\"") of
+ ((cc_label,_):_) ->
+ let cc_name = _PK_ cc_label in
+ (mkUserCC cc_name mod_name _NIL_{-grp_name-},
+ stepOn (stepOverLexeme buf''))
+ _ ->
+ trace ("trouble lexing scc label: " ++ upk_label ++ " , ignoring")
+ (mkUserCC _NIL_ mod_name _NIL_{-grp_name-},
+ stepOn (stepOverLexeme buf''))
+ in
+ case prefixMatch (stepOn buf) "CAF:" of
+ Just buf' ->
+ case match_user_cc (stepOverLexeme buf') of
+ (cc, buf'') -> cont (ITscc (cafifyCC cc)) buf''
+ Nothing ->
+ case match_user_cc (stepOn buf) of
+ (cc, buf'') -> cont (ITscc cc) buf''
+ c -> cont (ITunknown [C# c]) (stepOn buf)
+
+
+-----------
+lex_num :: (IfaceToken -> IfM a) ->
+ (Int -> Int) -> Int# -> IfM a
+lex_num cont minus acc# buf =
+-- _trace ("lex_num: "++[C# (currentChar# buf)]) $
+ case scanNumLit (I# acc#) buf of
+ (acc',buf') ->
+ case currentChar# buf' of
+ '.'# ->
+ -- this case is not optimised at all, as the
+ -- presence of floating point numbers in interface
+ -- files is not that common. (ToDo)
+ case expandWhile (isDigit) (incLexeme buf') of
+ 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')
+
+
+
+------------
+lex_keyword cont buf =
+-- _trace ("lex_keyword: "++[C# (currentChar# buf)]) $
+ case currentChar# buf of
+ ':'# -> case lookAhead# buf 1# of
+ '_'# -> -- a binding, type (and other id-info) follows,
+ -- to make the parser ever so slightly, we push
+ --
+ lex_decl cont (stepOnBy# buf 2#)
+ v# -> cont (ITunknown (['_',':',C# v#])) (stepOnBy# buf 2#)
+ _ ->
+ case expandWhile (is_kwd_char) buf of
+ buf' ->
+ let kw = lexemeToFastString buf' in
+-- _trace ("kw: "++lexemeToString buf') $
+ case lookupUFM ifaceKeywordsFM kw of
+ Nothing -> cont (ITunknown (_UNPK_ kw)) -- (minor) sigh
+ (stepOverLexeme buf')
+ Just xx -> cont xx (stepOverLexeme buf')
+
+lex_decl cont buf =
+ case doDiscard False buf of -- spin until ;; is found
+ buf' ->
+ {- _trace (show (lexemeToString buf')) $ -}
+ case currentChar# buf' of
+ '\n'# -> -- newline, no id info.
+ cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
+ (stepOverLexeme buf')
+ '\r'# -> -- just to be sure for those Win* boxes..
+ cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
+ (stepOverLexeme buf')
+ '\NUL'# ->
+ cont (ITtysig (lexemeToBuffer (decLexeme buf')) Nothing)
+ (stepOverLexeme buf')
+ c -> -- run all over the id info
+ case doDiscard False (stepOverLexeme buf') of -- spin until ;; is found (outside a string!)
+ buf'' ->
+ --_trace ((C# c):show (lexemeToString (decLexeme buf'))) $
+ --_trace (show (lexemeToString (decLexeme buf''))) $
+ let idinfo =
+ if opt_IgnoreIfacePragmas then
+ Nothing
+ else
+ Just (lexemeToBuffer (decLexeme buf''))
+ --_trace (show is) $
+ in
+ cont (ITtysig (lexemeToBuffer (decLexeme buf')) idinfo)
+ (stepOverLexeme buf'')
+
+-- ToDo: hammer!
+is_kwd_char c@(C# c#) =
+ isAlphanum c || -- OLD: c `elem` "_@/\\"
+ (case c# of
+ '_'# -> True
+ '@'# -> True
+ '/'# -> True
+ '\\'# -> True
+ _ -> False)
+
+
+
+-----------
+lex_cstring cont buf =
+ case expandUntilMatch buf "\'\'" of
+ buf' -> cont (ITstring (lexemeToFastString (setCurrentPos# buf' (negateInt# 2#))))
+ (stepOverLexeme buf')
+
+-----------
+lex_tuple cont module_dot buf =
+ go 2 buf