[project @ 2001-05-08 11:55:24 by simonmar]

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

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 8fdd6ad..1d02739 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -16,7 +16,7 @@ An example that provokes the error is
 --------------------------------------------------------
 
 \begin{code}
-
+{-# OPTIONS -#include "hs_ctype.h" #-}
 module Lex (
 
        ifaceParseErr, srcParseErr,
@@ -27,7 +27,7 @@ module Lex (
        StringBuffer,
 
        P, thenP, thenP_, returnP, mapP, failP, failMsgP,
-       getSrcLocP, getSrcFile,
+       getSrcLocP, setSrcLocP, getSrcFile,
        layoutOn, layoutOff, pushContext, popContext
     ) where
 
@@ -52,7 +52,7 @@ import FastString
 import StringBuffer
 import GlaExts
 import Ctype
-import Char            ( ord )
+import Char            ( chr, ord )
 import PrelRead        ( readRational__ ) -- Glasgow non-std
 \end{code}
 
@@ -397,8 +397,7 @@ lexer cont buf s@(PState{
                })
 
        -- first, start a new lexeme and lose all the whitespace
-  =  _scc_ "Lexer" 
-  tab line bol atbol (stepOverLexeme buf)
+  =  tab line bol atbol (stepOverLexeme buf)
   where
        line = srcLocLine loc
 
@@ -668,11 +667,12 @@ lex_prag cont buf
 lex_string cont glaexts s buf
   = case currentChar# buf of
        '"'#{-"-} -> 
-          let buf' = incLexeme buf; s' = mkFastStringInt (reverse s) in
-          case currentChar# buf' of
+          let buf' = incLexeme buf
+               s' = mkFastStringNarrow (map chr (reverse s)) 
+           in case currentChar# buf' of
                '#'# | flag glaexts -> if all (<= 0xFF) s
                     then cont (ITprimstring s') (incLexeme buf')
-                    else lexError "primitive string literal must contain only characters <= '\xFF'" buf'
+                    else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
                _                   -> cont (ITstring s') buf'
 
        -- ignore \& in a string, deal with string gaps
@@ -701,7 +701,7 @@ 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 (I# (ord# c)) (incLexeme buf)
+       c | is_string c -> cont glaexts (I# (ord# c)) (incLexeme buf)
        other -> charError buf
 
 char_end cont glaexts c buf
@@ -741,10 +741,7 @@ lex_escape cont buf
                            (c,buf2):_ -> cont (ord c) buf2
                            [] -> charError buf'
 
-after_charnum cont i buf
-  = if i >= 0 && i <= 0x7FFFFFFF
-       then cont (fromInteger i) buf
-       else charError buf
+after_charnum cont i buf = cont (fromInteger i) buf
 
 readNum cont buf is_digit base conv = read buf 0
   where read buf i 
@@ -919,7 +916,7 @@ lex_id cont glaexts buf =
 
  let lexeme  = lexemeToFastString buf' in
 
- case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+ case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
        Just kwd_token -> --trace ("hkeywd: "++_UNPK_(lexeme)) $
                          cont kwd_token buf';
        Nothing        -> 
@@ -1020,7 +1017,7 @@ lex_id3 cont glaexts mod buf just_a_conid
       new_buf     = mergeLexemes buf buf'
       is_a_qvarid = cont (mk_qvar_token mod lexeme) new_buf
      in
-     case _scc_ "Lex.haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
+     case _scc_ "haskellKeyword" lookupUFM haskellKeywordsFM lexeme of {
            Nothing          -> is_a_qvarid ;
 
            Just kwd_token | isSpecial kwd_token   -- special ids (as, qualified, hiding) shouldn't be
@@ -1179,6 +1176,13 @@ lexError str buf s@PState{ loc = loc }
 getSrcLocP :: P SrcLoc
 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
 
+-- use a temporary SrcLoc for the duration of the argument
+setSrcLocP :: SrcLoc -> P a -> P a
+setSrcLocP new_loc p buf s = 
+  case p buf s{ loc=new_loc } of
+       POk _ a   -> POk s a
+       PFailed e -> PFailed e
+
 getSrcFile :: P FAST_STRING
 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)