X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLex.lhs;h=b4c9bc44c79b0fc52837ef89c1ff6dc4732d1779;hb=1a8d01f99c116ea79fa765afc8f8f6129c5b270d;hp=7cd811d0d9f180d691e8b6bc04155af802330119;hpb=d069cec2bd92d4156aeab80f7eb1f222a82e4103;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 7cd811d..b4c9bc4 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -40,9 +40,10 @@ 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	( NewOrData(..), Boxity(..) )
+import BasicTypes	( Boxity(..) )
 import SrcLoc		( SrcLoc, incSrcLine, srcLocFile, srcLocLine,
 			  replaceSrcLine, mkSrcLoc )
 
@@ -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 =
@@ -950,23 +964,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 +1014,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