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