From 2ef5da495a59715d9965cc4c834b2538feccec40 Mon Sep 17 00:00:00 2001
From: sof <unknown>
Date: Thu, 8 Jul 1999 13:46:27 +0000
Subject: [PATCH] [project @ 1999-07-08 13:46:25 by sof] A 'foreign export'
(static) declaration doesn't bind a name but simply adds an occurrence of a
name.
---
ghc/compiler/rename/RnIfaces.lhs | 19 +++++++++++++++++--
ghc/compiler/rename/RnNames.lhs | 13 -------------
ghc/compiler/rename/RnSource.lhs | 3 ++-
3 files changed, 19 insertions(+), 16 deletions(-)
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index c5018a4c8177..9683ef2c8863 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -22,6 +22,7 @@ module RnIfaces (
import CmdLineOpts ( opt_NoPruneDecls, opt_IgnoreIfacePragmas )
import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), IfaceSig(..),
HsType(..), ConDecl(..), IE(..), ConDetails(..), Sig(..),
+ ForeignDecl(..), ForKind(..), isDynamic,
FixitySig(..), RuleDecl(..),
isClassOpSig
)
@@ -30,7 +31,7 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleD
extractHsTyRdrNames
)
import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
- lookupOccRn,
+ lookupOccRn, lookupImplicitOccRn,
pprAvail,
availName, availNames, addAvailToNameSet,
FreeVars, emptyFVs
@@ -787,11 +788,25 @@ getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
returnRn (Just (Avail var_name))
getDeclBinders new_name (FixD _) = returnRn Nothing
-getDeclBinders new_name (ForD _) = returnRn Nothing
+
+ -- foreign declarations
+getDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
+ | binds_haskell_name kind dyn
+ = new_name nm loc `thenRn` \ name ->
+ returnRn (Just (Avail name))
+
+ | otherwise -- a foreign export
+ = lookupImplicitOccRn nm `thenRn_`
+ returnRn Nothing
+
getDeclBinders new_name (DefD _) = returnRn Nothing
getDeclBinders new_name (InstD _) = returnRn Nothing
getDeclBinders new_name (RuleD _) = returnRn Nothing
+binds_haskell_name (FoImport _) _ = True
+binds_haskell_name FoLabel _ = True
+binds_haskell_name FoExport ext_nm = isDynamic ext_nm
+
----------------
getConFieldNames new_name (ConDecl con _ _ (RecCon fielddecls) src_loc : rest)
= mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 9f46d363c1a6..f549234e0491 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -306,15 +306,6 @@ getLocalDeclBinders new_name (ValD binds)
do_one (rdr_name, loc) = new_name rdr_name loc `thenRn` \ name ->
returnRn (Avail name)
- -- foreign declarations
-getLocalDeclBinders new_name (ForD (ForeignDecl nm kind _ dyn _ loc))
- | binds_haskell_name kind dyn
- = new_name nm loc `thenRn` \ name ->
- returnRn [Avail name]
-
- | otherwise
- = returnRn []
-
getLocalDeclBinders new_name decl
= getDeclBinders new_name decl `thenRn` \ maybe_avail ->
case maybe_avail of
@@ -326,10 +317,6 @@ getLocalDeclBinders new_name decl
-- etc, into the cache
new_sys_name rdr_name loc = newImplicitBinder (rdrNameOcc rdr_name) loc
-binds_haskell_name (FoImport _) _ = True
-binds_haskell_name FoLabel _ = True
-binds_haskell_name FoExport ext_nm = isDynamic ext_nm
-
fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG FixityEnv
fixitiesFromLocalDecls gbl_env decls
= foldlRn getFixities emptyNameEnv decls
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index 9508d78ffd25..753ab7b5be17 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -362,7 +362,7 @@ rnDecl (DefD (DefaultDecl tys src_loc))
\begin{code}
rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
= pushSrcLocRn src_loc $
- lookupBndrRn name `thenRn` \ name' ->
+ lookupOccRn name `thenRn` \ name' ->
let
fvs1 = case imp_exp of
FoImport _ | not isDyn -> emptyFVs
@@ -370,6 +370,7 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
FoExport | isDyn -> mkNameSet [makeStablePtr_NAME,
deRefStablePtr_NAME,
bindIO_NAME]
+ | otherwise -> mkNameSet [name']
_ -> emptyFVs
in
rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) ->
--
GitLab