diff --git a/collects/mysterx/mysterx.rkt b/collects/mysterx/mysterx.rkt index ad4e66370a..d3b703fe01 100644 --- a/collects/mysterx/mysterx.rkt +++ b/collects/mysterx/mysterx.rkt @@ -79,8 +79,7 @@ com-scode->number number->com-scode com-object? - com-iunknown? - %%initialize-dotnet-runtime) + com-iunknown?) (define mx-version mxprims:mx-version) (define block-while-browsers mxprims:block-while-browsers) @@ -122,8 +121,6 @@ (define com-object-eq? mxprims:com-object-eq?) (define com-omit mxprims:com-omit) - (define %%initialize-dotnet-runtime mxprims:%%initialize-dotnet-runtime) - ;; sort results of "reflection" results (define (alphabetize lst) diff --git a/src/mysterx/array.cxx b/src/mysterx/array.cxx index 667d7772cc..0c6c9867a3 100644 --- a/src/mysterx/array.cxx +++ b/src/mysterx/array.cxx @@ -337,11 +337,11 @@ VARTYPE schemeValueToCOMType(Scheme_Object* val) else if (MX_SCODEP(val)) return VT_ERROR; else if (MX_COM_OBJP(val)) return VT_DISPATCH; else if (MX_IUNKNOWNP(val)) return VT_UNKNOWN; - else if (SCHEME_VECTORP(val)) getSchemeVectorType(val); - else if (scheme_apply(mx_marshal_raw_scheme_objects, 0, NULL) == scheme_false) + else if (SCHEME_VECTORP(val)) return getSchemeVectorType(val); + else scheme_signal_error("Unable to inject Scheme value %V into VARIANT", val); - else return VT_INT; - return VT_VARIANT; // If all else fails. (Eli: Looks like this is redundant) + + return VT_VARIANT; } diff --git a/src/mysterx/bstr.cxx b/src/mysterx/bstr.cxx index ca2b411e5a..d6f9f72ef0 100644 --- a/src/mysterx/bstr.cxx +++ b/src/mysterx/bstr.cxx @@ -215,16 +215,9 @@ Scheme_Object * BSTRToSchemeSymbol (BSTR bstr) return scheme_intern_exact_char_symbol (string, nchars); } -// This parameter controls whether strings returned by -// COM are converted to scheme symbols or to scheme strings. -Scheme_Object * mx_unmarshal_strings_as_symbols; - Scheme_Object * unmarshalBSTR (BSTR bstr) { - return - scheme_apply (mx_unmarshal_strings_as_symbols, 0, NULL) == scheme_false - ? BSTRToSchemeString (bstr) - : BSTRToSchemeSymbol (bstr); + return BSTRToSchemeString (bstr); } static diff --git a/src/mysterx/comtypes.cxx b/src/mysterx/comtypes.cxx index 95757653b6..31ed41b1f4 100644 --- a/src/mysterx/comtypes.cxx +++ b/src/mysterx/comtypes.cxx @@ -353,7 +353,7 @@ static int offsets[12] = Scheme_Object *mx_date_to_scheme_date(int argc,Scheme_Object **argv) { SYSTEMTIME sysTime; - Scheme_Object *p[10]; + Scheme_Object *p[10], *date_type; int yearDay; GUARANTEE_DATE ("date->com-date", 0); @@ -379,7 +379,9 @@ Scheme_Object *mx_date_to_scheme_date(int argc,Scheme_Object **argv) { p[8] = scheme_false; p[9] = scheme_make_integer(0); // time zone offset - return scheme_make_struct_instance(scheme_date_type,sizeray(p),p); + date_type = scheme_builtin_value("struct:date"); + + return scheme_make_struct_instance(date_type,sizeray(p),p); } static char *fieldNames[] = { @@ -390,10 +392,12 @@ static char *fieldNames[] = { Scheme_Object *scheme_date_to_mx_date(int argc,Scheme_Object **argv) { SYSTEMTIME sysTime; DATE vDate; - Scheme_Object *date; + Scheme_Object *date, *date_type; int i; - if (scheme_is_struct_instance(scheme_date_type,argv[0]) == FALSE) + date_type = scheme_builtin_value("struct:date"); + + if (scheme_is_struct_instance(date_type,argv[0]) == FALSE) scheme_wrong_type("date->com-date","struct:date",0,argc,argv); date = argv[0]; diff --git a/src/mysterx/mysterx.cxx b/src/mysterx/mysterx.cxx index be05dc234d..5b83323ece 100644 --- a/src/mysterx/mysterx.cxx +++ b/src/mysterx/mysterx.cxx @@ -70,7 +70,13 @@ static void GC_BOX_DONE(void *v) { # define GC_HANDLER_BOX_DONE(x) (scheme_gc_ptr_ok(x)) #endif -static Scheme_Object *mx_omit_obj; /* omitted argument placeholder */ +static Scheme_Object *mx_omit_obj_key; /* omitted argument placeholder */ + +static int is_mx_omit_obj(Scheme_Object *v) { + Scheme_Object *mx_omit_obj; + mx_omit_obj = scheme_hash_get(scheme_get_place_table(), mx_omit_obj_key); + return SAME_OBJ(v, mx_omit_obj); +} /* Normally false, but when true, mysterx will marshal any scheme */ /* object it would otherwise fail to marshal by simply sticking */ @@ -78,10 +84,6 @@ static Scheme_Object *mx_omit_obj; /* omitted argument placeholder */ /* best. Obviously this has GC implications, so don't use it. */ /* jrm uses it for dotnet. */ -Scheme_Object * mx_marshal_raw_scheme_objects; - -Scheme_Object *scheme_date_type; - MYSSINK_TABLE myssink_table; static char *objectAttributes[] = { @@ -400,9 +402,6 @@ static MX_PRIM mxPrims[] = { { mx_block_until_event,"block-until-event",1,1}, { mx_process_win_events,"process-win-events",0,0}, - // dotnet hack - { initialize_dotnet_runtime,"%%initialize-dotnet-runtime",0,0}, - }; #if !defined(SCHEME_NONNEGATIVE) @@ -2668,7 +2667,7 @@ BOOL schemeValueFitsElemDesc(Scheme_Object *val, ELEMDESC *pElemDesc) flags = pElemDesc->paramdesc.wParamFlags; if (flags & PARAMFLAG_FOPT) { - if (val == mx_omit_obj) + if (is_mx_omit_obj(val)) return TRUE; if (flags & PARAMFLAG_FHASDEFAULT) @@ -2833,14 +2832,9 @@ void marshalSchemeValueToVariant(Scheme_Object *val, VARIANTARG *pVariantArg) pVariantArg->parray = sa; } - else if (scheme_apply(mx_marshal_raw_scheme_objects, 0, NULL) == scheme_false) + else scheme_signal_error("Unable to inject Scheme value %V into VARIANT", val); - else { - uintptr_t v2; - pVariantArg->vt = VT_INT; - v2 = PtrToInt(val); - pVariantArg->intVal = v2; - } + return; } @@ -3766,7 +3760,7 @@ START_XFORM_SKIP; END_XFORM_SKIP; #endif - if (argv[k] == mx_omit_obj) { // omitted argument + if (is_mx_omit_obj(argv[k])) { // omitted argument methodArguments->rgvarg[j].vt = VT_ERROR; methodArguments->rgvarg[j].lVal = DISP_E_PARAMNOTFOUND; } @@ -3947,7 +3941,7 @@ START_XFORM_SKIP; END_XFORM_SKIP; #endif - if (argv[k] == mx_omit_obj) { // omitted argument + if (is_mx_omit_obj(argv[k])) { // omitted argument methodArguments->rgvarg[j].vt = VT_ERROR; methodArguments->rgvarg[j].lVal = DISP_E_PARAMNOTFOUND; } @@ -4173,6 +4167,7 @@ static Scheme_Object *mx_make_direct_call(int argc, Scheme_Object **argv, { HRESULT hr; Scheme_Object *retval; + Scheme_Object *mx_omit_obj; MX_ARGS_COUNT argsCount; IDispatch *pInterface; COMPTR funPtr; @@ -4231,6 +4226,8 @@ END_XFORM_SKIP; pushOneArg(retvalVa, buff); } + mx_omit_obj = scheme_hash_get(scheme_get_place_table(), mx_omit_obj_key); + // these must be macros, not functions, so that stack is maintained #ifdef MZ_PRECISE_GC @@ -5266,40 +5263,17 @@ START_XFORM_SKIP; END_XFORM_SKIP; #endif -Scheme_Object *scheme_initialize(Scheme_Env *env) +Scheme_Object *scheme_reload(Scheme_Env *env) { HRESULT hr; Scheme_Object *mx_fun; int i; Scheme_Object *mx_name; - Scheme_Object * arglist[1]; - - scheme_register_extension_global(&mx_omit_obj, sizeof(mx_omit_obj)); - scheme_register_extension_global(&scheme_date_type, sizeof(scheme_date_type)); + Scheme_Object * arglist[1], *mx_omit_obj; // globals in mysterx.cxx mx_name = scheme_intern_symbol(MXMAIN); - scheme_date_type = scheme_builtin_value("struct:date"); - - mx_com_object_type = scheme_make_type(""); - mx_com_type_type = scheme_make_type(""); - mx_browser_type = scheme_make_type(""); - mx_document_type = scheme_make_type(""); - mx_element_type = scheme_make_type(""); - mx_event_type = scheme_make_type(""); - mx_com_cy_type = scheme_make_type(""); - mx_com_date_type = scheme_make_type(""); - mx_com_scode_type = scheme_make_type(""); - mx_com_iunknown_type = scheme_make_type(""); - mx_com_omit_type = scheme_make_type(""); - mx_com_typedesc_type = scheme_make_type(""); - - mx_tbl_entry_type = scheme_make_type(""); - -#ifdef MZ_PRECISE_GC - register_traversers(); -#endif hr = CoInitialize(NULL); @@ -5309,17 +5283,6 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) return scheme_false; } - arglist[0] = scheme_false; - scheme_register_extension_global(&mx_unmarshal_strings_as_symbols, - sizeof mx_unmarshal_strings_as_symbols); - scheme_register_extension_global(&mx_marshal_raw_scheme_objects, - sizeof mx_marshal_raw_scheme_objects); - - mx_unmarshal_strings_as_symbols = - scheme_apply(scheme_builtin_value("make-parameter"), 1, arglist); - mx_marshal_raw_scheme_objects = - scheme_apply(scheme_builtin_value("make-parameter"), 1, arglist); - // export prims + omit value env = scheme_primitive_module(mx_name, env); @@ -5332,8 +5295,12 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) scheme_add_global(mxPrims[i].name, mx_fun, env); } - mx_omit_obj = (Scheme_Object *)scheme_malloc_atomic_tagged(sizeof(MX_OMIT)); - mx_omit_obj->type = mx_com_omit_type; + mx_omit_obj = scheme_hash_get(scheme_get_place_table(), mx_omit_obj_key); + if (!mx_omit_obj) { + mx_omit_obj = (Scheme_Object *)scheme_malloc_atomic_tagged(sizeof(MX_OMIT)); + mx_omit_obj->type = mx_com_omit_type; + scheme_hash_set(scheme_get_place_table(), mx_omit_obj_key, mx_omit_obj); + } scheme_add_global("com-omit", mx_omit_obj, env); @@ -5349,17 +5316,43 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) "Copyright (c) 1999-2003 PLT (Paul Steckler)\n"); } + return scheme_void; +} + +Scheme_Object *scheme_initialize(Scheme_Env *env) +{ + if (!mx_com_object_type) { + mx_com_object_type = scheme_make_type(""); + mx_com_type_type = scheme_make_type(""); + mx_browser_type = scheme_make_type(""); + mx_document_type = scheme_make_type(""); + mx_element_type = scheme_make_type(""); + mx_event_type = scheme_make_type(""); + mx_com_cy_type = scheme_make_type(""); + mx_com_date_type = scheme_make_type(""); + mx_com_scode_type = scheme_make_type(""); + mx_com_iunknown_type = scheme_make_type(""); + mx_com_omit_type = scheme_make_type(""); + mx_com_typedesc_type = scheme_make_type(""); + + mx_tbl_entry_type = scheme_make_type(""); + +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + } + + if (!mx_omit_obj_key) + mx_omit_obj_key = scheme_malloc_key(); + + scheme_reload(env); + scheme_add_atexit_closer(mx_exit_closer); atexit(mx_cleanup); return scheme_void; } -Scheme_Object *scheme_reload(Scheme_Env *env) -{ - return scheme_initialize(env); -} - // for some reason, couldn't put ATL stuff in browser.cxx // so we leave the Win message loop here @@ -5489,85 +5482,4 @@ BOOL APIENTRY DllMain(HANDLE hModule, DWORD reason, LPVOID lpReserved) END_XFORM_SKIP; #endif -#if defined (MYSTERX_DOTNET) -/// JRM HACKS for CLR -// Note that these must come last because the #include and #import -// both screw up some names used above. - -#include -// The import has a useless warning in it. -#pragma warning (disable: 4278) -#import -#pragma warning (default: 4278) - -// This doesn't appear to be necessary. -// -// raw_interfaces_only high_property_prefixes("_get", "_put", "_putref") -// -using namespace mscorlib; - -ICorRuntimeHost * pCLR = NULL; - -Scheme_Object* initialize_dotnet_runtime(int argc, Scheme_Object **argv) -{ - HRESULT hr; - _AppDomain *pDefaultDomain = NULL; - IUnknown *pAppDomainPunk = NULL; - IDispatch *pAppDomainDispatch = NULL; - - hr = CorBindToRuntimeEx(NULL, // latest version - // workspace mode - L"wks", - // We'll only be running one domain. - STARTUP_LOADER_OPTIMIZATION_SINGLE_DOMAIN, - CLSID_CorRuntimeHost, - IID_ICorRuntimeHost, - (void **) &pCLR); - - if (FAILED(hr)) - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "CorBindToRuntimeEx() failed."); - - hr = pCLR->Start(); - if (FAILED(hr)) - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "CLR failed to start."); - - hr = pCLR->GetDefaultDomain(&pAppDomainPunk); - if (FAILED(hr) || pAppDomainPunk == NULL) - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "GetDefaultDomain() failed."); - - hr = pAppDomainPunk->QueryInterface(__uuidof(_AppDomain), - (void **) &pDefaultDomain); - if (FAILED(hr) || pDefaultDomain == NULL) - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "QueryInterface for _AppDomain failed."); - pDefaultDomain->Release(); - - hr = pAppDomainPunk->QueryInterface(IID_IDispatch, - (void **) &pAppDomainDispatch); - if (FAILED(hr) || pAppDomainDispatch == NULL) - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "QueryInterface for IDispatch failed."); - - Scheme_Object * arglist[1] = {scheme_true}; - - scheme_apply(mx_unmarshal_strings_as_symbols, 1, arglist); - scheme_apply(mx_marshal_raw_scheme_objects, 1, arglist); - - return mx_make_idispatch(pAppDomainDispatch); -} - -/// END OF JRM HACK -#else -Scheme_Object * -initialize_dotnet_runtime(int argc, Scheme_Object **argv) -{ - scheme_signal_error("%%%%initialize-dotnet-runtime: " - "Support for .NET is not available in this image."); - return scheme_false; -} -#endif - #endif // MYSTERX_3M diff --git a/src/mysterx/mysterx.h b/src/mysterx/mysterx.h index cb81f406df..51da67735f 100644 --- a/src/mysterx/mysterx.h +++ b/src/mysterx/mysterx.h @@ -251,8 +251,6 @@ typedef struct _managed_obj_ { extern const CLSID emptyClsId; -extern Scheme_Object *scheme_date_type; - extern Scheme_Type mx_com_object_type; extern Scheme_Type mx_com_type_type; extern Scheme_Type mx_browser_type; @@ -268,11 +266,6 @@ extern Scheme_Type mx_com_typedesc_type; extern Scheme_Type mx_tbl_entry_type; -extern Scheme_Object *hash_table_get; -extern Scheme_Object *hash_table_put; -extern Scheme_Object *hash_table_remove; -extern Scheme_Object *make_hash_table; - Scheme_Object *mx_make_cy(CY *); Scheme_Object *mx_make_date(DATE *); Scheme_Object *mx_make_bool(unsigned); @@ -905,9 +898,6 @@ extern unsigned long browserCount; void *mx_wrap_handler(Scheme_Object *h); -// So array.cxx sees it -extern Scheme_Object * mx_marshal_raw_scheme_objects; - /* This indirection lets us delayload libmzsch.dll: */ #define scheme_false (scheme_make_false()) #define scheme_true (scheme_make_true())