1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 #include "scheme.h"
28 #include "prims.h"
29 #include "os.h"
30 #include "nt.h"
31 #include "ntdialog.h"
32 #include "ntgui.h"
33 #include "ntscreen.h"
34
35 extern /*static*/ HANDLE ghInstance = 0;
36 extern void scheme_main (int argc, const char ** argv);
37 extern void NT_preallocate_heap (void);
38 BOOL InitApplication(HANDLE);
39 BOOL InitInstance(HANDLE, int);
40
41 static SCHEME_OBJECT parse_event (SCREEN_EVENT *);
42
43 int WINAPI
WinMain(HINSTANCE hInst,HINSTANCE hPrevInst,LPSTR lpCmdLine,int nCmdShow)44 WinMain (HINSTANCE hInst, HINSTANCE hPrevInst, LPSTR lpCmdLine, int nCmdShow)
45 {
46 int argc;
47 char **argv;
48 extern int main (int, char **);
49
50 NT_preallocate_heap ();
51 ghInstance = hInst;
52 {
53 int cmdlen = strlen(lpCmdLine);
54 int maxargs = cmdlen/2+2;
55 char *cmdline = malloc(cmdlen+1);
56 char *s;
57
58 argv = malloc(sizeof(char*) * maxargs);
59
60 if (cmdline==0 || argv==0) {
61 outf_fatal ("WinMain cant malloc");
62 outf_flush_fatal ();
63 return FALSE;
64 }
65
66 argc = 1;
67 argv[0] = "scheme";
68
69 s = strcpy (cmdline, lpCmdLine);
70
71 while ((*s) != '\0')
72 {
73 while ((*s) == ' ')
74 s += 1;
75 if ((*s) == '"')
76 {
77 s += 1;
78 (argv[argc++]) = s;
79 while (1)
80 {
81 if ((*s) == '"')
82 {
83 (*s++) = '\0';
84 break;
85 }
86 if ((*s) == '\0')
87 {
88 outf_fatal ("WinMain: unterminated quoted argument.");
89 outf_flush_fatal ();
90 return (FALSE);
91 }
92 s += 1;
93 }
94 }
95 else
96 {
97 (argv[argc++]) = s;
98 while (1)
99 {
100 if ((*s) == ' ')
101 {
102 (*s++) = '\0';
103 break;
104 }
105 if ((*s) == '\0')
106 break;
107 s += 1;
108 }
109 }
110 }
111 argv[argc] = 0;
112 }
113
114 if (!hPrevInst)
115 if (!InitApplication(ghInstance))
116 return FALSE;
117
118 if (!InitInstance(ghInstance, nCmdShow))
119 return FALSE;
120
121 scheme_main (argc, ((const char **) argv));
122 return (0);
123 }
124
125 BOOL
InitApplication(HANDLE hInstance)126 InitApplication (HANDLE hInstance)
127 {
128 static BOOL done = FALSE;
129 if (done) return (TRUE);
130 done = TRUE;
131 return (Screen_InitApplication (hInstance));
132 }
133
134 static BOOL instance_initialized = FALSE;
135
136 BOOL
InitInstance(HANDLE hInstance,int nCmdShow)137 InitInstance (HANDLE hInstance, int nCmdShow)
138 {
139 instance_initialized = TRUE;
140 return (Screen_InitInstance (hInstance, nCmdShow));
141 }
142
143 void
nt_gui_default_poll(void)144 nt_gui_default_poll (void)
145 {
146 MSG msg;
147 int events_processed = 0;
148 while (PeekMessage ((&msg), 0, 0, 0, PM_REMOVE))
149 {
150 DispatchMessage (&msg);
151 events_processed += 1;
152 }
153 }
154
155 extern HANDLE master_tty_window;
156 extern void catatonia_trigger (void);
157 extern unsigned long * win32_catatonia_block;
158
159 void
catatonia_trigger(void)160 catatonia_trigger (void)
161 {
162 int mes_result;
163 static BOOL already_exitting = FALSE;
164 SCHEME_OBJECT saved = win32_catatonia_block[CATATONIA_BLOCK_LIMIT];
165
166 win32_catatonia_block[CATATONIA_BLOCK_LIMIT] = 0;
167
168 mes_result = (MessageBox (master_tty_window,
169 "Scheme appears to have become catatonic.\n"
170 "OK to kill it?",
171 "MIT/GNU Scheme",
172 (MB_ICONSTOP | MB_OKCANCEL)));
173
174 win32_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
175 win32_catatonia_block[CATATONIA_BLOCK_LIMIT] = saved;
176
177 if (mes_result != IDOK)
178 return;
179 else if (already_exitting)
180 exit (1);
181 else
182 {
183 already_exitting = TRUE;
184 termination_normal (0);
185 }
186 }
187
188 static void
nt_gui_high_priority_poll(void)189 nt_gui_high_priority_poll (void)
190 {
191 MSG close_msg;
192
193 if (PeekMessage (&close_msg, master_tty_window,
194 WM_CATATONIC, (WM_CATATONIC + 1),
195 PM_REMOVE))
196 DispatchMessage (&close_msg);
197 }
198
199 DEFINE_PRIMITIVE ("MICROCODE-POLL-INTERRUPT-HANDLER", Prim_microcode_poll_interrupt_handler, 2, 2,
200 "NT High-priority timer interrupt handler for Windows I/O.")
201 {
202 #ifndef USE_WM_TIMER
203 extern void low_level_timer_tick (void);
204 #endif
205
206 PRIMITIVE_HEADER (2);
207 if (((ARG_REF (1)) & (ARG_REF (2)) & INT_Global_GC) != 0)
208 {
209 nt_gui_high_priority_poll ();
210 CLEAR_INTERRUPT (INT_Global_GC);
211 }
212 else
213 {
214 win32_catatonia_block[CATATONIA_BLOCK_COUNTER] = 0;
215 nt_gui_default_poll ();
216 #ifndef USE_WM_TIMER
217 low_level_timer_tick ();
218 #endif
219 CLEAR_INTERRUPT (INT_Global_1);
220 }
221 PRIMITIVE_RETURN (UNSPECIFIC);
222 }
223
224 DEFINE_PRIMITIVE ("NT-DEFAULT-POLL-GUI", Prim_nt_default_poll_gui, 2, 2, 0)
225 {
226 PRIMITIVE_HEADER (2);
227
228 nt_gui_default_poll ();
229 PRIMITIVE_RETURN (UNSPECIFIC);
230 }
231
232 extern void NT_gui_init (void);
233
234 void
NT_gui_init(void)235 NT_gui_init (void)
236 {
237 if (!instance_initialized)
238 {
239 if (!InitApplication (ghInstance))
240 outf_console ("InitApplication failed\n");
241 if (!InitInstance (ghInstance, SW_SHOWNORMAL))
242 outf_console ("InitInstance failed\n");
243 }
244 }
245
246 static long
scheme_object_to_windows_object(SCHEME_OBJECT thing)247 scheme_object_to_windows_object (SCHEME_OBJECT thing)
248 {
249 if (INTEGER_P (thing))
250 return integer_to_long (thing);
251
252 if (STRING_P (thing))
253 return (long) (STRING_POINTER (thing));
254
255 if (thing==SHARP_F)
256 return 0;
257 if (thing==SHARP_T)
258 return 1;
259
260 if (OBJECT_TYPE (thing) == TC_VECTOR_1B ||
261 OBJECT_TYPE (thing) == TC_VECTOR_16B)
262 return (long) VECTOR_LOC (thing, 0);
263
264 return (long)thing;
265 }
266
267 /****************************************************************************/
268 /* first scheme window procedure requires every procedure to be purified */
269 /****************************************************************************/
270
271 extern SCHEME_OBJECT C_call_scheme (SCHEME_OBJECT, long, SCHEME_OBJECT *);
272
273 static SCHEME_OBJECT
apply4(SCHEME_OBJECT procedure,SCHEME_OBJECT arg1,SCHEME_OBJECT arg2,SCHEME_OBJECT arg3,SCHEME_OBJECT arg4)274 apply4 (SCHEME_OBJECT procedure, SCHEME_OBJECT arg1, SCHEME_OBJECT arg2,
275 SCHEME_OBJECT arg3, SCHEME_OBJECT arg4)
276 {
277 SCHEME_OBJECT argvec [4];
278 (argvec[0]) = arg1;
279 (argvec[1]) = arg2;
280 (argvec[2]) = arg3;
281 (argvec[3]) = arg4;
282 return (C_call_scheme (procedure, 4, argvec));
283 }
284
285 LRESULT CALLBACK
C_to_Scheme_WndProc(HWND hwnd,UINT message,WPARAM wParam,LPARAM lParam)286 C_to_Scheme_WndProc (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)
287 {
288 SCHEME_OBJECT thunk;
289 SCHEME_OBJECT result;
290
291 if (message==WM_CREATE || message==WM_NCCREATE) {
292 /*install thunk*/
293 LPCREATESTRUCT lpcs = (LPCREATESTRUCT) lParam;
294 SetWindowLong(hwnd, 0, (LONG)lpcs->lpCreateParams);
295 }
296
297 thunk = GetWindowLong (hwnd, 0);
298
299 if (thunk==0)
300 return DefWindowProc (hwnd, message, wParam, lParam);
301
302 result
303 = (apply4 (thunk,
304 (ulong_to_integer ((unsigned long) hwnd)),
305 (ulong_to_integer (message)),
306 (ulong_to_integer (wParam)),
307 (ulong_to_integer (lParam))));
308
309 return scheme_object_to_windows_object (result);
310 }
311
312 DEFINE_PRIMITIVE ("GET-SCHEME-WINDOW-PROCEDURE", Prim_get_scheme_window_procedure, 1, 1, 0)
313 {
314 PRIMITIVE_HEADER(1);
315 {
316 HWND hWnd = (HWND)arg_integer (1);
317 SCHEME_OBJECT result;
318
319 if (GetWindowLong(hWnd, GWL_WNDPROC) != (LONG) C_to_Scheme_WndProc)
320 result = SHARP_F;
321 else
322 result = (SCHEME_OBJECT) GetWindowLong(hWnd, 0);
323
324 PRIMITIVE_RETURN (result);
325 }
326 }
327
328 /****************************************************************************/
329 /*
330 Second version: There is only one scheme wndproc, which is called
331 to re-dispatch to the correct wndproc, indexing of the hwnd argument.
332 The one scheme procedure is set with SET-GENERAL-SCHEME-WNDPROC.
333 The procedure must be a purified first.
334 */
335
336 static SCHEME_OBJECT general_scheme_wndproc = SHARP_F;
337
338 DEFINE_PRIMITIVE ("GET-GENERAL-SCHEME-WNDPROC", Prim_get_general_scheme_wndproc, 0, 0, 0)
339 {
340 PRIMITIVE_HEADER(0);
341 {
342 PRIMITIVE_RETURN (general_scheme_wndproc);
343 }
344 }
345
346 DEFINE_PRIMITIVE ("SET-GENERAL-SCHEME-WNDPROC", Prim_set_general_scheme_wndproc, 1, 1, 0)
347 {
348 PRIMITIVE_HEADER(1);
349 {
350 SCHEME_OBJECT wndproc = ARG_REF(1);
351 if (!ADDRESS_IN_CONSTANT_P (OBJECT_ADDRESS (wndproc)))
352 signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
353 general_scheme_wndproc = wndproc;
354 PRIMITIVE_RETURN (UNSPECIFIC);
355 }
356 }
357
358 LRESULT CALLBACK
C_to_Scheme_WndProc_2(HWND hwnd,UINT message,WPARAM wParam,LPARAM lParam)359 C_to_Scheme_WndProc_2 (HWND hwnd, UINT message, WPARAM wParam, LPARAM lParam)
360 {
361 SCHEME_OBJECT result;
362
363 if (general_scheme_wndproc == SHARP_F)
364 return DefWindowProc (hwnd, message, wParam, lParam);
365
366 result
367 = (apply4 (general_scheme_wndproc,
368 (ulong_to_integer ((unsigned long) hwnd)),
369 (ulong_to_integer (message)),
370 (ulong_to_integer (wParam)),
371 (ulong_to_integer (lParam))));
372
373 return scheme_object_to_windows_object (result);
374 }
375
376 /***************************************************************************/
377
378 void
failed_foreign_function(void)379 failed_foreign_function (void)
380 {
381 PRIMITIVE_ABORT (ERR_INAPPLICABLE_OBJECT);
382 }
383
384 DEFINE_PRIMITIVE ("GET-HANDLE", Prim_get_handle, 1, 1,
385 "(id)\n"
386 "Returns an otherwise hard to get global C variable\n"
387 "id entity\n"
388 "0 instance handle\n"
389 "1 master tty handle\n"
390 "2 C to Scheme windows procedure address\n"
391 "3 C to Scheme windows procedure address (eta version)\n"
392 "4 failed-foreign-function address\n")
393 {
394 PRIMITIVE_HEADER(1);
395 {
396 long arg = arg_integer (1);
397 long result = 0;
398 switch (arg) {
399 case 0: result = (long) ghInstance; break;
400 case 1: result = (long) master_tty_window; break;
401 case 2: result = (long) C_to_Scheme_WndProc; break;
402 case 3: result = (long) C_to_Scheme_WndProc_2; break;
403 case 4: result = (long) failed_foreign_function; break;
404 default: error_bad_range_arg (1);
405 }
406 PRIMITIVE_RETURN (long_to_integer (result));
407 }
408 }
409
410 static unsigned long
arg_ulong_default(int arg_number,unsigned long def)411 arg_ulong_default (int arg_number, unsigned long def)
412 {
413 SCHEME_OBJECT object = (ARG_REF (arg_number));
414 if (object == SHARP_F)
415 return def;
416 if (! (INTEGER_P (object)))
417 error_wrong_type_arg (arg_number);
418 return integer_to_ulong (object);
419 }
420
421 DEFINE_PRIMITIVE ("WIN:CREATE-WINDOW", Prim_create_window, 10, 10,
422 "class-name\n"
423 "window-name\n"
424 "style\n"
425 "X\n"
426 "Y\n"
427 "width\n"
428 "height\n"
429 "parent\n"
430 "menu\n"
431 "(instance omitted)\n"
432 "lpParam: (lambda (hwnd message wparam lparam)). [think about MDI later]\n")
433 {
434 LPSTR class_name;
435 LPSTR window_name;
436 DWORD style;
437 int x, y, w, h;
438 HWND hWndParent;
439 HMENU hMenu;
440 LPVOID lpvParam;
441 HWND result;
442
443 CHECK_ARG (1, STRING_P);
444 CHECK_ARG (2, STRING_P);
445 class_name = (STRING_POINTER (ARG_REF (1)));
446 window_name = (STRING_POINTER (ARG_REF (2)));
447 style = integer_to_ulong (ARG_REF (3));
448 x = (int) arg_ulong_default (4, ((unsigned long) CW_USEDEFAULT));
449 y = (int) arg_ulong_default (5, ((unsigned long) CW_USEDEFAULT));
450 w = (int) arg_ulong_default (6, ((unsigned long) CW_USEDEFAULT));
451 h = (int) arg_ulong_default (7, ((unsigned long) CW_USEDEFAULT));
452 hWndParent = (HWND) arg_ulong_default (8, 0);
453 hMenu = (HMENU) arg_ulong_default (9, 0);
454 lpvParam = (LPVOID) ARG_REF (10);
455
456 result = CreateWindowEx (0, class_name, window_name, style, x, y, w, h,
457 hWndParent, hMenu, ghInstance, lpvParam);
458
459 return ulong_to_integer ((unsigned long) result);
460 }
461
462 DEFINE_PRIMITIVE ("WIN:DEF-WINDOW-PROC", Prim_def_window_proc, 4, 4, 0)
463 {
464 #if 0
465 outf_console ("\001");
466 #endif
467 return
468 long_to_integer
469 (DefWindowProc
470 (((HWND) (scheme_object_to_windows_object (ARG_REF (1)))),
471 ((UINT) (scheme_object_to_windows_object (ARG_REF (2)))),
472 ((WPARAM) (scheme_object_to_windows_object (ARG_REF (3)))),
473 ((LPARAM) (scheme_object_to_windows_object (ARG_REF (4))))));
474 }
475
476 DEFINE_PRIMITIVE ("REGISTER-CLASS", Prim__register_class, 10, 10,
477 "(style wndproc clsExtra wndExtra hInstance hIcon hCursor\n"
478 " hBackground menu-name class-name)\n"
479 "\n"
480 "cursor = 32512(arrow), 32513(ibeam), 32514(hourglass),\n"
481 " 32515(cross), 32516(uparrow)\n"
482 "background = 0 (white_brush)\n")
483 {
484 /* should lift background and cursor */
485 WNDCLASS wc;
486 BOOL rc;
487 PRIMITIVE_HEADER (10);
488 CHECK_ARG (10, STRING_P);
489
490 wc.style = arg_integer (1);
491 wc.lpfnWndProc = ((WNDPROC) (arg_integer (2)));
492 wc.cbClsExtra = scheme_object_to_windows_object (ARG_REF(3));
493 wc.cbWndExtra = scheme_object_to_windows_object (ARG_REF(4));
494 wc.hInstance = (HANDLE)scheme_object_to_windows_object (ARG_REF(5));
495 wc.hIcon = (HANDLE)scheme_object_to_windows_object (ARG_REF(6));
496 wc.hCursor = LoadCursor (NULL, MAKEINTRESOURCE(arg_integer(7)));
497 wc.hbrBackground = GetStockObject (arg_integer(8));
498 wc.lpszMenuName = (char*)scheme_object_to_windows_object (ARG_REF(9));
499 wc.lpszClassName = (char*)scheme_object_to_windows_object (ARG_REF(10));
500
501 rc = RegisterClass (&wc);
502 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT(rc));
503 }
504
505 DEFINE_PRIMITIVE ("APPLY_1", Prim_apply_1_xyz, 2, 2, 0)
506 {
507 SCHEME_OBJECT proc, arg, result;
508 PRIMITIVE_HEADER (2);
509
510 proc = ARG_REF (1);
511 arg = ARG_REF (2);
512
513 result = C_call_scheme (proc, 1, &arg);
514
515 PRIMITIVE_RETURN (result);
516 }
517
518 /************************************************************************/
519 /* Primitive versions of library stuff */
520 /************************************************************************/
521
522 DEFINE_PRIMITIVE ("NT:GET-MODULE-HANDLE", Prim_get_module_handle, 1, 1,
523 "(string) -> handle")
524 {
525 HANDLE it;
526
527 PRIMITIVE_HEADER (1);
528
529 CHECK_ARG (1, STRING_P);
530 it = GetModuleHandle (STRING_POINTER (ARG_REF (1)));
531 PRIMITIVE_RETURN (long_to_integer ((long) it));
532 }
533
534 DEFINE_PRIMITIVE ("NT:LOAD-LIBRARY", Prim_nt_load_library, 1, 1,
535 "(string) -> handle")
536 {
537 HANDLE it;
538
539 PRIMITIVE_HEADER (1);
540
541 CHECK_ARG (1, STRING_P);
542 it = LoadLibrary ((LPSTR) (STRING_POINTER (ARG_REF (1))));
543 PRIMITIVE_RETURN (long_to_integer ((long) it));
544 }
545
546 DEFINE_PRIMITIVE ("NT:FREE-LIBRARY", Prim_nt_free_library, 1, 1,
547 "(library-module-handle) -> bool")
548 {
549 HANDLE handle;
550 BOOL result;
551
552 PRIMITIVE_HEADER (1);
553
554 handle = ((HANDLE) (arg_integer (1)));
555 result = FreeLibrary (handle);
556 PRIMITIVE_RETURN (result ? SHARP_T : SHARP_F);
557 }
558
559 DEFINE_PRIMITIVE ("NT:GET-PROC-ADDRESS", Prim_nt_get_proc_address, 2, 2,
560 "(handle string/integer) -> address")
561 {
562 HMODULE module;
563 LPSTR function_name;
564 FARPROC it;
565 SCHEME_OBJECT function;
566
567 PRIMITIVE_HEADER (2);
568
569 module = (HMODULE) arg_integer (1);
570 function = ARG_REF (2);
571 if (STRING_P (function))
572 function_name = (STRING_POINTER (function));
573 else
574 function_name = (LPSTR) arg_integer (2);
575
576 it = GetProcAddress (module, function_name);
577
578 PRIMITIVE_RETURN (it==NULL ? SHARP_F : long_to_integer ((long) it));
579 }
580
581 DEFINE_PRIMITIVE ("NT:SEND-MESSAGE", Prim_send_message, 4, 4,
582 "(handle message wparam lparam)")
583 {
584 HWND hwnd;
585 UINT message;
586 WPARAM wParam;
587 LPARAM lParam;
588 SCHEME_OBJECT thing;
589 PRIMITIVE_HEADER (4);
590
591 hwnd = (HWND) arg_integer (1);
592 message = arg_integer (2);
593 wParam = arg_integer (3);
594 thing = ARG_REF (4);
595 if (STRING_P (thing))
596 lParam = (LPARAM) (STRING_POINTER (thing));
597 else
598 lParam = arg_integer (4);
599
600 PRIMITIVE_RETURN (long_to_integer (SendMessage (hwnd, message, wParam, lParam)));
601 }
602
603 static SCHEME_OBJECT call_ff_really (void);
604
605 DEFINE_PRIMITIVE ("CALL-FF", Prim_call_ff, 0, LEXPR, 0)
606 {
607 /* This indirection saves registers correctly in this stack frame
608 rather than in a bad position in relation to the bogus C argument
609 stack. */
610 PRIMITIVE_HEADER (LEXPR);
611 PRIMITIVE_RETURN (call_ff_really ());
612 }
613
614 static SCHEME_OBJECT
call_ff_really(void)615 call_ff_really (void)
616 {
617 unsigned long function_address;
618 SCHEME_OBJECT * argument_scan;
619 SCHEME_OBJECT * argument_limit;
620 long result = UNSPECIFIC;
621 unsigned long nargs = GET_LEXPR_ACTUALS;
622 if (nargs < 1)
623 signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
624 if (nargs > 30)
625 signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
626
627 function_address = (arg_ulong_integer (1));
628 argument_scan = (ARG_LOC (nargs + 1));
629 argument_limit = (ARG_LOC (2));
630 while (argument_scan > argument_limit)
631 {
632 long arg
633 = (scheme_object_to_windows_object
634 (STACK_LOCATIVE_PUSH (argument_scan)));
635 #ifdef CL386
636 __asm push arg
637 #else /* not CL386 */
638 #ifdef __WATCOMC__
639 {
640 extern void call_ff_really_1 (void);
641 #pragma aux call_ff_really_1 = "push arg";
642 call_ff_really_1 ();
643 }
644 #endif /* __WATCOMC__ */
645 #endif /* not CL386 */
646 }
647 #ifdef CL386
648 __asm
649 {
650 mov eax, function_address
651 call eax
652 mov result, eax
653 }
654 #else /* not CL386 */
655 #ifdef __WATCOMC__
656 {
657 extern void call_ff_really_2 (void);
658 #pragma aux call_ff_really_2 = \
659 "mov eax,function_address" \
660 "call eax" \
661 "mov result,eax" \
662 modify [eax edx ecx];
663 call_ff_really_2 ();
664 }
665 #endif /* __WATCOMC__ */
666 #endif /* not CL386 */
667 return (long_to_integer (result));
668 }
669
670 /* Primitives for hacking strings, to fetch and set signed and
671 unsigned 32 and 16 bit values at byte offsets. */
672
673 DEFINE_PRIMITIVE ("INT32-OFFSET-REF", Prim_int32_offset_ref, 2, 2,
674 "(mem-addr byte-offset)\n"
675 "Fetch 32 bit signed long from memory (a string)")
676 {
677 PRIMITIVE_HEADER (2);
678 {
679 long *base;
680 int offset;
681 CHECK_ARG (1, STRING_P);
682 base = (long*) (STRING_POINTER (ARG_REF (1)));
683 offset = arg_integer (2);
684 PRIMITIVE_RETURN ( long_to_integer(* (long*) (((char*)base)+offset) ) );
685 }
686 }
687
688 DEFINE_PRIMITIVE ("INT32-OFFSET-SET!", Prim_int32_offset_set, 3, 3,
689 "(mem-addr byte-offset 32-bit-value)\n"
690 "Set 32 bit signed long from memory (integer address or vector data)")
691 {
692 PRIMITIVE_HEADER (3);
693 {
694 long *base;
695 int offset;
696 long value;
697 CHECK_ARG (1, STRING_P);
698 base = (long*) (STRING_POINTER (ARG_REF (1)));
699 offset = arg_integer (2);
700 value = scheme_object_to_windows_object (ARG_REF (3));
701 * (long*) (((char*)base)+offset) = value;
702 }
703 PRIMITIVE_RETURN (UNSPECIFIC);
704 }
705
706 DEFINE_PRIMITIVE ("UINT32-OFFSET-REF", Prim_uint32_offset_ref, 2, 2,
707 "(mem-addr byte-offset)\n"
708 "Fetch 32 bit unsigned long from memory (a string)")
709 {
710 PRIMITIVE_HEADER (2);
711 {
712 unsigned long *base;
713 int offset;
714 CHECK_ARG (1, STRING_P);
715 base = (unsigned long*) (STRING_POINTER (ARG_REF (1)));
716 offset = arg_integer (2);
717 PRIMITIVE_RETURN
718 (ulong_to_integer(* (unsigned long*) (((char*)base)+offset)));
719 }
720 }
721
722 DEFINE_PRIMITIVE ("UINT32-OFFSET-SET!", Prim_uint32_offset_set, 3, 3,
723 "(mem-addr byte-offset 32-bit-value)\n"
724 "Set 32 bit unsigned long at offset from memory")
725 {
726 PRIMITIVE_HEADER (3);
727 {
728 unsigned long *base;
729 int offset;
730 unsigned long value;
731 CHECK_ARG (1, STRING_P);
732 base = (unsigned long*) (STRING_POINTER (ARG_REF (1)));
733 offset = arg_integer (2);
734 value = scheme_object_to_windows_object (ARG_REF (3));
735 * (unsigned long*) (((char*)base)+offset) = value;
736 }
737 PRIMITIVE_RETURN (UNSPECIFIC);
738 }
739
740 /* GUI utilities for debuggging .*/
741
742 #ifdef W32_TRAP_DEBUG
743
744 extern HANDLE ghInstance;
745 extern int TellUser (char *, ...);
746 extern int TellUserEx (int, char *, ...);
747 extern char * AskUser (char *, int);
748
749 int
TellUser(char * format,...)750 TellUser (char * format, ...)
751 {
752 va_list arg_ptr;
753 char buffer[1024];
754
755 va_start (arg_ptr, format);
756 wvsprintf (&buffer[0], format, arg_ptr);
757 va_end (arg_ptr);
758 return (MessageBox (master_tty_window,
759 ((LPCSTR) &buffer[0]),
760 ((LPCSTR) "MIT/GNU Scheme Win32 Notification"),
761 (MB_TASKMODAL | MB_ICONINFORMATION
762 | MB_SETFOREGROUND | MB_OK)));
763 }
764
765 int
TellUserEx(int flags,char * format,...)766 TellUserEx (int flags, char * format, ...)
767 {
768 va_list arg_ptr;
769 char buffer[1024];
770
771 va_start (arg_ptr, format);
772 wvsprintf (&buffer[0], format, arg_ptr);
773 va_end (arg_ptr);
774 return (MessageBox (master_tty_window,
775 ((LPCSTR) &buffer[0]),
776 ((LPCSTR) "MIT/GNU Scheme Win32 Notification"),
777 (MB_TASKMODAL | MB_ICONINFORMATION
778 | MB_SETFOREGROUND | flags)));
779 }
780
781 static char * askuserbuffer = ((char *) NULL);
782 static int askuserbufferlength = 0;
783
784 static BOOL APIENTRY
askuserdlgproc(HWND hwnddlg,UINT message,WPARAM wparam,LPARAM lparam)785 askuserdlgproc (HWND hwnddlg, UINT message,
786 WPARAM wparam, LPARAM lparam)
787 {
788 switch (message)
789 {
790 case WM_CLOSE:
791 done:
792 GetDlgItemText (hwnddlg, SCHEME_INPUT_TEXT,
793 askuserbuffer,
794 askuserbufferlength);
795 EndDialog (hwnddlg, 0);
796 return (TRUE);
797
798 case WM_COMMAND:
799 switch (wparam)
800 {
801 case IDOK:
802 goto done;
803
804 case IDCANCEL:
805 EndDialog (hwnddlg, -1);
806 return (TRUE);
807
808 default:
809 return (FALSE);
810 }
811
812 case WM_INITDIALOG:
813 return (TRUE);
814
815 default:
816 return (FALSE);
817 }
818 }
819
820 char *
AskUser(char * buf,int len)821 AskUser (char * buf, int len)
822 {
823 char * result;
824
825 askuserbuffer = buf;
826 askuserbufferlength = len;
827 result = (DialogBox (ghInstance,
828 SCHEME_INPUT,
829 master_tty_window,
830 askuserdlgproc));
831 if (result == -1)
832 return ((char *) NULL);
833
834 askuserbuffer = ((char *) NULL);
835 askuserbufferlength = 0;
836 return (buf);
837 }
838
839 #endif /* W32_TRAP_DEBUG */
840
841 /* Events */
842
843 /* Worst case consing for longs.
844 This should really be available elsewhere. */
845 #define LONG_TO_INTEGER_WORDS (4)
846 #define MAX_EVENT_STORAGE ((9 * (LONG_TO_INTEGER_WORDS + 1)) + 1)
847
848 DEFINE_PRIMITIVE ("WIN32-READ-EVENT", Prim_win32_read_event, 0, 0,
849 "()\n\
850 Returns the next event from the event queue.\n\
851 The event is deleted from the queue.\n\
852 Returns #f if there are no events in the queue.")
853 {
854 PRIMITIVE_HEADER (0);
855 /* Ensure that the primitive is not restarted due to GC: */
856 Primitive_GC_If_Needed (MAX_EVENT_STORAGE);
857 {
858 SCREEN_EVENT event;
859 SCHEME_OBJECT sevent;
860 while (1)
861 {
862 if (!Screen_read_event (&event))
863 PRIMITIVE_RETURN (SHARP_F);
864 sevent = (parse_event (&event));
865 if (sevent != SHARP_F)
866 PRIMITIVE_RETURN (sevent);
867 }
868 }
869 }
870
871 #define INIT_RESULT(n) \
872 { \
873 result = (allocate_marked_vector (TC_VECTOR, ((n) + 2), 1)); \
874 WRITE_UNSIGNED (event -> type); \
875 WRITE_UNSIGNED ((unsigned long) (event -> handle)); \
876 }
877
878 #define WRITE_RESULT(object) VECTOR_SET (result, (index++), (object))
879 #define WRITE_UNSIGNED(n) WRITE_RESULT (ulong_to_integer (n))
880 #define WRITE_SIGNED(n) WRITE_RESULT (long_to_integer (n))
881 #define WRITE_FLAG(n) WRITE_RESULT (((n) == 0) ? SHARP_F : SHARP_T)
882
883 static SCHEME_OBJECT
parse_event(SCREEN_EVENT * event)884 parse_event (SCREEN_EVENT * event)
885 {
886 unsigned int index = 0;
887 SCHEME_OBJECT result;
888 switch (event -> type)
889 {
890 case SCREEN_EVENT_TYPE_RESIZE:
891 INIT_RESULT (2);
892 WRITE_UNSIGNED (event->event.resize.rows);
893 WRITE_UNSIGNED (event->event.resize.columns);
894 break;
895 case SCREEN_EVENT_TYPE_KEY:
896 INIT_RESULT (6);
897 WRITE_UNSIGNED (event->event.key.repeat_count);
898 WRITE_SIGNED (event->event.key.virtual_keycode);
899 WRITE_UNSIGNED (event->event.key.virtual_scancode);
900 WRITE_UNSIGNED (event->event.key.control_key_state);
901 WRITE_SIGNED (event->event.key.ch);
902 WRITE_FLAG (event->event.key.key_down);
903 break;
904 case SCREEN_EVENT_TYPE_MOUSE:
905 INIT_RESULT (7);
906 WRITE_UNSIGNED (event->event.mouse.row);
907 WRITE_UNSIGNED (event->event.mouse.column);
908 WRITE_UNSIGNED (event->event.mouse.control_key_state);
909 WRITE_UNSIGNED (event->event.mouse.button_state);
910 WRITE_FLAG (event->event.mouse.up);
911 WRITE_FLAG (event->event.mouse.mouse_moved);
912 WRITE_FLAG (event->event.mouse.double_click);
913 break;
914 case SCREEN_EVENT_TYPE_CLOSE:
915 INIT_RESULT (0);
916 break;
917 case SCREEN_EVENT_TYPE_FOCUS:
918 INIT_RESULT (1);
919 WRITE_FLAG (event->event.focus.gained_p);
920 break;
921 case SCREEN_EVENT_TYPE_VISIBILITY:
922 INIT_RESULT (1);
923 WRITE_FLAG (event->event.visibility.show_p);
924 break;
925 default:
926 result = SHARP_F;
927 break;
928 }
929 return (result);
930 }
931
932 /* Primitives for Edwin Screens */
933 #define GETSCREEN(x) ((SCREEN) (GetWindowLong (x, 0)))
934
935 DEFINE_PRIMITIVE ("WIN32-SCREEN-CLEAR-RECTANGLE!", Prim_win32_screen_clear_rectangle, 6, 6,
936 "(hwnd xl xh yl yh attribute)")
937 {
938 PRIMITIVE_HEADER (6);
939 {
940 HWND hwnd = (HWND) arg_integer (1);
941 SCREEN screen = GETSCREEN ((HWND) hwnd);
942
943 Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (6));
944 clear_screen_rectangle (screen,
945 arg_integer(4), arg_integer(2),
946 arg_integer(5), arg_integer(3));
947 PRIMITIVE_RETURN (UNSPECIFIC);
948 }
949 }
950
951 DEFINE_PRIMITIVE ("WIN32-SCREEN-INVALIDATE-RECT!", Prim_win32_screen_invalidate_rect, 5, 5, 0)
952 {
953 PRIMITIVE_HEADER (5);
954 {
955 RECT rect;
956 HWND handle = (HWND) arg_integer (1);
957 SCREEN screen = GETSCREEN (handle);
958
959 Screen_CR_to_RECT (&rect, screen, arg_integer (4), arg_integer (2),
960 arg_integer (5), arg_integer (3));
961
962 InvalidateRect (handle, &rect, FALSE);
963 PRIMITIVE_RETURN(UNSPECIFIC);
964 }
965 }
966
967 DEFINE_PRIMITIVE ("WIN32-SCREEN-VERTICAL-SCROLL!", Prim_win32_screen_vertical_scroll, 6, 6,
968 "(handle xl xu yl yu amount)")
969 {
970 PRIMITIVE_HEADER (6);
971 {
972 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
973 int position = arg_integer (6);
974
975 scroll_screen_vertically (screen, arg_integer (4), arg_integer (2),
976 arg_integer (5), arg_integer (3), position);
977
978 PRIMITIVE_RETURN(UNSPECIFIC);
979 }
980 }
981
982 DEFINE_PRIMITIVE ("WIN32-SCREEN-WRITE-CHAR!", Prim_win32_screen_write_char, 5, 5,
983 "(handle x y char attribute)")
984 {
985 PRIMITIVE_HEADER (5);
986 {
987 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
988
989 if (!screen)
990 error_bad_range_arg (1);
991
992 Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (5));
993 Screen_SetPosition (screen, arg_integer (3), arg_integer (2));
994 Screen_WriteCharUninterpreted (screen, (char) arg_integer (4), 0);
995 PRIMITIVE_RETURN (UNSPECIFIC);
996 }
997 }
998
999 DEFINE_PRIMITIVE ("WIN32-SCREEN-WRITE-SUBSTRING!", Prim_win32_screen_write_substring, 7, 7,
1000 "(handle x y string start end attribute)")
1001 {
1002 PRIMITIVE_HEADER (7);
1003 {
1004 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1005 int start = arg_nonnegative_integer (5);
1006 int end = arg_nonnegative_integer (6);
1007
1008 if (!screen)
1009 error_bad_range_arg (1);
1010 CHECK_ARG (4, STRING_P);
1011 if (start > STRING_LENGTH (ARG_REF (4)))
1012 error_bad_range_arg (5);
1013 if (end > STRING_LENGTH (ARG_REF (4)))
1014 error_bad_range_arg (6);
1015 Screen_SetAttributeDirect (screen, (SCREEN_ATTRIBUTE) arg_integer (7));
1016 WriteScreenBlock_NoInvalidRect (screen,
1017 arg_integer (3), arg_integer (2),
1018 ((LPSTR) STRING_ARG (4))+start,
1019 end-start);
1020 PRIMITIVE_RETURN (UNSPECIFIC);
1021 }
1022 }
1023
1024 DEFINE_PRIMITIVE ("WIN32-SCREEN-MOVE-CURSOR!", Prim_win32_screen_move_cursor, 3, 3,
1025 "(handle x y)")
1026 {
1027 PRIMITIVE_HEADER (3);
1028 {
1029 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1030
1031 Screen_SetPosition (screen, arg_integer (3), arg_integer (2));
1032
1033 PRIMITIVE_RETURN (UNSPECIFIC);
1034 }
1035 }
1036
1037 DEFINE_PRIMITIVE ("WIN32-SCREEN-CHAR-DIMENSIONS", Prim_win32_screen_char_dimensions, 1, 1,
1038 "(handle)\n\
1039 Returns pair (width . height).")
1040 {
1041 PRIMITIVE_HEADER (1);
1042 {
1043 HWND handle = ((HWND) (arg_integer (1)));
1044 int xchar;
1045 int ychar;
1046 screen_char_dimensions (handle, (&xchar), (&ychar));
1047 PRIMITIVE_RETURN
1048 (cons ((long_to_integer (xchar)), (long_to_integer (ychar))));
1049 }
1050 }
1051
1052 DEFINE_PRIMITIVE ("WIN32-SCREEN-SIZE", Prim_win32_screen_size, 1, 1,
1053 "(handle)\n\
1054 Returns pair (width . height).")
1055 {
1056 PRIMITIVE_HEADER (1);
1057 {
1058 HWND handle = (HWND) arg_integer (1);
1059 int width=0, height=0;
1060 Screen_GetSize (handle, &height, &width);
1061 PRIMITIVE_RETURN
1062 (cons (long_to_integer (width), long_to_integer (height)));
1063 }
1064 }
1065
1066 DEFINE_PRIMITIVE ("WIN32-SET-SCREEN-SIZE", Prim_win32_set_screen_size, 3, 3,
1067 "(handle width height)")
1068 {
1069 PRIMITIVE_HEADER (3);
1070 {
1071 HWND handle = ((HWND) (arg_integer (1)));
1072 int xchar;
1073 int ychar;
1074 screen_char_dimensions (handle, (&xchar), (&ychar));
1075 PRIMITIVE_RETURN
1076 (cons ((long_to_integer (xchar)), (long_to_integer (ychar))));
1077 }
1078 }
1079
1080 DEFINE_PRIMITIVE ("WIN32-SCREEN-CREATE!", Prim_win32_screen_create, 2, 2,
1081 "(parent-handle modes)")
1082 {
1083 PRIMITIVE_HEADER (2);
1084 {
1085 HWND hwnd = Screen_Create ((HANDLE) arg_integer (1),
1086 "Scheme Screen",
1087 (int) SW_SHOWNA);
1088
1089 if (hwnd != 0)
1090 SendMessage (hwnd, SCREEN_SETMODES,
1091 (WPARAM) arg_integer (2), (LPARAM) 0);
1092
1093 PRIMITIVE_RETURN (hwnd ? long_to_integer ((long) hwnd) : SHARP_F);
1094 }
1095 }
1096
1097 DEFINE_PRIMITIVE ("WIN32-SCREEN-SHOW-CURSOR!", Prim_win32_screen_show_cursor, 2, 2,
1098 "(handle show?)")
1099 {
1100 PRIMITIVE_HEADER (2);
1101 {
1102 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1103 Enable_Cursor (screen, (ARG_REF (2) == SHARP_F) ? FALSE : TRUE);
1104 PRIMITIVE_RETURN (UNSPECIFIC);
1105 }
1106 }
1107
1108 DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-ICON!", Prim_win32_screen_set_icon, 2, 2,
1109 "(screen-handle icon-handle)")
1110 {
1111 PRIMITIVE_HEADER (2);
1112 {
1113 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1114 HICON result = ScreenSetIcon (screen, (HICON) arg_integer (2));
1115 PRIMITIVE_RETURN (ulong_to_integer((unsigned long) result));
1116 }
1117 }
1118
1119 DEFINE_PRIMITIVE ("WIN32-SCREEN-CURRENT-FOCUS", Prim_win32_screen_current_focus, 0, 0,
1120 "() -> hwnd")
1121 {
1122 PRIMITIVE_HEADER (0);
1123 {
1124 PRIMITIVE_RETURN (ulong_to_integer((unsigned long) ScreenCurrentFocus()));
1125 }
1126 }
1127
1128 DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-DEFAULT-FONT!", Prim_win32_screen_set_default_font, 1, 1,
1129 "(font-name)")
1130 {
1131 PRIMITIVE_HEADER (1);
1132 {
1133 BOOL rc = ScreenSetDefaultFont (STRING_ARG (1));
1134 PRIMITIVE_RETURN ( rc ? SHARP_T : SHARP_F);
1135 }
1136 }
1137
1138 DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-FONT!", Prim_win32_screen_set_font, 2, 2,
1139 "(screen-handle font-name)")
1140 {
1141 PRIMITIVE_HEADER (2);
1142 {
1143 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1144 if (!screen) error_bad_range_arg (1);
1145 PRIMITIVE_RETURN ( ScreenSetFont (screen, STRING_ARG (2))
1146 ? SHARP_T : SHARP_F);
1147 }
1148 }
1149
1150 DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-FOREGROUND-COLOR!", Prim_win32_screen_set_foreground_color, 2, 2,
1151 "(screen-handle rgb)")
1152 {
1153 PRIMITIVE_HEADER (2);
1154 {
1155 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1156 if (!screen) error_bad_range_arg (1);
1157 PRIMITIVE_RETURN ( ScreenSetForegroundColour (screen, arg_integer (2))
1158 ? SHARP_T : SHARP_F);
1159 }
1160 }
1161
1162 DEFINE_PRIMITIVE ("WIN32-SCREEN-SET-BACKGROUND-COLOR!", Prim_win32_screen_set_background_color, 2, 2,
1163 "(screen-handle rgb)")
1164 {
1165 PRIMITIVE_HEADER (2);
1166 {
1167 SCREEN screen = GETSCREEN ((HWND) arg_integer (1));
1168 if (!screen) error_bad_range_arg (1);
1169 PRIMITIVE_RETURN ( ScreenSetBackgroundColour (screen, arg_integer (2))
1170 ? SHARP_T : SHARP_F);
1171 }
1172 }
1173