[project @ 1999-12-07 15:03:08 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 a6dee24..b1fd17e 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -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
@@ -101,7 +101,7 @@ 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) =
@@ -114,10 +114,10 @@ tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
     (_, 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) $
 
@@ -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 (isDynamic 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)
@@ -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 ()