Commit 0299e1a1 authored by chak's avatar chak
Browse files

[project @ 2002-02-04 03:40:31 by chak]

Foreign import/export declarations now conform to FFI Addendum Version 1.0

* The old form of foreign declarations is still supported, but generates
  deprecation warnings.

* There are some rather exotic old-style declarations which have become
  invalid as they are interpreted differently under the new scheme and there
  is no (easy) way to determine which style the programmer had in mind (eg,
  importing a C function with the name `wrapper' where the external name is
  explicitly given will not work in some situations - depends on whether an
  `unsafe' was specified and similar things).

* Some "new" old-style forms have been introduced to make parsing a little bit
  easier (ie, avoid shift/reduce conflicts between new-style and old-style
  grammar rules), but they are few, arcane, and don't really hurt (and I won't
  tell what they are, you need to find that out by yourself ;-)

* The FFI Addendum doesn't specify whether a header file that is requested for
  inclusion by multiple foreign declarations should be included only once or
  multiple times.  GHC at the moment includes an header as often as it appears
  in a foreign declaration.  For properly written headers, it doesn't make a
  difference anyway...

* Library object specifications are currently silently ignored.  The feature
  was mainly requested for external calls in .NET (ie, calls which invoke C
  routines when Haskell is compiled to ILX), but those don't seem to be
  supported yet.

* Foreign label declarations are currently broken, but they were already
  broken before I started messing with the stuff.

The code is moderately tested.  All modules in lib/std/ and hslibs/lang/
(using old-style declarations) still compile fine and I have run a couple of
tests on the different forms of new-style declarations.
parent a68338c1
......@@ -51,7 +51,7 @@ deSugar :: DynFlags
-> PersistentCompilerState -> HomeSymbolTable
-> Module -> PrintUnqualified
-> TcResults
-> IO (ModDetails, (SDoc, SDoc, [CoreBndr]))
-> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
deSugar dflags pcs hst mod_name unqual
(TcResults {tc_env = type_env,
......@@ -130,7 +130,7 @@ deSugarExpr dflags pcs hst mod_name unqual tc_expr
dsProgram mod_name all_binds rules fo_decls
= dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs ->
dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code) ->
dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code, headers) ->
let
ds_binds = [Rec (foreign_binds ++ core_prs)]
-- Notice that we put the whole lot in a big Rec, even the foreign binds
......@@ -142,7 +142,7 @@ dsProgram mod_name all_binds rules fo_decls
local_binders = mkVarSet (bindersOfBinds ds_binds)
in
mapDs (dsRule local_binders) rules `thenDs` \ rules' ->
returnDs (ds_binds, rules', (h_code, c_code, fe_binders))
returnDs (ds_binds, rules', (h_code, c_code, headers, fe_binders))
where
auto_scc | opt_SccProfilingOn = TopLevel
| otherwise = NoSccs
......
......@@ -15,7 +15,8 @@ import CoreSyn
import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad
import HsSyn ( ForeignDecl(..), FoExport(..), FoImport(..) )
import HsSyn ( ForeignDecl(..), ForeignExport(..),
ForeignImport(..), CImportSpec(..) )
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
......@@ -47,6 +48,7 @@ import PrelNames ( hasKey, ioTyConKey, deRefStablePtrName, newStablePtrName,
bindIOName, returnIOName
)
import BasicTypes ( Activation( NeverActive ) )
import ErrUtils ( addShortWarnLocLine )
import Outputable
import Maybe ( fromJust )
\end{code}
......@@ -77,17 +79,29 @@ dsForeigns :: Module
-- "foreign exported" functions.
, SDoc -- C stubs to use when calling
-- "foreign exported" functions.
, [FAST_STRING] -- headers that need to be included
-- into C code generated for this module
)
dsForeigns mod_name fos
= foldlDs combine ([], [], empty, empty) fos
= foldlDs combine ([], [], empty, empty, []) fos
where
combine (acc_feb, acc_f, acc_h, acc_c) (ForeignImport id _ spec _)
= dsFImport mod_name id spec `thenDs` \ (bs, h, c) ->
returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c)
combine (acc_feb, acc_f, acc_h, acc_c) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) _)
= dsFExport mod_name id (idType id) ext_nm cconv False `thenDs` \ (feb, b, h, c) ->
returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c)
combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
(ForeignImport id _ spec depr loc)
= dsFImport mod_name id spec `thenDs` \(bs, h, c, hd) ->
warnDepr depr loc `thenDs` \_ ->
returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header)
combine (acc_feb, acc_f, acc_h, acc_c, acc_header)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
= dsFExport mod_name id (idType id)
ext_nm cconv False `thenDs` \(feb, b, h, c) ->
warnDepr depr loc `thenDs` \_ ->
returnDs (feb:acc_feb, b : acc_f, h $$ acc_h, c $$ acc_c, acc_header)
warnDepr False _ = returnDs ()
warnDepr True loc = dsWarn (addShortWarnLocLine loc msg)
where
msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax")
\end{code}
......@@ -114,23 +128,38 @@ However, we create a worker/wrapper pair, thus:
The strictness/CPR analyser won't do this automatically because it doesn't look
inside returned tuples; but inlining this wrapper is a Really Good Idea
because it exposes the boxing to the call site.
\begin{code}
dsFImport :: Module
-> Id
-> FoImport
-> ForeignImport
-> DsM ([Binding], SDoc, SDoc, [FAST_STRING])
dsFImport modName id (CImport cconv safety header lib spec) =
dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) ->
returnDs (ids, h, c, if _NULL_ header then [] else [header])
-- FIXME: the `lib' field is needed for .NET ILX generation when invoking
-- routines that are external to the .NET runtime, but GHC doesn't
-- support such calls yet; if `_NULL_ lib', the value was not given
dsFImport modName id (DNImport spec) =
dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) ->
returnDs (ids, h, c, [])
dsCImport :: Module
-> Id
-> CImportSpec
-> CCallConv
-> Safety
-> DsM ([Binding], SDoc, SDoc)
dsFImport mod_name lbl_id (LblImport ext_nm)
= ASSERT(fromJust res_ty `eqType` addrPrimTy) -- typechecker ensures this
returnDs ([(lbl_id, rhs)], empty, empty)
dsCImport modName id (CLabel cid) _ _ =
ASSERT(fromJust res_ty `eqType` addrPrimTy) -- typechecker ensures this
returnDs ([(id, rhs)], empty, empty)
where
(res_ty, fo_rhs) = resultWrapper (idType lbl_id)
rhs = fo_rhs (mkLit (MachLabel ext_nm))
dsFImport mod_name fn_id (CImport spec) = dsFCall mod_name fn_id (CCall spec)
dsFImport mod_name fn_id (DNImport spec) = dsFCall mod_name fn_id (DNCall spec)
dsFImport mod_name fn_id (CDynImport cconv) = dsFExportDynamic mod_name fn_id cconv
(resTy, foRhs) = resultWrapper (idType id)
rhs = foRhs (mkLit (MachLabel cid))
dsCImport modName id (CFunction target) cconv safety =
dsFCall modName id (CCall (CCallSpec target cconv safety))
dsCImport modName id CWrapper cconv _ =
dsFExportDynamic modName id cconv
\end{code}
......
......@@ -10,7 +10,8 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@,
module HsDecls (
HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
DefaultDecl(..),
ForeignDecl(..), FoImport(..), FoExport(..), FoType(..),
ForeignDecl(..), ForeignImport(..), ForeignExport(..),
CImportSpec(..), FoType(..),
ConDecl(..), ConDetails(..),
BangType(..), getBangType, getBangStrictness, unbangedType,
DeprecDecl(..), DeprecTxt,
......@@ -35,7 +36,8 @@ import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
)
import CoreSyn ( CoreRule(..), RuleName )
import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) )
import ForeignCall ( CExportSpec, CCallSpec, DNCallSpec, CCallConv )
import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety,
CExportSpec(..))
-- others:
import Name ( NamedThing )
......@@ -87,13 +89,13 @@ data HsDecl name pat
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
=> HsDecl name pat -> name
#endif
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD decl) = forDeclName decl
hsDeclName (FixD (FixitySig name _ _)) = name
hsDeclName (TyClD decl) = tyClDeclName decl
hsDeclName (InstD decl) = instDeclName decl
hsDeclName (ForD decl) = foreignDeclName decl
hsDeclName (FixD (FixitySig name _ _)) = name
-- Others don't make sense
#ifdef DEBUG
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x)
#endif
......@@ -719,43 +721,110 @@ instance (Outputable name)
%************************************************************************
\begin{code}
-- foreign declarations are distinguished as to whether they define or use a
-- Haskell name
--
-- * the Boolean value indicates whether the pre-standard deprecated syntax
-- has been used
--
data ForeignDecl name
= ForeignImport name (HsType name) FoImport SrcLoc
| ForeignExport name (HsType name) FoExport SrcLoc
= ForeignImport name (HsType name) ForeignImport Bool SrcLoc -- defines name
| ForeignExport name (HsType name) ForeignExport Bool SrcLoc -- uses name
forDeclName (ForeignImport n _ _ _) = n
forDeclName (ForeignExport n _ _ _) = n
-- yield the Haskell name defined or used in a foreign declaration
--
foreignDeclName :: ForeignDecl name -> name
foreignDeclName (ForeignImport n _ _ _ _) = n
foreignDeclName (ForeignExport n _ _ _ _) = n
data FoImport
= LblImport CLabelString -- foreign label
| CImport CCallSpec -- foreign import
| CDynImport CCallConv -- foreign export dynamic
| DNImport DNCallSpec -- foreign import dotnet
-- specification of an imported external entity in dependence on the calling
-- convention
--
data ForeignImport = -- import of a C entity
--
-- * the two strings specifying a header file or library
-- may be empty, which indicates the absence of a
-- header or object specification (both are not used
-- in the case of `CWrapper' and when `CFunction'
-- has a dynamic target)
--
-- * the calling convention is irrelevant for code
-- generation in the case of `CLabel', but is needed
-- for pretty printing
--
-- * `Safety' is irrelevant for `CLabel' and `CWrapper'
--
CImport CCallConv -- ccall or stdcall
Safety -- safe or unsafe
FastString -- name of C header
FastString -- name of library object
CImportSpec -- details of the C entity
-- import of a .NET function
--
| DNImport DNCallSpec
-- details of an external C entity
--
data CImportSpec = CLabel CLabelString -- import address of a C label
| CFunction CCallTarget -- static or dynamic function
| CWrapper -- wrapper to expose closures
-- (former f.e.d.)
data FoExport = CExport CExportSpec
-- specification of an externally exported entity in dependence on the calling
-- convention
--
data ForeignExport = CExport CExportSpec -- contains the calling convention
| DNExport -- presently unused
-- abstract type imported from .NET
--
data FoType = DNType -- In due course we'll add subtype stuff
deriving( Eq ) -- Used for equality instance for TyClDecl
deriving (Eq) -- Used for equality instance for TyClDecl
-- pretty printing of foreign declarations
--
instance Outputable name => Outputable (ForeignDecl name) where
ppr (ForeignImport nm ty (LblImport lbl) src_loc)
= ptext SLIT("foreign label") <+> ppr lbl <+> ppr nm <+> dcolon <+> ppr ty
ppr (ForeignImport nm ty decl src_loc)
= ptext SLIT("foreign import") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
ppr (ForeignExport nm ty decl src_loc)
= ptext SLIT("foreign export") <+> ppr decl <+> ppr nm <+> dcolon <+> ppr ty
instance Outputable FoImport where
ppr (CImport d) = ppr d
ppr (CDynImport conv) = text "dynamic" <+> ppr conv
ppr (DNImport d) = ptext SLIT("dotnet") <+> ppr d
ppr (LblImport l) = ptext SLIT("label") <+> ppr l
instance Outputable FoExport where
ppr (CExport d) = ppr d
ppr (ForeignImport n ty fimport _ _) =
ptext SLIT("foreign import") <+> ppr fimport <+>
ppr n <+> dcolon <+> ppr ty
ppr (ForeignExport n ty fexport _ _) =
ptext SLIT("foreign export") <+> ppr fexport <+>
ppr n <+> dcolon <+> ppr ty
instance Outputable ForeignImport where
ppr (DNImport spec) =
ptext SLIT("dotnet") <+> ppr spec
ppr (CImport cconv safety header lib spec) =
ppr cconv <+> ppr safety <+>
char '"' <> pprCEntity header lib spec <> char '"'
where
pprCEntity header lib (CLabel lbl) =
ptext SLIT("static") <+> ptext header <+> char '&' <>
pprLib lib <> ppr lbl
pprCEntity header lib (CFunction (StaticTarget lbl)) =
ptext SLIT("static") <+> ptext header <+> char '&' <>
pprLib lib <> ppr lbl
pprCEntity header lib (CFunction (DynamicTarget)) =
ptext SLIT("dynamic")
pprCEntity header lib (CFunction (CasmTarget _)) =
panic "HsDecls.pprCEntity: malformed C function target"
pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper")
--
pprLib lib | nullFastString lib = empty
| otherwise = char '[' <> ppr lib <> char ']'
instance Outputable ForeignExport where
ppr (CExport (CExportStatic lbl cconv)) =
ppr cconv <+> char '"' <> ppr lbl <> char '"'
ppr (DNExport ) =
ptext SLIT("dotnet") <+> ptext SLIT("\"<unused>\"")
instance Outputable FoType where
ppr DNType = ptext SLIT("type dotnet")
ppr DNType = ptext SLIT("type dotnet")
\end{code}
......
......@@ -69,6 +69,7 @@ import CodeOutput ( codeOutput )
import Module ( ModuleName, moduleName, mkHomeModule,
moduleUserString, lookupModuleEnv )
import CmdLineOpts
import DriverState ( v_HCHeader )
import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
......@@ -83,7 +84,8 @@ import Name ( Name, nameModule, nameOccName, getName, isGlobalName )
import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module )
import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import IOExts ( newIORef, readIORef, writeIORef, modifyIORef,
unsafePerformIO )
import Monad ( when )
import Maybe ( isJust, fromJust )
......@@ -334,7 +336,22 @@ hscRecomp ghci_mode dflags have_object
mod_name_to_Module nm
= do m <- findModule nm ; return (fst (fromJust m))
(h_code,c_code,fe_binders) = foreign_stuff
(h_code, c_code, headers, fe_binders) = foreign_stuff
-- turn the list of headers requested in foreign import
-- declarations into a string suitable for emission into generated
-- C code...
--
foreign_headers =
unlines
. map (\fname -> "#include \"" ++ _UNPK_ fname ++ "\"")
. reverse
$ headers
-- ...and add the string to the headers requested via command line
-- options
--
; modifyIORef v_HCHeader (++ foreign_headers)
; imported_modules <- mapM mod_name_to_Module imported_module_names
......
......@@ -118,6 +118,7 @@ data Token
| ITexport
| ITlabel
| ITdynamic
| ITsafe
| ITunsafe
| ITwith
| ITstdcallconv
......@@ -292,6 +293,7 @@ isSpecial ITforall = True
isSpecial ITexport = True
isSpecial ITlabel = True
isSpecial ITdynamic = True
isSpecial ITsafe = True
isSpecial ITunsafe = True
isSpecial ITwith = True
isSpecial ITccallconv = True
......@@ -306,6 +308,7 @@ ghcExtensionKeywordsFM = listToUFM $
( "export", ITexport ),
( "label", ITlabel ),
( "dynamic", ITdynamic ),
( "safe", ITunsafe ),
( "unsafe", ITunsafe ),
( "with", ITwith ),
( "stdcall", ITstdcallconv),
......
......@@ -5,34 +5,48 @@
\begin{code}
module ParseUtil (
parseError -- String -> Pa
parseError -- String -> Pa
, mkVanillaCon, mkRecCon,
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp
, groupBindings
, mkExtName -- RdrName -> ExtName
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkInstType -- HsType -> P HsType
, checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
, checkDo -- [Stmt] -> P [Stmt]
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, CallConv(..)
, mkImport -- CallConv -> Safety
-- -> (FAST_STRING, RdrName, RdrNameHsType)
-- -> SrcLoc
-- -> P RdrNameHsDecl
, mkExport -- CallConv
-- -> (FAST_STRING, RdrName, RdrNameHsType)
-- -> SrcLoc
-- -> P RdrNameHsDecl
, mkExtName -- RdrName -> CLabelString
, checkPrec -- String -> P String
, checkContext -- HsType -> P HsContext
, checkInstType -- HsType -> P HsType
, checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName])
, checkPattern -- HsExp -> P HsPat
, checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat]
, checkDo -- [Stmt] -> P [Stmt]
, checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
, checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
) where
#include "HsVersions.h"
import List ( isSuffixOf )
import Lex
import HsSyn -- Lots of it
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
DNCallSpec(..))
import SrcLoc
import RdrHsSyn ( RdrBinding(..),
RdrNameHsType, RdrNameBangType, RdrNameContext,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr,
RdrNameGRHSs, RdrNameHsRecordBinds,
RdrNameMonoBinds, RdrNameConDetails, RdrNameHsDecl,
mkNPlusKPat
)
import RdrName
......@@ -40,7 +54,7 @@ import PrelNames ( unitTyCon_RDR )
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
import CStrings ( CLabelString )
import FastString ( unpackFS )
import FastString ( nullFastString )
import Outputable
-----------------------------------------------------------------------------
......@@ -298,13 +312,105 @@ mkRecConstrOrUpdate exp fs@(_:_)
mkRecConstrOrUpdate _ _
= parseError "Empty record update"
-- Supplying the ext_name in a foreign decl is optional ; if it
-----------------------------------------------------------------------------
-- utilities for foreign declarations
-- supported calling conventions
--
data CallConv = CCall CCallConv -- ccall or stdcall
| DNCall -- .NET
-- construct a foreign import declaration
--
mkImport :: CallConv
-> Safety
-> (FAST_STRING, RdrName, RdrNameHsType)
-> SrcLoc
-> P RdrNameHsDecl
mkImport (CCall cconv) safety (entity, v, ty) loc =
parseCImport entity cconv safety v `thenP` \importSpec ->
returnP $ ForD (ForeignImport v ty importSpec False loc)
mkImport (DNCall ) _ (entity, v, ty) loc =
returnP $ ForD (ForeignImport v ty (DNImport (DNCallSpec entity)) False loc)
-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
--
parseCImport :: FAST_STRING
-> CCallConv
-> Safety
-> RdrName
-> P ForeignImport
parseCImport entity cconv safety v
-- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak
| entity == SLIT ("dynamic") =
returnP $ CImport cconv safety _NIL_ _NIL_ (CFunction DynamicTarget)
| entity == SLIT ("wrapper") =
returnP $ CImport cconv safety _NIL_ _NIL_ CWrapper
| otherwise = parse0 (_UNPK_ entity)
where
-- using the static keyword?
parse0 (' ': rest) = parse0 rest
parse0 ('s':'t':'a':'t':'i':'c':rest) = parse1 rest
parse0 rest = parse1 rest
-- check for header file name
parse1 "" = parse4 "" _NIL_ False _NIL_
parse1 (' ':rest) = parse1 rest
parse1 str@('&':_ ) = parse2 str _NIL_
parse1 str@('[':_ ) = parse3 str _NIL_ False
parse1 str
| ".h" `isSuffixOf` first = parse2 rest (_PK_ first)
| otherwise = parse4 str _NIL_ False _NIL_
where
(first, rest) = break (\c -> c == ' ' || c == '&' || c == '[') str
-- check for address operator (indicating a label import)
parse2 "" header = parse4 "" header False _NIL_
parse2 (' ':rest) header = parse2 rest header
parse2 ('&':rest) header = parse3 rest header True
parse2 str@('[':_ ) header = parse3 str header False
parse2 str header = parse4 str header False _NIL_
-- check for library object name
parse3 (' ':rest) header isLbl = parse3 rest header isLbl
parse3 ('[':rest) header isLbl =
case break (== ']') rest of
(lib, ']':rest) -> parse4 rest header isLbl (_PK_ lib)
_ -> parseError "Missing ']' in entity"
parse3 str header isLbl = parse4 str header isLbl _NIL_
-- check for name of C function
parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib
parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib
parse4 str header isLbl lib
| all (== ' ') rest = build (_PK_ first) header isLbl lib
| otherwise = parseError "Malformed entity string"
where
(first, rest) = break (== ' ') str
--
build cid header False lib = returnP $
CImport cconv safety header lib (CFunction (StaticTarget cid))
build cid header True lib = returnP $
CImport cconv safety header lib (CLabel cid )
-- construct a foreign export declaration
--
mkExport :: CallConv
-> (FAST_STRING, RdrName, RdrNameHsType)
-> SrcLoc
-> P RdrNameHsDecl
mkExport (CCall cconv) (entity, v, ty) loc = returnP $
ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc)
where
entity' | nullFastString entity = mkExtName v
| otherwise = entity
mkExport DNCall (entity, v, ty) loc =
parseError "Foreign export is not yet supported for .NET"
-- Supplying the ext_name in a foreign decl is optional; if it
-- isn't there, the Haskell name is assumed. Note that no transformation
-- of the Haskell name is then performed, so if you foreign export (++),
-- it's external name will be "++". Too bad; it's important because we don't
-- want z-encoding (e.g. names with z's in them shouldn't be doubled)
-- (This is why we use occNameUserString.)
--
mkExtName :: RdrName -> CLabelString
mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm))
......
{-
{- -*-haskell-*-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.82 2002/01/29 09:58:18 simonpj Exp $
$Id: Parser.y,v 1.83 2002/02/04 03:40:32 chak Exp $
Haskell grammar.
......@@ -43,8 +43,7 @@ import Outputable
{-
-----------------------------------------------------------------------------
Conflicts: 14 shift/reduce
(note: it's currently 21 -- JRL, 31/1/2000)
Conflicts: 21 shift/reduce, -=chak[4Feb2]
8 for abiguity in 'if x then y else z + 1'
(shift parses as 'if x then y else (z + 1)', as per longest-parse rule)
......@@ -66,6 +65,9 @@ Conflicts: 14 shift/reduce
Only sensible parse is 'x @ (Rec{..})', which is what resolving
to shift gives us.
6 for conflicts between `fdecl' and `fdeclDEPRECATED', which are resolved
correctly, and moreover, should go away when `fdeclDEPRECATED' is removed.
-----------------------------------------------------------------------------
-}
......@@ -102,6 +104,7 @@ Conflicts: 14 shift/reduce
'export' { ITexport }
'label' { ITlabel }
'dynamic' { ITdynamic }
'safe' { ITsafe }
'unsafe' { ITunsafe }
'with' { ITwith }
'stdcall' { ITstdcallconv }
......@@ -368,44 +371,123 @@ topdecl :: { RdrBinding }
in RdrHsDecl (InstD (InstDecl $3 binds sigs Nothing $1)) }
| srcloc 'default' '(' types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) }
| 'foreign' fordecl { RdrHsDecl $2 }
| 'foreign' fdecl { RdrHsDecl $2 }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
| decl { $1 }
fordecl :: { RdrNameHsDecl }
fordecl : srcloc 'label' ext_name varid '::' sigtype
{ ForD (ForeignImport $4 $6 (LblImport ($3 `orElse` mkExtName $4)) $1) }
----------- ccall/stdcall decls ------------
| srcloc 'import' ccallconv ext_name unsafe_flag varid_no_unsafe '::' sigtype
{ let
call_spec = CCallSpec (StaticTarget ($4 `orElse` mkExtName $6)) $3 $5
in
ForD (ForeignImport $6 $8 (CImport call_spec) $1)
}
| srcloc 'import' ccallconv 'dynamic' unsafe_flag varid_no_unsafe '::' sigtype
{ let
call_spec = CCallSpec DynamicTarget $3 $5
in
ForD (ForeignImport $6 $8 (CImport call_spec) $1)
}
| srcloc 'export' ccallconv ext_name varid '::' sigtype
{ ForD (ForeignExport $5 $7 (CExport (CExportStatic ($4 `orElse` mkExtName $5) $3)) $1) }
| srcloc 'export' ccallconv 'dynamic' varid '::' sigtype
{ ForD (ForeignImport $5 $7 (CDynImport $3) $1) }
----------- .NET decls ------------
| srcloc 'import' 'dotnet' ext_name varid '::' sigtype
{ ForD (ForeignImport $5 $7 (DNImport (DNCallSpec ($4 `orElse` mkExtName $5))) $1) }
| srcloc 'import' 'dotnet' 'type' ext_name tycon
{ TyClD (ForeignType $6 $5 DNType $1) }
-- for the time being, the following accepts foreign declarations conforming
-- to the FFI Addendum, Version 1.0 as well as pre-standard declarations
--
-- * a flag indicates whether pre-standard declarations have been used and
-- triggers a deprecation warning further down the road
--
-- NB: The first two rules could be combined into one by replacing `safety1'
-- with `safety'. However, the combined rule conflicts with the
-- DEPRECATED rules.