Commit 57d07fb8 authored by sof's avatar sof
Browse files

[project @ 1998-11-08 17:10:35 by sof]

First take at 'foreign label's
parent cbf8c1c9
......@@ -19,7 +19,7 @@ import DsCCall ( getIoOkDataCon, boxResult, unboxArg,
import DsMonad
import DsUtils
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic )
import HsSyn ( ExtName(..), ForeignDecl(..), isDynamic, ForKind(..) )
import CallConv
import TcHsSyn ( maybeBoxedPrimType, TypecheckedForeignDecl )
import CoreUtils ( coreExprType )
......@@ -51,7 +51,8 @@ import TysWiredIn ( getStatePairingConInfo,
realWorldStateTy, stateDataCon,
isFFIArgumentTy, unitTy,
addrTy, stablePtrTyCon,
stateAndPtrPrimDataCon
stateAndPtrPrimDataCon,
addrDataCon
)
import Outputable
\end{code}
......@@ -83,6 +84,9 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
| isForeignImport =
dsFImport i (idType i) uns ext_nm cconv `thenDs` \ b ->
returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
| isForeignLabel =
dsFLabel i ext_nm `thenDs` \ b ->
returnDs (b:acc_fi, acc_fe, acc_hc, acc_h, acc_c)
| isDynamic ext_nm =
dsFExportDynamic i (idType i) ext_nm cconv `thenDs` \ (fi,fe,hc,h,c) ->
returnDs (fi:acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
......@@ -91,8 +95,17 @@ dsForeigns fos = foldlDs combine ([],[],empty,empty,empty) fos
returnDs (acc_fi, fe:acc_fe, hc $$ acc_hc, h $$ acc_h, c $$ acc_c)
where
isForeignImport = maybeToBool imp_exp
(Just uns) = imp_exp
isForeignImport =
case imp_exp of
FoImport _ -> True
_ -> False
isForeignLabel =
case imp_exp of
FoLabel -> True
_ -> False
(FoImport uns) = imp_exp
\end{code}
......@@ -149,6 +162,21 @@ mkArgs ty =
\end{code}
\begin{code}
dsFLabel :: Id -> ExtName -> DsM CoreBinding
dsFLabel nm ext_name =
returnDs (NonRec nm fo_rhs)
where
fo_rhs = mkCon addrDataCon [] [LitArg (MachLitLit enm AddrRep)]
enm =
case ext_name of
ExtName f _ -> f
\end{code}
\begin{code}
dsFExport :: Id
-> Type -- Type of foreign export.
......
......@@ -354,7 +354,7 @@ instance (NamedThing name, Outputable name)
data ForeignDecl name =
ForeignDecl
name
(Maybe Bool) -- Nothing => foreign export; Just unsafe => foreign import unsafe
ForKind
(HsType name)
ExtName
CallConv
......@@ -369,8 +369,16 @@ instance (NamedThing name, Outputable name)
where
(ppr_imp_exp, ppr_unsafe) =
case imp_exp of
Nothing -> (ptext SLIT("export"), empty)
Just us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
FoLabel -> (ptext SLIT("label"), empty)
FoExport -> (ptext SLIT("export"), empty)
FoImport us
| us -> (ptext SLIT("import"), ptext SLIT("unsafe"))
| otherwise -> (ptext SLIT("import"), empty)
data ForKind
= FoLabel
| FoExport
| FoImport Bool -- True => unsafe call.
data ExtName
= Dynamic
......
......@@ -32,8 +32,8 @@ module HsSyn (
-- friends:
import HsBinds
import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
DefaultDecl(..), ForeignDecl(..), ExtName(..), isDynamic,
FixityDecl(..),
DefaultDecl(..), ForeignDecl(..), ForKind(..),
ExtName(..), isDynamic, FixityDecl(..),
ConDecl(..), ConDetails(..), BangType(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..),
hsDeclName
......
......@@ -197,7 +197,6 @@ cvOtherDecls b
go acc (RdrClassDecl d) = ClD d : acc
go acc (RdrInstDecl d) = InstD d : acc
go acc (RdrDefaultDecl d) = DefD d : acc
-- go acc (RdrForeignDecl d) = ForD d : acc
go acc other = acc
-- Ignore value bindings
......
......@@ -964,9 +964,11 @@ wlkExtName (U_just pt)
rdCallConv :: Int -> UgnM CallConv
rdCallConv x = returnUgn x
rdImpExp :: Int -> Bool -> UgnM (Maybe Bool)
rdImpExp 0 isUnsafe = -- foreign import
returnUgn (Just isUnsafe)
rdForKind :: Int -> Bool -> UgnM ForKind
rdForKind 0 isUnsafe = -- foreign import
returnUgn (FoImport isUnsafe)
rdImpExp 1 _ = -- foreign export
returnUgn Nothing
returnUgn FoExport
rdImpExp 2 _ = -- foreign label
returnUgn FoLabel
\end{code}
......@@ -16,7 +16,7 @@ import CmdLineOpts ( opt_NoImplicitPrelude, opt_WarnDuplicateExports,
import HsSyn ( HsModule(..), ImportDecl(..), HsDecl(..),
IE(..), ieName,
ForeignDecl(..), ExtName(..),
ForeignDecl(..), ExtName(..), ForKind(..),
FixityDecl(..),
collectTopBinders
)
......@@ -226,12 +226,17 @@ importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
returnRn (val_avails ++ avails)
-- foreign import declaration
getLocalDeclBinders avails (ForD (ForeignDecl nm (Just _) _ _ _ loc))
getLocalDeclBinders avails (ForD (ForeignDecl nm (FoImport _) _ _ _ loc))
= do_one (nm,loc) `thenRn` \ for_avail ->
returnRn (for_avail : avails)
-- foreign import declaration
getLocalDeclBinders avails (ForD (ForeignDecl nm FoLabel _ _ _ loc))
= do_one (nm,loc) `thenRn` \ for_avail ->
returnRn (for_avail : avails)
-- foreign export dynamic declaration
getLocalDeclBinders avails (ForD (ForeignDecl nm Nothing _ Dynamic _ loc))
getLocalDeclBinders avails (ForD (ForeignDecl nm FoExport _ Dynamic _ loc))
= do_one (nm,loc) `thenRn` \ for_avail ->
returnRn (for_avail : avails)
......
......@@ -35,7 +35,9 @@ import FiniteMap ( lookupFM )
import Id ( GenId{-instance NamedThing-} )
import IdInfo ( FBTypeInfo, ArgUsageInfo )
import Lex ( isLexCon )
import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME )
import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR, allClass_NAME,
ioOkDataCon_NAME
)
import Maybes ( maybeToBool )
import Bag ( bagToList )
import Outputable
......@@ -309,15 +311,22 @@ rnDecl (DefD (DefaultDecl tys src_loc))
rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc))
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
(if is_export then
(if is_import then
addImplicitOccRn name'
else
returnRn name') `thenRn_`
rnHsSigType fo_decl_msg ty `thenRn` \ ty' ->
-- hack: force the constructors of IO to be slurped in,
-- since we need 'em when desugaring a foreign decl.
addImplicitOccRn ioOkDataCon_NAME `thenRn_`
returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc))
where
fo_decl_msg = ptext SLIT("a foreign declaration")
is_export = not (maybeToBool imp_exp) && not (isDynamic ext_nm)
is_import =
not (isDynamic ext_nm) &&
case imp_exp of
FoImport _ -> True
_ -> False
\end{code}
......
......@@ -21,7 +21,7 @@ module TcForeign
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(..), isDynamic, MonoBinds(..),
OutPat(..)
OutPat(..), ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
......@@ -79,20 +79,22 @@ tcForeignExports decls =
-- defines a binding
isForeignImport :: ForeignDecl name -> Bool
isForeignImport (ForeignDecl _ (Just _) _ _ _ _) = True
isForeignImport (ForeignDecl _ Nothing _ Dynamic _ _) = True
isForeignImport _ = False
isForeignImport (ForeignDecl _ k _ dyn _ _) =
case k of
FoImport _ -> True
FoExport -> case dyn of { Dynamic -> True ; _ -> False }
FoLabel -> True
-- exports a binding
isForeignExport :: ForeignDecl name -> Bool
isForeignExport (ForeignDecl _ Nothing _ ext_nm _ _) = not (isDynamic ext_nm)
isForeignExport _ = False
isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
isForeignExport _ = False
\end{code}
\begin{code}
tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsType hs_ty `thenTc` \ sig_ty ->
......@@ -105,7 +107,20 @@ tcFImport fo@(ForeignDecl nm Nothing hs_ty Dynamic cconv src_loc) =
(arg_tys, res_ty) ->
checkForeignExport True t_ty arg_tys res_ty `thenTc_`
let i = (mkUserId nm sig_ty) in
returnTc (i, (ForeignDecl i Nothing undefined Dynamic cconv src_loc))
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcHsType hs_ty `thenTc` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
-- of the foreign type.
(_, t_ty) = splitForAllTys sig_ty
in
check (isAddrTy t_ty) (illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
let i = (mkUserId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment