summaryrefslogtreecommitdiff
path: root/ghc/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/rename')
-rw-r--r--ghc/compiler/rename/ParseIface.y5
-rw-r--r--ghc/compiler/rename/RnHsSyn.lhs3
-rw-r--r--ghc/compiler/rename/RnIfaces.lhs3
-rw-r--r--ghc/compiler/rename/RnNames.lhs12
-rw-r--r--ghc/compiler/rename/RnSource.lhs64
5 files changed, 46 insertions, 41 deletions
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 78aa4773da..47fda3acf6 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -351,6 +351,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 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
@@ -808,9 +810,10 @@ core_aexpr : qvar_name { UfVar $1 }
(is_dyn, is_casm, may_gc) = $2
target | is_dyn = DynamicTarget
+ | is_casm = CasmTarget $3
| otherwise = StaticTarget $3
- ccall = CCallSpec target CCallConv may_gc is_casm
+ ccall = CCallSpec target CCallConv may_gc
in
UfFCall (CCall ccall) $4
}
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 13c14bca8d..a1fbfeb0c8 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -119,6 +119,9 @@ In all cases this is set up for interface-file declarations:
\begin{code}
tyClDeclFVs :: RenamedTyClDecl -> NameSet
+tyClDeclFVs (ForeignType {})
+ = emptyFVs
+
tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos})
= extractHsTyNames ty `plusFV`
plusFVs (map hsIdInfoFVs id_infos)
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 7cab59c01d..f60ae46059 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -489,7 +489,8 @@ getGates :: FreeVars -- Things mentioned in the source program
getGates source_fvs decl
= get_gates (\n -> n `elemNameSet` source_fvs) decl
-get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
+get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
+get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty
get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
= (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets`
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index a54dbd857c..2bfe8a5c46 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -13,7 +13,7 @@ module RnNames (
import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
- ForeignDecl(..), ForKind(..), isDynamicExtName,
+ ForeignDecl(..),
collectLocatedHsBinders
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
@@ -244,17 +244,11 @@ getLocalDeclBinders mod (ValD binds)
new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
-getLocalDeclBinders mod (ForD (ForeignDecl nm kind _ ext_nm _ loc))
- | binds_haskell_name kind
+getLocalDeclBinders mod (ForD (ForeignImport nm _ _ loc))
= newTopBinder mod nm loc `thenRn` \ name ->
returnRn [Avail name]
-
- | otherwise -- a foreign export
+getLocalDeclBinders mod (ForD _)
= returnRn []
- where
- binds_haskell_name (FoImport _) = True
- binds_haskell_name FoLabel = True
- binds_haskell_name FoExport = isDynamicExtName ext_nm
getLocalDeclBinders mod (FixD _) = returnRn []
getLocalDeclBinders mod (DeprecD _) = returnRn []
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 781e67ca41..71fe8ffc44 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -49,8 +49,6 @@ import CmdLineOpts ( DynFlag(..) )
-- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import Maybes ( maybeToBool )
-import ErrUtils ( Message )
-import CStrings ( isCLabelString )
import ListSetOps ( removeDupsEq )
\end{code}
@@ -112,39 +110,44 @@ rnSourceDecl (RuleD rule)
= rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) ->
returnRn (RuleD new_rule, fvs)
+rnSourceDecl (ForD ford)
+ = rnHsForeignDecl ford `thenRn` \ (new_ford, fvs) ->
+ returnRn (ForD new_ford, fvs)
+
rnSourceDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) ->
returnRn (DefD (DefaultDecl tys' src_loc), fvs)
where
doc_str = text "a `default' declaration"
+\end{code}
-rnSourceDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
- = pushSrcLocRn src_loc $
- lookupOccRn name `thenRn` \ name' ->
- let
- extra_fvs FoExport
- | isDyn = lookupOrigNames [newStablePtr_RDR, deRefStablePtr_RDR,
- bindIO_RDR, returnIO_RDR]
- | otherwise =
- lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs ->
- returnRn (addOneFV fvs name')
- extra_fvs other = returnRn emptyFVs
- in
- checkRn (ok_ext_nm ext_nm) (badExtName ext_nm) `thenRn_`
- extra_fvs imp_exp `thenRn` \ fvs1 ->
+%*********************************************************
+%* *
+\subsection{Foreign declarations}
+%* *
+%*********************************************************
+
+\begin{code}
+rnHsForeignDecl (ForeignImport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames (extras spec) `thenRn` \ fvs2 ->
+ returnRn (ForeignImport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
+ where
+ extras (CDynImport _) = [newStablePtr_RDR, deRefStablePtr_RDR, bindIO_RDR, returnIO_RDR]
+ extras other = []
- rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
- returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc),
- fvs1 `plusFV` fvs2)
- where
- fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name
- isDyn = isDynamicExtName ext_nm
+rnHsForeignDecl (ForeignExport name ty spec src_loc)
+ = pushSrcLocRn src_loc $
+ lookupOccRn name `thenRn` \ name' ->
+ rnHsTypeFVs (fo_decl_msg name) ty `thenRn` \ (ty', fvs1) ->
+ lookupOrigNames [bindIO_RDR, returnIO_RDR] `thenRn` \ fvs2 ->
+ returnRn (ForeignExport name' ty' spec src_loc, fvs1 `plusFV` fvs2)
- ok_ext_nm Dynamic = True
- ok_ext_nm (ExtName nm (Just mb)) = isCLabelString nm && isCLabelString mb
- ok_ext_nm (ExtName nm Nothing) = isCLabelString nm
+fo_decl_msg name = ptext SLIT("The foreign declaration for") <+> ppr name
\end{code}
@@ -284,6 +287,11 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
where
doc_str = text "the interface signature for" <+> quotes (ppr name)
+rnTyClDecl (ForeignType {tcdName = name, tcdFoType = spec, tcdLoc = loc})
+ = pushSrcLocRn loc $
+ lookupTopBndrRn name `thenRn` \ name' ->
+ returnRn (ForeignType {tcdName = name', tcdFoType = spec, tcdLoc = loc})
+
rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs,
tcdLoc = src_loc, tcdSysNames = sys_names})
@@ -428,7 +436,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G
meth_doc = text "the default-methods for class" <+> ppr (tcdName rn_cls_decl)
finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs)
- -- Not a class declaration
+ -- Not a class or data type declaration
\end{code}
@@ -879,10 +887,6 @@ badRuleVar name var
ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
ptext SLIT("does not appear on left hand side")]
-badExtName :: ExtName -> Message
-badExtName ext_nm
- = sep [quotes (ppr ext_nm) <+> ptext SLIT("is not a valid C identifier")]
-
dupClassAssertWarn ctxt (assertion : dups)
= sep [hsep [ptext SLIT("Duplicate class assertion"),
quotes (ppr assertion),
View Lorry Controller Status