[project @ 2002-04-02 13:21:36 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 43c861a..b2ddda6 100644 (file)
--- a/ghc/compiler/typecheck/TcForeign.lhs
+++ b/ghc/compiler/typecheck/TcForeign.lhs
@@ -26,17 +26,18 @@ import HsSyn                ( HsDecl(..), ForeignDecl(..), HsExpr(..),
 import RnHsSyn         ( RenamedHsDecl, RenamedForeignDecl )
 
 import TcMonad
-import TcEnv           ( newLocalName )
 import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
 import TcHsSyn         ( TcMonoBinds, TypecheckedForeignDecl, TcForeignExportDecl )
 import TcExpr          ( tcExpr )                      
 import Inst            ( emptyLIE, LIE, plusLIE )
 
 import ErrUtils                ( Message )
-import Id              ( Id, mkLocalId )
-import Name            ( nameOccName )
+import Id              ( Id, mkLocalId, setIdLocalExported )
 import PrimRep         ( getPrimRepSize, isFloatingRep )
+import Module          ( Module )
 import Type            ( typePrimRep )
+import OccName         ( mkForeignExportOcc )
+import Name            ( NamedThing(..), mkExternalName )
 import TcType          ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
                          tcSplitForAllTys, 
                          isFFIArgumentTy, isFFIImportResultTy, 
@@ -44,7 +45,7 @@ import TcType         ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
                          isFFIExternalTy, isFFIDynArgumentTy,
                          isFFIDynResultTy, isForeignPtrTy
                        )
-import ForeignCall     ( CCallSpec(..), CExportSpec(..), CCallTarget(..),
+import ForeignCall     ( CExportSpec(..), CCallTarget(..),
                          isDynamicTarget, isCasmTarget ) 
 import CStrings                ( CLabelString, isCLabelString )
 import PrelNames       ( hasKey, ioTyConKey )
@@ -90,6 +91,8 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
        id                = mkLocalId nm sig_ty
    in
    tcCheckFIType sig_ty arg_tys res_ty imp_decl                `thenNF_Tc_` 
+   -- can't use sig_ty here because it :: Type and we need HsType Id
+   -- hence the undefined
    returnTc (id, ForeignImport id undefined imp_decl isDeprec src_loc)
 \end{code}
 
@@ -109,7 +112,7 @@ tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ CWrapper)
        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
        -- as ft -> IO Addr is accepted, too.  The use of the latter two forms
        -- is DEPRECATED, though.
-    checkCg checkCOrAsm                `thenNF_Tc_`
+    checkCg checkCOrAsmOrInterp                `thenNF_Tc_`
     case arg_tys of
        [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys                  `thenNF_Tc_`
                     checkForeignRes nonIOok  isFFIExportResultTy res1_ty       `thenNF_Tc_`
@@ -191,17 +194,18 @@ checkFEDArgs arg_tys = returnNF_Tc ()
 %************************************************************************
 
 \begin{code}
-tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
-tcForeignExports decls = 
+tcForeignExports :: Module -> [RenamedHsDecl] 
+                -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl])
+tcForeignExports mod decls = 
    foldlTc combine (emptyLIE, EmptyMonoBinds, [])
      [foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl]
   where
    combine (lie, binds, fs) fe = 
-       tcFExport fe `thenTc ` \ (a_lie, b, f) ->
+       tcFExport mod fe `thenTc ` \ (a_lie, b, f) ->
        returnTc (lie `plusLIE` a_lie, b `AndMonoBinds` binds, f:fs)
 
-tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
-tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
+tcFExport :: Module -> RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
+tcFExport mod fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
    tcAddSrcLoc src_loc                 $
    tcAddErrCtxt (foreignDeclCtxt fo)   $
 
@@ -214,9 +218,11 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
          -- constrained 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).
-   newLocalName nm                     `thenNF_Tc` \ id_name ->
+
+   tcGetUnique                         `thenNF_Tc` \ uniq ->
    let
-       id   = mkLocalId id_name sig_ty
+        gnm  = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
+       id   = setIdLocalExported (mkLocalId gnm sig_ty)
        bind = VarMonoBind id rhs
    in
    returnTc (lie, bind, ForeignExport id undefined spec isDeprec src_loc)