1 // mzobj.cxx : Implementation of CMzObj
2
3 #ifdef MZCOM_3M
4 /* xform.rkt converts this file to mzobj3m.cxx: */
5 # define i64 /* ??? why does expansion produce i64? */
6 # include "mzobj3m.cxx"
7 #else
8
9 #include "scheme.h"
10
11 #ifdef MZ_PRECISE_GC
12 START_XFORM_SKIP;
13 #endif
14
15 #include "resource.h"
16
17 #include <process.h>
18
19 #include <objbase.h>
20 extern "C" {
21 #include "com_glue.h"
22 };
23
24 #ifdef MZ_PRECISE_GC
25 END_XFORM_SKIP;
26 #endif
27
28 #include "mzobj.h"
29
30 #ifndef MZ_PRECISE_GC
31 # define GC_CAN_IGNORE /* empty */
32 #endif
33
34 #ifdef MZ_PRECISE_GC
35 START_XFORM_SKIP;
36 #endif
37
ErrorBox(const char * s)38 static void ErrorBox(const char *s) {
39 ::MessageBox(NULL,s,"MzCOM",MB_OK);
40 }
41
42 #ifdef MZ_PRECISE_GC
43 END_XFORM_SKIP;
44 #endif
45
46 static THREAD_GLOBALS tg;
47
48 static Scheme_Env *env;
49
50 static BOOL *pErrorState;
51 static OLECHAR *wideError;
52
53 static HANDLE evalLoopSems[2];
54 static HANDLE exitSem;
55
56 static Scheme_Object *exn_catching_apply;
57 static Scheme_Object *exn_p;
58 static Scheme_Object *exn_message;
59
60 static Scheme_At_Exit_Callback_Proc at_exit_callback;
61
62 /* This indirection lets us delayload libmzsch.dll: */
63 #define scheme_false (scheme_make_false())
64
_apply_thunk_catch_exceptions(Scheme_Object * f,Scheme_Object ** exn)65 static Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f,
66 Scheme_Object **exn) {
67 Scheme_Object *v;
68
69 v = _scheme_apply(exn_catching_apply,1,&f);
70
71 /* v is a pair: (cons #t value) or (cons #f exn) */
72
73 if (SCHEME_TRUEP(SCHEME_CAR(v))) {
74 return SCHEME_CDR(v);
75 }
76 else {
77 *exn = SCHEME_CDR(v);
78 return NULL;
79 }
80 }
81
extract_exn_message(Scheme_Object * v)82 static Scheme_Object *extract_exn_message(Scheme_Object *v) {
83 if (SCHEME_TRUEP(_scheme_apply(exn_p,1,&v)))
84 return _scheme_apply(exn_message,1,&v);
85 else
86 return NULL; /* Not an exn structure */
87 }
88
do_eval(void * s,int,Scheme_Object **)89 static Scheme_Object *do_eval(void *s,int,Scheme_Object **) {
90 return scheme_eval_string_all((char *)s,env,TRUE);
91 }
92
eval_string_or_get_exn_message(char * s)93 static Scheme_Object *eval_string_or_get_exn_message(char *s) {
94 Scheme_Object *v;
95 Scheme_Object *exn;
96
97 v = _apply_thunk_catch_exceptions(scheme_make_closed_prim(do_eval,s),&exn);
98 /* value */
99 if (v) {
100 *pErrorState = FALSE;
101 return v;
102 }
103
104 v = extract_exn_message(exn);
105 /* exn */
106 if (v) {
107 *pErrorState = TRUE;
108 return v;
109 }
110
111 /* `raise' was called on some arbitrary value */
112 return exn;
113 }
114
wideStringFromSchemeObj(Scheme_Object * obj,const char * fmt,int fmtlen)115 OLECHAR *wideStringFromSchemeObj(Scheme_Object *obj,const char *fmt,int fmtlen) {
116 char *s;
117 OLECHAR *wideString;
118 int len;
119
120 s = scheme_format_utf8((char *)fmt,fmtlen,1,&obj,NULL);
121 len = strlen(s);
122 wideString = (OLECHAR *)scheme_malloc((len + 1) * sizeof(OLECHAR));
123 MultiByteToWideChar(CP_ACP,(DWORD)0,s,len,wideString,len + 1);
124 wideString[len] = 0;
125 return wideString;
126 }
127
exitHandler(int)128 void exitHandler(int) {
129 if (at_exit_callback) at_exit_callback();
130 ReleaseSemaphore(exitSem,1,NULL);
131 _endthreadex(0);
132 }
133
setupSchemeEnv(Scheme_Env * in_env)134 void setupSchemeEnv(Scheme_Env *in_env)
135 {
136 const char *wrapper;
137 char exeBuff[260];
138 HMODULE mod;
139 static BOOL registered;
140
141 if (!registered) {
142 scheme_register_static(&env,sizeof(env));
143 scheme_register_static(&exn_catching_apply,sizeof(exn_catching_apply));
144 scheme_register_static(&exn_p,sizeof(exn_p));
145 scheme_register_static(&exn_message,sizeof(exn_message));
146 registered = TRUE;
147 }
148
149 env = in_env;
150
151 if (env == NULL) {
152 ErrorBox("Can't create Racket environment");
153 _endthreadex(0);
154 }
155
156 // set up collection paths, based on Racket startup
157
158 mod = GetModuleHandle("mzcom.exe");
159 GetModuleFileName(mod,exeBuff,sizeof(exeBuff));
160
161 scheme_add_global("mzcom-exe",scheme_make_utf8_string(exeBuff),env);
162 scheme_set_exec_cmd(exeBuff);
163 scheme_set_collects_path(scheme_make_path("../collects"));
164 scheme_set_config_path(scheme_make_path("../etc"));
165 scheme_init_collection_paths(env, scheme_make_null());
166
167 // initialize namespace
168
169 scheme_namespace_require(scheme_intern_symbol("racket"));
170
171 // set up exception trapping
172
173 wrapper =
174 "(lambda (thunk) "
175 "(with-handlers ([void (lambda (exn) (cons #f exn))]) "
176 "(cons #t (thunk))))";
177
178 exn_catching_apply = scheme_eval_string(wrapper,env);
179 exn_p = scheme_builtin_value("exn?");
180 exn_message = scheme_builtin_value("exn-message");
181 }
182
do_evalLoop(Scheme_Env * env,int argc,char ** _args)183 static int do_evalLoop(Scheme_Env *env, int argc, char **_args)
184 {
185 LPVOID args = (LPVOID)_args;
186 HRESULT *pHr;
187 BOOL doEval;
188 UINT len;
189 DWORD waitVal;
190 char *narrowInput;
191 Scheme_Object *outputObj;
192 Scheme_Object *sleepFun;
193 OLECHAR *outputBuffer;
194 THREAD_GLOBALS *pTg;
195 HANDLE readSem;
196 HANDLE writeSem;
197 HANDLE resetSem;
198 HANDLE resetDoneSem;
199 BSTR **ppInput;
200 BSTR *pOutput, po;
201 MSG msg;
202
203 // make sure all Racket calls are in this thread
204
205 setupSchemeEnv(env);
206
207 scheme_set_exit(exitHandler);
208 sleepFun = scheme_builtin_value("sleep");
209
210 pTg = (THREAD_GLOBALS *)args;
211
212 ppInput = pTg->ppInput;
213 pOutput = pTg->pOutput;
214 pHr = pTg->pHr;
215 readSem = pTg->readSem;
216 writeSem = pTg->writeSem;
217 resetSem = pTg->resetSem;
218 resetDoneSem = pTg->resetDoneSem;
219 pErrorState = pTg->pErrorState;
220
221 while (1) {
222
223 doEval = FALSE;
224
225 while (doEval == FALSE) {
226 waitVal = MsgWaitForMultipleObjects(2,evalLoopSems,FALSE,
227 5,QS_ALLINPUT);
228
229 switch (waitVal) {
230
231 case WAIT_TIMEOUT :
232
233 scheme_apply(sleepFun,0,NULL);
234 break;
235
236 case WAIT_OBJECT_0 + 1:
237
238 // reset semaphore signaled
239
240 setupSchemeEnv(scheme_basic_env());
241 ReleaseSemaphore(resetDoneSem,1,NULL);
242
243 break;
244
245 case WAIT_OBJECT_0 + 2:
246
247 // Windows msg
248
249 while (PeekMessage(&msg,NULL,0x400,0x400,PM_REMOVE)) {
250 TranslateMessage(&msg);
251 DispatchMessage(&msg);
252 }
253
254 scheme_apply(sleepFun,0,NULL);
255
256 break;
257
258 default :
259
260 // got string to eval
261
262 doEval = TRUE;
263
264 break;
265 }
266 }
267
268 len = SysStringLen(**ppInput);
269
270 narrowInput = (char *)scheme_malloc(len + 1);
271
272 scheme_dont_gc_ptr(narrowInput);
273
274 WideCharToMultiByte(CP_ACP,(DWORD)0,
275 **ppInput,len,
276 narrowInput,len + 1,
277 NULL,NULL);
278
279 narrowInput[len] = '\0';
280
281 outputObj = eval_string_or_get_exn_message(narrowInput);
282
283 scheme_gc_ptr_ok(narrowInput);
284
285 if (*pErrorState) {
286 wideError = wideStringFromSchemeObj(outputObj,"Racket error: ~a",18);
287 po = SysAllocString(L"");
288 *pOutput = po;
289 *pHr = E_FAIL;
290 }
291 else {
292 outputBuffer = wideStringFromSchemeObj(outputObj,"~s",2);
293 po = SysAllocString(outputBuffer);
294 *pOutput = po;
295 *pHr = S_OK;
296 }
297
298 ReleaseSemaphore(writeSem,1,NULL);
299
300 }
301
302 return 0;
303 }
304
record_at_exit(Scheme_At_Exit_Callback_Proc p)305 static int record_at_exit(Scheme_At_Exit_Callback_Proc p) XFORM_SKIP_PROC
306 {
307 at_exit_callback = p;
308 return 0;
309 }
310
311 #define NO_TLS_INDEX_FOR_WIN_TLS 1
312 #include "../bc/win_tls.inc"
313
evalLoop(void * args)314 static unsigned WINAPI evalLoop(void *args) XFORM_SKIP_PROC {
315 register_win_tls();
316 scheme_set_atexit(record_at_exit);
317
318 return scheme_main_setup(1, do_evalLoop, 0, (char **)args);
319 }
320
321 #ifdef MZ_PRECISE_GC
322 START_XFORM_SKIP;
323 #endif
324
startMzThread(void)325 void CMzObj::startMzThread(void) {
326 tg.pHr = &hr;
327 tg.ppInput = &globInput;
328 tg.pOutput = &globOutput;
329 tg.readSem = readSem;
330 tg.writeSem = writeSem;
331 tg.resetSem = resetSem;
332 tg.resetDoneSem = resetDoneSem;
333 tg.pErrorState = &errorState;
334
335 threadHandle = (HANDLE)_beginthreadex(NULL, 0, evalLoop, &tg, 0, NULL);
336 }
337
338
CMzObj(void * _com_obj)339 CMzObj::CMzObj(void *_com_obj) {
340
341 com_obj = _com_obj;
342
343 inputMutex = NULL;
344 readSem = NULL;
345 threadHandle = NULL;
346
347 inputMutex = CreateSemaphore(NULL,1,1,NULL);
348 if (inputMutex == NULL) {
349 ErrorBox("Can't create input mutex");
350 return;
351 }
352
353 readSem = CreateSemaphore(NULL,0,1,NULL);
354
355 if (readSem == NULL) {
356 ErrorBox("Can't create read semaphore");
357 return;
358 }
359
360 writeSem = CreateSemaphore(NULL,0,1,NULL);
361
362 if (writeSem == NULL) {
363 ErrorBox("Can't create write semaphore");
364 return;
365 }
366
367 exitSem = CreateSemaphore(NULL,0,1,NULL);
368
369 if (exitSem == NULL) {
370 ErrorBox("Can't create exit semaphore");
371 return;
372 }
373
374 resetSem = CreateSemaphore(NULL,0,1,NULL);
375
376 if (resetSem == NULL) {
377 ErrorBox("Can't create reset semaphore");
378 return;
379 }
380
381 resetDoneSem = CreateSemaphore(NULL,0,1,NULL);
382
383 if (resetSem == NULL) {
384 ErrorBox("Can't create reset-done semaphore");
385 return;
386 }
387
388 evalLoopSems[0] = readSem;
389 evalLoopSems[1] = resetSem;
390 evalDoneSems[0] = writeSem;
391 evalDoneSems[1] = exitSem;
392
393 startMzThread();
394
395 }
396
killMzThread(void)397 void CMzObj::killMzThread(void) {
398 if (threadHandle) {
399 DWORD threadStatus;
400
401 GetExitCodeThread(threadHandle,&threadStatus);
402
403 if (threadStatus == STILL_ACTIVE) {
404 TerminateThread(threadHandle,0);
405 }
406
407 CloseHandle(threadHandle);
408
409 threadHandle = NULL;
410 }
411 }
412
~CMzObj(void)413 CMzObj::~CMzObj(void) {
414
415 killMzThread();
416
417 if (readSem) {
418 CloseHandle(readSem);
419 }
420
421 if (writeSem) {
422 CloseHandle(writeSem);
423 }
424
425 if (exitSem) {
426 CloseHandle(exitSem);
427 }
428
429 if (inputMutex) {
430 CloseHandle(inputMutex);
431 }
432 }
433
RaiseError(const OLECHAR * msg)434 void CMzObj::RaiseError(const OLECHAR *msg) {
435 BSTR bstr;
436 ICreateErrorInfo *pICreateErrorInfo;
437 IErrorInfo *pIErrorInfo;
438
439 bstr = SysAllocString(msg);
440
441 if (CreateErrorInfo(&pICreateErrorInfo) == S_OK &&
442 pICreateErrorInfo != NULL) {
443 pICreateErrorInfo->SetGUID(com_get_class_iid());
444 pICreateErrorInfo->SetDescription((LPOLESTR)msg);
445 pICreateErrorInfo->SetSource((LPOLESTR)L"MzCOM.MzObj");
446 if (pICreateErrorInfo->QueryInterface(IID_IErrorInfo,
447 (void **)&pIErrorInfo) == S_OK &&
448 pIErrorInfo != NULL) {
449 SetErrorInfo(0,pIErrorInfo);
450 }
451 }
452
453 Fire_SchemeError((IMzObj *)com_obj, bstr);
454 SysFreeString(bstr);
455 }
456
testThread(void)457 BOOL CMzObj::testThread(void) {
458 DWORD threadStatus;
459
460 if (threadHandle == NULL) {
461 RaiseError(L"No evaluator");
462 return FALSE;
463 }
464
465 if (GetExitCodeThread(threadHandle,&threadStatus) == 0) {
466 RaiseError(L"Evaluator may be terminated");
467 }
468
469 if (threadStatus != STILL_ACTIVE) {
470 RaiseError(L"Evaluator terminated");
471 return FALSE;
472 }
473
474 return TRUE;
475 }
476
477 /////////////////////////////////////////////////////////////////////////////
478 // CMzObj
479
Eval(BSTR input,BSTR * output)480 HRESULT CMzObj::Eval(BSTR input, BSTR *output) {
481 if (!testThread()) {
482 return E_ABORT;
483 }
484
485 WaitForSingleObject(inputMutex,INFINITE);
486 globInput = &input;
487 // allow evaluator to read
488 ReleaseSemaphore(readSem,1,NULL);
489
490 // wait until evaluator done or eval thread terminated
491 if (WaitForMultipleObjects(2,evalDoneSems,FALSE,INFINITE) ==
492 WAIT_OBJECT_0 + 1) {
493 RaiseError(L"Racket terminated evaluator");
494 return E_FAIL;
495 }
496
497 *output = globOutput;
498 ReleaseSemaphore(inputMutex,1,NULL);
499
500 if (errorState) {
501 RaiseError(wideError);
502 }
503
504 return hr;
505 }
506
dlgProc(HWND hDlg,UINT msg,WPARAM wParam,LPARAM)507 INT_PTR WINAPI dlgProc(HWND hDlg,UINT msg,WPARAM wParam,LPARAM) {
508 switch(msg) {
509 case WM_INITDIALOG :
510 SetDlgItemText(hDlg,MZCOM_URL,
511 "http://www.cs.rice.edu/CS/PLT/packages/mzcom/");
512 return TRUE;
513 case WM_COMMAND :
514 switch (LOWORD(wParam)) {
515 case IDOK :
516 case IDCANCEL :
517 EndDialog(hDlg,0);
518 return FALSE;
519 }
520 default :
521 return FALSE;
522 }
523 }
524
About()525 HRESULT CMzObj::About() {
526 DialogBox(globHinst,MAKEINTRESOURCE(ABOUTBOX),NULL,dlgProc);
527 return S_OK;
528 }
529
Reset()530 HRESULT CMzObj::Reset() {
531 if (!testThread()) {
532 return E_ABORT;
533 }
534
535 ReleaseSemaphore(resetSem,1,NULL);
536 WaitForSingleObject(resetDoneSem,INFINITE);
537 return S_OK;
538 }
539
new_mzobj(IMzObj * com_obj)540 void *new_mzobj(IMzObj *com_obj)
541 {
542 return new CMzObj(com_obj);
543 }
544
delete_mzobj(void * o)545 void delete_mzobj(void *o)
546 {
547 delete (CMzObj *)o;
548 }
549
mzobj_about(void * o)550 HRESULT mzobj_about(void *o)
551 {
552 return ((CMzObj *)o)->About();
553 }
554
mzobj_reset(void * o)555 HRESULT mzobj_reset(void *o)
556 {
557 return ((CMzObj *)o)->Reset();
558 }
559
mzobj_eval(void * o,BSTR s,BSTR * r)560 HRESULT mzobj_eval(void *o, BSTR s, BSTR *r)
561 {
562 return ((CMzObj *)o)->Eval(s, r);
563 }
564
565 #ifdef __MINGW32__
566
operator new(size_t n)567 void * operator new(size_t n)
568 {
569 return malloc(n);
570 }
571
operator delete(void * p)572 void operator delete(void * p)
573 {
574 free(p);
575 }
576
operator delete(void * p,unsigned long long)577 void operator delete(void * p, unsigned long long)
578 {
579 free(p);
580 }
581
operator delete(void * p,unsigned int)582 void operator delete(void * p, unsigned int)
583 {
584 free(p);
585 }
586
587 #endif
588
589 #ifdef MZ_PRECISE_GC
590 END_XFORM_SKIP;
591 #endif
592
593 #endif // MZCOM_3M
594