X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParserCore.y;h=dd438b141324d73334b131f522f51265301593df;hb=38ef36af81c7fe05f12ead2bb3613cff208d81fe;hp=9318892847a5f955fa7bc87bb16a30e83eba5140;hpb=42b63073fb5e71fcd539ab80289cf6cf2a5b9641;p=ghc-hetmet.git

diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y
index 9318892..dd438b1 100644
--- a/ghc/compiler/parser/ParserCore.y
+++ b/ghc/compiler/parser/ParserCore.y
@@ -1,6 +1,8 @@
 {
 module ParserCore ( parseCore ) where
 
+import ForeignCall
+
 import HsCore
 import RdrHsSyn
 import HsSyn
@@ -68,7 +70,7 @@ import Outputable
 
 module	:: { RdrNameHsModule }
 	: '%module' modid tdefs vdefgs
-		{ HsModule (mkHomeModule $2) Nothing Nothing 
+		{ HsModule (Just (mkHomeModule $2)) Nothing 
 		           [] ($3 ++ concat $4) Nothing noSrcLoc}
 
 tdefs	:: { [RdrNameHsDecl] }
@@ -79,11 +81,15 @@ tdef	:: { RdrNameHsDecl }
 	: '%data' q_tc_name tbinds '=' '{' cons1 '}'
                 { TyClD (mkTyData DataType ([], $2, $3) (DataCons $6) Nothing noSrcLoc) }
 	| '%newtype' q_tc_name tbinds trep 
-		{ TyClD (mkTyData NewType ([], $2, $3) ($4 $2 $3) Nothing noSrcLoc) }
+		{ TyClD (mkTyData NewType ([], $2, $3) ($4 $2) Nothing noSrcLoc) }
 
-trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
-        : {- empty -}   { (\ x ts -> Unknown) }
-        | '=' ty        { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) }
+-- For a newtype we have to invent a fake data constructor name
+-- It doesn't matter what it is, because it won't be used
+trep    :: { (RdrName -> DataConDetails (ConDecl RdrName)) }
+        : {- empty -}   { (\ tc_name -> Unknown) }
+        | '=' ty        { (\ tc_name -> let { dc_name  = setRdrNameSpace tc_name dataName ;
+			                      con_info = PrefixCon [unbangedType $2] }
+			                in DataCons [ConDecl dc_name [] [] con_info noSrcLoc]) }
 
 tbind	:: { HsTyVarBndr RdrName }
 	:  name                    { IfaceTyVar $1 liftedTypeKind }
@@ -195,8 +201,10 @@ exp	:: { UfExpr RdrName }
 	       "InlineCall" -> UfNote UfInlineCall $3
 	       "InlineMe"   -> UfNote UfInlineMe $3
             }
---        | '%external' STRING aty   { External $2 $3 }
-
+        | '%external' STRING aty   { UfFCall (ForeignCall.CCall 
+                                               (CCallSpec (StaticTarget 
+                                                            (mkFastString $2)) 
+                                                          CCallConv (PlaySafe False))) $3 }
 alts1	:: { [UfAlt RdrName] }
 	: alt		{ [$1] }
 	| alt ';' alts1	{ $1:$3 }
@@ -259,6 +267,8 @@ convIntLit :: Integer -> RdrNameHsType -> Literal
 convIntLit i (HsTyVar n)
   | n == intPrimRdrName  = MachInt  i  
   | n == wordPrimRdrName = MachWord i
+  | n == charPrimRdrName = MachChar (fromInteger i)
+  | n == addrPrimRdrName && i == 0 = MachNullAddr
 convIntLit i aty
   = pprPanic "Unknown integer literal type" (ppr aty $$ ppr intPrimRdrName) 
 
@@ -270,11 +280,13 @@ convRatLit i aty
   = pprPanic "Unknown rational literal type" (ppr aty $$ ppr intPrimRdrName) 
 
 
-wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName :: RdrName
+wordPrimRdrName, intPrimRdrName, floatPrimRdrName, doublePrimRdrName, addrPrimRdrName :: RdrName
 wordPrimRdrName   = nameRdrName wordPrimTyConName
 intPrimRdrName    = nameRdrName intPrimTyConName
+charPrimRdrName   = nameRdrName charPrimTyConName
 floatPrimRdrName  = nameRdrName floatPrimTyConName
 doublePrimRdrName = nameRdrName doublePrimTyConName
+addrPrimRdrName   = nameRdrName addrPrimTyConName
 
 happyError :: P a 
 happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l