[project @ 1999-01-18 19:04:55 by sof]

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

diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index 75c12a6..11d5774 100644 (file)
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -37,9 +37,9 @@ import List             ( isSuffixOf )
 
 import CostCentre      -- Pretty much all of it
 import IdInfo          ( InlinePragInfo(..) )
-import Name            ( mkTupNameStr, mkUbxTupNameStr, 
-                         isLowerISO, isUpperISO )
+import Name            ( isLowerISO, isUpperISO, mkModule )
 
+import PrelMods                ( mkTupNameStr, mkUbxTupNameStr )
 import CmdLineOpts     ( opt_IgnoreIfacePragmas, opt_HiVersion, opt_NoHiCheck )
 import Demand          ( Demand(..) {- instance Read -} )
 import UniqFM           ( UniqFM, listToUFM, lookupUFM)
@@ -47,7 +47,7 @@ import BasicTypes     ( NewOrData(..), IfaceFlavour(..) )
 import SrcLoc          ( SrcLoc, incSrcLine, srcLocFile )
 
 import Maybes          ( MaybeErr(..) )
-import ErrUtils                ( ErrMsg )
+import ErrUtils                ( Message )
 import Outputable
 
 import FastString
@@ -127,7 +127,7 @@ data IfaceToken
   | ITletrec 
   | ITcoerce
   | ITinline
-  | ITccall (Bool,Bool)        -- (is_casm, may_gc)
+  | ITccall (Bool,Bool,Bool)   -- (is_dyn, is_casm, may_gc)
   | ITdefaultbranch
   | ITbottom
   | ITinteger_lit 
@@ -141,7 +141,7 @@ data IfaceToken
   | ITspecialise
   | ITnocaf
   | ITunfold InlinePragInfo
-  | ITstrict [Demand] 
+  | ITstrict ([Demand], Bool)
   | ITscc CostCentre
 
   | ITdotdot                   -- reserved symbols
@@ -217,7 +217,7 @@ lexIface cont buf =
 -- Numbers and comments
     '-'#  ->
       case lookAhead# buf 1# of
-        '-'# -> lex_comment cont (stepOnBy# buf 2#)
+--        '-'# -> lex_comment cont (stepOnBy# buf 2#)
         c    -> 
          if is_digit c
           then lex_num cont (negate) (ord# c -# ord# '0'#) (incLexeme (incLexeme buf))
@@ -331,7 +331,11 @@ lex_nested_comment cont buf =
 -------------------------------------------------------------------------------
 
 lex_demand cont buf = 
- case read_em [] buf of { (ls,buf') -> cont (ITstrict ls) (stepOverLexeme buf')}
+ case read_em [] buf of { (ls,buf') -> 
+ case currentChar# buf' of
+   'B'# -> cont (ITstrict (ls, True )) (stepOverLexeme (stepOn buf'))
+   _    -> cont (ITstrict (ls, False)) (stepOverLexeme buf')
+ }
  where
    -- code snatched from Demand.lhs
   read_em acc buf = 
@@ -359,19 +363,20 @@ lex_scc cont buf =
         case prefixMatch (stepOn buf) "CAFs." of
          Just buf' ->
           case untilChar# (stepOverLexeme buf') '\"'# of
-           buf'' -> cont (ITscc (mkAllCafsCC ({-module-}lexemeToFastString buf'') _NIL_)) (stepOn (stepOverLexeme buf''))
+           buf'' -> cont (ITscc (mkAllCafsCC (mkModule (lexemeToString buf'')) _NIL_)) 
+                        (stepOn (stepOverLexeme buf''))
          Nothing ->
             case prefixMatch (stepOn buf) "DICTs." of
              Just buf' ->
               case untilChar# (stepOverLexeme buf') '\"'# of
-               buf'' -> cont (ITscc (mkAllDictsCC (lexemeToFastString buf'') _NIL_ True)) 
+               buf'' -> cont (ITscc (mkAllDictsCC (mkModule (lexemeToString buf'')) _NIL_ True)) 
                         (stepOn (stepOverLexeme buf''))
              Nothing ->
              let
               match_user_cc buf =
                 case untilChar# buf '/'# of
                  buf' -> 
-                  let mod_name = lexemeToFastString buf' in
+                  let mod_name = mkModule (lexemeToString buf') in
 --                       case untilChar# (stepOn (stepOverLexeme buf')) '/'# of
 --                        buf'' -> 
 --                            let grp_name = lexemeToFastString buf'' in
@@ -481,7 +486,10 @@ lex_id cont buf =
 
 lex_sym cont buf =
  case expandWhile# is_symbol buf of
-   buf' -> case lookupUFM haskellKeySymsFM lexeme of {
+   buf'
+     | is_comment lexeme -> lex_comment cont new_buf
+     | otherwise         ->
+          case lookupUFM haskellKeySymsFM lexeme of {
                Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $
                                  cont kwd_token new_buf ;
                Nothing        -> --trace ("sym: "++unpackFS lexeme) $
@@ -490,6 +498,15 @@ lex_sym cont buf =
        where lexeme = lexemeToFastString buf'
              new_buf = stepOverLexeme buf'
 
+             is_comment fs 
+               | len < 2   = False
+               | otherwise = trundle 0
+                 where
+                  len = lengthFS fs
+                  
+                  trundle n | n == len  = True
+                            | otherwise = indexFS fs n == '-' && trundle (n+1)
+
 lex_con cont buf = 
  case expandWhile# is_ident buf of       { buf1 ->
  case expandWhile# (eqChar# '#'#) buf1 of { buf' ->
@@ -639,10 +656,13 @@ ifaceKeywordsFM = listToUFM $
         ("__Unot",             ITunfold IMustNotBeINLINEd),
         ("__Ux",               ITunfold IAmALoopBreaker),
        
-        ("__ccall",            ITccall (False, False)),
-        ("__ccall_GC",         ITccall (False, True)),
-        ("__casm",             ITccall (True,  False)),
-        ("__casm_GC",          ITccall (True,  True)),
+        ("__ccall",            ITccall (False, False, False)),
+        ("__dyn_ccall",                ITccall (True,  False, False)),
+        ("__dyn_ccall_GC",     ITccall (True,  False, True)),
+        ("__casm",             ITccall (False, True,  False)),
+        ("__dyn_casm",         ITccall (True,  True,  False)),
+        ("__casm_GC",          ITccall (False, True,  True)),
+        ("__dyn_casm_GC",      ITccall (True,  True,  True)),
 
         ("/\\",                        ITbiglam)
        ]
@@ -669,10 +689,14 @@ haskellKeywordsFM = listToUFM $
        ( "of",         ITof ),       
        ( "then",       ITthen ),     
        ( "type",       ITtype ),     
-       ( "where",      ITwhere ),    
-       ( "as",         ITas ),       
-       ( "qualified",  ITqualified ),
-       ( "hiding",     IThiding )
+       ( "where",      ITwhere )
+
+--     These three aren't Haskell keywords at all
+--     and 'as' is often used as a variable name
+--     ( "as",         ITas ),       
+--     ( "qualified",  ITqualified ),
+--     ( "hiding",     IThiding )
+
      ]
 
 haskellKeySymsFM = listToUFM $
@@ -734,7 +758,7 @@ doDiscard inStr buf =
 \begin{code}
 type IfM a = StringBuffer      -- Input string
          -> SrcLoc
-         -> MaybeErr a ErrMsg
+         -> MaybeErr a {-error-}Message
 
 returnIf   :: a -> IfM a
 returnIf a s l = Succeeded a
@@ -749,7 +773,7 @@ getSrcLocIf :: IfM SrcLoc
 getSrcLocIf s l = Succeeded l
 
 happyError :: IfM a
-happyError s l = Failed (ifaceParseErr l ([]::[IfaceToken]){-Todo-})
+happyError s l = Failed (ifaceParseErr s l)
 
 
 {- 
@@ -777,9 +801,12 @@ checkVersion mb@Nothing  s l
 
 -----------------------------------------------------------------
 
-ifaceParseErr l toks
+ifaceParseErr :: StringBuffer -> SrcLoc -> Message
+ifaceParseErr s l
   = hsep [ppr l, ptext SLIT("Interface-file parse error;"),
-          ptext SLIT("toks="), text (show (take 10 toks))]
+          ptext SLIT("current input ="), text first_bit]
+  where
+    first_bit = lexemeToString (stepOnBy# s 100#) 
 
 ifaceVersionErr hi_vers l toks
   = hsep [ppr l, ptext SLIT("Interface file version error;"),