[project @ 2000-03-23 17:45:17 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 cf850f1..58c73ab 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -20,15 +20,15 @@ module TcForeign
 #include "HsVersions.h"
 
 import HsSyn           ( HsDecl(..), ForeignDecl(..), HsExpr(..),
-                         ExtName(..), isDynamic, MonoBinds(..),
+                         ExtName(Dynamic), isDynamicExtName, MonoBinds(..),
                          OutPat(..), ForKind(..)
                        )
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 
 import TcMonad
 import TcEnv           ( newLocalId )
-import TcType          ( tcInstTcType, typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
-import TcMonoType      ( tcHsType )
+import TcType          ( typeToTcType, tcSplitRhoTy, zonkTcTypeToType )
+import TcMonoType      ( tcHsTopBoxedType )
 import TcHsSyn         ( TcMonoBinds, TypecheckedForeignDecl,
                          TcForeignExportDecl )
 import TcExpr          ( tcId, tcPolyExpr )                    
@@ -36,7 +36,7 @@ import Inst           ( emptyLIE, LIE, plusLIE )
 import CoreSyn
 
 import ErrUtils                ( Message )
-import Id              ( Id, idName, mkUserId )
+import Id              ( Id, idName, mkVanillaId )
 import Name            ( nameOccName )
 import Type            ( splitFunTys
                        , splitTyConApp_maybe
@@ -82,7 +82,7 @@ isForeignImport (ForeignDecl _ k _ dyn _ _) =
 
 -- exports a binding
 isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamic ext_nm)
+isForeignExport (ForeignDecl _ FoExport _ ext_nm _ _) = not (isDynamicExtName ext_nm)
 isForeignExport _                                    = False
 
 \end{code}
@@ -92,7 +92,7 @@ tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl)
 tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
-   tcHsType hs_ty                  `thenTc`    \ sig_ty ->
+   tcHsTopBoxedType hs_ty           `thenTc`   \ sig_ty ->
    let
       -- drop the foralls before inspecting the structure
       -- of the foreign type.
@@ -101,27 +101,27 @@ tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) =
    case splitFunTys t_ty of
      (arg_tys, res_ty) -> 
        checkForeignExport True t_ty arg_tys res_ty `thenTc_`
-       let i = (mkUserId nm sig_ty) in
+       let i = (mkVanillaId nm sig_ty) in
        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 ->
+   tcHsTopBoxedType 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
+   let i = (mkVanillaId 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) =
+tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty                   `thenTc` \ ty ->
+   tcHsTopBoxedType hs_ty           `thenTc` \ ty ->
     -- Check that the type has the right shape
     -- and that the argument and result types are acceptable.
    let
@@ -131,8 +131,8 @@ tcFImport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    in
    case splitFunTys t_ty of
      (arg_tys, res_ty) ->
-        checkForeignImport (isDynamic ext_nm) ty arg_tys res_ty `thenTc_`
-       let i = (mkUserId nm ty) in
+        checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
+       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)
@@ -140,7 +140,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
    tcAddSrcLoc src_loc              $
    tcAddErrCtxt (foreignDeclCtxt fo) $
 
-   tcHsType hs_ty                     `thenTc` \ sig_ty ->
+   tcHsTopBoxedType hs_ty             `thenTc` \ sig_ty ->
    let sig_tc_ty = typeToTcType sig_ty in
    tcPolyExpr (HsVar nm) sig_tc_ty     `thenTc`    \ (rhs, lie, _, _, _) ->
 
@@ -156,7 +156,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
          -- than its declared/inferred type. Hence the need
          -- to create a local binding which will call the exported function
          -- at a particular type (and, maybe, overloading).
-       newLocalId (nameOccName nm) sig_tc_ty   `thenNF_Tc` \ i ->
+       newLocalId (nameOccName nm) sig_tc_ty src_loc   `thenNF_Tc` \ i ->
        let
            bind  = VarMonoBind i rhs
        in
@@ -168,18 +168,18 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) =
 
 
 \begin{code}
-checkForeignImport :: Bool -> Type -> [Type] -> Type -> TcM s ()
-checkForeignImport is_dynamic ty args res
+checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s ()
+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) xs             `thenTc_`
+        mapTc (checkForeignArg (isFFIArgumentTy is_safe)) xs   `thenTc_`
        checkForeignRes (isFFIResultTy) res
  | otherwise =
-     mapTc (checkForeignArg isFFIArgumentTy) args              `thenTc_`
+     mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args     `thenTc_`
      checkForeignRes (isFFIResultTy) res
 
 checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s ()