projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
[project @ 2003-12-10 14:15:16 by simonmar]
[ghc-hetmet.git]
/
ghc
/
compiler
/
typecheck
/
TcForeign.lhs
diff --git
a/ghc/compiler/typecheck/TcForeign.lhs
b/ghc/compiler/typecheck/TcForeign.lhs
index
04e6ce4
..
b5b08f3
100644
(file)
--- a/
ghc/compiler/typecheck/TcForeign.lhs
+++ b/
ghc/compiler/typecheck/TcForeign.lhs
@@
-20,21
+20,14
@@
module TcForeign
#include "config.h"
#include "HsVersions.h"
#include "config.h"
#include "HsVersions.h"
-import HsSyn ( ForeignDecl(..), HsExpr(..),
- MonoBinds(..), ForeignImport(..), ForeignExport(..),
- CImportSpec(..)
- )
-import RnHsSyn ( RenamedForeignDecl )
+import HsSyn
import TcRnMonad
import TcRnMonad
-import TcMonoType ( tcHsSigType, UserTypeCtxt(..) )
-import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl )
+import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcExpr ( tcCheckSigma )
import ErrUtils ( Message )
import Id ( Id, mkLocalId, setIdLocalExported )
import TcExpr ( tcCheckSigma )
import ErrUtils ( Message )
import Id ( Id, mkLocalId, setIdLocalExported )
-import PrimRep ( getPrimRepSize, isFloatingRep )
-import Type ( typePrimRep )
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
import OccName ( mkForeignExportOcc )
import Name ( Name, NamedThing(..), mkExternalName )
import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe,
@@
-51,19
+44,21
@@
import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
import Outputable
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
import Outputable
+import SrcLoc ( Located(..), srcSpanStart )
+import Bag ( emptyBag, consBag )
\end{code}
\begin{code}
-- Defines a binding
\end{code}
\begin{code}
-- Defines a binding
-isForeignImport :: ForeignDecl name -> Bool
-isForeignImport (ForeignImport _ _ _ _ _) = True
-isForeignImport _ = False
+isForeignImport :: LForeignDecl name -> Bool
+isForeignImport (L _ (ForeignImport _ _ _ _)) = True
+isForeignImport _ = False
-- Exports a binding
-- Exports a binding
-isForeignExport :: ForeignDecl name -> Bool
-isForeignExport (ForeignExport _ _ _ _ _) = True
-isForeignExport _ = False
+isForeignExport :: LForeignDecl name -> Bool
+isForeignExport (L _ (ForeignExport _ _ _ _)) = True
+isForeignExport _ = False
\end{code}
%************************************************************************
\end{code}
%************************************************************************
@@
-73,14
+68,13
@@
isForeignExport _ = False
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
-tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl])
+tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id])
tcForeignImports decls
tcForeignImports decls
- = mapAndUnzipM tcFImport (filter isForeignImport decls)
+ = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls)
-tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl)
-tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
- = addSrcLoc src_loc $
- addErrCtxt (foreignDeclCtxt fo) $
+tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
+tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec)
+ = addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
let
-- drop the foralls before inspecting the structure
@@
-95,7
+89,7
@@
tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc)
tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' ->
-- can't use sig_ty here because it :: Type and we need HsType Id
-- hence the undefined
- returnM (id, ForeignImport id undefined imp_decl' isDeprec src_loc)
+ returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec)
\end{code}
\end{code}
@@
-198,22
+192,21
@@
checkFEDArgs arg_tys = returnM ()
%************************************************************************
\begin{code}
%************************************************************************
\begin{code}
-tcForeignExports :: [ForeignDecl Name]
- -> TcM (TcMonoBinds, [TcForeignDecl])
+tcForeignExports :: [LForeignDecl Name]
+ -> TcM (LHsBinds TcId, [LForeignDecl TcId])
tcForeignExports decls
tcForeignExports decls
- = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls)
+ = foldlM combine (emptyBag, []) (filter isForeignExport decls)
where
combine (binds, fs) fe =
where
combine (binds, fs) fe =
- tcFExport fe `thenM ` \ (b, f) ->
- returnM (b `AndMonoBinds` binds, f:fs)
+ wrapLocSndM tcFExport fe `thenM` \ (b, f) ->
+ returnM (b `consBag` binds, f:fs)
-tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl)
-tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
- addSrcLoc src_loc $
+tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id)
+tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) =
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
addErrCtxt (foreignDeclCtxt fo) $
tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty ->
- tcCheckSigma (HsVar nm) sig_ty `thenM` \ rhs ->
+ tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs ->
tcCheckFEType sig_ty spec `thenM_`
tcCheckFEType sig_ty spec `thenM_`
@@
-225,11
+218,12
@@
tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) =
newUnique `thenM` \ uniq ->
getModule `thenM` \ mod ->
let
newUnique `thenM` \ uniq ->
getModule `thenM` \ mod ->
let
- gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) src_loc
+ gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm))
+ Nothing (srcSpanStart loc)
id = setIdLocalExported (mkLocalId gnm sig_ty)
id = setIdLocalExported (mkLocalId gnm sig_ty)
- bind = VarMonoBind id rhs
+ bind = L loc (VarBind id rhs)
in
in
- returnM (bind, ForeignExport id undefined spec isDeprec src_loc)
+ returnM (bind, ForeignExport (L loc id) undefined spec isDeprec)
\end{code}
------------ Checking argument types for foreign export ----------------------
\end{code}
------------ Checking argument types for foreign export ----------------------
@@
-291,9
+285,6
@@
checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
checkDotnet other = Just (text "requires .NET support (-filx or win32)")
#endif
checkDotnet other = Just (text "requires .NET support (-filx or win32)")
#endif
-checkC HscC = Nothing
-checkC other = Just (text "requires C code generation (-fvia-C)")
-
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
checkCOrAsm other
checkCOrAsm HscC = Nothing
checkCOrAsm HscAsm = Nothing
checkCOrAsm other
@@
-305,12
+296,6
@@
checkCOrAsmOrInterp HscInterpreted = Nothing
checkCOrAsmOrInterp other
= Just (text "requires interpreted, C or native code generation")
checkCOrAsmOrInterp other
= Just (text "requires interpreted, C or native code generation")
-checkCOrAsmOrDotNet HscC = Nothing
-checkCOrAsmOrDotNet HscAsm = Nothing
-checkCOrAsmOrDotNet HscILX = Nothing
-checkCOrAsmOrDotNet other
- = Just (text "requires C, native or .NET ILX code generation")
-
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrDotNetOrInterp HscILX = Nothing
checkCOrAsmOrDotNetOrInterp HscC = Nothing
checkCOrAsmOrDotNetOrInterp HscAsm = Nothing
checkCOrAsmOrDotNetOrInterp HscILX = Nothing