[project @ 2001-07-23 23:08:41 by sof]

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

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index be83c11..fba97ed 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(..), Deferredness(..), 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
@@ -818,27 +819,38 @@ 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'
+   'X'# -> 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#)
+    'U'# -> do_unpack1 Drop Now acc (stepOnBy# buf 1#)
+    'S'# -> do_unpack1 Keep Now 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 defer acc buf
+    = case currentChar# buf of
+       '*'# -> do_unpack1 keepity Defer acc (stepOnBy# buf 1#)
+       '('# -> do_unpack2 keepity defer acc (stepOnBy# buf 1#)
+       _    -> read_em (Seq keepity defer [] : acc) buf
 
+  do_unpack2 keepity defer acc buf
+    = case read_em [] buf of
+        (stuff, rest) -> read_em (Seq keepity defer stuff : acc) rest
+
+  do_call acc buf
+    = case read_em [] buf of
+        ([dmd], rest) -> read_em (Call dmd : acc) rest
 
 ------------------
 lex_scc cont buf =
@@ -950,23 +962,36 @@ lex_sym cont buf =
        where lexeme = lexemeToFastString buf'
 
 
-lex_con cont glaexts buf = 
- -- trace ("con: "{-++unpackFS lexeme-}) $
- case expandWhile# is_ident buf          of { buf1 ->
- case slurp_trailing_hashes buf1 glaexts of { buf' ->
+-- lex_con recursively collects components of a qualified identifer.
+-- The argument buf is the StringBuffer representing the lexeme
+-- identified so far, where the next character is upper-case.
 
- case currentChar# buf' of
-     '.'# -> munch
+lex_con cont glaexts buf =
+ -- trace ("con: "{-++unpackFS lexeme-}) $
+ let empty_buf = stepOverLexeme buf in
+ case expandWhile# is_ident empty_buf    of { buf1 ->
+ case slurp_trailing_hashes buf1 glaexts of { con_buf ->
+
+ let all_buf = mergeLexemes buf con_buf
+     
+     con_lexeme = lexemeToFastString con_buf
+     mod_lexeme = lexemeToFastString (decLexeme buf)
+     all_lexeme = lexemeToFastString all_buf
+
+     just_a_conid
+       | emptyLexeme buf = cont (ITconid con_lexeme)               all_buf
+       | otherwise       = cont (ITqconid (mod_lexeme,con_lexeme)) all_buf
+ in
+
+ case currentChar# all_buf of
+     '.'# -> maybe_qualified cont glaexts all_lexeme 
+               (incLexeme all_buf) just_a_conid
      _    -> just_a_conid
- 
-   where
-    just_a_conid = cont (ITconid lexeme) buf'
-    lexeme = lexemeToFastString buf'
-    munch = lex_qid cont glaexts lexeme (incLexeme buf') just_a_conid
- }}
-
-lex_qid cont glaexts mod buf just_a_conid =
- -- trace ("quid: "{-++unpackFS lexeme-}) $
+  }}
+
+
+maybe_qualified cont glaexts mod buf just_a_conid =
+ -- trace ("qid: "{-++unpackFS lexeme-}) $
  case currentChar# buf of
   '['# ->      -- Special case for []
     case lookAhead# buf 1# of
@@ -987,9 +1012,14 @@ lex_qid cont glaexts mod buf just_a_conid =
   '-'# -> case lookAhead# buf 1# of
             '>'# -> cont (ITqconid (mod,SLIT("(->)"))) (setCurrentPos# buf 2#)
             _    -> lex_id3 cont glaexts mod buf just_a_conid
+
   _    -> lex_id3 cont glaexts mod buf just_a_conid
 
+
 lex_id3 cont glaexts mod buf just_a_conid
+  | is_upper (currentChar# buf) =
+     lex_con cont glaexts buf
+
   | is_symbol (currentChar# buf) =
      let 
        start_new_lexeme = stepOverLexeme buf