[project @ 2001-09-28 23:41:00 by sof]

[ghc-hetmet.git] / ghc / compiler / parser / Lex.lhs

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index b4c9bc4..0d04782 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -36,7 +36,6 @@ module Lex (
 import Char            ( isSpace, toUpper )
 import List             ( isSuffixOf )
 
-import IdInfo          ( InlinePragInfo(..) )
 import PrelNames       ( mkTupNameStr )
 import CmdLineOpts     ( opt_HiVersion, opt_NoHiCheck )
 import ForeignCall     ( Safety(..) )
@@ -152,7 +151,7 @@ data Token
   | ITarity 
   | ITspecialise
   | ITnocaf
-  | ITunfold InlinePragInfo
+  | ITunfold
   | ITstrict StrictSig
   | ITrules
   | ITcprinfo
@@ -346,7 +345,7 @@ ghcExtensionKeywordsFM = listToUFM $
        ("__C",                 ITnocaf),
        ("__R",                 ITrules),
         ("__D",                        ITdeprecated),
-        ("__U",                        ITunfold NoInlinePragInfo),
+        ("__U",                        ITunfold),
        
         ("__ccall",            ITccall (False, False, PlayRisky)),
         ("__ccall_GC",         ITccall (False, False, PlaySafe)),
@@ -406,7 +405,7 @@ lexer cont buf s@(PState{
   where
        line = srcLocLine loc
 
-       tab y bol atbol buf = -- trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
+       tab y bol atbol buf = --trace ("tab: " ++ show (I# y) ++ " : " ++ show (currentChar buf)) $
          case currentChar# buf of
 
            '\NUL'# ->
@@ -451,7 +450,7 @@ lexer cont buf s@(PState{
 
                else skip_to_end (stepOnBy# buf 2#) s'
                where
-                   skip_to_end = nested_comment (lexer cont)
+                   skip_to_end = skipNestedComment (lexer cont)
 
                -- special GHC extension: we grok cpp-style #line pragmas
            '#'# | lexemeIndex buf ==# bol ->   -- the '#' must be in column 0
@@ -497,26 +496,34 @@ line_prag cont buf s@PState{loc=loc} =
      _other -> cont (stepOverLexeme buf3) s{loc = replaceSrcLine loc l}
   }}}}
 
-nested_comment :: P a -> P a
-nested_comment cont buf = loop buf
+skipNestedComment :: P a -> P a
+skipNestedComment cont buf state = skipNestedComment' (loc state) cont buf state
+
+skipNestedComment' :: SrcLoc -> P a -> P a
+skipNestedComment' orig_loc cont buf = loop buf
  where
    loop buf = 
      case currentChar# buf of
-       '\NUL'# | bufferExhausted (stepOn buf) -> 
-               lexError "unterminated `{-'" buf -- -}
-       '-'# | lookAhead# buf 1# `eqChar#` '}'# ->
-               cont (stepOnBy# buf 2#)
+       '-'# | lookAhead# buf 1# `eqChar#` '}'# -> cont (stepOnBy# buf 2#)
 
        '{'# | lookAhead# buf 1# `eqChar#` '-'# ->
-             nested_comment (nested_comment cont) (stepOnBy# buf 2#)
+             skipNestedComment 
+               (skipNestedComment' orig_loc cont) 
+               (stepOnBy# buf 2#)
 
        '\n'# -> \ s@PState{loc=loc} ->
                 let buf' = stepOn buf in
-                nested_comment cont buf'
-                       s{loc = incSrcLine loc, bol = currentIndex# buf',
-                         atbol = 1#}
+                loop buf' s{loc = incSrcLine loc, 
+                            bol = currentIndex# buf',
+                            atbol = 1#}
 
-       _   -> nested_comment cont (stepOn buf)
+       -- pass the original SrcLoc to lexError so that the error is
+       -- reported at the line it was originally on, not the line at
+       -- the end of the file.
+       '\NUL'# | bufferExhausted (stepOn buf) -> 
+               \s -> lexError "unterminated `{-'" buf s{loc=orig_loc} -- -}
+
+       _   -> loop (stepOn buf)
 
 -- When we are lexing the first token of a line, check whether we need to
 -- insert virtual semicolons or close braces due to layout.
@@ -556,7 +563,7 @@ lexBOL cont buf s@(PState{
 
 lexToken :: (Token -> P a) -> Int# -> P a
 lexToken cont glaexts buf =
- -- trace "lexToken" $
+-- trace "lexToken" $
   case currentChar# buf of
 
     -- special symbols ----------------------------------------------------
@@ -599,9 +606,11 @@ lexToken cont glaexts buf =
           '-'# -> case lookAhead# buf 2# of
                    '#'# -> case lookAhead# buf 3# of
                                '#'# -> 
-                                  let (lexeme, buf') 
-                                         = doDiscard 0# (stepOnBy# (stepOverLexeme buf) 4#) in
-                                            cont (ITpragma lexeme) buf'
+                                  lexPragma
+                                     cont
+                                     (\ cont lexeme buf' -> cont (ITpragma lexeme) buf')
+                                     0#
+                                     (stepOnBy# (stepOverLexeme buf) 4#)
                                _ -> lex_prag cont (setCurrentPos# buf 3#)
                    _    -> cont ITocurly (incLexeme buf) 
           _ -> (layoutOff `thenP_` cont ITocurly)  (incLexeme buf) 
@@ -1114,20 +1123,21 @@ lex_ubx_tuple cont mod buf back_off =
 \end{code}
 
 -----------------------------------------------------------------------------
-doDiscard rips along really fast, looking for a '##-}', 
+'lexPragma' rips along really fast, looking for a '##-}', 
 indicating the end of the pragma we're skipping
 
 \begin{code}
-doDiscard inStr buf =
+lexPragma cont contf inStr buf =
  case currentChar# buf of
    '#'# | inStr ==# 0# ->
        case lookAhead# buf 1# of { '#'# -> 
        case lookAhead# buf 2# of { '-'# ->
        case lookAhead# buf 3# of { '}'# -> 
-          (lexemeToBuffer buf, stepOverLexeme (setCurrentPos# buf 4#));
-       _    -> doDiscard inStr (incLexeme buf) };
-        _    -> doDiscard inStr (incLexeme buf) };
-        _    -> doDiscard inStr (incLexeme buf) }
+           contf cont (lexemeToBuffer buf)
+                     (stepOverLexeme (setCurrentPos# buf 4#));
+       _    -> lexPragma cont contf inStr (incLexeme buf) };
+        _    -> lexPragma cont contf inStr (incLexeme buf) };
+        _    -> lexPragma cont contf inStr (incLexeme buf) }
 
    '"'# ->
        let
@@ -1142,19 +1152,24 @@ doDiscard inStr buf =
         '\\'# -> -- escaping something..
           if odd_slashes buf True (negateInt# 2#) 
                then  -- odd number of slashes, " is escaped.
-                     doDiscard inStr (incLexeme buf)
+                     lexPragma cont contf inStr (incLexeme buf)
                else  -- even number of slashes, \ is escaped.
-                     doDiscard not_inStr (incLexeme buf)
-         _ -> doDiscard not_inStr (incLexeme buf)
+                     lexPragma cont contf not_inStr (incLexeme buf)
+         _ -> lexPragma cont contf not_inStr (incLexeme buf)
 
    '\''# | inStr ==# 0# ->
        case lookAhead# buf 1# of { '"'# ->
        case lookAhead# buf 2# of { '\''# ->
-          doDiscard inStr (setCurrentPos# buf 3#);
-       _ -> doDiscard inStr (incLexeme buf) };
-       _ -> doDiscard inStr (incLexeme buf) }
+          lexPragma cont contf inStr (setCurrentPos# buf 3#);
+       _ -> lexPragma cont contf inStr (incLexeme buf) };
+       _ -> lexPragma cont contf inStr (incLexeme buf) }
+
+    -- a sign that the input is ill-formed, since pragmas are
+    -- assumed to always be properly closed (in .hi files).
+   '\NUL'# -> trace "lexPragma: unexpected end-of-file" $ 
+             cont (ITunknown "\NUL") buf
 
-   _ -> doDiscard inStr (incLexeme buf)
+   _ -> lexPragma cont contf inStr (incLexeme buf)
 
 \end{code}