[project @ 2001-10-18 09:17:04 by simonmar]

[ghc-hetmet.git] / ghc / compiler / rename / ParseIface.y

diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 4a942ea..96b701e 100644 (file)
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -36,17 +36,15 @@ import HsSyn                -- quite a bit of stuff
 import RdrHsSyn                -- oodles of synonyms
 import HsTypes         ( mkHsForAllTy, mkHsTupCon )
 import HsCore
-import Demand          ( mkStrictnessInfo )
 import Literal         ( Literal(..), mkMachInt, mkMachInt64, mkMachWord, mkMachWord64 )
-import BasicTypes      ( Fixity(..), FixityDirection(..), 
-                         NewOrData(..), Version, initialVersion, Boxity(..)
+import BasicTypes      ( Fixity(..), FixityDirection(..), StrictnessMark(..),
+                         NewOrData(..), Version, initialVersion, Boxity(..),
+                          Activation(..)
                        )
 import CostCentre       ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
-import Demand          ( StrictnessMark(..) )
-import CallConv         ( cCallConv )
 import Type            ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
 import IdInfo           ( InlinePragInfo(..) )
-import PrimOp           ( CCall(..), CCallTarget(..) )
+import ForeignCall     ( ForeignCall(..), CCallConv(..), CCallSpec(..), CCallTarget(..) )
 import Lex             
 
 import RnMonad         ( ParsedIface(..), ExportItem, IfaceDeprecs ) 
@@ -144,7 +142,7 @@ import FastString   ( tailFS )
  '__A'         { ITarity }
  '__P'         { ITspecialise }
  '__C'         { ITnocaf }
- '__U'         { ITunfold $$ }
+ '__U'         { ITunfold }
  '__S'         { ITstrict $$ }
  '__R'         { ITrules }
  '__M'         { ITcprinfo }
@@ -352,6 +350,8 @@ decl    : src_loc qvar_name '::' type maybe_idinfo
                        { IfaceSig $2 $4 ($5 $2) $1 }
        | src_loc 'type' qtc_name tv_bndrs '=' type                    
                        { TySynonym $3 $4 $6 $1 }
+       | src_loc 'foreign' 'type' qtc_name                    
+                       { ForeignType $4 Nothing DNType $1 }
        | src_loc 'data' opt_decl_context qtc_name tv_bndrs constrs            
                        { mkTyData DataType $3 $4 $5 $6 (length $6) Nothing $1 }
        | src_loc 'newtype' opt_decl_context qtc_name tv_bndrs newtype_constr
@@ -422,8 +422,12 @@ rules         :: { [RdrNameRuleDecl] }
           | rule ';' rules     { $1:$3 }
 
 rule      :: { RdrNameRuleDecl }
-rule      : src_loc STRING rule_forall qvar_name 
-            core_args '=' core_expr    { IfaceRule $2 $3 $4 $5 $7 $1 } 
+rule      : src_loc STRING activation rule_forall qvar_name 
+            core_args '=' core_expr    { IfaceRule $2 $3 $4 $5 $6 $8 $1 } 
+
+activation :: { Activation }
+activation : {- empty -}                { AlwaysActive }
+           | INTEGER                    { ActiveAfter (fromInteger $1) }
 
 rule_forall    :: { [UfBinder RdrName] }
 rule_forall    : '__forall' '{' core_bndrs '}' { $3 }
@@ -597,9 +601,8 @@ mod_name    :: { ModuleName }
 
 
 ---------------------------------------------------
-var_fs         :: { EncodedFS }
+var_fs          :: { EncodedFS }
                : VARID                 { $1 }
-               | '!'                   { SLIT("!") }
                | 'as'                  { SLIT("as") }
                | 'qualified'           { SLIT("qualified") }
                | 'hiding'              { SLIT("hiding") }
@@ -690,7 +693,7 @@ qcls_name   :: { RdrName }
 
 ---------------------------------------------------
 tv_name                :: { RdrName }
-               :  VARID                { mkRdrUnqual (mkSysOccFS tvName $1) }
+               :  var_fs               { mkRdrUnqual (mkSysOccFS tvName $1) }
 
 tv_bndr                :: { HsTyVarBndr RdrName }
                :  tv_name '::' akind   { IfaceTyVar $1 $3 }
@@ -745,22 +748,13 @@ id_info           :: { [HsIdInfo RdrName] }
 id_info_item   :: { HsIdInfo RdrName }
                : '__A' INTEGER                 { HsArity (fromInteger $2) }
                | '__U' inline_prag core_expr   { HsUnfold $2 $3 }
-               | '__M'                         { HsCprInfo }
-               | '__S'                         { HsStrictness (mkStrictnessInfo $1) }
+               | '__S'                         { HsStrictness $1 }
                | '__C'                         { HsNoCafRefs }
                | '__P' qvar_name INTEGER       { HsWorker $2 (fromInteger $3) }
 
 inline_prag     :: { InlinePragInfo }
-                :  {- empty -}                  { NoInlinePragInfo }
-               | '[' from_prag phase ']'       { IMustNotBeINLINEd $2 $3 }
-
-from_prag      :: { Bool }
-               : {- empty -}                   { True }
-               | '!'                           { False }
-
-phase          :: { Maybe Int }
-               : {- empty -}                   { Nothing }
-               | INTEGER                       { Just (fromInteger $1) }
+                :  {- empty -}                  { AlwaysActive }
+               | '[' INTEGER ']'               { ActiveAfter (fromInteger $2) }
 
 -------------------------------------------------------
 core_expr      :: { UfExpr RdrName }
@@ -808,12 +802,13 @@ core_aexpr      : qvar_name                                       { UfVar $1 }
                            { let
                                  (is_dyn, is_casm, may_gc) = $2
 
-                                target | is_dyn    = DynamicTarget (error "CCall dyn target bogus unique")
+                                target | is_dyn    = DynamicTarget
+                                       | is_casm   = CasmTarget $3
                                        | otherwise = StaticTarget $3
 
-                                ccall = CCall target is_casm may_gc cCallConv
+                                ccall = CCallSpec target CCallConv may_gc
                             in
-                            UfCCall ccall $4
+                            UfFCall (CCall ccall) $4
                           }