[project @ 1999-06-28 15:42:33 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 b484bcc..727039c 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -34,7 +34,7 @@ module Lex (
 
 #include "HsVersions.h"
 
-import Char            ( ord, isSpace )
+import Char            ( ord, isSpace, toUpper )
 import List             ( isSuffixOf )
 
 import IdInfo          ( InlinePragInfo(..), CprInfo(..) )
@@ -96,15 +96,13 @@ Laziness, you know it makes sense :-)
 
 \begin{code}
 data Token
-  = ITas                       -- Haskell keywords
-  | ITcase
+  = ITcase                     -- Haskell keywords
   | ITclass
   | ITdata
   | ITdefault
   | ITderiving
   | ITdo
   | ITelse
-  | IThiding
   | ITif
   | ITimport
   | ITin
@@ -116,10 +114,10 @@ data Token
   | ITmodule
   | ITnewtype
   | ITof
-  | ITqualified
   | ITthen
   | ITtype
   | ITwhere
+  | ITscc
 
   | ITforall                   -- GHC extension keywords
   | ITforeign
@@ -155,7 +153,7 @@ data Token
   | ITstrict ([Demand], Bool)
   | ITrules
   | ITcprinfo (CprInfo)
-  | ITscc
+  | IT__scc
   | ITsccAllCafs
 
   | ITspecialise_prag          -- Pragmas
@@ -235,6 +233,7 @@ pragmaKeywordsFM = listToUFM $
        ( "SOURCE",     ITsource_prag ),
        ( "INLINE",     ITinline_prag ),
        ( "NOINLINE",   ITnoinline_prag ),
+       ( "NOTINLINE",  ITnoinline_prag ),
        ( "LINE",       ITline_prag ),
        ( "RULES",      ITrules_prag ),
        ( "RULEZ",      ITrules_prag )  -- american spelling :-)
@@ -243,7 +242,6 @@ pragmaKeywordsFM = listToUFM $
 haskellKeywordsFM = listToUFM $
       map (\ (x,y) -> (_PK_ x,y))
        [( "_",         ITunderscore ),
-       ( "as",         ITas ),
        ( "case",       ITcase ),     
        ( "class",      ITclass ),    
        ( "data",       ITdata ),     
@@ -251,7 +249,6 @@ haskellKeywordsFM = listToUFM $
        ( "deriving",   ITderiving ), 
        ( "do",         ITdo ),       
        ( "else",       ITelse ),     
-       ( "hiding",     IThiding ),
        ( "if",         ITif ),       
        ( "import",     ITimport ),   
        ( "in",         ITin ),       
@@ -263,13 +260,12 @@ haskellKeywordsFM = listToUFM $
        ( "module",     ITmodule ),   
        ( "newtype",    ITnewtype ),  
        ( "of",         ITof ),       
-       ( "qualified",  ITqualified ),
        ( "then",       ITthen ),     
        ( "type",       ITtype ),     
-       ( "where",      ITwhere )
+       ( "where",      ITwhere ),
+       ( "_scc_",      ITscc )
      ]
 
-
 ghcExtensionKeywordsFM = listToUFM $
        map (\ (x,y) -> (_PK_ x,y))
      [ ( "forall",     ITforall ),
@@ -339,6 +335,10 @@ haskellKeySymsFM = listToUFM $
        ,("!",          ITbang)
        ,(".",          ITdot)          -- sadly, for 'forall a . t'
        ]
+
+not_special_op ITminus = False
+not_special_op ITbang  = False
+not_special_op _ = True
 \end{code}
 
 -----------------------------------------------------------------------------
@@ -400,7 +400,8 @@ lexer cont buf s@(PState{
                  if lookAhead# buf 3# `eqChar#` '#'# then is_a_token else
                  case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1->
                  case expandWhile# is_ident (stepOverLexeme buf1)   of { buf2->
-                 let lexeme = lexemeToFastString buf2 in
+                 let lexeme = mkFastString -- ToDo: too slow
+                                 (map toUpper (lexemeToString buf2)) in
                  case lookupUFM pragmaKeywordsFM lexeme of
                        Just ITline_prag -> line_prag (lexer cont) buf2 s'
                        Just other -> is_a_token
@@ -522,9 +523,8 @@ lexToken cont glaexts buf =
                (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
                _ -> lexError "too many '}'s" buf s
 
-    '#'# | flag glaexts 
-        -> case lookAhead# buf 1# of
-               ')'# -> cont ITcubxparen (setCurrentPos# buf 2#)
+    '#'# -> case lookAhead# buf 1# of
+               ')'#  | flag glaexts -> cont ITcubxparen (setCurrentPos# buf 2#)
                '-'# -> case lookAhead# buf 2# of
                           '}'# -> cont ITclose_prag (setCurrentPos# buf 3#)
                           _    -> lex_sym cont (incLexeme buf)
@@ -588,6 +588,7 @@ lexToken cont glaexts buf =
       | is_symbol c -> lex_sym cont buf
       | is_upper  c -> lex_con cont glaexts buf
       | is_ident  c -> lex_id  cont glaexts buf
+      | otherwise   -> lexError "illegal character" buf
 
 -- Int# is unlifted, and therefore faster than Bool for flags.
 {-# INLINE flag #-}
@@ -601,7 +602,7 @@ flag _  = True
 lex_prag cont buf
   = case expandWhile# is_space buf of { buf1 ->
     case expandWhile# is_ident (stepOverLexeme buf1) of { buf2 -> 
-    let lexeme = lexemeToFastString buf2 in
+    let lexeme = mkFastString (map toUpper (lexemeToString buf2)) in
     case lookupUFM pragmaKeywordsFM lexeme of
        Just kw -> cont kw (mergeLexemes buf buf2)
        Nothing -> panic "lex_prag"
@@ -977,8 +978,9 @@ lex_id3 cont glaexts mod buf just_a_conid
        new_buf = mergeLexemes buf buf'
      in
      case lookupUFM haskellKeySymsFM lexeme of {
-       Just kwd_token -> just_a_conid; -- avoid M.:: etc.
-       Nothing        -> cont (mk_qvar_token mod lexeme) new_buf
+       Just kwd_token | not_special_op kwd_token
+                       -> just_a_conid;        -- avoid M.::, but not M.!
+       other -> cont (mk_qvar_token mod lexeme) new_buf
      }}
 
   | otherwise   =
@@ -995,15 +997,11 @@ lex_id3 cont glaexts mod buf just_a_conid
      let
       lexeme  = lexemeToFastString buf'
       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 {
            Just kwd_token -> just_a_conid; -- avoid M.where etc.
-           Nothing        -> 
-     if flag glaexts
-       then case lookupUFM ghcExtensionKeywordsFM lexeme of {
-           Just kwd_token -> just_a_conid;
-           Nothing        -> cont (mk_qvar_token mod lexeme) new_buf }
-       else just_a_conid
+           Nothing        -> is_a_qvarid
      }}}