[project @ 2001-09-24 11:27:31 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 7aed428..b4c9bc4 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -40,7 +40,8 @@ import IdInfo         ( InlinePragInfo(..) )
 import PrelNames       ( mkTupNameStr )
 import CmdLineOpts     ( opt_HiVersion, opt_NoHiCheck )
 import ForeignCall     ( Safety(..) )
-import Demand          ( Demand(..) {- instance Read -} )
+import NewDemand       ( StrictSig(..), Demand(..), Keepity(..), 
+                         DmdResult(..), mkTopDmdType )
 import UniqFM           ( listToUFM, lookupUFM )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
@@ -152,7 +153,7 @@ data Token
   | ITspecialise
   | ITnocaf
   | ITunfold InlinePragInfo
-  | ITstrict ([Demand], Bool)
+  | ITstrict StrictSig
   | ITrules
   | ITcprinfo
   | ITdeprecated
@@ -439,6 +440,9 @@ lexer cont buf s@(PState{
                  let lexeme = mkFastString -- ToDo: too slow
                                  (map toUpper (lexemeToString buf2)) in
                  case lookupUFM pragmaKeywordsFM lexeme of
+                       -- ignore RULES pragmas when -fglasgow-exts is off
+                       Just ITrules_prag | not (flag glaexts) ->
+                          skip_to_end (stepOnBy# buf 2#) s'
                        Just ITline_prag -> 
                           line_prag skip_to_end buf2 s'
                        Just other -> is_a_token
@@ -818,27 +822,37 @@ silly_escape_chars = [
 lex_demand cont buf = 
  case read_em [] buf of { (ls,buf') -> 
  case currentChar# buf' of
-   'B'# -> cont (ITstrict (ls, True )) (incLexeme buf')
-   _    -> cont (ITstrict (ls, False)) buf'
+   'b'# -> cont (ITstrict (StrictSig (mkTopDmdType ls BotRes))) (incLexeme buf')
+   'm'# -> cont (ITstrict (StrictSig (mkTopDmdType ls RetCPR))) (incLexeme buf')
+   _    -> cont (ITstrict (StrictSig (mkTopDmdType ls TopRes))) buf'
  }
  where
-   -- code snatched from Demand.lhs
   read_em acc buf = 
    case currentChar# buf of
-    'L'# -> read_em (WwLazy False : acc) (stepOn buf)
-    'A'# -> read_em (WwLazy True  : acc) (stepOn buf)
-    'S'# -> read_em (WwStrict     : acc) (stepOn buf)
-    'P'# -> read_em (WwPrim       : acc) (stepOn buf)
-    'E'# -> read_em (WwEnum       : acc) (stepOn buf)
+    'L'# -> read_em (Lazy : acc) (stepOn buf)
+    'A'# -> read_em (Abs : acc) (stepOn buf)
+    'V'# -> read_em (Eval : acc) (stepOn buf)
+    'X'# -> read_em (Err : acc) (stepOn buf)
+    'B'# -> read_em (Bot : acc) (stepOn buf)
     ')'# -> (reverse acc, stepOn buf)
-    'U'# -> do_unpack True  acc (stepOnBy# buf 2#)
-    'u'# -> do_unpack False acc (stepOnBy# buf 2#)
+    'C'# -> do_call acc (stepOnBy# buf 2#)
+    'D'# -> do_unpack1 Defer acc (stepOnBy# buf 1#)
+    'U'# -> do_unpack1 Drop acc (stepOnBy# buf 1#)
+    'S'# -> do_unpack1 Keep acc (stepOnBy# buf 1#)
     _    -> (reverse acc, buf)
 
-  do_unpack wrapper_unpacks acc buf
-   = case read_em [] buf of
-      (stuff, rest) -> read_em (WwUnpack wrapper_unpacks stuff : acc) rest
+  do_unpack1 keepity acc buf
+    = case currentChar# buf of
+       '('# -> do_unpack2 keepity acc (stepOnBy# buf 1#)
+       _    -> read_em (Seq keepity [] : acc) buf
 
+  do_unpack2 keepity acc buf
+    = case read_em [] buf of
+        (stuff, rest) -> read_em (Seq keepity stuff : acc) rest
+
+  do_call acc buf
+    = case read_em [] buf of
+        ([dmd], rest) -> read_em (Call dmd : acc) rest
 
 ------------------
 lex_scc cont buf =