projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2000-11-24 09:51:38 by simonpj]
[ghc-hetmet.git]
/
ghc
/
compiler
/
typecheck
/
TcForeign.lhs
diff --git
a/ghc/compiler/typecheck/TcForeign.lhs
b/ghc/compiler/typecheck/TcForeign.lhs
index
c84c3c8
..
c8d61d2
100644
(file)
--- a/
ghc/compiler/typecheck/TcForeign.lhs
+++ b/
ghc/compiler/typecheck/TcForeign.lhs
@@
-21,42
+21,41
@@
module TcForeign
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
import HsSyn ( HsDecl(..), ForeignDecl(..), HsExpr(..),
ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
- OutPat(..), ForKind(..)
+ ForKind(..)
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
)
import RnHsSyn ( RenamedHsDecl, RenamedForeignDecl )
import TcMonad
import TcEnv ( newLocalId )
-import TcType ( tcSplitRhoTy, zonkTcTypeToType )
import TcMonoType ( tcHsBoxedSigType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
import TcMonoType ( tcHsBoxedSigType )
import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl,
TcForeignExportDecl )
-import TcExpr ( tcId, tcPolyExpr )
+import TcExpr ( tcPolyExpr )
import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
-import Id ( Id, idName, mkVanillaId )
+import Id ( Id, mkVanillaId )
import Name ( nameOccName )
import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
)
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
import Name ( nameOccName )
import Type ( splitFunTys
, splitTyConApp_maybe
, splitForAllTys
)
import TysWiredIn ( isFFIArgumentTy, isFFIResultTy,
- isFFIExternalTy, isAddrTy,
- isFFIDynResultTy, isFFILabelTy
+ isFFIExternalTy, isFFIDynArgumentTy, isFFIDynResultTy,
+ isFFILabelTy
)
import Type ( Type )
)
import Type ( Type )
-import Unique
+import PrelNames ( hasKey, ioTyConKey )
import Outputable
\end{code}
\begin{code}
import Outputable
\end{code}
\begin{code}
-tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl])
+tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl])
tcForeignImports decls =
mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
tcForeignImports decls =
mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl]
-tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl])
+tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
tcForeignExports decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
[ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
tcForeignExports decls =
foldlTc combine (emptyLIE, EmptyMonoBinds, [])
[ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
@@
-81,7
+80,7
@@
isForeignExport _ = False
\end{code}
\begin{code}
\end{code}
\begin{code}
-tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
+tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
@@
-129,7
+128,7
@@
tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_
let i = (mkVanillaId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
let i = (mkVanillaId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
-tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl)
+tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
tcAddSrcLoc src_loc $
tcAddErrCtxt (foreignDeclCtxt fo) $
@@
-161,26
+160,28
@@
tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
\begin{code}
\begin{code}
-checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM ()
checkForeignImport is_dynamic is_safe ty args res
| is_dynamic =
-- * first arg has got to be an Addr
case args of
[] -> check False (illegalForeignTyErr True{-Arg-} ty)
(x:xs) ->
checkForeignImport is_dynamic is_safe ty args res
| is_dynamic =
-- * first arg has got to be an Addr
case args of
[] -> check False (illegalForeignTyErr True{-Arg-} ty)
(x:xs) ->
- check (isAddrTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
- mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs `thenTc_`
+ getDOptsTc `thenTc` \ dflags ->
+ check (isFFIDynArgumentTy x) (illegalForeignTyErr True{-Arg-} ty) `thenTc_`
+ mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) xs `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
| otherwise =
checkForeignRes True {-NonIO ok-} isFFIResultTy res
| otherwise =
- mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_`
+ getDOptsTc `thenTc` \ dflags ->
+ mapTc (checkForeignArg (isFFIArgumentTy dflags is_safe)) args `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
checkForeignRes True {-NonIO ok-} isFFIResultTy res
-checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()
+checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM ()
checkForeignExport is_dynamic ty args res
| is_dynamic =
-- * the first (and only!) arg has got to be a function type
-- and it must return IO t
checkForeignExport is_dynamic ty args res
| is_dynamic =
-- * the first (and only!) arg has got to be a function type
-- and it must return IO t
- -- * result type is an Addr or IO Addr
+ -- * result type is IO Addr
case args of
[arg] ->
case splitFunTys arg of
case args of
[arg] ->
case splitFunTys arg of
@@
-193,13
+194,13
@@
checkForeignExport is_dynamic ty args res
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
mapTc (checkForeignArg isFFIExternalTy) args `thenTc_`
checkForeignRes True {-NonIO ok-} isFFIResultTy res
-checkForeignArg :: (Type -> Bool) -> Type -> TcM s ()
+checkForeignArg :: (Type -> Bool) -> Type -> TcM ()
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty)
-- Check that the type has the form
-- (IO t) or (t) , and that t satisfies the given predicate.
--
-checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s ()
+checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM ()
checkForeignRes non_io_result_ok pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
checkForeignRes non_io_result_ok pred_res_ty ty =
case (splitTyConApp_maybe ty) of
Just (io, [res_ty])
@@
-213,7
+214,7
@@
checkForeignRes non_io_result_ok pred_res_ty ty =
Warnings
\begin{code}
Warnings
\begin{code}
-check :: Bool -> Message -> TcM s ()
+check :: Bool -> Message -> TcM ()
check True _ = returnTc ()
check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
check True _ = returnTc ()
check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()