[project @ 2001-12-10 01:27:59 by sebc]

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

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 0d04782..5880ee1 100644 (file)
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -39,8 +39,8 @@ import List             ( isSuffixOf )
 import PrelNames       ( mkTupNameStr )
 import CmdLineOpts     ( opt_HiVersion, opt_NoHiCheck )
 import ForeignCall     ( Safety(..) )
-import NewDemand       ( StrictSig(..), Demand(..), Keepity(..), 
-                         DmdResult(..), mkTopDmdType )
+import NewDemand       ( StrictSig(..), Demand(..), Demands(..),
+                         DmdResult(..), mkTopDmdType, evalDmd, lazyDmd )
 import UniqFM           ( listToUFM, lookupUFM )
 import BasicTypes      ( Boxity(..) )
 import SrcLoc          ( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
@@ -210,7 +210,8 @@ data Token
   | ITqvarsym (FAST_STRING,FAST_STRING)
   | ITqconsym (FAST_STRING,FAST_STRING)
 
-  | ITipvarid FAST_STRING      -- GHC extension: implicit param: ?x
+  | ITdupipvarid   FAST_STRING -- GHC extension: implicit param: ?x
+  | ITsplitipvarid FAST_STRING -- GHC extension: implicit param: %x
 
   | ITpragma StringBuffer
 
@@ -653,7 +654,9 @@ lexToken cont glaexts buf =
               cont (ITunknown "\NUL") (stepOn buf)
 
     '?'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
-           lex_ip cont (incLexeme buf)
+           lex_ip ITdupipvarid cont (incLexeme buf)
+    '%'# | flag glaexts && is_lower (lookAhead# buf 1#) ->
+           lex_ip ITsplitipvarid cont (incLexeme buf)
     c | is_digit  c -> lex_num cont glaexts 0 buf
       | is_symbol c -> lex_sym cont buf
       | is_upper  c -> lex_con cont glaexts buf
@@ -838,30 +841,37 @@ lex_demand cont buf =
  where
   read_em acc buf = 
    case currentChar# buf of
-    '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)
-    '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)
+    'T'# -> read_em (Top     : acc) (stepOn buf)
+    'L'# -> read_em (lazyDmd : acc) (stepOn buf)
+    'A'# -> read_em (Abs     : acc) (stepOn buf)
+    'V'# -> read_em (evalDmd : acc) (stepOn buf)       -- Temporary, until
+                                                       -- we've recompiled prelude etc
+    'C'# -> do_unary Call  acc (stepOnBy# buf 2#)      -- Skip 'C('
 
-  do_unpack1 keepity acc buf
-    = case currentChar# buf of
-       '('# -> do_unpack2 keepity acc (stepOnBy# buf 1#)
-       _    -> read_em (Seq keepity [] : acc) buf
+    'U'# -> do_seq1 Eval        acc (stepOnBy# buf 1#)
+    'D'# -> do_seq1 Defer       acc (stepOnBy# buf 1#)
+    'S'# -> do_seq1 (Box . Eval) acc (stepOnBy# buf 1#)
 
-  do_unpack2 keepity acc buf
-    = case read_em [] buf of
-        (stuff, rest) -> read_em (Seq keepity stuff : acc) rest
+    _    -> (reverse acc, buf)
 
-  do_call acc buf
+  do_seq1 fn acc buf
+    = case currentChar# buf of
+       '('# -> do_seq2 fn acc (stepOnBy# buf 1#)
+       _    -> read_em (fn (Poly Abs) : acc) buf
+
+  do_seq2 fn acc buf
+    = case read_em [] buf of { (dmds, buf) -> 
+      case currentChar# buf of
+       ')'# -> read_em (fn (Prod dmds) : acc)
+                       (stepOn buf) 
+       '*'# -> ASSERT( length dmds == 1 )
+               read_em (fn (Poly (head dmds)) : acc)
+                       (stepOnBy# buf 2#)      -- Skip '*)'
+      }
+       
+  do_unary fn acc buf
     = case read_em [] buf of
-        ([dmd], rest) -> read_em (Call dmd : acc) rest
+        ([dmd], rest) -> read_em (fn dmd : acc) (stepOn rest)  -- Skip ')'
 
 ------------------
 lex_scc cont buf =
@@ -929,10 +939,10 @@ lex_cstring cont buf =
 -----------------------------------------------------------------------------
 -- identifiers, symbols etc.
 
-lex_ip cont buf =
+lex_ip ip_constr cont buf =
  case expandWhile# is_ident buf of
-   buf' -> cont (ITipvarid lexeme) buf'
-          where lexeme = lexemeToFastString buf'
+   buf' -> cont (ip_constr (tailFS lexeme)) buf'
+       where lexeme = lexemeToFastString buf'
 
 lex_id cont glaexts buf =
  let buf1 = expandWhile# is_ident buf in