summaryrefslogtreecommitdiff
path: root/ghc/rts/dotnet
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/rts/dotnet')
-rw-r--r--ghc/rts/dotnet/Invoke.c1081
-rw-r--r--ghc/rts/dotnet/Invoker.cpp338
-rw-r--r--ghc/rts/dotnet/Invoker.h197
-rw-r--r--ghc/rts/dotnet/InvokerClient.h180
-rw-r--r--ghc/rts/dotnet/Makefile53
-rw-r--r--ghc/rts/dotnet/invoker.snkbin0 -> 596 bytes
6 files changed, 1849 insertions, 0 deletions
diff --git a/ghc/rts/dotnet/Invoke.c b/ghc/rts/dotnet/Invoke.c
new file mode 100644
index 0000000000..585dcacaad
--- /dev/null
+++ b/ghc/rts/dotnet/Invoke.c
@@ -0,0 +1,1081 @@
+/*
+ * 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;
+}
diff --git a/ghc/rts/dotnet/Invoker.cpp b/ghc/rts/dotnet/Invoker.cpp
new file mode 100644
index 0000000000..d8ad87212d
--- /dev/null
+++ b/ghc/rts/dotnet/Invoker.cpp
@@ -0,0 +1,338 @@
+//
+// (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 */
diff --git a/ghc/rts/dotnet/Invoker.h b/ghc/rts/dotnet/Invoker.h
new file mode 100644
index 0000000000..d649a4c716
--- /dev/null
+++ b/ghc/rts/dotnet/Invoker.h
@@ -0,0 +1,197 @@
+//
+// (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 */
diff --git a/ghc/rts/dotnet/InvokerClient.h b/ghc/rts/dotnet/InvokerClient.h
new file mode 100644
index 0000000000..122f455c01
--- /dev/null
+++ b/ghc/rts/dotnet/InvokerClient.h
@@ -0,0 +1,180 @@
+/*
+ * 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
diff --git a/ghc/rts/dotnet/Makefile b/ghc/rts/dotnet/Makefile
new file mode 100644
index 0000000000..95b6c38890
--- /dev/null
+++ b/ghc/rts/dotnet/Makefile
@@ -0,0 +1,53 @@
+#
+# .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
diff --git a/ghc/rts/dotnet/invoker.snk b/ghc/rts/dotnet/invoker.snk
new file mode 100644
index 0000000000..05a222178a
--- /dev/null
+++ b/ghc/rts/dotnet/invoker.snk
Binary files differ
View Lorry Controller Status