*/
#undef VOID_INT_SIGNALS
+/* Define if you want to include .NET interop support. */
+#undef WANT_DOTNET_SUPPORT
+
\f
/* Leave that blank line there!! Autoheader needs it.
If you're adding to this file, keep in mind:
)
AC_SUBST(GhcLibsWithHOpenGL)
+dnl ** .NET interop support?
+dnl --------------------------------------------------------------
+AC_ARG_ENABLE(dotnet,
+[ --enable-dotnet
+ Build .NET interop layer.
+],
+[DotnetSupport=YES],
+[DotnetSupport=NO]
+)
+AC_DEFINE(WANT_DOTNET_SUPPORT)
+AC_SUBST(DotnetSupport)
+
dnl --------------------------------------------------------------
dnl End of configure script option section
dnl --------------------------------------------------------------
)
import ForeignCall ( CCallSpec(..), CCallTarget(..), playSafe,
- playThreadSafe, ccallConvAttribute )
+ playThreadSafe, ccallConvAttribute,
+ ForeignCall(..), Safety(..), DNCallSpec(..),
+ DNType(..), DNKind(..) )
import CLabel ( externallyVisibleCLabel,
needsCDecl, pprCLabel, mkClosureLabel,
mkReturnInfoLabel, mkReturnPtLabel, mkClosureTblLabel,
import Maybes ( catMaybes )
import PrimOp ( primOpNeedsWrapper )
import MachOp ( MachOp(..) )
-import ForeignCall ( ForeignCall(..) )
import PrimRep ( isFloatingRep, PrimRep(..), getPrimRepSize )
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
that the runtime check that PerformGC is being used sensibly will work.
\begin{code}
-pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
- = vcat [
- char '{',
- declare_local_vars, -- local var for *result*
- vcat local_arg_decls,
- pp_save_context,
- process_casm local_vars pp_non_void_args call_str,
- pp_restore_context,
- assign_results,
- char '}'
- ]
+pprFCall call uniq args results vol_regs
+ = case call of
+ CCall (CCallSpec target _cconv safety) ->
+ vcat [ char '{',
+ declare_local_vars, -- local var for *result*
+ vcat local_arg_decls,
+ makeCall target safety
+ (process_casm local_vars pp_non_void_args (call_str target)),
+ assign_results,
+ char '}'
+ ]
+ DNCall (DNCallSpec isStatic kind assem nm argTys resTy) ->
+ let
+ target = StaticTarget (mkFastString nm)
+ resultVar = "_ccall_result"
+
+ hasAssemArg = isStatic || kind == DNConstructor
+ invokeOp =
+ case kind of
+ DNMethod
+ | isStatic -> "DN_invokeStatic"
+ | otherwise -> "DN_invokeMethod"
+ DNField
+ | isStatic ->
+ if resTy == DNUnit
+ then "DN_setStatic"
+ else "DN_getStatic"
+ | otherwise ->
+ if resTy == DNUnit
+ then "DN_setField"
+ else "DN_getField"
+ DNConstructor -> "DN_createObject"
+
+ (methArrDecl, methArrInit, methArrName, methArrLen)
+ | null argTys = (empty, empty, text "NULL", text "0")
+ | otherwise =
+ ( text "DotnetArg __meth_args[" <> int (length argTys) <> text "];"
+ , vcat (zipWith3 (\ idx arg argTy ->
+ text "__meth_args[" <> int idx <> text "].arg." <> text (toDotnetArgField argTy) <> equals <> ppr_amode arg <> semi $$
+ text "__meth_args[" <> int idx <> text "].arg_type=" <> text (toDotnetTy argTy) <> semi)
+ [0..]
+ non_void_args
+ argTys)
+ , text "__meth_args"
+ , int (length non_void_args)
+ )
+ in
+ vcat [ char '{',
+ declare_local_vars,
+ vcat local_arg_decls,
+ vcat [ methArrDecl
+ , methArrInit
+ , text "_ccall_result1 =" <+> text invokeOp <> parens (
+ hcat (punctuate comma $
+ (if hasAssemArg then
+ ((if null assem then
+ text "NULL"
+ else
+ doubleQuotes (text assem)):)
+ else
+ id) $
+ [ doubleQuotes $ text nm
+ , methArrName
+ , methArrLen
+ , text (toDotnetTy resTy)
+ , text "(void*)&" <> text resultVar
+ ])) <> semi
+ ],
+ assign_results,
+ char '}'
+ ]
where
(pp_saves, pp_restores) = ppr_vol_regs vol_regs
-
- thread_macro_args = ppr_uniq_token <> comma <+>
- text "rts" <> ppr (playThreadSafe safety)
- ppr_uniq_token = text "tok_" <> ppr uniq
- (pp_save_context, pp_restore_context)
+
+ makeCall target safety theCall =
+ vcat [ pp_save_context, theCall, pp_restore_context ]
+ where
+ (pp_save_context, pp_restore_context)
| playSafe safety = ( text "{ I_" <+> ppr_uniq_token <>
text "; SUSPEND_THREAD" <> parens thread_macro_args <> semi
, text "RESUME_THREAD" <> parens thread_macro_args <> text ";}"
)
| otherwise = ( pp_basic_saves $$ pp_saves,
pp_basic_restores $$ pp_restores)
+ where
+ thread_macro_args = ppr_uniq_token <> comma <+>
+ text "rts" <> ppr (playThreadSafe safety)
+ ppr_uniq_token = text "tok_" <> ppr uniq
+
non_void_args =
let nvas = init args
non_void_results =
let nvrs = grab_non_void_amodes results
- in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
+ in ASSERT (forDotnet || listLengthCmp nvrs 1 /= GT) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
= unzip [ ppr_casm_arg a i | (a,i) <- non_void_args `zip` [1..] ]
(declare_local_vars, local_vars, assign_results)
- = ppr_casm_results non_void_results
+ = ppr_casm_results non_void_results forDotnet
+
+ forDotnet
+ = case call of
+ DNCall{} -> True
+ _ -> False
- call_str = case target of
- CasmTarget str -> unpackFS str
- StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
- DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
+ call_str tgt
+ = case tgt of
+ CasmTarget str -> unpackFS str
+ StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
+ DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
ccall_args = zipWith (\ _ i -> char '%' <> int i) non_void_args [0..]
dyn_fun = parens (parens (ptext SLIT("_ccall_fun_ty") <> ppr uniq) <> text "%0")
text "));"
])
+toDotnetTy :: DNType -> String
+toDotnetTy x =
+ case x of
+ DNByte -> "Dotnet_Byte"
+ DNBool -> "Dotnet_Bool"
+ DNChar -> "Dotnet_Char"
+ DNDouble -> "Dotnet_Double"
+ DNFloat -> "Dotnet_Float"
+ DNInt -> "Dotnet_Int"
+ DNInt8 -> "Dotnet_Int8"
+ DNInt16 -> "Dotnet_Int16"
+ DNInt32 -> "Dotnet_Int32"
+ DNInt64 -> "Dotnet_Int64"
+ DNWord8 -> "Dotnet_Word8"
+ DNWord16 -> "Dotnet_Word16"
+ DNWord32 -> "Dotnet_Word32"
+ DNWord64 -> "Dotnet_Word64"
+ DNPtr -> "Dotnet_Ptr"
+ DNUnit -> "Dotnet_Unit"
+ DNObject -> "Dotnet_Object"
+ DNString -> "Dotnet_String"
+
+toDotnetArgField :: DNType -> String
+toDotnetArgField x =
+ case x of
+ DNByte -> "arg_byte"
+ DNBool -> "arg_bool"
+ DNChar -> "arg_char"
+ DNDouble -> "arg_double"
+ DNFloat -> "arg_float"
+ DNInt -> "arg_int"
+ DNInt8 -> "arg_int8"
+ DNInt16 -> "arg_int16"
+ DNInt32 -> "arg_int32"
+ DNInt64 -> "arg_int64"
+ DNWord8 -> "arg_word8"
+ DNWord16 -> "arg_word16"
+ DNWord32 -> "arg_word32"
+ DNWord64 -> "arg_word64"
+ DNPtr -> "arg_ptr"
+ DNUnit -> "arg_ptr" -- can't happen
+ DNObject -> "arg_obj"
+ DNString -> "arg_str"
ppr_casm_arg :: CAddrMode -> Int -> (SDoc, SDoc)
-- (a) decl and assignment, (b) local var to be used later
\begin{code}
ppr_casm_results
:: [CAddrMode] -- list of results (length <= 1)
+ -> Bool -- True => multiple results OK.
->
( SDoc, -- declaration of any local vars
[SDoc], -- list of result vars (same length as results)
SDoc ) -- assignment (if any) of results in local var to registers
-ppr_casm_results []
+ppr_casm_results [] _
= (empty, [], empty) -- no results
-ppr_casm_results [r]
- = let
+ppr_casm_results (r:rs) multiResultsOK
+ | not multiResultsOK && not (null rs) = panic "ppr_casm_results: ccall/casm with many results"
+ | otherwise
+ = foldr (\ (a,b,c) (as,bs,cs) -> (a $$ as, b ++ bs, c $$ cs))
+ (empty,[],empty)
+ (zipWith pprRes (r:rs) ("" : map show [(1::Int)..]))
+ where
+ pprRes r suf = (declare_local_var, [local_var], assign_result)
+ where
result_reg = ppr_amode r
r_kind = getAmodeRep r
- local_var = ptext SLIT("_ccall_result")
+ local_var = ptext SLIT("_ccall_result") <> text suf
(result_type, assign_result)
= (pprPrimKind r_kind,
hcat [ result_reg, equals, local_var, semi ])
declare_local_var = hcat [ result_type, space, local_var, semi ]
- in
- (declare_local_var, [local_var], assign_result)
-ppr_casm_results rs
- = panic "ppr_casm_results: ccall/casm with many results"
\end{code}
tyVarsOfType, mkForAllTys, mkTyConApp,
isPrimitiveType, splitTyConApp_maybe,
splitNewType_maybe, splitForAllTy_maybe,
+ splitTyConApp,
+ isUnboxedTupleType
)
import PrimOp ( PrimOp(..) )
import TysPrim ( realWorldStatePrimTy, intPrimTy,
- byteArrayPrimTyCon, mutableByteArrayPrimTyCon
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon,
+ addrPrimTy
)
-import TyCon ( TyCon, tyConDataCons )
+import TyCon ( TyCon, tyConDataCons, tyConName )
import TysWiredIn ( unitDataConId,
unboxedSingletonDataCon, unboxedPairDataCon,
unboxedSingletonTyCon, unboxedPairTyCon,
trueDataCon, falseDataCon,
- trueDataConId, falseDataConId
+ trueDataConId, falseDataConId,
+ listTyCon, charTyCon, stringTy,
+ tupleTyCon, tupleCon
)
+import BasicTypes ( Boxity(..) )
import Literal ( mkMachInt )
import CStrings ( CLabelString )
import PrelNames ( Unique, hasKey, ioTyConKey, boolTyConKey, unitTyConKey,
int8TyConKey, int16TyConKey, int32TyConKey,
word8TyConKey, word16TyConKey, word32TyConKey
+ -- dotnet interop
+ , marshalStringName, unmarshalStringName
+ , marshalObjectName, unmarshalObjectName
+ , objectTyConName
)
import VarSet ( varSetElems )
import Constants ( wORD_SIZE)
-> DsM CoreExpr
dsCCall lbl args may_gc is_asm result_ty
- = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
- boxResult [] result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
- getUniqueDs `thenDs` \ uniq ->
+ = mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
+ boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ getUniqueDs `thenDs` \ uniq ->
let
target | is_asm = CasmTarget lbl
| otherwise = StaticTarget lbl
\ body -> Case arg case_bndr [(DataAlt data_con,vars,body)]
)
+ | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+ tc == listTyCon,
+ Just (cc,[]) <- splitTyConApp_maybe arg_ty,
+ cc == charTyCon
+ -- String; dotnet only
+ = dsLookupGlobalId marshalStringName `thenDs` \ unpack_id ->
+ newSysLocalDs addrPrimTy `thenDs` \ prim_string ->
+ returnDs (Var prim_string,
+ \ body ->
+ let
+ io_ty = exprType body
+ (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_string body
+ ])
+ | Just (tc, [arg_ty]) <- splitTyConApp_maybe arg_ty,
+ tyConName tc == objectTyConName
+ -- Object; dotnet only
+ = dsLookupGlobalId marshalObjectName `thenDs` \ unpack_id ->
+ newSysLocalDs addrPrimTy `thenDs` \ prim_obj ->
+ returnDs (Var prim_obj,
+ \ body ->
+ let
+ io_ty = exprType body
+ (Just (_,[io_arg])) = tcSplitTyConApp_maybe io_ty
+ in
+ mkApps (Var unpack_id)
+ [ Type io_arg
+ , arg
+ , Lam prim_obj body
+ ])
+
| otherwise
= getSrcLocDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
\begin{code}
-boxResult :: [Id] -> Type -> DsM (Type, CoreExpr -> CoreExpr)
+boxResult :: [Id]
+ -> ((Maybe Type, CoreExpr -> CoreExpr) -> (Maybe Type, CoreExpr -> CoreExpr))
+ -> Maybe Id
+ -> Type
+ -> DsM (Type, CoreExpr -> CoreExpr)
-- Takes the result of the user-level ccall:
-- either (IO t),
-- the result type will be
-- State# RealWorld -> (# State# RealWorld #)
-boxResult arg_ids result_ty
+boxResult arg_ids augment mbTopCon result_ty
= case tcSplitTyConApp_maybe result_ty of
-- This split absolutely has to be a tcSplit, because we must
-- see the IO type; and it's a newtype which is transparent to splitTyConApp.
-- The result is IO t, so wrap the result in an IO constructor
Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey
- -> mk_alt return_result
- (resultWrapper io_res_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
- newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ -> resultWrapper io_res_ty `thenDs` \ res ->
+ let aug_res = augment res
+ extra_result_tys =
+ case aug_res of
+ (Just ty,_)
+ | isUnboxedTupleType ty ->
+ let (Just (_, ls)) = splitTyConApp_maybe ty in tail ls
+ _ -> []
+ in
+ mk_alt (return_result extra_result_tys) aug_res
+ `thenDs` \ (ccall_res_ty, the_alt) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
io_data_con = head (tyConDataCons io_tycon)
+ toIOCon =
+ case mbTopCon of
+ Nothing -> dataConWrapId io_data_con
+ Just x -> x
wrap = \ the_call ->
- mkApps (Var (dataConWrapId io_data_con))
+ mkApps (Var toIOCon)
[ Type io_res_ty,
Lam state_id $
Case (App the_call (Var state_id))
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
- return_result state ans = mkConApp unboxedPairDataCon
- [Type realWorldStatePrimTy, Type io_res_ty,
- state, ans]
-
+ return_result ts state anss
+ = mkConApp (tupleCon Unboxed (2 + length ts))
+ (Type realWorldStatePrimTy : Type io_res_ty : map Type ts ++
+ state : anss)
-- It isn't, so do unsafePerformIO
-- It's not conveniently available, so we inline it
- other -> mk_alt return_result
- (resultWrapper result_ty) `thenDs` \ (ccall_res_ty, the_alt) ->
+ other -> resultWrapper result_ty `thenDs` \ res ->
+ mk_alt return_result (augment res) `thenDs` \ (ccall_res_ty, the_alt) ->
let
wrap = \ the_call -> Case (App the_call (Var realWorldPrimId))
(mkWildId ccall_res_ty)
in
returnDs (realWorldStatePrimTy `mkFunTy` ccall_res_ty, wrap)
where
- return_result state ans = ans
+ return_result state [ans] = ans
+ return_result _ _ = panic "return_result: expected single result"
where
mk_alt return_result (Nothing, wrap_result)
= -- The ccall returns ()
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
- (wrap_result (panic "boxResult"))
+ [wrap_result (panic "boxResult")]
ccall_res_ty = mkTyConApp unboxedSingletonTyCon [realWorldStatePrimTy]
the_alt = (DataAlt unboxedSingletonDataCon, [state_id], the_rhs)
returnDs (ccall_res_ty, the_alt)
mk_alt return_result (Just prim_res_ty, wrap_result)
- = -- The ccall returns a non-() value
+ -- The ccall returns a non-() value
+ | isUnboxedTupleType prim_res_ty
+ = let
+ (Just (_, ls@(prim_res_ty1:extras))) = splitTyConApp_maybe prim_res_ty
+ arity = 1 + length ls
+ in
+ mapDs newSysLocalDs ls `thenDs` \ args_ids@(result_id:as) ->
+ newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
+ let
+ the_rhs = return_result (Var state_id)
+ (wrap_result (Var result_id) : map Var as)
+ ccall_res_ty = mkTyConApp (tupleTyCon Unboxed arity)
+ (realWorldStatePrimTy : ls)
+ the_alt = ( DataAlt (tupleCon Unboxed arity)
+ , (state_id : args_ids)
+ , the_rhs
+ )
+ in
+ returnDs (ccall_res_ty, the_alt)
+ | otherwise
+ =
newSysLocalDs prim_res_ty `thenDs` \ result_id ->
newSysLocalDs realWorldStatePrimTy `thenDs` \ state_id ->
let
the_rhs = return_result (Var state_id)
- (wrap_result (Var result_id))
+ [wrap_result (Var result_id)]
ccall_res_ty = mkTyConApp unboxedPairTyCon [realWorldStatePrimTy, prim_res_ty]
the_alt = (DataAlt unboxedPairDataCon, [state_id, result_id], the_rhs)
resultWrapper :: Type
- -> (Maybe Type, -- Type of the expected result, if any
- CoreExpr -> CoreExpr) -- Wrapper for the result
+ -> DsM (Maybe Type, -- Type of the expected result, if any
+ CoreExpr -> CoreExpr) -- Wrapper for the result
resultWrapper result_ty
-- Base case 1: primitive types
| isPrimitiveType result_ty
- = (Just result_ty, \e -> e)
+ = returnDs (Just result_ty, \e -> e)
-- Base case 2: the unit type ()
| Just (tc,_) <- maybe_tc_app, tc `hasKey` unitTyConKey
- = (Nothing, \e -> Var unitDataConId)
+ = returnDs (Nothing, \e -> Var unitDataConId)
-- Base case 3: the boolean type
| Just (tc,_) <- maybe_tc_app, tc `hasKey` boolTyConKey
- = (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
- [(DEFAULT ,[],Var trueDataConId ),
- (LitAlt (mkMachInt 0),[],Var falseDataConId)])
+ = returnDs
+ (Just intPrimTy, \e -> Case e (mkWildId intPrimTy)
+ [(DEFAULT ,[],Var trueDataConId ),
+ (LitAlt (mkMachInt 0),[],Var falseDataConId)])
-- Recursive newtypes
| Just rep_ty <- splitNewType_maybe result_ty
- = let
- (maybe_ty, wrapper) = resultWrapper rep_ty
- in
- (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
+ = resultWrapper rep_ty `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs (maybe_ty, \e -> mkCoerce2 result_ty rep_ty (wrapper e))
-- The type might contain foralls (eg. for dummy type arguments,
-- referring to 'Ptr a' is legal).
| Just (tyvar, rest) <- splitForAllTy_maybe result_ty
- = let
- (maybe_ty, wrapper) = resultWrapper rest
- in
- (maybe_ty, \e -> Lam tyvar (wrapper e))
+ = resultWrapper rest `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs (maybe_ty, \e -> Lam tyvar (wrapper e))
-- Data types with a single constructor, which has a single arg
| Just (tycon, tycon_arg_tys, data_con, data_con_arg_tys) <- splitProductType_maybe result_ty,
dataConSourceArity data_con == 1
= let
- (maybe_ty, wrapper) = resultWrapper unwrapped_res_ty
(unwrapped_res_ty : _) = data_con_arg_tys
narrow_wrapper = maybeNarrow tycon
in
- (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
- (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+ resultWrapper unwrapped_res_ty `thenDs` \ (maybe_ty, wrapper) ->
+ returnDs
+ (maybe_ty, \e -> mkApps (Var (dataConWrapId data_con))
+ (map Type tycon_arg_tys ++ [wrapper (narrow_wrapper e)]))
+
+ -- Strings; 'dotnet' only.
+ | Just (tc, [arg_ty]) <- maybe_tc_app, tc == listTyCon,
+ Just (cc,[]) <- splitTyConApp_maybe arg_ty, cc == charTyCon
+ = dsLookupGlobalId unmarshalStringName `thenDs` \ pack_id ->
+ returnDs (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
+
+ -- Objects; 'dotnet' only.
+ | Just (tc, [arg_ty]) <- maybe_tc_app,
+ tyConName tc == objectTyConName
+ = dsLookupGlobalId unmarshalObjectName `thenDs` \ pack_id ->
+ returnDs (Just addrPrimTy,
+ \ e -> App (Var pack_id) e)
| otherwise
= pprPanic "resultWrapper" (ppr result_ty)
tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs,
)
+import BasicTypes ( Boxity(..) )
import HscTypes ( ForeignStubs(..) )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
Safety(..), playSafe,
ccallConvAttribute
)
import CStrings ( CLabelString )
-import TysWiredIn ( unitTy, stablePtrTyCon )
+import TysWiredIn ( unitTy, stablePtrTyCon, tupleTyCon )
import TysPrim ( addrPrimTy, mkStablePtrPrimTy, alphaTy )
import PrimRep ( getPrimRepSizeInBytes )
-import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName )
+import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName,
+ checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
import Maybe ( fromJust )
-> Bool -- True <=> no headers in the f.i decl
-> DsM ([Binding], SDoc, SDoc)
dsCImport id (CLabel cid) _ _ no_hdrs
- = ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
- returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
- where
- (resTy, foRhs) = resultWrapper (idType id)
- rhs = foRhs (mkLit (MachLabel cid Nothing))
+ = resultWrapper (idType id) `thenDs` \ (resTy, foRhs) ->
+ ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this
+ let rhs = foRhs (mkLit (MachLabel cid Nothing)) in
+ returnDs ([(setImpInline no_hdrs id, rhs)], empty, empty)
dsCImport id (CFunction target) cconv safety no_hdrs
= dsFCall id (CCall (CCallSpec target cconv safety)) no_hdrs
dsCImport id CWrapper cconv _ _
-- ForeignObj#s live across a 'safe' foreign import).
maybe_arg_ids | unsafe_call fcall = work_arg_ids
| otherwise = []
+
+ forDotnet =
+ case fcall of
+ DNCall{} -> True
+ _ -> False
+
+ topConDs
+ | forDotnet =
+ dsLookupGlobalId checkDotnetResName `thenDs` \ check_id ->
+ return (Just check_id)
+ | otherwise = return Nothing
+
+ augmentResultDs
+ | forDotnet =
+ newSysLocalDs addrPrimTy `thenDs` \ err_res ->
+ returnDs (\ (mb_res_ty, resWrap) ->
+ case mb_res_ty of
+ Nothing -> (Just (mkTyConApp (tupleTyCon Unboxed 1)
+ [ addrPrimTy ]),
+ resWrap)
+ Just x -> (Just (mkTyConApp (tupleTyCon Unboxed 2)
+ [ x, addrPrimTy ]),
+ resWrap))
+ | otherwise = returnDs id
in
- boxResult maybe_arg_ids io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
+ augmentResultDs `thenDs` \ augment ->
+ topConDs `thenDs` \ topCon ->
+ boxResult maybe_arg_ids augment topCon io_res_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ ccall_uniq ->
getUniqueDs `thenDs` \ work_uniq ->
dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
dsLit (HsLitLit str ty)
- = ASSERT( isJust maybe_ty )
- returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
- where
- (maybe_ty, wrap_fn) = resultWrapper ty
- Just rep_ty = maybe_ty
+ = resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) ->
+ ASSERT( isJust maybe_ty )
+ let (Just rep_ty) = maybe_ty in
+ returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
dsLit (HsRat r ty)
= mkIntegerExpr (numerator r) `thenDs` \ num ->
Int64Rep -> Int64Rep
Word64Rep -> Word64Rep
other -> IntRep
+
+-- a bit late to catch this here..
+foreignCallCode _ DNCall{} _
+ = panic "foreignCallCode: .NET interop not supported via NCG; compile with -fvia-C"
\end{code}
%************************************************************************
import HscTypes ( RdrAvailInfo, GenAvailInfo(..) )
import TysWiredIn ( unitTyCon )
import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..),
- DNCallSpec(..))
+ DNCallSpec(..), DNKind(..))
import OccName ( srcDataName, varName, isDataOcc, isTcOcc, occNameUserString,
mkDefaultMethodOcc, mkVarOcc )
import SrcLoc
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)
+ parseDImport entity `thenP` \ spec ->
+ returnP $ ForD (ForeignImport v ty (DNImport spec) False loc)
-- parse the entity string of a foreign import declaration for the `ccall' or
-- `stdcall' calling convention'
build cid header True lib = returnP $
CImport cconv safety header lib (CLabel cid )
+--
+-- Unravel a dotnet spec string.
+--
+parseDImport :: FastString -> P DNCallSpec
+parseDImport entity = parse0 comps
+ where
+ comps = words (unpackFS entity)
+
+ parse0 [] = d'oh
+ parse0 (x : xs)
+ | x == "static" = parse1 True xs
+ | otherwise = parse1 False (x:xs)
+
+ parse1 _ [] = d'oh
+ parse1 isStatic (x:xs)
+ | x == "method" = parse2 isStatic DNMethod xs
+ | x == "field" = parse2 isStatic DNField xs
+ | x == "ctor" = parse2 isStatic DNConstructor xs
+ parse1 isStatic xs = parse2 isStatic DNMethod xs
+
+ parse2 _ _ [] = d'oh
+ parse2 isStatic kind (('[':x):xs) =
+ case x of
+ [] -> d'oh
+ vs | last vs == ']' -> parse3 isStatic kind (init vs) xs
+ parse2 isStatic kind xs = parse3 isStatic kind "" xs
+
+ parse3 isStatic kind assem [x] =
+ returnP (DNCallSpec isStatic kind assem x
+ -- these will be filled in once known.
+ (error "FFI-dotnet-args")
+ (error "FFI-dotnet-result"))
+ parse3 _ _ _ _ = d'oh
+
+ d'oh = parseError "Malformed entity string"
+
-- construct a foreign export declaration
--
mkExport :: CallConv
CCallTarget(..), isDynamicTarget, isCasmTarget,
CCallConv(..), defaultCCallConv, ccallConvToInt, ccallConvAttribute,
- DNCallSpec(..),
+ DNCallSpec(..), DNKind(..), DNType(..),
+ withDNTypes,
okToExposeFCall
) where
#include "HsVersions.h"
-import CStrings ( CLabelString, pprCLabelString )
-import FastString ( FastString )
+import CStrings ( CLabelString, pprCLabelString )
+import FastString ( FastString )
import Binary
import Outputable
\end{code}
%************************************************************************
%* *
-\subsubsection{.NET stuff}
+\subsubsection{.NET interop}
%* *
%************************************************************************
\begin{code}
-data DNCallSpec = DNCallSpec FastString
- deriving (Eq)
+data DNCallSpec =
+ DNCallSpec Bool -- True => static method/field
+ DNKind -- what type of access
+ String -- assembly
+ String -- fully qualified method/field name.
+ [DNType] -- argument types.
+ DNType -- result type.
+ deriving ( Eq )
+ {-! derive: Binary !-}
+
+data DNKind
+ = DNMethod
+ | DNField
+ | DNConstructor
+ deriving ( Eq )
{-! derive: Binary !-}
+data DNType
+ = DNByte
+ | DNBool
+ | DNChar
+ | DNDouble
+ | DNFloat
+ | DNInt
+ | DNInt8
+ | DNInt16
+ | DNInt32
+ | DNInt64
+ | DNWord8
+ | DNWord16
+ | DNWord32
+ | DNWord64
+ | DNPtr
+ | DNUnit
+ | DNObject
+ | DNString
+ deriving ( Eq )
+ {-! derive: Binary !-}
+
+withDNTypes :: DNCallSpec -> [DNType] -> DNType -> DNCallSpec
+withDNTypes (DNCallSpec isStatic k assem nm _ _) argTys resTy
+ = DNCallSpec isStatic k assem nm argTys resTy
+
instance Outputable DNCallSpec where
- ppr (DNCallSpec s) = char '"' <> ftext s <> char '"'
+ ppr (DNCallSpec isStatic kind ass nm _ _ )
+ = char '"' <>
+ (if isStatic then text "static" else empty) <+>
+ (text (case kind of { DNMethod -> "method" ; DNField -> "field"; DNConstructor -> "ctor" })) <+>
+ (if null ass then char ' ' else char '[' <> text ass <> char ']') <>
+ text nm <>
+ char '"'
\end{code}
_ -> do return StdCallConv
instance Binary DNCallSpec where
- put_ bh (DNCallSpec aa) = do
- put_ bh aa
+ put_ bh (DNCallSpec isStatic kind ass nm _ _) = do
+ put_ bh isStatic
+ put_ bh kind
+ put_ bh ass
+ put_ bh nm
get bh = do
- aa <- get bh
- return (DNCallSpec aa)
+ isStatic <- get bh
+ kind <- get bh
+ ass <- get bh
+ nm <- get bh
+ return (DNCallSpec isStatic kind ass nm [] undefined)
+
+instance Binary DNKind where
+ put_ bh DNMethod = do
+ putByte bh 0
+ put_ bh DNField = do
+ putByte bh 1
+ put_ bh DNConstructor = do
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> do return DNMethod
+ 1 -> do return DNField
+ _ -> do return DNConstructor
+
+instance Binary DNType where
+ put_ bh DNByte = do
+ putByte bh 0
+ put_ bh DNBool = do
+ putByte bh 1
+ put_ bh DNChar = do
+ putByte bh 2
+ put_ bh DNDouble = do
+ putByte bh 3
+ put_ bh DNFloat = do
+ putByte bh 4
+ put_ bh DNInt = do
+ putByte bh 5
+ put_ bh DNInt8 = do
+ putByte bh 6
+ put_ bh DNInt16 = do
+ putByte bh 7
+ put_ bh DNInt32 = do
+ putByte bh 8
+ put_ bh DNInt64 = do
+ putByte bh 9
+ put_ bh DNWord8 = do
+ putByte bh 10
+ put_ bh DNWord16 = do
+ putByte bh 11
+ put_ bh DNWord32 = do
+ putByte bh 12
+ put_ bh DNWord64 = do
+ putByte bh 13
+ put_ bh DNPtr = do
+ putByte bh 14
+ put_ bh DNUnit = do
+ putByte bh 15
+ put_ bh DNObject = do
+ putByte bh 16
+ put_ bh DNString = do
+ putByte bh 17
+
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return DNByte
+ 1 -> return DNBool
+ 2 -> return DNChar
+ 3 -> return DNDouble
+ 4 -> return DNFloat
+ 5 -> return DNInt
+ 6 -> return DNInt8
+ 7 -> return DNInt16
+ 8 -> return DNInt32
+ 9 -> return DNInt64
+ 10 -> return DNWord8
+ 11 -> return DNWord16
+ 12 -> return DNWord32
+ 13 -> return DNWord64
+ 14 -> return DNPtr
+ 15 -> return DNUnit
+ 16 -> return DNObject
+ 17 -> return DNString
-- Imported from other files :-
-- Booleans
andName, orName
+
+ -- dotnet interop
+ , objectTyConName, marshalObjectName, unmarshalObjectName
+ , marshalStringName, unmarshalStringName, checkDotnetResName
]
monadNames :: [Name] -- The monad ops need by a HsDo
pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler"
sYSTEM_IO_Name = mkModuleName "System.IO"
dYNAMIC_Name = mkModuleName "Data.Dynamic"
+tRAVERSE_Name = mkModuleName "Data.Traverse"
gENERICS_Name = mkModuleName "Data.Generics"
+dOTNET_Name = mkModuleName "GHC.Dotnet"
rEAD_PREC_Name = mkModuleName "Text.ParserCombinators.ReadPrec"
lEX_Name = mkModuleName "Text.Read.Lex"
-- Recursive-do notation
mfixName = varQual mONAD_FIX_Name FSLIT("mfix") mfixIdKey
+
+-- dotnet interop
+objectTyConName = wTcQual dOTNET_Name FSLIT("Object") objectTyConKey
+unmarshalObjectName = varQual dOTNET_Name FSLIT("unmarshalObject") unmarshalObjectIdKey
+marshalObjectName = varQual dOTNET_Name FSLIT("marshalObject") marshalObjectIdKey
+marshalStringName = varQual dOTNET_Name FSLIT("marshalString") marshalStringIdKey
+unmarshalStringName = varQual dOTNET_Name FSLIT("unmarshalString") unmarshalStringIdKey
+checkDotnetResName = varQual dOTNET_Name FSLIT("checkResult") checkDotnetResNameIdKey
+
\end{code}
%************************************************************************
-- Parallel array type constructor
parrTyConKey = mkPreludeTyConUnique 82
+-- dotnet interop
+objectTyConKey = mkPreludeTyConUnique 83
+
---------------- Template Haskell -------------------
-- USES TyConUniques 100-119
-----------------------------------------------------
bpermutePIdKey = mkPreludeMiscIdUnique 91
bpermuteDftPIdKey = mkPreludeMiscIdUnique 92
indexOfPIdKey = mkPreludeMiscIdUnique 93
+
+-- dotnet interop
+unmarshalObjectIdKey = mkPreludeMiscIdUnique 94
+marshalObjectIdKey = mkPreludeMiscIdUnique 95
+marshalStringIdKey = mkPreludeMiscIdUnique 96
+unmarshalStringIdKey = mkPreludeMiscIdUnique 97
+checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98
+
\end{code}
Certain class operations from Prelude classes. They get their own
import NameSet
import NameEnv
import ErrUtils ( dumpIfSet )
-import PrelNames ( newStablePtrName, bindIOName, returnIOName )
+import PrelNames ( newStablePtrName, bindIOName, returnIOName
+ -- dotnet interop
+ , objectTyConName,
+ , unmarshalObjectName, marshalObjectName
+ , unmarshalStringName, marshalStringName
+ , checkDotnetResName
+ )
import List ( partition )
import Bag ( bagToList )
import Outputable
returnM (ForeignImport name' ty' spec isDeprec src_loc,
fvs `plusFV` extras spec)
where
- extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
- bindIOName, returnIOName]
+ extras (CImport _ _ _ _ CWrapper)
+ = mkFVs [ newStablePtrName
+ , bindIOName
+ , returnIOName
+ ]
+ extras (DNImport _)
+ = mkFVs [ bindIOName
+ , objectTyConName
+ , unmarshalObjectName
+ , marshalObjectName
+ , marshalStringName
+ , unmarshalStringName
+ , checkDotnetResName
+ ]
extras _ = emptyFVs
rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
, tcForeignExports
) where
+#include "config.h"
#include "HsVersions.h"
import HsSyn ( ForeignDecl(..), HsExpr(..),
isFFIArgumentTy, isFFIImportResultTy,
isFFIExportResultTy, isFFILabelTy,
isFFIExternalTy, isFFIDynArgumentTy,
- isFFIDynResultTy,
+ isFFIDynResultTy, isFFIDotnetTy, isFFIDotnetObjTy,
+ toDNType
)
import ForeignCall ( CExportSpec(..), CCallTarget(..), CCallConv(..),
- isDynamicTarget, isCasmTarget )
+ isDynamicTarget, isCasmTarget, withDNTypes, DNKind(..), DNCallSpec(..) )
import CStrings ( CLabelString, isCLabelString )
import PrelNames ( hasKey, ioTyConKey )
import CmdLineOpts ( dopt_HscLang, HscLang(..) )
-- things are LocalIds. However, it does not need zonking,
-- (so TcHsSyn.zonkForeignExports ignores it).
in
- tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM_`
+ 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 id undefined imp_decl' isDeprec src_loc)
\end{code}
------------ Checking types for foreign import ----------------------
\begin{code}
-tcCheckFIType _ _ _ (DNImport _)
- = checkCg checkDotNet
-
-tcCheckFIType sig_ty arg_tys res_ty (CImport _ _ _ _ (CLabel _))
+tcCheckFIType _ arg_tys res_ty (DNImport spec)
+ = checkCg checkDotnet `thenM_`
+ getDOpts `thenM` \ dflags ->
+ checkForeignArgs (isFFIDotnetTy dflags) arg_tys `thenM_`
+ checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty `thenM_`
+ let (DNCallSpec isStatic kind _ _ _ _) = spec in
+ (case kind of
+ DNMethod | not isStatic ->
+ case arg_tys of
+ [] -> addErrTc illegalDNMethodSig
+ _
+ | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
+ | otherwise -> returnM ()
+ _ -> returnM ()) `thenM_`
+ returnM (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
+
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _))
= checkCg checkCOrAsm `thenM_`
- check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
+ check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty) `thenM_`
+ return idecl
-tcCheckFIType sig_ty arg_tys res_ty (CImport cconv _ _ _ CWrapper)
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper)
= -- Foreign wrapper (former f.e.d.)
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a
-- 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 checkCOrAsmOrInterp `thenM_`
- case arg_tys of
- [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
- checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
- checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
+ (case arg_tys of
+ [arg1_ty] -> checkForeignArgs isFFIExternalTy arg1_tys `thenM_`
+ checkForeignRes nonIOok isFFIExportResultTy res1_ty `thenM_`
+ checkForeignRes mustBeIO isFFIDynResultTy res_ty `thenM_`
checkFEDArgs arg1_tys
where
(arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
- other -> addErrTc (illegalForeignTyErr empty sig_ty)
+ other -> addErrTc (illegalForeignTyErr empty sig_ty) ) `thenM_`
+ return idecl
-tcCheckFIType sig_ty arg_tys res_ty (CImport _ safety _ _ (CFunction target))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CFunction target))
| isDynamicTarget target -- Foreign import dynamic
= checkCg checkCOrAsmOrInterp `thenM_`
case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr
- [] -> check False (illegalForeignTyErr empty sig_ty)
- (arg1_ty:arg_tys) -> getDOpts `thenM` \ dflags ->
- check (isFFIDynArgumentTy arg1_ty)
- (illegalForeignTyErr argument arg1_ty) `thenM_`
- checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
- checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
-
+ [] ->
+ check False (illegalForeignTyErr empty sig_ty) `thenM_`
+ return idecl
+ (arg1_ty:arg_tys) ->
+ getDOpts `thenM` \ dflags ->
+ check (isFFIDynArgumentTy arg1_ty)
+ (illegalForeignTyErr argument arg1_ty) `thenM_`
+ checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
+ return idecl
| otherwise -- Normal foreign import
= checkCg (if isCasmTarget target
then checkC else checkCOrAsmOrDotNetOrInterp) `thenM_`
checkCTarget target `thenM_`
getDOpts `thenM` \ dflags ->
checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys `thenM_`
- checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
+ checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty `thenM_`
+ return idecl
-- This makes a convenient place to check
-- that the C identifier is valid for C
\end{code}
\begin{code}
-checkDotNet HscILX = Nothing
-checkDotNet other = Just (text "requires .NET code generation (-filx)")
+checkDotnet HscILX = Nothing
+#if defined(mingw32_TARGET_OS)
+checkDotnet HscC = Nothing
+checkDotnet _ = Just (text "requires C code generation (-fvia-C)")
+#else
+checkDotnet other = Just (text "requires .NET support (-filx or win32)")
+#endif
checkC HscC = Nothing
checkC other = Just (text "requires C code generation (-fvia-C)")
foreignDeclCtxt fo
= hang (ptext SLIT("When checking declaration:"))
4 (ppr fo)
+
+illegalDNMethodSig
+ = ptext SLIT("'This pointer' expected as last argument")
+
\end{code}
isFFIDynArgumentTy, -- :: Type -> Bool
isFFIDynResultTy, -- :: Type -> Bool
isFFILabelTy, -- :: Type -> Bool
+ isFFIDotnetTy, -- :: DynFlags -> Type -> Bool
+ isFFIDotnetObjTy, -- :: Type -> Bool
+
+ toDNType, -- :: Type -> DNType
---------------------------------
-- Unifier and matcher
import TyCon ( TyCon, isUnLiftedTyCon )
import Class ( classHasFDs, Class )
import Var ( TyVar, Id, tyVarKind, isMutTyVar, mutTyVarDetails )
-import ForeignCall ( Safety, playSafe )
+import ForeignCall ( Safety, playSafe
+ , DNType(..)
+ )
import VarEnv
import VarSet
import OccName ( OccName, mkDictOcc )
import NameSet
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
-import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
+import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon,
+ charTyCon, listTyCon )
import BasicTypes ( IPName(..), ipNameName )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
-- or a newtype of either.
isFFILabelTy = checkRepTyCon (\tc -> tc == ptrTyCon || tc == funPtrTyCon || tc == addrTyCon)
+isFFIDotnetTy :: DynFlags -> Type -> Bool
+isFFIDotnetTy dflags ty
+ = checkRepTyCon (\ tc -> not (isByteArrayLikeTyCon tc) &&
+ (legalFIResultTyCon dflags tc ||
+ isFFIDotnetObjTy ty || isStringTy ty)) ty
+
+-- Support String as an argument or result from a .NET FFI call.
+isStringTy ty =
+ case tcSplitTyConApp_maybe (repType ty) of
+ Just (tc, [arg_ty])
+ | tc == listTyCon ->
+ case tcSplitTyConApp_maybe (repType arg_ty) of
+ Just (cc,[]) -> cc == charTyCon
+ _ -> False
+ _ -> False
+
+-- Support String as an argument or result from a .NET FFI call.
+isFFIDotnetObjTy ty =
+ let
+ (_, t_ty) = tcSplitForAllTys ty
+ in
+ case tcSplitTyConApp_maybe (repType t_ty) of
+ Just (tc, [arg_ty]) | getName tc == objectTyConName -> True
+ _ -> False
+
+toDNType :: Type -> DNType
+toDNType ty
+ | isStringTy ty = DNString
+ | isFFIDotnetObjTy ty = DNObject
+ | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
+ case lookup (getUnique tc) dn_assoc of
+ Just x -> x
+ Nothing
+ | tc `hasKey` ioTyConKey -> toDNType (head argTys)
+ | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ where
+ dn_assoc :: [ (Unique, DNType) ]
+ dn_assoc = [ (unitTyConKey, DNUnit)
+ , (intTyConKey, DNInt)
+ , (int8TyConKey, DNInt8)
+ , (int16TyConKey, DNInt16)
+ , (int32TyConKey, DNInt32)
+ , (int64TyConKey, DNInt64)
+ , (wordTyConKey, DNInt)
+ , (word8TyConKey, DNWord8)
+ , (word16TyConKey, DNWord16)
+ , (word32TyConKey, DNWord32)
+ , (word64TyConKey, DNWord64)
+ , (floatTyConKey, DNFloat)
+ , (doubleTyConKey, DNDouble)
+ , (addrTyConKey, DNPtr)
+ , (ptrTyConKey, DNPtr)
+ , (funPtrTyConKey, DNPtr)
+ , (charTyConKey, DNChar)
+ , (boolTyConKey, DNBool)
+ ]
+
checkRepTyCon :: (TyCon -> Bool) -> Type -> Bool
-- Look through newtypes
-- Non-recursive ones are transparent to splitTyConApp,
-- bytearrays from a _ccall_ / foreign declaration
-- (or be passed them as arguments in foreign exported functions).
legalFEArgTyCon tc
- | getUnique tc `elem` [ byteArrayTyConKey, mutableByteArrayTyConKey ]
+ | isByteArrayLikeTyCon tc
= False
-- It's also illegal to make foreign exports that take unboxed
-- arguments. The RTS API currently can't invoke such things. --SDM 7/2000
legalFIResultTyCon :: DynFlags -> TyCon -> Bool
legalFIResultTyCon dflags tc
- | getUnique tc `elem`
- [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
- | tc == unitTyCon = True
- | otherwise = marshalableTyCon dflags tc
+ | isByteArrayLikeTyCon tc = False
+ | tc == unitTyCon = True
+ | otherwise = marshalableTyCon dflags tc
legalFEResultTyCon :: TyCon -> Bool
legalFEResultTyCon tc
- | getUnique tc `elem`
- [ byteArrayTyConKey, mutableByteArrayTyConKey ] = False
- | tc == unitTyCon = True
- | otherwise = boxedMarshalableTyCon tc
+ | isByteArrayLikeTyCon tc = False
+ | tc == unitTyCon = True
+ | otherwise = boxedMarshalableTyCon tc
legalOutgoingTyCon :: DynFlags -> Safety -> TyCon -> Bool
-- Checks validity of types going from Haskell -> external world
legalOutgoingTyCon dflags safety tc
- | playSafe safety && getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
+ | playSafe safety && isByteArrayLikeTyCon tc
= False
| otherwise
= marshalableTyCon dflags tc
, byteArrayTyConKey, mutableByteArrayTyConKey
, boolTyConKey
]
+
+isByteArrayLikeTyCon :: TyCon -> Bool
+isByteArrayLikeTyCon tc =
+ getUnique tc `elem` [byteArrayTyConKey, mutableByteArrayTyConKey]
\end{code}
--- /dev/null
+/*
+ * C callable bridge to the .NET object model
+ *
+ * (c) 2003, sof.
+ *
+ */
+#ifndef __DNINVOKE_H__
+#define __DNINVOKE_H__
+#include "Dotnet.h"
+
+extern char* DN_invokeStatic ( char *assemName,
+ char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+extern char* DN_getStatic ( char *assemName,
+ char *fieldClsName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+extern char* DN_setStatic ( char *assemName,
+ char *fieldClsName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+extern char* DN_createObject ( char *assemName,
+ char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+
+extern char* DN_invokeMethod ( char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+
+extern char* DN_getField ( char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+extern char* DN_setField ( char *clsAndMethName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res);
+
+extern void stopDotnetBridge(void);
+
+#endif /* __DNINVOKE_H__ */
--- /dev/null
+/*
+ * Types and definitions to support GHC .NET interop.
+ *
+ * (c) 2003, sof.
+ *
+ */
+#ifndef __DOTNET_H__
+#define __DOTNET_H__
+
+typedef enum {
+ Dotnet_Byte = 0,
+ Dotnet_Boolean,
+ Dotnet_Char,
+ Dotnet_Double,
+ Dotnet_Float,
+ Dotnet_Int,
+ Dotnet_Int8,
+ Dotnet_Int16,
+ Dotnet_Int32,
+ Dotnet_Int64,
+ Dotnet_Word8,
+ Dotnet_Word16,
+ Dotnet_Word32,
+ Dotnet_Word64,
+ Dotnet_Ptr,
+ Dotnet_Unit,
+ Dotnet_Object,
+ Dotnet_String
+} DotnetType;
+
+typedef union {
+ unsigned char arg_byte;
+ unsigned int arg_bool;
+ unsigned char arg_char;
+ int arg_int;
+ signed char arg_int8;
+ signed short arg_int16;
+ signed int arg_int32;
+#if defined(_MSC_VER)
+ signed __int64 arg_int64;
+#else
+ signed long long arg_int64;
+#endif
+ float arg_float;
+ double arg_double;
+ unsigned char arg_word8;
+ unsigned short arg_word16;
+ unsigned int arg_word32;
+#if defined(_MSC_VER)
+ unsigned __int64 arg_word64;
+#else
+ unsigned long long arg_word64;
+#endif
+ void* arg_ptr;
+ void* arg_obj;
+ void* arg_str;
+} DotnetArgVal;
+
+typedef struct {
+ DotnetArgVal arg;
+ DotnetType arg_type;
+} DotnetArg;
+
+#endif /* __DOTNET_H__ */
/* -----------------------------------------------------------------------------
- * $Id: Stg.h,v 1.51 2003/05/23 08:28:48 simonmar Exp $
+ * $Id: Stg.h,v 1.52 2003/05/29 14:39:30 sof Exp $
*
* (c) The GHC Team, 1998-1999
*
extern void stackOverflow(void);
+#if defined(WANT_DOTNET_SUPPORT)
+#include "DNInvoke.h"
+#endif
+
/* Creating and destroying an adjustor thunk.
I cannot make myself create a separate .h file
for these two (sof.)
PACKAGE_CPP_OPTS += -DHAVE_LIBMINGWEX
endif
+ifeq "$(DotnetSupport)" "YES"
+
+#
+# Would like to just use SUBDIRS here, but need to
+# descend into dotnet/ earlier than that.
+#
+all ::
+ $(MAKE) -C dotnet all
+
+# But use SUBDIRS for other recursive targets.
+SUBDIRS += dotnet
+
+LIBOBJS += dotnet/Invoke.o
+endif
+
#-----------------------------------------------------------------------------
# Include the Front panel code?
--- /dev/null
+/*
+ * C callable bridge to the .NET object model
+ *
+ * Managed C++ is used to access the .NET object model via
+ * System.Reflection. Here we provide C callable functions
+ * to that functionality, which we then export via a COM
+ * component.
+ *
+ * Note: the _only_ reason why we're going via COM and not simply
+ * exposing the required via some DLL entry points, is that COM
+ * gives us location independence (i.e., the RTS doesn't need
+ * be told where this interop layer resides in order to hoik
+ * it in, the CLSID suffices (provided the component has been
+ * registered, of course.)) It is a bit tiresome to have play
+ * by the .NET COM Interop's rules as regards argument arrays,
+ * so we may want to revisit this issue at some point.
+ *
+ * [ But why not simply use MC++ and provide C-callable entry
+ * points to the relevant functionality, and avoid COM interop
+ * alltogether? Because we have to be able to (statically)
+ * link with gcc-compiled code, and linking MC++ and gcc-compiled
+ * object files doesn't work.]
+ *
+ * Note: you need something never than gcc-2.95 to compile this
+ * code (I'm using gcc-3.2, which comes with mingw-2).
+ */
+#define _WIN32_DCOM
+#define COBJMACROS
+#include <stdio.h>
+#include <stdlib.h>
+#include <wtypes.h>
+#ifndef _MSC_VER
+#include <oaidl.h>
+#include <objbase.h>
+#include <oleauto.h>
+# if defined(COBJMACROS) && !defined(_MSC_VER)
+#define IErrorInfo_QueryInterface(T,r,O) (T)->lpVtbl->QueryInterface(T,r,O)
+#define IErrorInfo_AddRef(T) (T)->lpVtbl->AddRef(T)
+#define IErrorInfo_Release(T) (T)->lpVtbl->Release(T)
+#define IErrorInfo_GetSource(T,pbstr) (T)->lpVtbl->GetSource(T,pbstr)
+#define IErrorInfo_GetDescription(T,pbstr) (T)->lpVtbl->GetDescription(T,pbstr)
+
+#define ISupportErrorInfo_QueryInterface(T,r,O) (T)->lpVtbl->QueryInterface(T,r,O)
+#define ISupportErrorInfo_AddRef(T) (T)->lpVtbl->AddRef(T)
+#define ISupportErrorInfo_Release(T) (T)->lpVtbl->Release(T)
+#define ISupportErrorInfo_InterfaceSupportsErrorInfo(T,iid) (T)->lpVtbl->InterfaceSupportsErrorInfo(T,iid)
+# endif
+#endif
+#include "DNInvoke.h"
+#define WANT_UUID_DECLS
+#include "InvokerClient.h"
+#include "Dotnet.h"
+
+/* Local prototypes */
+static void genError( IUnknown* pUnk,
+ HRESULT hr,
+ char* loc,
+ char** pErrMsg);
+static int startBridge(char**);
+static int fromVariant
+ ( DotnetType resTy,
+ VARIANT* pVar,
+ void* res,
+ char** pErrMsg);
+static VARIANT* toVariant ( DotnetArg* p );
+
+/* Pointer to .NET COM component instance; instantiated on demand. */
+static InvokeBridge* pBridge = NULL;
+
+/* convert a char* to a BSTR, copied from the HDirect comlib/ sources */
+static
+HRESULT
+stringToBSTR( /*[in,ptr]*/const char* pstrz
+ , /*[out]*/ BSTR* pbstr
+ )
+{
+ int i;
+
+ if (!pbstr) {
+ return E_FAIL;
+ } else {
+ *pbstr = NULL;
+ }
+ if (!pstrz) {
+ return S_OK;
+ }
+
+ i = MultiByteToWideChar(CP_ACP, 0, pstrz, -1, NULL, 0);
+ if ( i < 0 ) {
+ return E_FAIL;
+ }
+ *pbstr = SysAllocStringLen(NULL,i-1);
+ if (*pbstr != NULL) {
+ MultiByteToWideChar(CP_ACP, 0, pstrz, -1, *pbstr, i-1);
+ // (*pbstr)[i]=0;
+ return S_OK;
+ } else {
+ return E_FAIL;
+ }
+}
+
+static
+char*
+bstrToString( BSTR bstr )
+{
+ int i,len;
+ char *res;
+ int blen;
+
+ if (!bstr) {
+ return NULL;
+ }
+
+ blen = SysStringLen(bstr);
+
+ /* pass in NULL for the multi-byte arg in order to compute length first */
+ len = WideCharToMultiByte(CP_ACP, 0, bstr, blen,
+ NULL, 0, NULL, NULL);
+ if (len == 0) return NULL;
+
+ /* Allocate string of required length. */
+ res = (char*)malloc(sizeof(char) * (len + 1));
+ if (!res) return NULL;
+
+ i = WideCharToMultiByte(CP_ACP, 0, bstr, blen,
+ res, (len+1), NULL, NULL);
+
+ /* Poor error handling to map this to NULL. */
+ if ( i == 0 ) return NULL;
+
+ /* Terminate and return */
+ res[i] = '\0';
+ return res;
+}
+
+static
+void
+freeArgs ( SAFEARRAY* psa )
+{
+ /* The argument SAFEARRAYs contain dynamically allocated
+ * VARIANTs. Release the VARIANT contents and its memory here.
+ */
+ long lb,ub;
+ int i;
+ HRESULT hr;
+ VARIANT *pv = NULL;
+
+ hr = SafeArrayGetLBound(psa, 1, &lb);
+ if (FAILED(hr)) {
+ fprintf(stderr, "freeArgs: failed fetching lower bound\n");
+ SafeArrayDestroy(psa);
+ return;
+ }
+ hr = SafeArrayGetUBound(psa, 1, &ub);
+ if (FAILED(hr)) {
+ fprintf(stderr, "freeArgs: failed fetching upper bound\n");
+ SafeArrayDestroy(psa);
+ return;
+ }
+ for ( i = 0; i < (ub - lb); i++ ) {
+ hr = SafeArrayGetElement(psa,(long*)&i,(void*)pv);
+ if (FAILED(hr)) {
+ fprintf(stderr, "freeArgs: unable to fetch element %d\n", i);
+ SafeArrayDestroy(psa);
+ return;
+ }
+ VariantClear(pv);
+ free(pv);
+ }
+ SafeArrayDestroy(psa);
+}
+
+static
+SAFEARRAY*
+marshalArgs ( DotnetArg* args,
+ unsigned int n_args )
+{
+ SAFEARRAY *psa;
+ SAFEARRAYBOUND rgsabound[1];
+ int i;
+ long idxArr[1];
+ HRESULT hr;
+ VARIANT* var;
+
+ rgsabound[0].lLbound = 0;
+ rgsabound[0].cElements = n_args;
+ psa = SafeArrayCreate(VT_VARIANT, 1, rgsabound);
+
+ for(i=0;i < n_args; i++) {
+ idxArr[0] = i;
+ var = toVariant(&args[i]);
+ hr = SafeArrayPutElement(psa, idxArr, (void*)var);
+ }
+ return psa;
+}
+
+/*
+ * ***** Accessing the .NET object model *****
+ *
+ * General remarks:
+ *
+ * - the functions report error conditions via their return value; a char*.
+ * If NULL, the call was successful. If not, the returned string
+ * contains the (dynamically allocated) error message.
+ *
+ * This unorthodox calling convetion is used to simplify the task
+ * of interfacing to these funs from GHC-generated code.
+ */
+
+/*
+ * Function: DN_invokeStatic()
+ *
+ * Given assembly and fully-qualified name of a static .NET method,
+ * invoke it using the supplied arguments.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_invokeStatic ( char *assemName,
+ char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res)
+{
+ SAFEARRAY* psa;
+ VARIANT result;
+ HRESULT hr;
+ BSTR b_assemName;
+ BSTR b_methName;
+ char* errMsg = NULL;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ /* Package up arguments */
+ psa = marshalArgs(args, n_args);
+ VariantInit(&result);
+
+ hr = stringToBSTR(assemName, &b_assemName);
+ hr = stringToBSTR(methName, &b_methName);
+
+ hr = InvokeBridge_InvokeStaticMethod(pBridge,
+ b_assemName,
+ b_methName,
+ psa,
+ &result);
+ SysFreeString(b_assemName);
+ SysFreeString(b_methName);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "DInvoke.invokeStatic", &errMsg);
+ return errMsg;
+ }
+
+ fromVariant(resultTy, &result, res, &errMsg);
+ freeArgs(psa);
+
+ return errMsg;
+}
+
+/*
+ * Function: DN_invokeMethod()
+ *
+ * Given method name and arguments, invoke .NET method on an object.
+ * The object ref / this-pointer is passed in as the last argument.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_invokeMethod ( char *clsAndMethName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res)
+{
+ SAFEARRAY* psa;
+ VARIANT result;
+ HRESULT hr;
+ char* methName;
+ BSTR b_methName;
+ char* errMsg = NULL;
+ VARIANT *thisPtr;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ if (n_args <= 0) {
+ genError(NULL, 0x0, "Invoke.invokeMethod - missing this pointer", &errMsg);
+ return errMsg;
+ }
+
+ /* The this-pointer is last */
+ thisPtr = toVariant(&args[n_args-1]);
+
+ /* Package up arguments */
+ psa = marshalArgs(args, n_args-1);
+ VariantInit(&result);
+
+ /* If the user has qualified method with class, ignore the class bit. */
+ if ( (methName = strrchr(clsAndMethName, '.')) == NULL) {
+ methName = clsAndMethName;
+ } else {
+ /* Skip past '.' */
+ methName++;
+ }
+
+ hr = stringToBSTR(methName, &b_methName);
+ hr = InvokeBridge_InvokeMethod(pBridge,
+ *thisPtr,
+ b_methName,
+ psa,
+ &result);
+ SysFreeString(b_methName);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "Invoke.invokeMethod", &errMsg);
+ return errMsg;
+ }
+
+ fromVariant(resultTy, &result, res, &errMsg);
+ freeArgs(psa);
+
+ return errMsg;
+}
+
+/*
+ * Function: DN_getField()
+ *
+ * Given a field name and an object pointer, read a field value.
+ * The object ref / this-pointer is passed in as the last argument.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_getField ( char *clsAndMethName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res)
+{
+ VARIANT result;
+ HRESULT hr;
+ char* methName;
+ BSTR b_methName;
+ char* errMsg = NULL;
+ VARIANT *thisPtr;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ if (n_args <= 0) {
+ genError(NULL, 0x0, "Invoke.getField - missing this pointer", &errMsg);
+ return errMsg;
+ }
+
+ /* The this-pointer is last */
+ thisPtr = toVariant(&args[n_args-1]);
+ VariantInit(&result);
+
+ /* If the user has qualified method with class, ignore the class bit. */
+ if ( (methName = strrchr(clsAndMethName, '.')) == NULL) {
+ methName = clsAndMethName;
+ } else {
+ /* Skip past '.' */
+ methName++;
+ }
+
+ hr = stringToBSTR(methName, &b_methName);
+ hr = InvokeBridge_GetField(pBridge,
+ *thisPtr,
+ b_methName,
+ &result);
+ SysFreeString(b_methName);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "Invoke.getField", &errMsg);
+ return errMsg;
+ }
+
+ fromVariant(resultTy, &result, res, &errMsg);
+ return errMsg;
+}
+
+/*
+ * Function: DN_setField()
+ *
+ * Given field name, a value and an object reference, set the field value of
+ * an object.
+ * The object ref / this-pointer is passed in as the last argument.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_setField ( char *clsAndMethName,
+ DotnetArg *args,
+ int n_args,
+ /* next two args are ignored */
+ DotnetType resultTy,
+ void *res)
+{
+ HRESULT hr;
+ char* methName;
+ BSTR b_methName;
+ char* errMsg = NULL;
+ VARIANT *thisPtr;
+ VARIANT *pVal;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ if (n_args != 2) {
+ genError(NULL, 0x0, "Invoke.setField - missing this pointer", &errMsg);
+ return errMsg;
+ }
+
+ /* The this-pointer is last */
+ thisPtr = toVariant(&args[1]);
+
+ /* Package up arguments */
+ pVal = toVariant(&args[0]);
+
+ /* If the user has qualified method with class, ignore the class bit. */
+ if ( (methName = strrchr(clsAndMethName, '.')) == NULL) {
+ methName = clsAndMethName;
+ } else {
+ /* Skip past '.' */
+ methName++;
+ }
+
+ hr = stringToBSTR(methName, &b_methName);
+ hr = InvokeBridge_SetField(pBridge,
+ *thisPtr,
+ b_methName,
+ *pVal);
+ SysFreeString(b_methName);
+ VariantClear(pVal);
+ free(pVal);
+ free(thisPtr);
+
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "Invoke.setField", &errMsg);
+ return errMsg;
+ }
+ return errMsg;
+}
+
+
+/*
+ * Function: DN_createObject()
+ *
+ * Given assembly and fully-qualified name of a type,
+ * invoke its (possibly parameterised) constructor.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_createObject ( char *assemName,
+ char *methName,
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res)
+{
+ SAFEARRAY* psa;
+ VARIANT result;
+ HRESULT hr;
+ BSTR b_assemName;
+ BSTR b_methName;
+ char* errMsg = NULL;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ /* Package up arguments */
+ psa = marshalArgs(args, n_args);
+ VariantInit(&result);
+
+ hr = stringToBSTR(assemName, &b_assemName);
+ hr = stringToBSTR(methName, &b_methName);
+
+ hr = InvokeBridge_CreateObject(pBridge,
+ b_assemName,
+ b_methName,
+ psa,
+ &result);
+ SysFreeString(b_assemName);
+ SysFreeString(b_methName);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "DN_createObject", &errMsg);
+ return errMsg;
+ }
+
+ fromVariant(resultTy, &result, res, &errMsg);
+ freeArgs(psa);
+
+ return errMsg;
+}
+
+/*
+ * Function: DN_getStatic()
+ *
+ * Given assembly and fully-qualified field name, fetch value of static
+ * field.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_getStatic ( char *assemName,
+ char *fieldClsName,
+ /* the next two args are ignored */
+ DotnetArg *args,
+ int n_args,
+ DotnetType resultTy,
+ void *res)
+{
+ VARIANT result;
+ HRESULT hr;
+ BSTR b_assemName;
+ BSTR b_clsName;
+ BSTR b_fieldName;
+ char* errMsg = NULL;
+ char* fieldName;
+ char* clsName = fieldName;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ fieldName = (char*)malloc(sizeof(char) * (strlen(fieldClsName) + 1));
+ strcpy(fieldName, fieldClsName);
+ clsName = fieldName;
+
+ if (( fieldName = strrchr(fieldName, '.')) == NULL ) {
+ genError((IUnknown*)pBridge, 0x0, "Invoke.getStatic - malformed field spec", &errMsg);
+ return errMsg;
+ }
+ *fieldName = '\0';
+ fieldName++;
+
+ VariantInit(&result);
+
+ hr = stringToBSTR(assemName, &b_assemName);
+ hr = stringToBSTR(fieldName, &b_fieldName);
+ hr = stringToBSTR(clsName, &b_clsName);
+ /* ToDo: honour assembly spec */
+ hr = InvokeBridge_GetStaticField(pBridge,
+ b_clsName,
+ b_fieldName,
+ &result);
+ SysFreeString(b_assemName);
+ SysFreeString(b_clsName);
+ SysFreeString(b_fieldName);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "Invoke.getStatic", &errMsg);
+ return errMsg;
+ }
+ fromVariant(resultTy, &result, res, &errMsg);
+
+ return errMsg;
+}
+
+/*
+ * Function: DN_setStatic()
+ *
+ * Given assembly and fully-qualified field name, set value of static
+ * field.
+ *
+ * Returns NULL on success, pointer to error message if an error.
+ *
+ */
+char*
+DN_setStatic ( char *assemName,
+ char *fieldClsName,
+ DotnetArg *args,
+ int n_args,
+ /* the next two args are ignored */
+ DotnetType resultTy,
+ void *res)
+{
+ VARIANT result;
+ VARIANT *pVal;
+ HRESULT hr;
+ BSTR b_assemName;
+ BSTR b_clsName;
+ BSTR b_fieldName;
+ char* errMsg = NULL;
+ char* fieldName;
+ char* clsName = fieldName;
+
+ if (!pBridge && !startBridge(&errMsg)) {
+ return errMsg;
+ }
+
+ fieldName = (char*)malloc(sizeof(char) * (strlen(fieldClsName) + 1));
+ strcpy(fieldName, fieldClsName);
+ clsName = fieldName;
+
+ if (( fieldName = strrchr(fieldName, '.')) == NULL ) {
+ genError((IUnknown*)pBridge, 0x0, "Invoke.setStatic - malformed field spec", &errMsg);
+ return errMsg;
+ }
+ *fieldName = '\0';
+ fieldName++;
+
+ pVal = toVariant(&args[0]);
+ VariantInit(&result);
+
+ hr = stringToBSTR(assemName, &b_assemName);
+ hr = stringToBSTR(fieldName, &b_fieldName);
+ hr = stringToBSTR(clsName, &b_clsName);
+ /* ToDo: honour assembly spec */
+ hr = InvokeBridge_SetStaticField(pBridge,
+ b_clsName,
+ b_fieldName,
+ *pVal);
+ SysFreeString(b_assemName);
+ SysFreeString(b_clsName);
+ SysFreeString(b_fieldName);
+ VariantClear(pVal);
+ free(pVal);
+ if (FAILED(hr)) {
+ genError((IUnknown*)pBridge, hr, "Invoke.setStatic", &errMsg);
+ return errMsg;
+ }
+ fromVariant(resultTy, &result, res, &errMsg);
+
+ return errMsg;
+}
+
+
+
+
+/*
+ * Function: startBridge(pErrMsg)
+ *
+ * Instantiates an InvokeBridge component, which is then
+ * used to interact with the .NET world.
+ *
+ * If the component isn't available locally, zero is returned.
+ * Otherwise, 1.
+ */
+static
+int
+startBridge(char** pErrMsg)
+{
+ HRESULT hr;
+ IUnknown *pUnk;
+
+ hr = CoInitializeEx(NULL, COINIT_APARTMENTTHREADED);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.createBridge.CoInitializeEx", pErrMsg);
+ return FALSE;
+ }
+
+ hr = CoCreateInstance( &CLSID_InvokeBridge,
+ NULL,
+ CLSCTX_INPROC_SERVER,
+ &IID_IUnknown,
+ (void**)&pUnk);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.createBridge.CoCreateInstance", pErrMsg);
+ return 0;
+ }
+
+ hr = IUnknown_QueryInterface(pUnk, &IID_InvokeBridge, (void**)&pBridge);
+ IUnknown_Release(pUnk);
+ if (FAILED(hr)) {
+ genError(pUnk, hr, "DInvoke.createBridge.QueryInterface.InvokeBridge", pErrMsg);
+ return 0;
+ }
+
+ return 1;
+}
+
+/*
+ * Function: stopBridge()
+ *
+ * Releases the InvokeBridge object and closes the COM library.
+ *
+ */
+void
+stopDotnetBridge()
+{
+ if (pBridge) {
+ InvokeBridge_Release(pBridge);
+ pBridge = NULL;
+ CoUninitialize();
+ }
+ /* Match up the call to CoInitializeEx() in startBridge(). */
+}
+
+/*
+ * Function: genError()
+ *
+ * Construct a string describing an error condition given
+ * an HRESULT and a location.
+ *
+ * If an interface pointer is passed in via the first arg,
+ * attempts are made to get at richer error information through
+ * the IErrorInfo interface. (Note: we don't currently look for
+ * the _Exception interface for even more detailed info.)
+ *
+ */
+#define LOCATION_HDR "Location: "
+#define HRESULT_HDR "HRESULT: "
+#define SOURCE_HDR "Source: "
+#define DESCR_HDR "Description: "
+#define NEWLINE_EXTRA 3
+
+static
+void
+genError(IUnknown* pUnk,
+ HRESULT err,
+ char* loc,
+ char** pErrMsg)
+{
+ HRESULT hr;
+ HRESULT invoke_hr = err;
+ char* invoke_src = NULL;
+ char* invoke_descr = NULL;
+ char* buf;
+ int bufLen;
+
+ /* If an interface pointer has been supplied, look for
+ * IErrorInfo in order to get more detailed information
+ * on the failure.
+ *
+ * The CLR's .NET COM Interop implementation does provide
+ * IErrorInfo, so we're not really clutching at straws here..
+ *
+ * Note: CLR also reflects .NET exceptions via the _Exception*
+ * interface..
+ *
+ */
+ if (pUnk) {
+ ISupportErrorInfo *pSupp;
+ IErrorInfo *pErrInfo;
+ BSTR src = NULL;
+ BSTR descr = NULL;
+
+ hr = IUnknown_QueryInterface(pUnk,
+ &IID_ISupportErrorInfo,
+ (void**)&pSupp);
+ if ( SUCCEEDED(hr) ) {
+ hr = ISupportErrorInfo_InterfaceSupportsErrorInfo(pSupp,
+ &IID_InvokeBridge);
+ if ( SUCCEEDED(hr) ) {
+ hr = GetErrorInfo(0,&pErrInfo);
+ if ( SUCCEEDED(hr) ) {
+ IErrorInfo_GetSource(pErrInfo,&src);
+ IErrorInfo_GetDescription(pErrInfo,&descr);
+ invoke_src = bstrToString(src);
+ invoke_descr = bstrToString(descr);
+
+ IErrorInfo_Release(pErrInfo);
+ if (src) { SysFreeString(src); src = NULL; }
+ if (descr) { SysFreeString(descr); descr = NULL; }
+ }
+ ISupportErrorInfo_Release(pSupp);
+ }
+ }
+ }
+ /* Putting it all together.. */
+ bufLen = sizeof(LOCATION_HDR) + strlen(loc) + NEWLINE_EXTRA +
+ sizeof(HRESULT_HDR) + 16 + NEWLINE_EXTRA +
+ sizeof(SOURCE_HDR) + (invoke_src ? strlen(invoke_src) : 16) + NEWLINE_EXTRA +
+ sizeof(DESCR_HDR) + (invoke_descr ? strlen(invoke_descr) : 16) + NEWLINE_EXTRA;
+ buf = (char*) malloc(sizeof(char) * (bufLen + 1));
+ if (!buf) {
+ fprintf(stderr, "Unable to allocate %d for error message", (bufLen + 1));
+ *pErrMsg = NULL;
+ return;
+ }
+
+ _snprintf(buf, bufLen, "%s%s\n%s0x%08x\n%s%s\n%s%s",
+ LOCATION_HDR, loc,
+ HRESULT_HDR, invoke_hr,
+ SOURCE_HDR, invoke_src,
+ DESCR_HDR, invoke_descr);
+
+ /* Done with these chaps */
+ if (invoke_src) free(invoke_src);
+ if (invoke_descr) free(invoke_descr);
+
+ if (pErrMsg) *pErrMsg = buf;
+ fprintf(stderr, "**InvokeBridge Error:\n%s", buf); fflush(stderr);
+}
+
+/* Converting to/from VARIANTs */
+
+/*
+ * Function: fromVariant()
+ *
+ * Unmarshal the contents of a VARIANT, converting its embedded value
+ * into the desired DotnetType (if possible.)
+ *
+ * Returns 1 if successful, 0 otherwise. If the conversion fails,
+ * *pErrMsg holds the error message string.
+ */
+static
+int
+fromVariant (DotnetType resTy,
+ VARIANT* pVar,
+ void* res,
+ char** pErrMsg)
+{
+ VARIANT vNew;
+ HRESULT hr;
+
+ VariantInit(&vNew);
+ switch(resTy) {
+ case Dotnet_Byte:
+ case Dotnet_Char:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UI1);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UI1}", pErrMsg);
+ return FALSE;
+ }
+ *((unsigned char*)res) = vNew.bVal;
+ return 1;
+ case Dotnet_Boolean:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_BOOL);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_BOOL}", pErrMsg);
+ return 0;
+ }
+ *((unsigned char*)res) = vNew.bVal;
+ return 1;
+ case Dotnet_Int:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_INT);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_INT}", pErrMsg);
+ return 0;
+ }
+ *((int*)res) = vNew.intVal;
+ return 1;
+ case Dotnet_Int8:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_I1);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_I1}", pErrMsg);
+ return 0;
+ }
+ *((signed char*)res) = vNew.bVal;
+ return 1;
+ case Dotnet_Int16:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_I2);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_I2}", pErrMsg);
+ return 0;
+ }
+ *((signed short*)res) = vNew.iVal;
+ return 1;
+ case Dotnet_Int32:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_I4);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_I4}", pErrMsg);
+ return 0;
+ }
+ *((signed int*)res) = vNew.lVal;
+ return 1;
+ case Dotnet_Int64:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_I8);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_I8}", pErrMsg);
+ return 0;
+ }
+#ifdef _MSC_VER
+ *((__int64*)res) = vNew.llVal;
+#else
+ *((long long*)res) = vNew.lVal;
+#endif
+ return 1;
+ case Dotnet_Float:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_R4);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_R4}", pErrMsg);
+ return 0;
+ }
+ *((float*)res) = vNew.fltVal;
+ return 1;
+ case Dotnet_Double:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_R8);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_R4}", pErrMsg);
+ return 0;
+ }
+ *((double*)res) = vNew.dblVal;
+ return 1;
+ case Dotnet_Word8:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UI1);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UI1}", pErrMsg);
+ return 0;
+ }
+ *((unsigned char*)res) = vNew.bVal;
+ return 1;
+ case Dotnet_Word16:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UI2);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UI2}", pErrMsg);
+ return 0;
+ }
+ *((unsigned short*)res) = vNew.uiVal;
+ return 1;
+ case Dotnet_Word32:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UI4);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UI4}", pErrMsg);
+ return 0;
+ }
+ *((unsigned int*)res) = vNew.ulVal;
+ return 1;
+ case Dotnet_Word64:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UI8);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UI8}", pErrMsg);
+ return 0;
+ }
+#ifdef _MSC_VER
+ *((unsigned __int64*)res) = vNew.ullVal;
+#else
+ *((unsigned long long*)res) = vNew.lVal;
+#endif
+ return 1;
+ case Dotnet_Ptr:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_BYREF);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_BYREF}", pErrMsg);
+ return 0;
+ }
+ *((void**)res) = vNew.byref;
+ return 1;
+ case Dotnet_Unit:
+ return 0;
+ case Dotnet_Object:
+ if ( pVar->vt == VT_BSTR ) {
+ /* Special handling for strings. If the user has asked for
+ * the string in object form, give him/her that.
+ */
+ VARIANT res;
+
+ VariantInit(&res);
+ hr = InvokeBridge_NewString(pBridge,
+ pVar->bstrVal,
+ &res);
+ if (SUCCEEDED(hr)) {
+ pVar = &res;
+ }
+ }
+ hr = VariantChangeType (&vNew, pVar, 0, VT_UNKNOWN);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_UNKNOWN}", pErrMsg);
+ return 0;
+ }
+ *((IUnknown**)res) = vNew.punkVal;
+ return 1;
+ case Dotnet_String:
+ hr = VariantChangeType (&vNew, pVar, 0, VT_BSTR);
+ if (FAILED(hr)) {
+ genError(NULL, hr, "DInvoke.fromVariant{VT_BSTR}", pErrMsg);
+ return 0;
+ }
+ /* Storage is allocated by malloc(), caller is resp for freeing. */
+ *((char**)res) = bstrToString(vNew.bstrVal);
+ return 1;
+ }
+ return 0;
+}
+
+/*
+ * Function: toVariant()
+ *
+ * Convert a DotnetArg into a VARIANT. The VARIANT
+ * is dynamically allocated.
+ *
+ * The result is the pointer to the filled-in VARIANT structure;
+ * NULL if allocation failed.
+ *
+ */
+static
+VARIANT*
+toVariant ( DotnetArg* p )
+{
+ VARIANT* v = (VARIANT*)malloc(sizeof(VARIANT));
+ if (!v) return NULL;
+ VariantInit(v);
+ switch (p->arg_type) {
+ case Dotnet_Byte:
+ v->vt = VT_UI1;
+ v->bVal = p->arg.arg_byte;
+ break;
+ case Dotnet_Char:
+ v->vt = VT_UI1;
+ v->bVal = p->arg.arg_char;
+ break;
+ case Dotnet_Boolean:
+ v->vt = VT_BOOL;
+ v->boolVal = p->arg.arg_bool;
+ break;
+ case Dotnet_Int:
+ v->vt = VT_INT;
+ v->intVal = p->arg.arg_int;
+ break;
+ case Dotnet_Int8:
+ v->vt = VT_I1;
+ v->bVal = p->arg.arg_int8;
+ break;
+ case Dotnet_Int16:
+ v->vt = VT_I2;
+ v->iVal = p->arg.arg_int16;
+ break;
+ case Dotnet_Int32:
+ v->vt = VT_I4;
+ v->lVal = p->arg.arg_int32;
+ break;
+ case Dotnet_Int64:
+ v->vt = VT_I8;
+#ifdef _MSC_VER
+ v->llVal = p->arg.arg_int64;
+#else
+ (long long*)(v->lVal) = p->arg.arg_int64;
+#endif
+ break;
+ case Dotnet_Float:
+ v->vt = VT_R4;
+ v->fltVal = p->arg.arg_float;
+ break;
+ case Dotnet_Double:
+ v->vt = VT_R8;
+ v->dblVal = p->arg.arg_double;
+ break;
+ case Dotnet_Word8:
+ v->vt = VT_UI1;
+ v->bVal = p->arg.arg_word8;
+ break;
+ case Dotnet_Word16:
+ v->vt = VT_UI2;
+ v->uiVal = p->arg.arg_word16;
+ break;
+ case Dotnet_Word32:
+ v->vt = VT_UI4;
+ v->ulVal = p->arg.arg_word32;
+ break;
+ case Dotnet_Word64:
+ v->vt = VT_UI8;
+#ifdef _MSC_VER
+ v->ullVal = p->arg.arg_word64;
+#else
+ (unsigned long long*)(v->lVal) = p->arg.arg_word64;
+#endif
+ break;
+ case Dotnet_Ptr:
+ v->vt = VT_BYREF;
+ v->byref = p->arg.arg_ptr;
+ break;
+ case Dotnet_Unit:
+ v->vt = VT_EMPTY;
+ break;
+ case Dotnet_Object:
+ v->vt = VT_UNKNOWN;
+ v->punkVal = (IUnknown*)p->arg.arg_obj;
+ break;
+ case Dotnet_String: {
+ BSTR b;
+ HRESULT hr;
+ v->vt = VT_BSTR;
+ hr = stringToBSTR((const char*)p->arg.arg_str,&b);
+ v->bstrVal = b;
+ break; }
+ }
+ return v;
+}
--- /dev/null
+//
+// (c) 2002-2003, sof.
+//
+// Dynamic invocation helper classes. The details of how
+// to access the .NET object model via the Reflection API
+// is taken care of by Invoker.{h,cpp}
+//
+#include "Invoker.h"
+
+namespace DynInvoke {
+
+static TypeName* ParseType(String* str) {
+ int curPos = 0;
+ int endPos;
+
+ // Console::WriteLine("x{0}y", str);
+ TypeName* typeName = new TypeName();
+
+ if ( str->get_Chars(0) == '[' ) {
+ endPos = str->IndexOf(']');
+ curPos = endPos + 1;
+ typeName->m_assembly = str->Substring(1,endPos-1);
+ typeName->m_length = endPos+1;
+ }
+ String* delimStr = " ,()";
+ Char delims __gc [] = delimStr->ToCharArray();
+
+ endPos = str->IndexOfAny(delims,curPos);
+ // Console::WriteLine("{0} {1} x{2}x", __box(endPos), __box(curPos), str);
+ if ( endPos == -1 ) {
+ typeName->m_class = str->Substring(curPos);
+ } else {
+ typeName->m_class = str->Substring(curPos,endPos-curPos);
+ }
+
+ // typeName->m_class = str->Substring(curPos,endPos-curPos);
+ typeName->m_length += endPos-curPos;
+
+ return typeName;
+}
+
+// Method: GetType(String* typeName);
+//
+// Purpose: Assembly-savvy version of Type::GetType()
+//
+Type* InvokeBridge::GetType(String* typeName) {
+
+ try {
+ Type* t = Type::GetType(typeName);
+ if (t) return t;
+ } catch (Exception*) {
+ ;
+ }
+
+ for (int i=0;i < InvokeBridge::m_assemblies->Count; i++) {
+ try {
+ String* stuff = String::Format("{0},{1}",typeName,InvokeBridge::m_assemblies->get_Item(i)->ToString());
+ // Console::WriteLine(stuff);
+ Type* t = Type::GetType(stuff);
+ if (t) {
+ return t;
+ }
+ } catch (Exception*) {
+ continue;
+ }
+ }
+ return 0;
+}
+
+//
+// Method: CreateInstance(String* typeName, Object* [])
+//
+// Purpose: Assembly-savvy invocation of Activator::CreateInstance
+Object* InvokeBridge::CreateInstance(TypeName* typeName,
+ Object* args[]) {
+
+ Object* instance = 0;
+ Type* t = InvokeBridge::GetType(typeName->toStdString());
+
+ // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t);
+ if (!t) {
+ try {
+ Assembly* localA = Assembly::LoadFrom(typeName->m_assembly);
+ t = localA->GetType(typeName->m_class);
+ } catch (Exception* e) {
+ ;
+ }
+ }
+
+ if (!t) {
+ try {
+ AppDomain* currentDomain = AppDomain::CurrentDomain;
+
+ // Assembly* stuff[] = currentDomain->GetAssemblies();
+ // for (int i=0;i < stuff.Length; i++) {
+ // Console::WriteLine("x{0} y{1}", stuff[i]->ToString(), stuff[i]->FullName);
+ // }
+ // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t);
+ Assembly* localA = Assembly::LoadWithPartialName("HugsAssembly");
+ t = localA->GetType(typeName->m_class);
+ // Console::WriteLine("x{0} y{1}", typeName->toStdString(), t);
+ } catch (Exception*) {
+ ;
+ }
+ }
+
+ if (t) {
+ try {
+ Object* o =Activator::CreateInstance(t,(Object* [])args);
+ return o;
+ } catch (Exception* e) {
+ Console::WriteLine("Failure: {0}", e);
+ return 0;
+ }
+ }
+}
+
+//
+// Method: CreateObject(String* objSpec, Object* args[])
+//
+// Purpose: Given a fully qualified name of a class/type, try
+// to create an instance of it.
+//
+Object* InvokeBridge::CreateObject(String* assemName,
+ String* objSpec,
+ Object* args[]) {
+
+ Object* instance = 0;
+
+ // Unravel the name of the class/type.
+ TypeName* typeName = ParseType(objSpec);
+
+ if (assemName != 0 && assemName->Length > 0) {
+ typeName->m_assembly = assemName;
+ }
+
+ // Try creating the instance..
+ try {
+ instance = InvokeBridge::CreateInstance(typeName,(Object* [])args);
+ } catch (Exception* e) {
+ Console::WriteLine("Unable to create instance \"{0}\" {1}", objSpec, e);
+ throw(e);
+ }
+ if (!instance) {
+ Console::WriteLine("Unable to create instance \"{0}\"", objSpec);
+ }
+ return instance;
+}
+
+//
+// Method: InvokeMethod
+//
+// Purpose: Given a pointer to an already created object, look up
+// one of its method. If found, invoke the method passing it
+// 'args' as arguments.
+//
+Object*
+InvokeBridge::InvokeMethod(Object* obj,
+ String* methName,
+ Object* args[]) {
+ // Get the methods from the type
+ MethodInfo* methods __gc[] = obj->GetType()->GetMethods();
+ MethodInfo* mInfo;
+
+ if (!methods) {
+ Console::WriteLine("InvokeMethod: No matching types found");
+ return 0;
+ }
+
+ System::Reflection::BindingFlags flgs
+ = (System::Reflection::BindingFlags) // why do I need to cast?
+ (System::Reflection::BindingFlags::Public |
+ System::Reflection::BindingFlags::NonPublic |
+ System::Reflection::BindingFlags::Instance |
+ System::Reflection::BindingFlags::Static |
+ System::Reflection::BindingFlags::InvokeMethod);
+
+ /* Caller is assumed to catch any exceptions raised. */
+ return obj->GetType()->InvokeMember(methName,
+ flgs,
+ 0,
+ obj,
+ (Object __gc* [])args);
+}
+
+//
+// Method: InvokeStaticMethod
+//
+// Purpose: Invoke a static method, given the fully qualified name
+// of the method (and its arguments). If found, invoke the
+// method passing it 'args' as arguments.
+//
+Object* InvokeBridge::InvokeStaticMethod(String* assemName,
+ String* typeAndMethName,
+ Object* args[]) {
+
+ // Get the methods from the type
+ MethodInfo* methods __gc[];
+ MethodInfo* mInfo;
+
+ int lastDot = typeAndMethName->LastIndexOf('.');
+ String* className = typeAndMethName->Substring(0,lastDot);
+ String* methName = typeAndMethName->Substring(lastDot+1);
+
+ // Unravel the name of the class/type.
+ TypeName* typeName = ParseType(className);
+ Type* t;
+
+ if (assemName != 0 && assemName->Length > 0) {
+ typeName->m_assembly = assemName;
+ }
+
+ try {
+ t = InvokeBridge::GetType(typeName->toStdString());
+
+ if (!t) {
+ try {
+ Assembly* localA = Assembly::LoadFrom(typeName->m_assembly);
+ t = localA->GetType(typeName->m_class);
+ // Console::WriteLine("InvokeStaticMethod: Type {0} found", t);
+ } catch (Exception* e) {
+ ;
+ }
+ }
+
+ if (t) {
+ methods = t->GetMethods();
+ } else {
+ Console::WriteLine("InvokeStaticMethod: Type {0} not found", className);
+ return 0;
+ }
+ } catch (Exception *e) {
+ Console::WriteLine("InvokeStaticMethod: Type {0} not found", className);
+ throw(e);
+ }
+
+ System::Reflection::BindingFlags flgs
+ = (System::Reflection::BindingFlags) // why do I need to cast?
+ (System::Reflection::BindingFlags::DeclaredOnly |
+ System::Reflection::BindingFlags::Public |
+ System::Reflection::BindingFlags::NonPublic |
+ System::Reflection::BindingFlags::Static |
+ System::Reflection::BindingFlags::InvokeMethod);
+
+ return t->InvokeMember(methName,
+ flgs,
+ 0,
+ 0,
+ (Object __gc* [])args);
+}
+
+//
+// Method: GetField
+//
+// Purpose: Fetch the (boxed) value of named field of a given object.
+//
+Object* InvokeBridge::GetField(Object* obj, System::String* fieldName) {
+
+ FieldInfo* fInfo = obj->GetType()->GetField(fieldName);
+ return fInfo->GetValue(obj);
+}
+
+//
+// Method: GetStaticField
+//
+// Purpose: Fetch the (boxed) value of named static field.
+//
+Object* InvokeBridge::GetStaticField(System::String* clsName,
+ System::String* fieldName) {
+
+ Type* ty = InvokeBridge::GetType(clsName);
+ System::Reflection::BindingFlags static_field_flgs
+ = (System::Reflection::BindingFlags)
+ (System::Reflection::BindingFlags::Public |
+ System::Reflection::BindingFlags::NonPublic |
+ System::Reflection::BindingFlags::FlattenHierarchy |
+ System::Reflection::BindingFlags::Static);
+
+ FieldInfo* fInfo = ty->GetField(fieldName, static_field_flgs);
+ return fInfo->GetValue(0); // according to doc, ok to pass any val here.
+}
+
+//
+// Method: SetField
+//
+// Purpose: Replace the (boxed) value of named field of a given object.
+//
+void InvokeBridge::SetField(Object* obj, System::String* fieldName, Object* val) {
+
+ FieldInfo* fInfo = obj->GetType()->GetField(fieldName);
+ fInfo->SetValue(obj,val);
+ return;
+}
+
+//
+// Method: SetStaticField
+//
+// Purpose: Replace the (boxed) value of named static field.
+//
+void InvokeBridge::SetStaticField(System::String* clsName,
+ System::String* fieldName,
+ Object* val) {
+
+ Type* ty = InvokeBridge::GetType(clsName);
+ System::Reflection::BindingFlags static_field_flgs
+ = (System::Reflection::BindingFlags)
+ (System::Reflection::BindingFlags::Public |
+ System::Reflection::BindingFlags::NonPublic |
+ System::Reflection::BindingFlags::FlattenHierarchy |
+ System::Reflection::BindingFlags::Static);
+
+ FieldInfo* fInfo = ty->GetField(fieldName,static_field_flgs);
+ fInfo->SetValue(0,val);
+ return;
+}
+
+Object* InvokeBridge::NewString(System::String* s)
+{
+ System::String* c = System::String::Copy(s);
+ return dynamic_cast<Object*>(c);
+}
+
+Array* InvokeBridge::NewArgArray(int sz)
+{
+ return Array::CreateInstance(__typeof(Object), sz);
+}
+
+void InvokeBridge::SetArg(Object* arr[], Object* val, int idx)
+{
+ arr->SetValue(val,idx);
+}
+
+Object* InvokeBridge::GetArg(Object* arr[], int idx)
+{
+ return arr->GetValue(idx);
+}
+
+} /* namespace */
--- /dev/null
+//
+// (c) 2003, sof.
+//
+// Dynamic invocation helper classes. The details of how
+// to access the .NET object model via the Reflection API
+// is taken care of by Invoker.{h,cpp}
+//
+#pragma once
+#using <mscorlib.dll>
+
+using namespace System;
+using namespace System::Reflection;
+using namespace System::Text;
+using namespace System::Runtime::InteropServices;
+
+[assembly:AssemblyKeyFileAttribute(S"invoker.snk")];
+
+namespace DynInvoke {
+
+//
+// Class: TypeName
+//
+// Purpose: pairing up an assembly name and the type/class name.
+//
+[ComVisible(false)]
+public __gc class TypeName {
+
+public:
+ System::String* m_assembly;
+ System::String* m_class;
+ int m_length;
+
+ TypeName() {
+ m_assembly = String::Empty;
+ m_class = String::Empty;
+ m_length = 0;
+ }
+
+ void Print() {
+ if (m_assembly && m_assembly != String::Empty ) {
+ Console::Write("[");
+ Console::Write(m_assembly);
+ Console::Write("]");
+ }
+ Console::WriteLine(m_class);
+ }
+
+ int Length() { return m_length; }
+
+ System::String* toStdString() {
+ System::String* res = new System::String(m_class->ToCharArray());
+
+ if (m_assembly && m_assembly != String::Empty ){
+ res = String::Concat(res, S",");
+ res = String::Concat(res, m_assembly);
+ }
+ return res;
+ }
+};
+
+//
+// Class: InvokeBridge
+//
+// Purpose: Collection of (static) methods for dynamically creating
+// objects and accessing methods/fields on them.
+//
+[ClassInterface(ClassInterfaceType::AutoDual),
+GuidAttribute("39D497D9-60E0-3525-B7F2-7BC096D3A2A3"),
+ComVisible(true)
+]
+public __gc class InvokeBridge {
+public:
+ InvokeBridge() {
+ Assembly* corAss = Assembly::Load("mscorlib.dll");
+ System::String* dir = System::IO::Path::GetDirectoryName(corAss->Location);
+
+ m_assemblies = new System::Collections::ArrayList();
+
+ System::String* fs[] = System::IO::Directory::GetFiles(dir, "*.dll");
+ for (int i=0;i < fs->Length; i++) {
+ try {
+ Assembly* tAss = Assembly::LoadFrom(fs[i]);
+ m_assemblies->Add(tAss->FullName);
+ } catch (Exception* e) {
+ continue;
+ }
+ }
+ }
+
+ //
+ // Method: CreateObject(String* assemName, String* objSpec, Object* args[])
+ //
+ // Purpose: Given a fully qualified name of a class/type, try
+ // to create an instance of it.
+ //
+ Object* CreateObject(System::String* assemName,
+ System::String* objSpec,
+ Object* args[]);
+
+ //
+ // Method: InvokeMethod
+ //
+ // Purpose: Given a pointer to an already created object, look up
+ // one of its method. If found, invoke the method passing it
+ // 'args' as arguments.
+ //
+ // Comments: the format of the method-spec is "methodName(type1,..,typeN)" [N>=0]
+ //
+ Object* InvokeMethod(Object* obj,
+ System::String* methSpec,
+ Object* args[]);
+
+ //
+ // Method: InvokeStaticMethod
+ //
+ // Purpose: Invoke a static method, given the fully qualified name
+ // of the method (and its arguments). If found, invoke the
+ // method passing it 'args' as arguments.
+ //
+ // Comments: the format of the method-spec is
+ // "T1.T2.<..>.Tn.methodName(type1,..,typeN)" [N>=0]
+ //
+ Object* InvokeStaticMethod(System::String* assemName,
+ System::String* methSpec,
+ Object* args[]);
+
+ //
+ // Method: GetField
+ //
+ // Purpose: Fetch the (boxed) value of named field of a given object.
+ //
+ Object* GetField(Object* obj, System::String* fieldSpec);
+
+ //
+ // Method: GetField
+ //
+ // Purpose: Fetch the (boxed) value of named static field.
+ //
+ Object* GetStaticField(System::String* clsName,
+ System::String* fieldSpec);
+
+ //
+ // Method: SetField
+ //
+ // Purpose: Replace the (boxed) value of named field of a given object.
+ //
+ void SetField(Object* obj, System::String* fieldSpec, Object* val);
+
+ //
+ // Method: SetStaticField
+ //
+ // Purpose: Replace the (boxed) value of named field of a given object.
+ //
+ void SetStaticField(System::String* clsName,
+ System::String* fieldSpec,
+ Object* val);
+
+
+ //
+ // Method: NewString
+ //
+ // Purpose: construct a System.String object copy in a manner that avoids
+ // COM Interop from deconstructing it to a BSTR.
+ //
+ System::Object* NewString( System::String* s);
+
+ //
+ // Method: NewArgArray
+ //
+ // Purpose: create a new array for holding (boxed) arguments to constructors/
+ // methods.
+ //
+ Array* NewArgArray(int sz);
+
+ //
+ // Method: SetArg
+ //
+ // Purpose: set an entry in the argument vector.
+ //
+ void SetArg(Object* arr[], Object* val, int idx);
+
+ //
+ // Method: GetArg
+ //
+ // Purpose: get an entry in the argument vector.
+ //
+ Object* GetArg(Object* arr[], int idx);
+
+ System::Type* InvokeBridge::GetType(System::String* typeName);
+
+protected:
+ System::Collections::ArrayList __gc* m_assemblies;
+ Object* InvokeBridge::CreateInstance(TypeName* typeName,
+ Object* args[]);
+};
+
+} /* namespace */
--- /dev/null
+/*
+ * InvokerClient interface defns for use with gcc.
+ *
+ * Note: These declarations mirror those of the InvokeBridge
+ * class declaration.
+ *
+ */
+
+#include <windows.h>
+#include <wtypes.h>
+#include <oaidl.h>
+
+#ifdef __cplusplus
+extern "C"{
+#endif
+
+#ifndef STDCALL
+#define STDCALL __stdcall
+#endif
+
+extern const CLSID CLSID_InvokeBridge;
+extern const IID IID_IUnknown;
+extern const IID IID_NULL;
+extern const IID IID_InvokeBridge;
+
+#ifdef WANT_UUID_DECLS
+const CLSID CLSID_InvokeBridge = { 0x39D497D9,0x60E0,0x3525,{0xB7,0xF2,0x7B,0xC0,0x96,0xD3,0xA2,0xA3}};
+//const IID IID_NULL = {0x00000000L, 0x0000, 0x0000, {0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}};
+//const IID IID_IUnknown = {0x00000000L, 0x0000, 0x0000, {0xC0, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x46}};
+const IID IID_InvokeBridge = { 0xAFF5FFCA, 0xC5C2, 0x3D5B, {0xAF, 0xD5, 0xED, 0x8E, 0x4B, 0x38, 0xDB, 0x7B}};
+ //0x3A85D703, 0xFAE4,0x3C5E, {0x9F,0x7E,0x20,0x98,0x31,0xCD,0x61,0x7A}};
+#endif
+
+#ifndef __InvokeBridge_INTERFACE_DEFINED__
+#define __InvokeBridge_INTERFACE_DEFINED__
+#undef INTERFACE
+#define INTERFACE InvokeBridge
+DECLARE_INTERFACE(InvokeBridge)
+{
+ STDMETHOD(QueryInterface)(THIS_ REFIID,PVOID*) PURE;
+ STDMETHOD_(ULONG,AddRef)(THIS) PURE;
+ STDMETHOD_(ULONG,Release)(THIS) PURE;
+ STDMETHOD(GetTypeInfoCount)(THIS_ UINT*) PURE;
+ STDMETHOD(GetTypeInfo)(THIS_ UINT,LCID,LPTYPEINFO*) PURE;
+ STDMETHOD(GetIDsOfNames)(THIS_ REFIID,LPOLESTR*,UINT,LCID,DISPID*) PURE;
+ STDMETHOD(Invoke)(THIS_ DISPID,REFIID,LCID,WORD,DISPPARAMS*,VARIANT*,EXCEPINFO*,UINT*) PURE;
+
+ STDMETHOD(ToString)(THIS_ BSTR*) PURE;
+ STDMETHOD(Equals)(THIS_ BSTR*) PURE;
+ STDMETHOD(GetHashCode)(THIS_ long*) PURE;
+ STDMETHOD(GetType)(THIS_ IUnknown**);
+ STDMETHOD(CreateObject)(THIS_ BSTR,BSTR,SAFEARRAY*, VARIANT*) PURE;
+ STDMETHOD(InvokeMethod)(THIS_ VARIANT,BSTR,SAFEARRAY*,VARIANT*) PURE;
+ STDMETHOD(InvokeStaticMethod)(THIS_ BSTR,BSTR,SAFEARRAY*,VARIANT*) PURE;
+
+ HRESULT ( STDCALL *GetField )(
+ InvokeBridge * This,
+ /* [in] */ VARIANT obj,
+ /* [in] */ BSTR fieldSpec,
+ /* [retval][out] */ VARIANT *pRetVal);
+
+ HRESULT ( STDCALL *GetStaticField )(
+ InvokeBridge * This,
+ /* [in] */ BSTR clsName,
+ /* [in] */ BSTR fieldSpec,
+ /* [retval][out] */ VARIANT *pRetVal);
+
+ HRESULT ( STDCALL *SetField )(
+ InvokeBridge * This,
+ /* [in] */ VARIANT obj,
+ /* [in] */ BSTR fieldSpec,
+ /* [in] */ VARIANT val);
+
+ HRESULT ( STDCALL *SetStaticField )(
+ InvokeBridge * This,
+ /* [in] */ BSTR clsName,
+ /* [in] */ BSTR fieldSpec,
+ /* [in] */ VARIANT val);
+
+ HRESULT ( STDCALL *NewString )(
+ InvokeBridge * This,
+ /* [in] */ BSTR s,
+ /* [retval][out] */VARIANT* pRetVal);
+
+ HRESULT ( STDCALL *NewArgArray )(
+ InvokeBridge * This,
+ /* [in] */ long sz,
+ /* [retval][out] */IUnknown **pRetVal);
+
+ HRESULT ( STDCALL *SetArg )(
+ InvokeBridge * This,
+ /* [in] */ SAFEARRAY * arr,
+ /* [in] */ VARIANT val,
+ /* [in] */ long idx);
+
+ HRESULT ( STDCALL *GetArg )(
+ InvokeBridge * This,
+ /* [in] */ SAFEARRAY * arr,
+ /* [in] */ long idx,
+ /* [retval][out] */ VARIANT *pRetVal);
+
+ HRESULT ( STDCALL *GetType_2 )(
+ InvokeBridge * This,
+ /* [in] */ BSTR typeName,
+ /* [retval][out] */ IUnknown **pRetVal);
+};
+#endif
+
+#define InvokeBridge_QueryInterface(This,riid,ppvObject) \
+ (This)->lpVtbl->QueryInterface(This,riid,ppvObject)
+
+#define InvokeBridge_AddRef(This) \
+ (This)->lpVtbl->AddRef(This)
+
+#define InvokeBridge_Release(This) \
+ (This)->lpVtbl->Release(This)
+
+#define InvokeBridge_GetTypeInfoCount(This,pctinfo) \
+ (This)->lpVtbl->GetTypeInfoCount(This,pctinfo)
+
+#define InvokeBridge_GetTypeInfo(This,iTInfo,lcid,ppTInfo) \
+ (This)->lpVtbl->GetTypeInfo(This,iTInfo,lcid,ppTInfo)
+
+#define InvokeBridge_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) \
+ (This)->lpVtbl->GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)
+
+#define InvokeBridge_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) \
+ (This)->lpVtbl->Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)
+
+#define InvokeBridge_get_ToString(This,pRetVal) \
+ (This)->lpVtbl->get_ToString(This,pRetVal)
+
+#define InvokeBridge_Equals(This,obj,pRetVal) \
+ (This)->lpVtbl->Equals(This,obj,pRetVal)
+
+#define InvokeBridge_GetHashCode(This,pRetVal) \
+ (This)->lpVtbl->GetHashCode(This,pRetVal)
+
+#define InvokeBridge_GetType(This,pRetVal) \
+ (This)->lpVtbl->GetType(This,pRetVal)
+
+#define InvokeBridge_CreateObject(This,assemName,objSpec,args,pRetVal) \
+ (This)->lpVtbl->CreateObject(This,assemName,objSpec,args,pRetVal)
+
+#define InvokeBridge_InvokeMethod(This,obj,methSpec,args,pRetVal) \
+ (This)->lpVtbl->InvokeMethod(This,obj,methSpec,args,pRetVal)
+
+#define InvokeBridge_InvokeStaticMethod(This,assemName,methSpec,args,pRetVal) \
+ (This)->lpVtbl->InvokeStaticMethod(This,assemName,methSpec,args,pRetVal)
+
+#define InvokeBridge_GetField(This,obj,fieldSpec,pRetVal) \
+ (This)->lpVtbl->GetField(This,obj,fieldSpec,pRetVal)
+
+#define InvokeBridge_GetStaticField(This,clsName,fieldSpec,pRetVal) \
+ (This)->lpVtbl->GetStaticField(This,clsName,fieldSpec,pRetVal)
+
+#define InvokeBridge_SetField(This,obj,fieldSpec,val) \
+ (This)->lpVtbl->SetField(This,obj,fieldSpec,val)
+
+#define InvokeBridge_SetStaticField(This,clsName,fieldSpec,val) \
+ (This)->lpVtbl->SetStaticField(This,clsName,fieldSpec,val)
+
+#define InvokeBridge_NewString(This,s,pRetVal) \
+ (This)->lpVtbl->NewString(This,s,pRetVal)
+
+#define InvokeBridge_NewArgArray(This,sz,pRetVal) \
+ (This)->lpVtbl->NewArgArray(This,sz,pRetVal)
+
+#define InvokeBridge_SetArg(This,arr,val,idx) \
+ (This)->lpVtbl->SetArg(This,arr,val,idx)
+
+#define InvokeBridge_GetArg(This,arr,idx,pRetVal) \
+ (This)->lpVtbl->GetArg(This,arr,idx,pRetVal)
+
+#define InvokeBridge_GetType_2(This,typeName,pRetVal) \
+ (This)->lpVtbl->GetType_2(This,typeName,pRetVal)
+
+#ifdef __cplusplus
+}
+#endif
--- /dev/null
+#
+# .NET interop for GHC.
+#
+# (c) 2003, sof.
+#
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+
+all :: Invoker.dll Invoke.o
+
+#
+# To compile the dotnet interop bits, you need to have the
+# .NET Framework SDK or VS.NET installed. The following
+# apps are used:
+#
+MCPP=cl
+TLBEXP=tlbexp
+REGASM=regasm
+GACUTIL=gacutil
+
+Invoker.dll : Invoker.obj
+ $(MCPP) /LD /clr /o Invoker.dll Invoker.obj
+ $(TLBEXP) Invoker.dll
+ $(REGASM) Invoker.dll
+ $(GACUTIL) /i Invoker.dll
+
+Invoker.obj : Invoker.cpp Invoker.h
+ $(MCPP) /LD /clr /c Invoker.cpp
+
+CLEAN_FILES += $(wildcard *.obj *.dll *.tlb)
+
+# ToDo:
+# - switch to /ir (i.e., copy it into the GAC.)
+# - sort out installation story.
+
+# drop the assembly
+remove :
+ $(GACUTIL) /u Invoker
+
+#
+# NOTE: For DotnetCc a version of gcc later than gcc-2.95 is
+# required (I'm using the gcc-3.2 snapshot that comes with mingw-2)
+#
+ifeq "$(DotnetCc)" ""
+DotnetCc=$(CC)
+endif
+DotnetCcOpts=$(CC_OPTS) $(DOTNET_EXTRA_CC_OPTS)
+SRC_CC_OPTS += -I$(TOP)/includes
+
+Invoke.o : Invoke.c
+ $(DotnetCc) $(DotnetCcOpts) -c $< -o $@
+
+include $(TOP)/mk/target.mk
#ifdef mingw32_TARGET_OS
,"wsock32" /* for the linker */
#endif
+#ifdef WANT_DOTNET_SUPPORT
+ , "oleaut32", "ole32", "uuid"
+#endif
#if defined(DEBUG) && defined(HAVE_LIBBFD)
,"bfd", "iberty" /* for debugging */
#endif
*/
#undef VOID_INT_SIGNALS
+/* Define if you want to include .NET interop support. */
+#undef WANT_DOTNET_SUPPORT
+
\f
/* Leave that blank line there!! Autoheader needs it.
If you're adding to this file, keep in mind:
X_CFLAGS=@X_CFLAGS@
X_LIBS=@X_LIBS@
+
+#
+# .NET interop support?
+#
+DotnetSupport=@DotnetSupport@
+
################################################################################
#
# happy project
projects / ghc-hetmet.git / commitdiff