X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FLex.lhs;h=daeabfb75466079b136fc737a5299929c0c855c1;hb=c9ed624be9c92be63178bded7ebabffd8136e9a6;hp=3ff951a726803fb2d5a409b4b7cfe7018eca23e6;hpb=a52dc4b852e433d00aa1c79acc41bb92f39e66d7;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs
index 3ff951a..daeabfb 100644
--- a/ghc/compiler/parser/Lex.lhs
+++ b/ghc/compiler/parser/Lex.lhs
@@ -27,7 +27,7 @@ module Lex (
 	StringBuffer,
 
 	P, thenP, thenP_, returnP, mapP, failP, failMsgP,
-	getSrcLocP, getSrcFile,
+	getSrcLocP, setSrcLocP, getSrcFile,
 	layoutOn, layoutOff, pushContext, popContext
     ) where
 
@@ -39,6 +39,7 @@ import List             ( isSuffixOf )
 import IdInfo		( InlinePragInfo(..) )
 import PrelNames	( mkTupNameStr )
 import CmdLineOpts	( opt_HiVersion, opt_NoHiCheck )
+import ForeignCall	( Safety(..) )
 import Demand		( Demand(..) {- instance Read -} )
 import UniqFM           ( listToUFM, lookupUFM )
 import BasicTypes	( NewOrData(..), Boxity(..) )
@@ -52,7 +53,7 @@ import FastString
 import StringBuffer
 import GlaExts
 import Ctype
-import Char		( ord )
+import Char		( chr, ord )
 import PrelRead 	( readRational__ ) -- Glasgow non-std
 \end{code}
 
@@ -110,7 +111,7 @@ data Token
   | ITthen
   | ITtype
   | ITwhere
-  | ITscc
+  | ITscc			-- ToDo: remove (we use {-# SCC "..." #-} now)
 
   | ITforall			-- GHC extension keywords
   | ITforeign
@@ -121,9 +122,9 @@ data Token
   | ITwith
   | ITstdcallconv
   | ITccallconv
+  | ITdotnet
 
   | ITinterface			-- interface keywords
-  | ITexpr
   | IT__export
   | ITdepends
   | IT__forall
@@ -131,7 +132,7 @@ data Token
   | ITcoerce
   | ITinlineMe
   | ITinlineCall
-  | ITccall (Bool,Bool,Bool)	-- (is_dyn, is_casm, may_gc)
+  | ITccall (Bool,Bool,Safety)	-- (is_dyn, is_casm, may_gc)
   | ITdefaultbranch
   | ITbottom
   | ITinteger_lit 
@@ -165,6 +166,7 @@ data Token
   | ITrules_prag
   | ITdeprecated_prag
   | ITline_prag
+  | ITscc_prag
   | ITclose_prag
 
   | ITdotdot  			-- reserved symbols
@@ -244,6 +246,7 @@ pragmaKeywordsFM = listToUFM $
 	( "LINE",       ITline_prag ),
 	( "RULES",	ITrules_prag ),
 	( "RULEZ",	ITrules_prag ),	-- american spelling :-)
+	( "SCC",	ITscc_prag ),
 	( "DEPRECATED",	ITdeprecated_prag )
  	]
 
@@ -274,7 +277,7 @@ haskellKeywordsFM = listToUFM $
 	( "then",	ITthen ),     
 	( "type",	ITtype ),     
 	( "where",	ITwhere ),
-	( "_scc_",	ITscc )
+	( "_scc_",	ITscc )		-- ToDo: remove
      ]
 
 isSpecial :: Token -> Bool
@@ -306,14 +309,14 @@ ghcExtensionKeywordsFM = listToUFM $
 	( "with",	ITwith ),
 	( "stdcall",    ITstdcallconv),
 	( "ccall",      ITccallconv),
-        ("_ccall_",	ITccall (False, False, False)),
-        ("_ccall_GC_",	ITccall (False, False, True)),
-        ("_casm_",	ITccall (False, True,  False)),
-        ("_casm_GC_",	ITccall (False, True,  True)),
+	( "dotnet",     ITdotnet),
+        ("_ccall_",	ITccall (False, False, PlayRisky)),
+        ("_ccall_GC_",	ITccall (False, False, PlaySafe)),
+        ("_casm_",	ITccall (False, True,  PlayRisky)),
+        ("_casm_GC_",	ITccall (False, True,  PlaySafe)),
 
 	-- interface keywords
         ("__interface",		ITinterface),
-        ("__expr",		ITexpr),
 	("__export",		IT__export),
 	("__depends",		ITdepends),
 	("__forall",		IT__forall),
@@ -344,14 +347,14 @@ ghcExtensionKeywordsFM = listToUFM $
         ("__D",			ITdeprecated),
         ("__U",			ITunfold NoInlinePragInfo),
 	
-        ("__ccall",		ITccall (False, False, False)),
-        ("__ccall_GC",		ITccall (False, False, True)),
-        ("__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)),
+        ("__ccall",		ITccall (False, False, PlayRisky)),
+        ("__ccall_GC",		ITccall (False, False, PlaySafe)),
+        ("__dyn_ccall",		ITccall (True,  False, PlayRisky)),
+        ("__dyn_ccall_GC",	ITccall (True,  False, PlaySafe)),
+        ("__casm",		ITccall (False, True,  PlayRisky)),
+        ("__dyn_casm",		ITccall (True,  True,  PlayRisky)),
+        ("__casm_GC",		ITccall (False, True,  PlaySafe)),
+        ("__dyn_casm_GC",	ITccall (True,  True,  PlaySafe)),
 
         ("/\\",			ITbiglam)
      ]
@@ -668,11 +671,12 @@ lex_prag cont buf
 lex_string cont glaexts s buf
   = case currentChar# buf of
 	'"'#{-"-} -> 
-	   let buf' = incLexeme buf; s' = mkFastStringInt (reverse s) in
-	   case currentChar# buf' of
+	   let buf' = incLexeme buf
+               s' = mkFastStringNarrow (map chr (reverse s)) 
+           in case currentChar# buf' of
 		'#'# | flag glaexts -> if all (<= 0xFF) s
                     then cont (ITprimstring s') (incLexeme buf')
-                    else lexError "primitive string literal must contain only characters <= '\xFF'" buf'
+                    else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf'
 		_                   -> cont (ITstring s') buf'
 
 	-- ignore \& in a string, deal with string gaps
@@ -742,7 +746,7 @@ lex_escape cont buf
 			    [] -> charError buf'
 
 after_charnum cont i buf
-  = if i >= 0 && i <= 0x7FFFFFFF
+  = if i >= 0 && i <= 0x10FFFF
 	then cont (fromInteger i) buf
 	else charError buf
 
@@ -1179,12 +1183,16 @@ lexError str buf s@PState{ loc = loc }
 getSrcLocP :: P SrcLoc
 getSrcLocP buf s@(PState{ loc = loc }) = POk s loc
 
+-- use a temporary SrcLoc for the duration of the argument
+setSrcLocP :: SrcLoc -> P a -> P a
+setSrcLocP new_loc p buf s = 
+  case p buf s{ loc=new_loc } of
+      POk _ a   -> POk s a
+      PFailed e -> PFailed e
+  
 getSrcFile :: P FAST_STRING
 getSrcFile buf s@(PState{ loc = loc }) = POk s (srcLocFile loc)
 
-getContext :: P [LayoutContext]
-getContext buf s@(PState{ context = ctx }) = POk s ctx
-
 pushContext :: LayoutContext -> P ()
 pushContext ctxt buf s@(PState{ context = ctx }) = POk s{context = ctxt:ctx} ()