[project @ 2000-01-28 20:52:37 by lewie]

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

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 5528052..8dae914 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -128,6 +128,9 @@ data Token
   | ITlabel
   | ITdynamic
   | ITunsafe
+  | ITwith
+  | ITstdcallconv
+  | ITccallconv
 
   | ITinterface                        -- interface keywords
   | IT__export
@@ -182,7 +185,6 @@ data Token
   | ITdot
 
   | ITbiglam                   -- GHC-extension symbols
-  | IThash
 
   | ITocurly                   -- special symbols
   | ITccurly
@@ -207,6 +209,8 @@ data Token
   | ITqvarsym (FAST_STRING,FAST_STRING)
   | ITqconsym (FAST_STRING,FAST_STRING)
 
+  | ITipvarid FAST_STRING      -- GHC extension: implicit param: ?x
+
   | ITpragma StringBuffer
 
   | ITchar       Char 
@@ -281,6 +285,9 @@ ghcExtensionKeywordsFM = listToUFM $
        ( "label",      ITlabel ),
        ( "dynamic",    ITdynamic ),
        ( "unsafe",     ITunsafe ),
+       ( "with",       ITwith ),
+       ( "stdcall",    ITstdcallconv),
+       ( "ccall",      ITccallconv),
         ("_ccall_",    ITccall (False, False, False)),
         ("_ccall_GC_", ITccall (False, False, True)),
         ("_casm_",     ITccall (False, True,  False)),
@@ -366,7 +373,8 @@ lexer cont buf s@(PState{
                })
 
        -- first, start a new lexeme and lose all the whitespace
-  = tab line bol atbol (stepOverLexeme buf)
+  =  _scc_ "Lexer" 
+  tab line bol atbol (stepOverLexeme buf)
   where
        line = srcLocLine loc
 
@@ -506,7 +514,6 @@ lexBOL cont buf s@(PState{
 lexToken :: (Token -> P a) -> Int# -> P a
 lexToken cont glaexts buf =
  --trace "lexToken" $
- _scc_ "Lexer" 
   case currentChar# buf of
 
     -- special symbols ----------------------------------------------------
@@ -587,6 +594,8 @@ lexToken cont glaexts buf =
               trace "lexIface: misplaced NUL?" $ 
               cont (ITunknown "\NUL") (stepOn buf)
 
+    '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+           lex_ip cont (setCurrentPos# buf 1#)
     c | is_digit  c -> lex_num cont glaexts 0 buf
       | is_symbol c -> lex_sym cont buf
       | is_upper  c -> lex_con cont glaexts buf
@@ -624,9 +633,9 @@ lex_string cont glaexts s buf
 
        -- ignore \& in a string, deal with string gaps
        '\\'# | next_ch `eqChar#` '&'# 
-               -> lex_string cont glaexts s (setCurrentPos# buf 2#)
+               -> lex_string cont glaexts s buf'
              | is_space next_ch
-               -> lex_stringgap cont glaexts s buf'
+               -> lex_stringgap cont glaexts s (incLexeme buf)
 
            where next_ch = lookAhead# buf 1#
                  buf' = setCurrentPos# buf 2#
@@ -704,8 +713,8 @@ readNum cont buf is_digit base conv = read buf 0
 
 is_hexdigit c 
        =  is_digit c 
-       || (c `geChar#` 'a'# && c `leChar#` 'h'#)
-       || (c `geChar#` 'A'# && c `leChar#` 'H'#)
+       || (c `geChar#` 'a'# && c `leChar#` 'f'#)
+       || (c `geChar#` 'A'# && c `leChar#` 'F'#)
 
 hex c | is_digit c = ord# c -# ord# '0'#
       | otherwise  = ord# (to_lower c) -# ord# 'a'# +# 10#
@@ -861,9 +870,10 @@ after_lexnum cont glaexts i buf
 
 lex_cstring cont buf =
  case expandUntilMatch (stepOverLexeme buf) "\'\'" of
-   buf' -> cont (ITlitlit (lexemeToFastString 
+   Just buf' -> cont (ITlitlit (lexemeToFastString 
                                (setCurrentPos# buf' (negateInt# 2#))))
-               (mergeLexemes buf buf')
+                  (mergeLexemes buf buf')
+   Nothing   -> lexError "unterminated ``" buf
 
 ------------------------------------------------------------------------------
 -- Character Classes
@@ -888,12 +898,18 @@ is_ident  = is_ctype 1
 is_symbol = is_ctype 2
 is_any    = is_ctype 4
 is_space  = is_ctype 8
-is_upper  = is_ctype 16
-is_digit  = is_ctype 32
+is_lower  = is_ctype 16
+is_upper  = is_ctype 32
+is_digit  = is_ctype 64
 
 -----------------------------------------------------------------------------
 -- identifiers, symbols etc.
 
+lex_ip cont buf =
+ case expandWhile# is_ident buf of
+   buf' -> cont (ITipvarid lexeme) buf'
+          where lexeme = lexemeToFastString buf'
+
 lex_id cont glaexts buf =
  case expandWhile# is_ident buf of { buf1 ->