[project @ 1999-08-02 09:47:18 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..e1de35a 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(..) )
@@ -120,6 +120,7 @@ data Token
   | ITthen
   | ITtype
   | ITwhere
+  | ITscc
 
   | ITforall                   -- GHC extension keywords
   | ITforeign
@@ -146,8 +147,8 @@ data Token
   | ITlit_lit
   | ITstring_lit
   | ITtypeapp
-  | ITonce
-  | ITmany
+  | ITusage
+  | ITfuall
   | ITarity 
   | ITspecialise
   | ITnocaf
@@ -155,7 +156,7 @@ data Token
   | ITstrict ([Demand], Bool)
   | ITrules
   | ITcprinfo (CprInfo)
-  | ITscc
+  | IT__scc
   | ITsccAllCafs
 
   | ITspecialise_prag          -- Pragmas
@@ -235,6 +236,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 :-)
@@ -266,10 +268,10 @@ haskellKeywordsFM = listToUFM $
        ( "qualified",  ITqualified ),
        ( "then",       ITthen ),     
        ( "type",       ITtype ),     
-       ( "where",      ITwhere )
+       ( "where",      ITwhere ),
+       ( "_scc_",      ITscc )
      ]
 
-
 ghcExtensionKeywordsFM = listToUFM $
        map (\ (x,y) -> (_PK_ x,y))
      [ ( "forall",     ITforall ),
@@ -302,13 +304,13 @@ ghcExtensionKeywordsFM = listToUFM $
        ("__litlit",            ITlit_lit),
        ("__string",            ITstring_lit),
        ("__a",                 ITtypeapp),
-       ("__o",                 ITonce),
-       ("__m",                 ITmany),
+       ("__u",                 ITusage),
+       ("__fuall",             ITfuall),
        ("__A",                 ITarity),
        ("__P",                 ITspecialise),
        ("__C",                 ITnocaf),
        ("__R",                 ITrules),
-        ("__u",                        ITunfold NoInlinePragInfo),
+        ("__U",                        ITunfold NoInlinePragInfo),
        
         ("__ccall",            ITccall (False, False, False)),
         ("__ccall_GC",         ITccall (False, False, True)),
@@ -400,7 +402,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
@@ -520,11 +523,10 @@ lexToken cont glaexts buf =
     '}'# -> \ s@PState{context = ctx} ->
            case ctx of 
                (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'}
-               _ -> lexError "too many '}'s" buf s
+               _        -> 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 +590,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 +604,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"
@@ -700,8 +703,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#
@@ -976,10 +979,9 @@ lex_id3 cont glaexts mod buf just_a_conid
        -- real lexeme is M.<sym>
        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
-     }}
+     cont (mk_qvar_token mod lexeme) new_buf
+       -- wrong, but arguably morally right: M... is now a qvarsym
+     }
 
   | otherwise   =
      let 
@@ -995,15 +997,13 @@ 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
+       -- TODO: special ids (as, qualified, hiding) shouldn't be
+       -- recognised as keywords here.  ie.  M.as is a qualified varid.
      }}}
 
 
@@ -1198,13 +1198,25 @@ h = h
        - we still need to insert another '}' followed by a ';',
          hence the atbol trick.
 
+There's also a special hack in here to deal with
+
+       do
+          ....
+          e $ do
+          blah
+
+i.e. the inner context is at the same indentation level as the outer
+context.  This is strictly illegal according to Haskell 98, but
+there's a lot of existing code using this style and it doesn't make
+any sense to disallow it, since empty 'do' lists don't make sense.
 -}
 
-layoutOn :: P ()
-layoutOn buf s@(PState{ bol = bol, context = ctx }) =
+layoutOn :: Bool -> P ()
+layoutOn strict buf s@(PState{ bol = bol, context = ctx }) =
     let offset = lexemeIndex buf -# bol in
     case ctx of
-       Layout prev_off : _ | prev_off >=# offset ->
+       Layout prev_off : _ 
+          | if strict then prev_off >=# offset else prev_off ># offset ->
                --trace ("layout on, column: " ++  show (I# offset)) $
                POk s{ context = Layout (offset +# 1#) : ctx, atbol = 1# } ()
        other ->