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 / x11base.c < prev    next >
C/C++ Source or Header  |  2001-07-01  |  78KB  |  2,607 lines
  1. /* -*-C-*-
  2.  
  3. $Id: x11base.c,v 1.77 2001/07/02 01:55:25 cph Exp $
  4.  
  5. Copyright (c) 1989-2001 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
  20. USA.
  21. */
  22.  
  23. /* Common X11 support. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "ux.h"
  28. #include "uxselect.h"
  29. #include "osio.h"
  30. #include "x11.h"
  31. #include <X11/Xmd.h>
  32. #include <X11/keysym.h>
  33.  
  34. extern void EXFUN (block_signals, (void));
  35. extern void EXFUN (unblock_signals, (void));
  36.  
  37. #ifndef X_DEFAULT_FONT
  38. #define X_DEFAULT_FONT "fixed"
  39. #endif
  40.  
  41. int x_debug = 0;
  42. static int initialization_done = 0;
  43. static const char * x_default_font = 0;
  44.  
  45. #define INITIALIZE_ONCE()                        \
  46. {                                    \
  47.   if (!initialization_done)                        \
  48.     initialize_once ();                            \
  49. }
  50.  
  51. static void EXFUN (initialize_once, (void));
  52.  
  53. PTR
  54. DEFUN (x_malloc, (size), unsigned int size)
  55. {
  56.   PTR result = (UX_malloc (size));
  57.   if (result == 0)
  58.     error_external_return ();
  59.   return (result);
  60. }
  61.  
  62. PTR
  63. DEFUN (x_realloc, (ptr, size), PTR ptr AND unsigned int size)
  64. {
  65.   PTR result = (UX_realloc (ptr, size));
  66.   if (result == 0)
  67.     error_external_return ();
  68.   return (result);
  69. }
  70.  
  71. /* Allocation Tables */
  72.  
  73. struct allocation_table
  74. {
  75.   PTR * items;
  76.   int length;
  77. };
  78.  
  79. static struct allocation_table x_display_table;
  80. static struct allocation_table x_window_table;
  81. static struct allocation_table x_image_table;
  82. static struct allocation_table x_visual_table;
  83. static struct allocation_table x_colormap_table;
  84.  
  85. static void
  86. DEFUN (allocation_table_initialize, (table), struct allocation_table * table)
  87. {
  88.   (table -> length) = 0;
  89. }
  90.  
  91. static unsigned int
  92. DEFUN (allocate_table_index, (table, item),
  93.        struct allocation_table * table AND
  94.        PTR item)
  95. {
  96.   unsigned int length = (table -> length);
  97.   unsigned int new_length;
  98.   PTR * items = (table -> items);
  99.   PTR * new_items;
  100.   PTR * scan;
  101.   PTR * end;
  102.   if (length == 0)
  103.     {
  104.       new_length = 4;
  105.       new_items = (x_malloc ((sizeof (PTR)) * new_length));
  106.     }
  107.   else
  108.     {
  109.       scan = items;
  110.       end = (scan + length);
  111.       while (scan < end)
  112.     if ((*scan++) == 0)
  113.       {
  114.         (*--scan) = item;
  115.         return (scan - items);
  116.       }
  117.       new_length = (length * 2);
  118.       new_items = (x_realloc (items, ((sizeof (PTR)) * new_length)));
  119.     }
  120.   scan = (new_items + length);
  121.   end = (new_items + new_length);
  122.   (*scan++) = item;
  123.   while (scan < end)
  124.     (*scan++) = 0;
  125.   (table -> items) = new_items;
  126.   (table -> length) = new_length;
  127.   return (length);
  128. }
  129.  
  130. static PTR
  131. DEFUN (allocation_item_arg, (arg, table),
  132.        unsigned int arg AND
  133.        struct allocation_table * table)
  134. {
  135.   unsigned int index = (arg_index_integer (arg, (table -> length)));
  136.   PTR item = ((table -> items) [index]);
  137.   if (item == 0)
  138.     error_bad_range_arg (arg);
  139.   return (item);
  140. }
  141.  
  142. struct xdisplay *
  143. DEFUN (x_display_arg, (arg), unsigned int arg)
  144. {
  145.   INITIALIZE_ONCE ();
  146.   return (allocation_item_arg (arg, (&x_display_table)));
  147. }
  148.  
  149. struct xwindow *
  150. DEFUN (x_window_arg, (arg), unsigned int arg)
  151. {
  152.   INITIALIZE_ONCE ();
  153.   return (allocation_item_arg (arg, (&x_window_table)));
  154. }
  155.  
  156. static struct xwindow *
  157. DEFUN (x_window_to_xw, (display, window),
  158.        Display * display AND
  159.        Window window)
  160. {
  161.   struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
  162.   struct xwindow ** end = (scan + (x_window_table . length));
  163.   while (scan < end)
  164.     {
  165.       struct xwindow * xw = (*scan++);
  166.       if ((xw != 0)
  167.       && ((XW_DISPLAY (xw)) == display)
  168.       && ((XW_WINDOW (xw)) == window))
  169.     return (xw);
  170.     }
  171.   return (0);
  172. }
  173.  
  174. struct ximage *
  175. DEFUN (x_image_arg, (arg), unsigned int arg)
  176. {
  177.   INITIALIZE_ONCE ();
  178.   return (allocation_item_arg (arg, (&x_image_table)));
  179. }
  180.  
  181. unsigned int
  182. DEFUN (allocate_x_image, (image), XImage * image)
  183. {
  184.   struct ximage * xi = (x_malloc (sizeof (struct ximage)));
  185.   unsigned int index = (allocate_table_index ((&x_image_table), xi));
  186.   (XI_ALLOCATION_INDEX (xi)) = index;
  187.   (XI_IMAGE (xi)) = image;
  188.   return (index);
  189. }
  190.  
  191. void
  192. DEFUN (deallocate_x_image, (xi), struct ximage * xi)
  193. {
  194.   ((x_image_table . items) [XI_ALLOCATION_INDEX (xi)]) = 0;
  195.   free (xi);
  196. }
  197.  
  198. struct xvisual *
  199. DEFUN (x_visual_arg, (arg), unsigned int arg)
  200. {
  201.   INITIALIZE_ONCE ();
  202.   return (allocation_item_arg (arg, (&x_visual_table)));
  203. }
  204.  
  205. unsigned int
  206. DEFUN (allocate_x_visual, (visual), Visual * visual)
  207. {
  208.   struct xvisual * xv = (x_malloc (sizeof (struct xvisual)));
  209.   unsigned int index = (allocate_table_index ((&x_visual_table), xv));
  210.   (XV_ALLOCATION_INDEX (xv)) = index;
  211.   (XV_VISUAL (xv)) = visual;
  212.   return (index);
  213. }
  214.  
  215. void
  216. DEFUN (deallocate_x_visual, (xv), struct xvisual * xv)
  217. {
  218.   ((x_visual_table . items) [XV_ALLOCATION_INDEX (xv)]) = 0;
  219.   free (xv);
  220. }
  221.  
  222. struct xcolormap *
  223. DEFUN (x_colormap_arg, (arg), unsigned int arg)
  224. {
  225.   INITIALIZE_ONCE ();
  226.   return (allocation_item_arg (arg, (&x_colormap_table)));
  227. }
  228.  
  229. unsigned int
  230. DEFUN (allocate_x_colormap, (colormap, xd),
  231.        Colormap colormap AND
  232.        struct xdisplay * xd)
  233. {
  234.   struct xcolormap * xcm = (x_malloc (sizeof (struct xcolormap)));
  235.   unsigned int index = (allocate_table_index ((&x_colormap_table), xcm));
  236.   (XCM_ALLOCATION_INDEX (xcm)) = index;
  237.   (XCM_COLORMAP (xcm)) = colormap;
  238.   (XCM_XD (xcm)) = xd;
  239.   return (index);
  240. }
  241.  
  242. void
  243. DEFUN (deallocate_x_colormap, (xcm), struct xcolormap * xcm)
  244. {
  245.   ((x_colormap_table . items) [XCM_ALLOCATION_INDEX (xcm)]) = 0;
  246.   free (xcm);
  247. }
  248.  
  249. /* Error Handlers */
  250.  
  251. static int
  252. DEFUN (x_io_error_handler, (display), Display * display)
  253. {
  254.   fprintf (stderr, "\nX IO Error\n");
  255.   fflush (stderr);
  256. #if 0
  257.   error_external_return ();
  258. #else
  259.   termination_eof ();
  260. #endif
  261.   return (0);
  262. }
  263.  
  264. static int
  265. DEFUN (x_error_handler, (display, error_event),
  266.        Display * display AND
  267.        XErrorEvent * error_event)
  268. {
  269.   char buffer [2048];
  270.   XGetErrorText (display, (error_event -> error_code),
  271.          buffer, (sizeof (buffer)));
  272.   fprintf (stderr, "\nX Error: %s\n", buffer);
  273.   fprintf (stderr, "         Request code: %d\n",
  274.        (error_event -> request_code));
  275.   fprintf (stderr, "         Error serial: %lx\n", (error_event -> serial));
  276.   fflush (stderr);
  277. #if 0
  278.   error_external_return ();
  279. #else
  280.   termination_eof ();
  281. #endif
  282.   return (0);
  283. }
  284.  
  285. typedef int EXFUN ((* x_error_handler_t), (Display *, XErrorEvent *));
  286.  
  287. static void
  288. DEFUN (unbind_x_error_handler, (storage), PTR storage)
  289. {
  290.   (void) (XSetErrorHandler (* ((x_error_handler_t *) storage)));
  291. }
  292.  
  293. static void
  294. DEFUN (bind_x_error_handler, (handler), x_error_handler_t handler)
  295. {
  296.   x_error_handler_t * storage = (dstack_alloc (sizeof (x_error_handler_t)));
  297.   (*storage) = (XSetErrorHandler (handler));
  298.   dstack_protect (unbind_x_error_handler, storage);
  299. }
  300.  
  301. static jmp_buf x_prim_checkpoint;
  302.  
  303. static int
  304. DEFUN (catch_x_errors_handler, (display, event),
  305.        Display * display AND
  306.        XErrorEvent * event)
  307. {
  308.   longjmp (x_prim_checkpoint, (event -> error_code));
  309. }
  310.  
  311. #define CATCH_X_ERRORS(target)                        \
  312. {                                    \
  313.   bind_x_error_handler (catch_x_errors_handler);            \
  314.   (target) = (setjmp (x_prim_checkpoint));                \
  315. }
  316.  
  317. /* Defaults and Attributes */
  318.  
  319. static int
  320. DEFUN (x_decode_color, (display, color_map, color_name, color_return),
  321.        Display * display AND
  322.        Colormap color_map AND
  323.        char * color_name AND
  324.        unsigned long * color_return)
  325. {
  326.   XColor cdef;
  327.   if ((XParseColor (display, color_map, color_name, (&cdef)))
  328.       && (XAllocColor (display, color_map, (&cdef))))
  329.     {
  330.       (*color_return) = (cdef . pixel);
  331.       return (1);
  332.     }
  333.   return (0);
  334. }
  335.  
  336. Colormap
  337. DEFUN (xw_color_map, (xw), struct xwindow * xw)
  338. {
  339.   XWindowAttributes a;
  340.   if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
  341.     error_external_return ();
  342.   return (a . colormap);
  343. }
  344.  
  345. static unsigned long
  346. DEFUN (arg_window_color, (arg, display, xw),
  347.        unsigned int arg AND
  348.        Display * display AND
  349.        struct xwindow * xw)
  350. {
  351.   unsigned long result;
  352.   SCHEME_OBJECT object = (ARG_REF (arg));
  353.   if (INTEGER_P (object))
  354.     {
  355.       if (! (integer_to_ulong_p (object)))
  356.     error_bad_range_arg (arg);
  357.       result = (integer_to_ulong (object));
  358.     }
  359.   else if (! (x_decode_color
  360.           (display, (xw_color_map (xw)), (STRING_ARG (arg)), (&result))))
  361.     error_bad_range_arg (arg);
  362.   return (result);
  363. }
  364.  
  365. static void
  366. DEFUN (x_set_mouse_colors,
  367.        (display, color_map, mouse_cursor, mouse_pixel, background_pixel),
  368.        Display * display AND
  369.        Colormap color_map AND
  370.        Cursor mouse_cursor AND
  371.        unsigned long mouse_pixel AND
  372.        unsigned long background_pixel)
  373. {
  374.   XColor mouse_color;
  375.   XColor background_color;
  376.   (mouse_color . pixel) = mouse_pixel;
  377.   XQueryColor (display, color_map, (&mouse_color));
  378.   (background_color . pixel) = background_pixel;
  379.   XQueryColor (display, color_map, (&background_color));
  380.   XRecolorCursor (display, mouse_cursor, (&mouse_color), (&background_color));
  381. }
  382.  
  383. char *
  384. DEFUN (x_get_default,
  385.        (display, resource_name, resource_class,
  386.     property_name, property_class, sdefault),
  387.        Display * display AND
  388.        CONST char * resource_name AND
  389.        CONST char * resource_class AND
  390.        CONST char * property_name AND
  391.        CONST char * property_class AND
  392.        char * sdefault)
  393. {
  394.   char * result = (XGetDefault (display, resource_name, property_name));
  395.   if (result != 0)
  396.     return (result);
  397.   result = (XGetDefault (display, resource_class, property_name));
  398.   if (result != 0)
  399.     return (result);
  400.   result = (XGetDefault (display, resource_name, property_class));
  401.   if (result != 0)
  402.     return (result);
  403.   result = (XGetDefault (display, resource_class, property_class));
  404.   if (result != 0)
  405.     return (result);
  406.   return (sdefault);
  407. }
  408.  
  409. static unsigned long
  410. DEFUN (x_default_color,
  411.        (display, resource_name, resource_class,
  412.     property_name, property_class, default_color),
  413.        Display * display AND
  414.        CONST char * resource_name AND
  415.        CONST char * resource_class AND
  416.        CONST char * property_name AND
  417.        CONST char * property_class AND
  418.        unsigned long default_color)
  419. {
  420.   char * color_name =
  421.     (x_get_default
  422.      (display, resource_name, resource_class,
  423.       property_name, property_class, 0));
  424.   unsigned long result;
  425.   return
  426.     (((color_name != 0)
  427.       && (x_decode_color
  428.       (display,
  429.        (DefaultColormap (display, (DefaultScreen (display)))),
  430.        color_name,
  431.        (&result))))
  432.      ? result
  433.      : default_color);
  434. }
  435.  
  436. void
  437. DEFUN (x_default_attributes, 
  438.        (display, resource_name, resource_class, attributes),
  439.        Display * display AND
  440.        CONST char * resource_name AND
  441.        CONST char * resource_class AND
  442.        struct drawing_attributes * attributes)
  443. {
  444.   int screen_number = (DefaultScreen (display));
  445.   (attributes -> font) =
  446.     (XLoadQueryFont
  447.      (display,
  448.       ((x_default_font != 0)
  449.        ? x_default_font
  450.        : (x_get_default
  451.       (display, resource_name, resource_class,
  452.        "font", "Font", X_DEFAULT_FONT)))));
  453.   if ((attributes -> font) == 0)
  454.     error_external_return ();
  455.   {
  456.     char * s =
  457.       (x_get_default
  458.        (display, resource_name, resource_class,
  459.     "borderWidth", "BorderWidth", 0));
  460.     (attributes -> border_width) = ((s == 0) ? 1 : (atoi (s)));
  461.   }
  462.   {
  463.     char * s =
  464.       (x_get_default
  465.        (display, resource_name, resource_class,
  466.     "internalBorder", "BorderWidth", 0));
  467.     (attributes -> internal_border_width) =
  468.       ((s == 0) ? (attributes -> border_width) : (atoi (s)));
  469.   }
  470.   {
  471.     unsigned long white_pixel = (WhitePixel (display, screen_number));
  472.     unsigned long black_pixel = (BlackPixel (display, screen_number));
  473.     unsigned long foreground_pixel;
  474.     (attributes -> background_pixel) =
  475.       (x_default_color
  476.        (display, resource_name, resource_class,
  477.     "background", "Background", white_pixel));
  478.     foreground_pixel =
  479.       (x_default_color
  480.        (display, resource_name, resource_class,
  481.     "foreground", "Foreground", black_pixel));
  482.     (attributes -> foreground_pixel) = foreground_pixel;
  483.     (attributes -> border_pixel) =
  484.       (x_default_color
  485.        (display, resource_name, resource_class,
  486.     "borderColor", "BorderColor", foreground_pixel));
  487.     (attributes -> cursor_pixel) =
  488.       (x_default_color
  489.        (display, resource_name, resource_class,
  490.     "cursorColor", "Foreground", foreground_pixel));
  491.     (attributes -> mouse_pixel) =
  492.       (x_default_color
  493.        (display, resource_name, resource_class,
  494.     "pointerColor", "Foreground", foreground_pixel));
  495.   }
  496. }
  497.  
  498. /* Open/Close Windows and Displays */
  499.  
  500. #define MAKE_GC(gc, fore, back)                        \
  501. {                                    \
  502.   XGCValues gcv;                            \
  503.   (gcv . font) = fid;                            \
  504.   (gcv . foreground) = (fore);                        \
  505.   (gcv . background) = (back);                        \
  506.   (gc) =                                \
  507.     (XCreateGC (display,                        \
  508.         window,                            \
  509.         (GCFont | GCForeground | GCBackground),            \
  510.         (& gcv)));                        \
  511. }
  512.  
  513. struct xwindow *
  514. DEFUN (x_make_window, (xd, window, x_size, y_size, attributes, methods, extra),
  515.        struct xdisplay * xd AND
  516.        Window window AND
  517.        int x_size AND
  518.        int y_size AND
  519.        struct drawing_attributes * attributes AND
  520.        struct xwindow_methods * methods AND
  521.        unsigned int extra)
  522. {
  523.   GC normal_gc;
  524.   GC reverse_gc;
  525.   GC cursor_gc;
  526.   struct xwindow * xw;
  527.   Display * display = (XD_DISPLAY (xd));
  528.   Font fid = ((attributes -> font) -> fid);
  529.   unsigned long foreground_pixel = (attributes -> foreground_pixel);
  530.   unsigned long background_pixel = (attributes -> background_pixel);
  531.   Cursor mouse_cursor = (XCreateFontCursor (display, XC_left_ptr));
  532.   MAKE_GC (normal_gc, foreground_pixel, background_pixel);
  533.   MAKE_GC (reverse_gc, background_pixel, foreground_pixel);
  534.   MAKE_GC (cursor_gc, background_pixel, (attributes -> cursor_pixel));
  535.   x_set_mouse_colors
  536.     (display,
  537.      (DefaultColormap (display, (DefaultScreen (display)))),
  538.      mouse_cursor,
  539.      (attributes -> mouse_pixel),
  540.      background_pixel);
  541.   XDefineCursor (display, window, mouse_cursor);
  542.   XSelectInput (display, window, 0);
  543.   xw =
  544.     (x_malloc (((sizeof (struct xwindow)) - (sizeof (xw -> extra))) + extra));
  545.   (XW_ALLOCATION_INDEX (xw)) = (allocate_table_index ((&x_window_table), xw));
  546.   (XW_XD (xw)) = xd;
  547.   (XW_WINDOW (xw)) = window;
  548.   (XW_X_SIZE (xw)) = x_size;
  549.   (XW_Y_SIZE (xw)) = y_size;
  550.   (XW_CLIP_X (xw)) = 0;
  551.   (XW_CLIP_Y (xw)) = 0;
  552.   (XW_CLIP_WIDTH (xw)) = x_size;
  553.   (XW_CLIP_HEIGHT (xw)) = y_size;
  554.   (xw -> attributes) = (*attributes);
  555.   (xw -> methods) = (*methods);
  556.   (XW_NORMAL_GC (xw)) = normal_gc;
  557.   (XW_REVERSE_GC (xw)) = reverse_gc;
  558.   (XW_CURSOR_GC (xw)) = cursor_gc;
  559.   (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
  560.   (XW_EVENT_MASK (xw)) = 0;
  561.   return (xw);
  562. }
  563.  
  564. static jmp_buf x_close_window_jmp_buf;
  565.  
  566. static int
  567. DEFUN (x_close_window_io_error, (display), Display * display)
  568. {
  569.   longjmp (x_close_window_jmp_buf, 1);
  570. }
  571.  
  572. static void
  573. DEFUN (x_close_window, (xw), struct xwindow * xw)
  574. {
  575.   Display * display = (XW_DISPLAY (xw));
  576.   ((x_window_table . items) [XW_ALLOCATION_INDEX (xw)]) = 0;
  577.   if ((setjmp (x_close_window_jmp_buf)) == 0)
  578.     {
  579.       XSetIOErrorHandler (x_close_window_io_error);
  580.       {
  581.     x_deallocator_t deallocator = (XW_DEALLOCATOR (xw));
  582.     if (deallocator != 0)
  583.       (*deallocator) (xw);
  584.       }
  585.       {
  586.     XFontStruct * font = (XW_FONT (xw));
  587.     if (font != 0)
  588.       XFreeFont (display, font);
  589.       }
  590.       XDestroyWindow (display, (XW_WINDOW (xw)));
  591.       /* Guarantee that the IO error occurs while the IO error handler
  592.      is rebound, if at all. */
  593.       XFlush (display);
  594.     }
  595.   XSetIOErrorHandler (x_io_error_handler);
  596.   free (xw);
  597. }
  598.  
  599. static void
  600. DEFUN (x_close_display, (xd), struct xdisplay * xd)
  601. {
  602.   struct xwindow ** scan = ((struct xwindow **) (x_window_table . items));
  603.   struct xwindow ** end = (scan + (x_window_table . length));
  604.   while (scan < end)
  605.     {
  606.       struct xwindow * xw = (*scan++);
  607.       if ((xw != 0) && ((XW_XD (xw)) == xd))
  608.     x_close_window (xw);
  609.     }
  610.   ((x_display_table . items) [XD_ALLOCATION_INDEX (xd)]) = 0;
  611.   XCloseDisplay (XD_DISPLAY (xd));
  612. }
  613.  
  614. static void
  615. DEFUN_VOID (x_close_all_displays)
  616. {
  617.   struct xdisplay ** scan = ((struct xdisplay **) (x_display_table . items));
  618.   struct xdisplay ** end = (scan + (x_display_table . length));
  619.   while (scan < end)
  620.     {
  621.       struct xdisplay * xd = (*scan++);
  622.       if (xd != 0)
  623.     x_close_display (xd);
  624.     }
  625. }
  626.  
  627. /* Window Manager Properties */
  628.  
  629. static void
  630. DEFUN (xw_set_class_hint, (xw, name, class),
  631.        struct xwindow * xw AND
  632.        CONST char * name AND
  633.        CONST char * class)
  634. {
  635.   XClassHint * class_hint = (XAllocClassHint ());
  636.   if (class_hint == 0)
  637.     error_external_return ();
  638.   /* This structure is misdeclared, so cast the args. */
  639.   (class_hint -> res_name) = ((char *) name);
  640.   (class_hint -> res_class) = ((char *) class);
  641.   XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint);
  642.   XFree ((PTR) class_hint);
  643. }
  644.  
  645. void
  646. DEFUN (xw_set_wm_input_hint, (xw, input_hint),
  647.        struct xwindow * xw AND
  648.        int input_hint)
  649. {
  650.   XWMHints * hints = (XAllocWMHints ());
  651.   if (hints == 0)
  652.     error_external_return ();
  653.   (hints -> flags) = InputHint;
  654.   (hints -> input) = (input_hint != 0);
  655.   XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints);
  656.   XFree ((PTR) hints);
  657. }
  658.  
  659. void
  660. DEFUN (xw_set_wm_name, (xw, name), struct xwindow * xw AND CONST char * name)
  661. {
  662.   XTextProperty property;
  663.   if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
  664.     error_external_return ();
  665.   XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
  666. }
  667.  
  668. void
  669. DEFUN (xw_set_wm_icon_name, (xw, name),
  670.        struct xwindow * xw AND
  671.        CONST char * name)
  672. {
  673.   XTextProperty property;
  674.   if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
  675.     error_external_return ();
  676.   XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
  677. }
  678.  
  679. void
  680. DEFUN (x_decode_window_map_arg,
  681.        (map_arg, resource_name, resource_class, map_p),
  682.        SCHEME_OBJECT map_arg AND
  683.        CONST char ** resource_name AND
  684.        CONST char ** resource_class AND
  685.        int * map_p)
  686. {
  687.   (*map_p) = 0;
  688.   if (map_arg == SHARP_F)
  689.     (*map_p) = 1;
  690.   else if ((PAIR_P (map_arg))
  691.        && (STRING_P (PAIR_CAR (map_arg)))
  692.        && (STRING_P (PAIR_CDR (map_arg))))
  693.     {
  694.       (*resource_name) =
  695.     ((CONST char *) (STRING_LOC ((PAIR_CAR (map_arg)), 0)));
  696.       (*resource_class) =
  697.     ((CONST char *) (STRING_LOC ((PAIR_CDR (map_arg)), 0)));
  698.       (*map_p) = 1;
  699.     }
  700.   else if ((VECTOR_P (map_arg))
  701.        && ((VECTOR_LENGTH (map_arg)) == 3)
  702.        && (BOOLEAN_P (VECTOR_REF (map_arg, 0)))
  703.        && (STRING_P (VECTOR_REF (map_arg, 1)))
  704.        && (STRING_P (VECTOR_REF (map_arg, 2))))
  705.     {
  706.       (*resource_name) =
  707.     ((CONST char *) (STRING_LOC ((VECTOR_REF (map_arg, 1)), 0)));
  708.       (*resource_class) =
  709.     ((CONST char *) (STRING_LOC ((VECTOR_REF (map_arg, 2)), 0)));
  710.       (*map_p) = (OBJECT_TO_BOOLEAN (VECTOR_REF (map_arg, 0)));
  711.     }
  712. }
  713.  
  714. void
  715. DEFUN (xw_make_window_map, (xw, resource_name, resource_class, map_p),
  716.        struct xwindow * xw AND
  717.        CONST char * resource_name AND
  718.        CONST char * resource_class AND
  719.        int map_p)
  720. {
  721.   xw_set_class_hint (xw, resource_name, resource_class);
  722.   if (map_p)
  723.     {
  724.       XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  725.       XFlush (XW_DISPLAY (xw));
  726.     }
  727. }
  728.  
  729. /* Event Processing */
  730.  
  731. static void
  732. DEFUN (xw_process_event, (xw, event),
  733.        struct xwindow * xw AND
  734.        XEvent * event)
  735. {
  736.   if (x_debug > 0)
  737.     {
  738.       char * type_name;
  739.       fprintf (stderr, "\nX event: ");
  740.       switch (event -> type)
  741.     {
  742.     case ButtonPress:    type_name = "ButtonPress"; break;
  743.     case ButtonRelease:    type_name = "ButtonRelease"; break;
  744.     case CirculateNotify:    type_name = "CirculateNotify"; break;
  745.     case CreateNotify:    type_name = "CreateNotify"; break;
  746.     case DestroyNotify:    type_name = "DestroyNotify"; break;
  747.     case EnterNotify:    type_name = "EnterNotify"; break;
  748.     case Expose:        type_name = "Expose"; break;
  749.     case FocusIn:        type_name = "FocusIn"; break;
  750.     case FocusOut:        type_name = "FocusOut"; break;
  751.     case GraphicsExpose:    type_name = "GraphicsExpose"; break;
  752.     case GravityNotify:    type_name = "GravityNotify"; break;
  753.     case KeyPress:        type_name = "KeyPress"; break;
  754.     case KeyRelease:    type_name = "KeyRelease"; break;
  755.     case LeaveNotify:    type_name = "LeaveNotify"; break;
  756.     case MapNotify:        type_name = "MapNotify"; break;
  757.     case MappingNotify:    type_name = "MappingNotify"; break;
  758.     case MotionNotify:    type_name = "MotionNotify"; break;
  759.     case NoExpose:        type_name = "NoExpose"; break;
  760.     case ReparentNotify:    type_name = "ReparentNotify"; break;
  761.     case SelectionClear:    type_name = "SelectionClear"; break;
  762.     case SelectionRequest:    type_name = "SelectionRequest"; break;
  763.     case UnmapNotify:    type_name = "UnmapNotify"; break;
  764.     case VisibilityNotify:    type_name = "VisibilityNotify"; break;
  765.     case ConfigureNotify:
  766.       {
  767.         fprintf (stderr, "ConfigureNotify; width = %d, height = %d",
  768.              ((event -> xconfigure) . width),
  769.              ((event -> xconfigure) . height));
  770.         goto debug_done;
  771.       }
  772.     case ClientMessage:
  773.       {
  774.         struct xdisplay * xd = (XW_XD (xw));
  775.         if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
  776.         && (((event -> xclient) . format) == 32))
  777.           {
  778.         if (((Atom) (((event -> xclient) . data . l) [0]))
  779.             == (XD_WM_DELETE_WINDOW (xd)))
  780.           type_name = "WM_DELETE_WINDOW";
  781.         else if (((Atom) (((event -> xclient) . data . l) [0]))
  782.              == (XD_WM_TAKE_FOCUS (xd)))
  783.           type_name = "WM_TAKE_FOCUS";
  784.         else
  785.           type_name = "WM_PROTOCOLS";
  786.           }
  787.         else
  788.           {
  789.         fprintf (stderr,
  790.              "ClientMessage; message_type = 0x%x, format = %d",
  791.              ((unsigned int) ((event -> xclient) . message_type)),
  792.              ((event -> xclient) . format));
  793.         goto debug_done;
  794.           }
  795.       }
  796.       break;
  797.     case PropertyNotify:
  798.       {
  799.         fprintf
  800.           (stderr,
  801.            "PropertyNotify; window=%ld, atom=%ld, time=%ld, state=%d",
  802.            ((event -> xproperty) . window),
  803.            ((event -> xproperty) . atom),
  804.            ((event -> xproperty) . time),
  805.            ((event -> xproperty) . state));
  806.         goto debug_done;
  807.       }
  808.     case SelectionNotify:
  809.       {
  810.         fprintf
  811.           (stderr,
  812.            "SelectionNotify; req=%ld, sel=%ld, targ=%ld, prop=%ld, t=%ld",
  813.            ((event -> xselection) . requestor),
  814.            ((event -> xselection) . selection),
  815.            ((event -> xselection) . target),
  816.            ((event -> xselection) . property),
  817.            ((event -> xselection) . time));
  818.         goto debug_done;
  819.       }
  820.     default:        type_name = 0; break;
  821.     }
  822.       if (type_name != 0)
  823.     fprintf (stderr, "%s", type_name);
  824.       else
  825.     fprintf (stderr, "%d", (event -> type));
  826.     debug_done:
  827.       fprintf (stderr, "\n");
  828.       fflush (stderr);
  829.     }
  830.   switch (event -> type)
  831.     {
  832.     case MappingNotify:
  833.       switch ((event -> xmapping) . request)
  834.     {
  835.     case MappingKeyboard:
  836.     case MappingModifier:
  837.       XRefreshKeyboardMapping (& (event -> xmapping));
  838.       break;
  839.     }
  840.       break;
  841.     }
  842.   if (xw != 0)
  843.     (* (XW_EVENT_PROCESSOR (xw))) (xw, event);
  844. }
  845.  
  846. enum event_type
  847. {
  848.   event_type_button_down,
  849.   event_type_button_up,
  850.   event_type_configure,
  851.   event_type_enter,
  852.   event_type_focus_in,
  853.   event_type_focus_out,
  854.   event_type_key_press,
  855.   event_type_leave,
  856.   event_type_motion,
  857.   event_type_expose,
  858.   event_type_delete_window,
  859.   event_type_map,
  860.   event_type_unmap,
  861.   event_type_take_focus,
  862.   event_type_visibility,
  863.   event_type_selection_clear,
  864.   event_type_selection_notify,
  865.   event_type_selection_request,
  866.   event_type_property_notify,
  867.   event_type_supremum
  868. };
  869.  
  870. #define EVENT_MASK_ARG(arg)                        \
  871.   (arg_ulong_index_integer                        \
  872.    ((arg), (1 << ((unsigned int) event_type_supremum))))
  873.  
  874. #define EVENT_ENABLED(xw, type)                        \
  875.   (((xw) == 0)                                \
  876.    || (((XW_EVENT_MASK (xw)) & (1 << ((unsigned int) (type)))) != 0))
  877.  
  878. #define EVENT_0 2
  879. #define EVENT_1 3
  880. #define EVENT_2 4
  881. #define EVENT_3 5
  882. #define EVENT_4 6
  883.  
  884. #define EVENT_INTEGER(event, slot, number)                \
  885.   VECTOR_SET ((event), (slot), (long_to_integer (number)))
  886.  
  887. #define EVENT_ULONG_INTEGER(event, slot, number)            \
  888.   VECTOR_SET ((event), (slot), (ulong_to_integer (number)))
  889.  
  890. static SCHEME_OBJECT
  891. DEFUN (make_event_object, (xw, type, extra),
  892.        struct xwindow * xw AND
  893.        enum event_type type AND
  894.        unsigned int extra)
  895. {
  896.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (2 + extra), 1));
  897.   VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM ((long) type)));
  898.   VECTOR_SET (result, 1, ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw))));
  899.   return (result);
  900. }
  901.  
  902. static SCHEME_OBJECT
  903. DEFUN (button_event, (xw, event, type),
  904.        struct xwindow * xw AND
  905.        XButtonEvent * event AND
  906.        enum event_type type)
  907. {
  908.   SCHEME_OBJECT result = (make_event_object (xw, type, 4));
  909.   EVENT_INTEGER (result, EVENT_0, (event -> x));
  910.   EVENT_INTEGER (result, EVENT_1, (event -> y));
  911.   {
  912.     SCHEME_OBJECT conversion;
  913.     int button_number;
  914.     switch (event -> button)
  915.       {
  916.       case Button1: button_number = 1; break;
  917.       case Button2: button_number = 2; break;
  918.       case Button3: button_number = 3; break;
  919.       case Button4: button_number = 4; break;
  920.       case Button5: button_number = 5; break;
  921.       default: button_number = 0; break;
  922.       }
  923.     if (button_number) {
  924.       --button_number;
  925.       if ((event -> state) & ShiftMask) {
  926.     button_number += 5;
  927.       }
  928.       if ((event -> state) & ControlMask) {
  929.     button_number += 10;
  930.       }
  931.       if ((event -> state) & Mod1Mask) {
  932.     button_number += 20;
  933.       }
  934.       conversion = (LONG_TO_UNSIGNED_FIXNUM (button_number));
  935.     } else {
  936.       conversion = (SHARP_F);
  937.     }
  938.     VECTOR_SET (result, EVENT_2, conversion);
  939.   }
  940.   EVENT_ULONG_INTEGER (result, EVENT_3, (event -> time));
  941.   return (result);
  942. }
  943.  
  944. static SCHEME_OBJECT
  945. DEFUN (convert_bucky_bits, (state, allp), unsigned int state AND int allp)
  946. {
  947.   long bucky = 0;
  948.   if (state & Mod1Mask)    bucky |= 0x0001; /* meta */
  949.   if (state & ControlMask) bucky |= 0x0002; /* control */
  950.   if (state & Mod2Mask)    bucky |= 0x0004; /* super */
  951.   if (state & Mod3Mask)    bucky |= 0x0008; /* hyper */
  952.   if (state & Mod4Mask)    bucky |= 0x0010; /* top */
  953.   if (allp)
  954.     {
  955.       if (state & ShiftMask)   bucky |= 0x0020;
  956.       if (state & LockMask)    bucky |= 0x0040;
  957.       if (state & Mod2Mask)    bucky |= 0x0080;
  958.       if (state & Mod5Mask)    bucky |= 0x0100;
  959.       if (state & Button1Mask) bucky |= 0x0200;
  960.       if (state & Button2Mask) bucky |= 0x0400;
  961.       if (state & Button3Mask) bucky |= 0x0800;
  962.       if (state & Button4Mask) bucky |= 0x1000;
  963.       if (state & Button5Mask) bucky |= 0x2000;
  964.     }
  965.   return (LONG_TO_UNSIGNED_FIXNUM (bucky));
  966. }
  967.  
  968. static XComposeStatus compose_status;
  969.  
  970. static SCHEME_OBJECT
  971. DEFUN (key_event, (xw, event, type),
  972.        struct xwindow * xw AND
  973.        XKeyEvent * event AND
  974.        enum event_type type)
  975. {
  976.   char copy_buffer [80];
  977.   KeySym keysym;
  978.   int nbytes;
  979.  
  980.   /* Make ShiftLock modifier not affect keys with other modifiers. */
  981.   if ((event -> state) &
  982.       (ShiftMask || ControlMask
  983.        || Mod1Mask || Mod2Mask || Mod3Mask || Mod4Mask || Mod5Mask))
  984.     {
  985.       if (((event->state) & LockMask) != 0)
  986.     (event->state) -= LockMask;
  987.     }
  988.   nbytes =
  989.     (XLookupString (event,
  990.             copy_buffer,
  991.             (sizeof (copy_buffer)),
  992.             (&keysym),
  993.             (&compose_status)));
  994.   /* If the BackSpace keysym is received, and XLookupString has
  995.      translated it into ASCII backspace, substitute ASCII rubout
  996.      instead.  */
  997.   if ((keysym == XK_BackSpace)
  998.       && (nbytes == 1)
  999.       && ((copy_buffer[0]) == '\b'))
  1000.     (copy_buffer[0]) = '\177';
  1001.   if (IsModifierKey (keysym))
  1002.     return (SHARP_F);
  1003.   else
  1004.     {
  1005.       SCHEME_OBJECT result = (make_event_object (xw, type, 4));
  1006.       VECTOR_SET (result, EVENT_0,
  1007.           (memory_to_string (nbytes,
  1008.                      ((unsigned char *) copy_buffer))));
  1009.       /* Create Scheme bucky bits (kept independent of the character).
  1010.      X has already controlified, so Scheme may choose to ignore
  1011.      the control bucky bit.  */
  1012.       VECTOR_SET (result, EVENT_1, (convert_bucky_bits ((event -> state), 0)));
  1013.       /* Move vendor-specific bit from bit 28 (zero-based) to bit 23
  1014.      so that all keysym values will fit in Scheme fixnums.  */
  1015.       VECTOR_SET
  1016.     (result,
  1017.      EVENT_2,
  1018.      (LONG_TO_UNSIGNED_FIXNUM ((keysym & 0xffffff)
  1019.                    | (0x800000 & (keysym >> 5)))));
  1020.       EVENT_ULONG_INTEGER (result, EVENT_3, (event -> time));
  1021.       return (result);
  1022.     }
  1023. }
  1024.  
  1025. #define CONVERT_TRIVIAL_EVENT(scheme_name)                \
  1026.   if (EVENT_ENABLED (xw, scheme_name))                    \
  1027.     result = (make_event_object (xw, scheme_name, 0));            \
  1028.   break
  1029.  
  1030. static SCHEME_OBJECT
  1031. DEFUN (x_event_to_object, (event), XEvent * event)
  1032. {
  1033.   struct xwindow * xw
  1034.     = (x_window_to_xw (((event -> xany) . display),
  1035.                ((event -> xany) . window)));
  1036.   SCHEME_OBJECT result = SHARP_F;
  1037.   switch (event -> type)
  1038.     {
  1039.     case KeyPress:
  1040.       if (EVENT_ENABLED (xw, event_type_key_press))
  1041.     result = (key_event (xw, (& (event -> xkey)), event_type_key_press));
  1042.       break;
  1043.     case ButtonPress:
  1044.       if (EVENT_ENABLED (xw, event_type_button_down))
  1045.     result =
  1046.       (button_event (xw, (& (event -> xbutton)), event_type_button_down));
  1047.       break;
  1048.     case ButtonRelease:
  1049.       if (EVENT_ENABLED (xw, event_type_button_up))
  1050.     result =
  1051.       (button_event (xw, (& (event -> xbutton)), event_type_button_up));
  1052.       break;
  1053.     case MotionNotify:
  1054.       if (EVENT_ENABLED (xw, event_type_motion))
  1055.     {
  1056.       result = (make_event_object (xw, event_type_motion, 3));
  1057.       EVENT_INTEGER (result, EVENT_0, ((event -> xmotion) . x));
  1058.       EVENT_INTEGER (result, EVENT_1, ((event -> xmotion) . y));
  1059.       VECTOR_SET (result, EVENT_2,
  1060.               (convert_bucky_bits (((event -> xmotion) . state), 1)));
  1061.     }
  1062.       break;
  1063.     case ConfigureNotify:
  1064.       if (EVENT_ENABLED (xw, event_type_configure))
  1065.     {
  1066.       result = (make_event_object (xw, event_type_configure, 2));
  1067.       EVENT_ULONG_INTEGER
  1068.         (result, EVENT_0, ((event -> xconfigure) . width));
  1069.       EVENT_ULONG_INTEGER
  1070.         (result, EVENT_1, ((event -> xconfigure) . height));
  1071.     }
  1072.       break;
  1073.     case Expose:
  1074.       if (EVENT_ENABLED (xw, event_type_expose))
  1075.     {
  1076.       result = (make_event_object (xw, event_type_expose, 5));
  1077.       EVENT_INTEGER (result, EVENT_0, ((event -> xexpose) . x));
  1078.       EVENT_INTEGER (result, EVENT_1, ((event -> xexpose) . y));
  1079.       EVENT_ULONG_INTEGER (result, EVENT_2, ((event -> xexpose) . width));
  1080.       EVENT_ULONG_INTEGER (result, EVENT_3, ((event -> xexpose) . height));
  1081.       VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (0)));
  1082.     }
  1083.       break;
  1084.     case GraphicsExpose:
  1085.       if (EVENT_ENABLED (xw, event_type_expose))
  1086.     {
  1087.       result = (make_event_object (xw, event_type_expose, 5));
  1088.       EVENT_INTEGER (result, EVENT_0, ((event -> xgraphicsexpose) . x));
  1089.       EVENT_INTEGER (result, EVENT_1, ((event -> xgraphicsexpose) . y));
  1090.       EVENT_ULONG_INTEGER
  1091.         (result, EVENT_2, ((event -> xgraphicsexpose) . width));
  1092.       EVENT_ULONG_INTEGER
  1093.         (result, EVENT_3, ((event -> xgraphicsexpose) . height));
  1094.       VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (1)));
  1095.     }
  1096.       break;
  1097.     case ClientMessage:
  1098.       {
  1099.     struct xdisplay * xd = (XW_XD (xw));
  1100.     if ((((event -> xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
  1101.         && (((event -> xclient) . format) == 32))
  1102.       {
  1103.         if (((Atom) (((event -> xclient) . data . l) [0]))
  1104.         == (XD_WM_DELETE_WINDOW (xd)))
  1105.           {
  1106.         if (EVENT_ENABLED (xw, event_type_delete_window))
  1107.           result =
  1108.             (make_event_object (xw, event_type_delete_window, 0));
  1109.           }
  1110.         else if (((Atom) (((event -> xclient) . data . l) [0]))
  1111.              == (XD_WM_TAKE_FOCUS (xd)))
  1112.           {
  1113.         if (EVENT_ENABLED (xw, event_type_take_focus))
  1114.           {
  1115.             result =
  1116.               (make_event_object (xw, event_type_take_focus, 1));
  1117.             EVENT_INTEGER
  1118.               (result, EVENT_0, (((event -> xclient) . data . l) [1]));
  1119.           }
  1120.           }
  1121.       }
  1122.       }
  1123.       break;
  1124.     case VisibilityNotify:
  1125.       if (EVENT_ENABLED (xw, event_type_visibility))
  1126.     {
  1127.       unsigned int state;
  1128.       switch ((event -> xvisibility) . state)
  1129.         {
  1130.         case VisibilityUnobscured:
  1131.           state = 0;
  1132.           break;
  1133.         case VisibilityPartiallyObscured:
  1134.           state = 1;
  1135.           break;
  1136.         case VisibilityFullyObscured:
  1137.           state = 2;
  1138.           break;
  1139.         default:
  1140.           state = 3;
  1141.           break;
  1142.         }
  1143.       result = (make_event_object (xw, event_type_visibility, 1));
  1144.       EVENT_ULONG_INTEGER (result, EVENT_0, state);
  1145.     }
  1146.       break;
  1147.     case SelectionClear:
  1148.       if (EVENT_ENABLED (xw, event_type_selection_clear))
  1149.     {
  1150.       result = (make_event_object (xw, event_type_selection_clear, 2));
  1151.       EVENT_ULONG_INTEGER
  1152.         (result, EVENT_0, ((event -> xselectionclear) . selection));
  1153.       EVENT_ULONG_INTEGER
  1154.         (result, EVENT_1, ((event -> xselectionclear) . time));
  1155.     }
  1156.       break;
  1157.     case SelectionNotify:
  1158.       if (EVENT_ENABLED (xw, event_type_selection_notify))
  1159.     {
  1160.       result = (make_event_object (xw, event_type_selection_notify, 5));
  1161.       EVENT_ULONG_INTEGER
  1162.         (result, EVENT_0, ((event -> xselection) . requestor));
  1163.       EVENT_ULONG_INTEGER
  1164.         (result, EVENT_1, ((event -> xselection) . selection));
  1165.       EVENT_ULONG_INTEGER
  1166.         (result, EVENT_2, ((event -> xselection) . target));
  1167.       EVENT_ULONG_INTEGER
  1168.         (result, EVENT_3, ((event -> xselection) . property));
  1169.       EVENT_ULONG_INTEGER
  1170.         (result, EVENT_4, ((event -> xselection) . time));
  1171.     }
  1172.       break;
  1173.     case SelectionRequest:
  1174.       if (EVENT_ENABLED (xw, event_type_selection_request))
  1175.     {
  1176.       result = (make_event_object (xw, event_type_selection_request, 5));
  1177.       EVENT_ULONG_INTEGER
  1178.         (result, EVENT_0, ((event -> xselectionrequest) . requestor));
  1179.       EVENT_ULONG_INTEGER
  1180.         (result, EVENT_1, ((event -> xselectionrequest) . selection));
  1181.       EVENT_ULONG_INTEGER
  1182.         (result, EVENT_2, ((event -> xselectionrequest) . target));
  1183.       EVENT_ULONG_INTEGER
  1184.         (result, EVENT_3, ((event -> xselectionrequest) . property));
  1185.       EVENT_ULONG_INTEGER
  1186.         (result, EVENT_4, ((event -> xselectionrequest) . time));
  1187.     }
  1188.       break;
  1189.     case PropertyNotify:
  1190.       if (EVENT_ENABLED (xw, event_type_property_notify))
  1191.     {
  1192.       result = (make_event_object (xw, event_type_property_notify, 4));
  1193.       /* Must store window element separately because this window
  1194.          might not have a corresponding XW object.  */
  1195.       EVENT_ULONG_INTEGER
  1196.         (result, EVENT_0, ((event -> xproperty) . window));
  1197.       EVENT_ULONG_INTEGER
  1198.         (result, EVENT_1, ((event -> xproperty) . atom));
  1199.       EVENT_ULONG_INTEGER
  1200.         (result, EVENT_2, ((event -> xproperty) . time));
  1201.       EVENT_ULONG_INTEGER
  1202.         (result, EVENT_3, ((event -> xproperty) . state));
  1203.     }
  1204.       break;
  1205.     case EnterNotify: CONVERT_TRIVIAL_EVENT (event_type_enter);
  1206.     case LeaveNotify: CONVERT_TRIVIAL_EVENT (event_type_leave);
  1207.     case FocusIn: CONVERT_TRIVIAL_EVENT (event_type_focus_in);
  1208.     case FocusOut: CONVERT_TRIVIAL_EVENT (event_type_focus_out);
  1209.     case MapNotify: CONVERT_TRIVIAL_EVENT (event_type_map);
  1210.     case UnmapNotify: CONVERT_TRIVIAL_EVENT (event_type_unmap);
  1211.     }
  1212.   return (result);
  1213. }
  1214.  
  1215. static void
  1216. DEFUN (update_input_mask, (xw), struct xwindow * xw)
  1217. {
  1218.   {
  1219.     unsigned long event_mask = 0;
  1220.     if (EVENT_ENABLED (xw, event_type_expose))
  1221.       event_mask |= ExposureMask;
  1222.     if ((EVENT_ENABLED (xw, event_type_configure))
  1223.     || (EVENT_ENABLED (xw, event_type_map))
  1224.     || (EVENT_ENABLED (xw, event_type_unmap)))
  1225.       event_mask |= StructureNotifyMask;
  1226.     if (EVENT_ENABLED (xw, event_type_button_down))
  1227.       event_mask |= ButtonPressMask;
  1228.     if (EVENT_ENABLED (xw, event_type_button_up))
  1229.       event_mask |= ButtonReleaseMask;
  1230.     if (EVENT_ENABLED (xw, event_type_key_press))
  1231.       event_mask |= KeyPressMask;
  1232.     if (EVENT_ENABLED (xw, event_type_enter))
  1233.       event_mask |= EnterWindowMask;
  1234.     if (EVENT_ENABLED (xw, event_type_leave))
  1235.       event_mask |= LeaveWindowMask;
  1236.     if ((EVENT_ENABLED (xw, event_type_focus_in))
  1237.     || (EVENT_ENABLED (xw, event_type_focus_out)))
  1238.       event_mask |= FocusChangeMask;
  1239.     if (EVENT_ENABLED (xw, event_type_motion))
  1240.       event_mask |= (PointerMotionMask | PointerMotionHintMask);
  1241.     if (EVENT_ENABLED (xw, event_type_visibility))
  1242.       event_mask |= VisibilityChangeMask;
  1243.     if (EVENT_ENABLED (xw, event_type_property_notify))
  1244.       event_mask |= PropertyChangeMask;
  1245.     XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask);
  1246.   }
  1247.   {
  1248.     struct xdisplay * xd = (XW_XD (xw));
  1249.     Atom protocols [2];
  1250.     unsigned int n_protocols = 0;
  1251.     if (EVENT_ENABLED (xw, event_type_delete_window))
  1252.       (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd));
  1253.     if (EVENT_ENABLED (xw, event_type_take_focus))
  1254.       (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd));
  1255.     if (n_protocols > 0)
  1256.       XSetWMProtocols
  1257.     ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols);
  1258.   }
  1259. }
  1260.  
  1261. static void
  1262. DEFUN (ping_server, (xd, arg), struct xdisplay * xd)
  1263. {
  1264.   /* Periodically ping the server connection to see if it has died.  */
  1265.   (XD_SERVER_PING_TIMER (xd)) += 1;
  1266.   if ((XD_SERVER_PING_TIMER (xd)) >= 100)
  1267.     {
  1268.       (XD_SERVER_PING_TIMER (xd)) = 0;
  1269.       XNoOp (XD_DISPLAY (xd));
  1270.       XFlush (XD_DISPLAY (xd));
  1271.     }
  1272. }
  1273.  
  1274. /* The use of `XD_CACHED_EVENT' prevents an event from being lost due
  1275.    to garbage collection.  First `XD_CACHED_EVENT' is set to hold the
  1276.    current event, then the allocations are performed.  If one of them
  1277.    fails, the primitive will exit, and when it reenters it will notice
  1278.    the cached event and use it.  It is important that this be the only
  1279.    entry that reads events -- or else that all other event readers
  1280.    cooperate with this strategy.  */
  1281.  
  1282. static SCHEME_OBJECT
  1283. DEFUN (xd_process_events, (xd, non_block_p, use_select_p),
  1284.        struct xdisplay * xd AND
  1285.        int non_block_p AND
  1286.        int use_select_p)
  1287. {
  1288.   Display * display = (XD_DISPLAY (xd));
  1289.   unsigned int events_queued;
  1290.   SCHEME_OBJECT result;
  1291.   if (x_debug > 1)
  1292.     {
  1293.       fprintf (stderr, "Enter xd_process_events (%s)\n",
  1294.            (non_block_p ? "non-blocking" : "blocking"));
  1295.       fflush (stderr);
  1296.     }
  1297.   if (!OS_have_select_p)
  1298.     use_select_p = 0;
  1299.   if (XD_CACHED_EVENT_P (xd))
  1300.     {
  1301.       events_queued = (XEventsQueued (display, QueuedAlready));
  1302.       goto restart;
  1303.     }
  1304.   if (use_select_p)
  1305.     events_queued = (XEventsQueued (display, QueuedAlready));
  1306.   else if (non_block_p)
  1307.     {
  1308.       ping_server (xd);
  1309.       events_queued = (XEventsQueued (display, QueuedAfterReading));
  1310.     }
  1311.   else
  1312.     events_queued = 0;
  1313.   while (1)
  1314.     {
  1315.       XEvent event;
  1316.       if (events_queued > 0)
  1317.     events_queued -= 1;
  1318.       else
  1319.     {
  1320.       if (use_select_p)
  1321.         switch (UX_select_input ((ConnectionNumber (display)),
  1322.                      (!non_block_p)))
  1323.           {
  1324.           case select_input_none:
  1325.         result = SHARP_F; goto done;
  1326.           case select_input_other:
  1327.         result = (LONG_TO_FIXNUM (-2)); goto done;
  1328.           case select_input_process_status:
  1329.         result = (LONG_TO_FIXNUM (-3)); goto done;
  1330.           case select_input_interrupt:
  1331.         result = (LONG_TO_FIXNUM (-4)); goto done;
  1332.           case select_input_argument:
  1333.         ping_server (xd);
  1334.         events_queued = (XEventsQueued (display, QueuedAfterReading));
  1335.         continue;
  1336.           }
  1337.       else if (non_block_p)
  1338.         {
  1339.           result = SHARP_F;
  1340.           goto done;
  1341.         }
  1342.       ping_server (xd);
  1343.     }
  1344.       XNextEvent (display, (&event));
  1345.       if ((event . type) == KeymapNotify)
  1346.     continue;
  1347.       {
  1348.     struct xwindow * xw
  1349.       = (x_window_to_xw (display, (event . xany . window)));
  1350.     if ((xw == 0)
  1351.         && (! (((event . type) == PropertyNotify)
  1352.            || ((event . type) == SelectionClear)
  1353.            || ((event . type) == SelectionNotify)
  1354.            || ((event . type) == SelectionRequest))))
  1355.       continue;
  1356.     xw_process_event (xw, (&event));
  1357.       }
  1358.       (XD_CACHED_EVENT (xd)) = event;
  1359.       (XD_CACHED_EVENT_P (xd)) = 1;
  1360.     restart:
  1361.       result = (x_event_to_object (&event));
  1362.       (XD_CACHED_EVENT_P (xd)) = 0;
  1363.       if (result != SHARP_F)
  1364.     goto done;
  1365.     }
  1366.  done:
  1367.   if (x_debug > 1)
  1368.     {
  1369.       fprintf (stderr, "Return from xd_process_events: ");
  1370.       if (result == SHARP_F)
  1371.     fprintf (stderr, "#f");
  1372.       else if (FIXNUM_P (result))
  1373.     fprintf (stderr, "%ld", (FIXNUM_TO_LONG (result)));
  1374.       else
  1375.     fprintf (stderr, "[vector]");
  1376.       fprintf (stderr, "\n");
  1377.       fflush (stderr);
  1378.     }
  1379.   return (result);
  1380. }
  1381.  
  1382. /* Open/Close Primitives */
  1383.  
  1384. static void
  1385. DEFUN_VOID (initialize_once)
  1386. {
  1387.   allocation_table_initialize (&x_display_table);
  1388.   allocation_table_initialize (&x_window_table);
  1389.   allocation_table_initialize (&x_image_table);
  1390.   XSetErrorHandler (x_error_handler);
  1391.   XSetIOErrorHandler (x_io_error_handler);
  1392.   add_reload_cleanup (x_close_all_displays);
  1393.   initialization_done = 1;
  1394. }
  1395.  
  1396. DEFINE_PRIMITIVE ("X-DEBUG", Prim_x_debug, 1, 1, 0)
  1397. {
  1398.   PRIMITIVE_HEADER (1);
  1399.   {
  1400.     SCHEME_OBJECT object = (ARG_REF (1));
  1401.     if (object == SHARP_F)
  1402.       x_debug = 0;
  1403.     else if (UNSIGNED_FIXNUM_P (object))
  1404.       x_debug = (UNSIGNED_FIXNUM_TO_LONG (object));
  1405.     else
  1406.       x_debug = 1;
  1407.   }
  1408.   PRIMITIVE_RETURN (UNSPECIFIC);
  1409. }
  1410.  
  1411. DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0)
  1412. {
  1413.   PRIMITIVE_HEADER (1);
  1414.   INITIALIZE_ONCE ();
  1415.   {
  1416.     struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay)));    
  1417.     /* Added 7/95 by Nick in an attempt to fix problem Hal was having
  1418.        with SWAT over PPP (i.e. slow connections).  */
  1419.     block_signals ();
  1420.     (XD_DISPLAY (xd)) =
  1421.       (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? 0 : (STRING_ARG (1))));
  1422.     unblock_signals ();
  1423.     if ((XD_DISPLAY (xd)) == 0)
  1424.       {
  1425.     free (xd);
  1426.     PRIMITIVE_RETURN (SHARP_F);
  1427.       }
  1428.     (XD_ALLOCATION_INDEX (xd)) =
  1429.       (allocate_table_index ((&x_display_table), xd));
  1430.     (XD_SERVER_PING_TIMER (xd)) = 0;
  1431.     (XD_WM_PROTOCOLS (xd)) =
  1432.       (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False));
  1433.     (XD_WM_DELETE_WINDOW (xd)) =
  1434.       (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False));
  1435.     (XD_WM_TAKE_FOCUS (xd)) =
  1436.       (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False));
  1437.     (XD_CACHED_EVENT_P (xd)) = 0;
  1438.     XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0, "\177", 1);
  1439.     PRIMITIVE_RETURN (XD_TO_OBJECT (xd));
  1440.   }
  1441. }
  1442.  
  1443. DEFINE_PRIMITIVE ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0)
  1444. {
  1445.   PRIMITIVE_HEADER (1);
  1446.   x_close_display (x_display_arg (1));
  1447.   PRIMITIVE_RETURN (UNSPECIFIC);
  1448. }
  1449.  
  1450. DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0)
  1451. {
  1452.   PRIMITIVE_HEADER (0);
  1453.   INITIALIZE_ONCE ();
  1454.   x_close_all_displays ();
  1455.   PRIMITIVE_RETURN (UNSPECIFIC);
  1456. }
  1457.  
  1458. DEFINE_PRIMITIVE ("X-DISPLAY-GET-SIZE", Prim_x_display_get_size, 2, 2, 0)
  1459. {
  1460.   PRIMITIVE_HEADER (2);
  1461.   {
  1462.     struct xdisplay * xd = (x_display_arg (1));
  1463.     Display * display = (XD_DISPLAY (xd));
  1464.     long screen = (arg_nonnegative_integer (2));
  1465.     PRIMITIVE_RETURN
  1466.       (cons ((ulong_to_integer (DisplayWidth (display, screen))),
  1467.          (ulong_to_integer (DisplayHeight (display, screen)))));
  1468.   }
  1469. }
  1470.  
  1471. DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0)
  1472. {
  1473.   PRIMITIVE_HEADER (1);
  1474.   {
  1475.     struct xwindow * xw = (x_window_arg (1));
  1476.     Display * display = (XW_DISPLAY (xw));
  1477.     x_close_window (xw);
  1478.     XFlush (display);
  1479.   }
  1480.   PRIMITIVE_RETURN (UNSPECIFIC);
  1481. }
  1482.  
  1483. DEFINE_PRIMITIVE ("X-SET-DEFAULT-FONT", Prim_x_set_default_font, 2, 2, 0)
  1484. {
  1485.   PRIMITIVE_HEADER (2);
  1486.   {
  1487.     struct xdisplay * xd = (x_display_arg (1));
  1488.     Display * display = (XD_DISPLAY (xd));
  1489.     const char * name = (STRING_ARG (2));
  1490.     XFontStruct * font = (XLoadQueryFont (display, name));
  1491.     if (font == 0)
  1492.       PRIMITIVE_RETURN (SHARP_F);
  1493.     XFreeFont (display, font);
  1494.     if (x_default_font != 0)
  1495.       OS_free ((PTR) x_default_font);
  1496.     {
  1497.       char * copy = (OS_malloc ((strlen (name)) + 1));
  1498.       const char * s1 = name;
  1499.       char * s2 = copy;
  1500.       while (1)
  1501.     {
  1502.       char c = (*s1++);
  1503.       (*s2++) = c;
  1504.       if (c == '\0')
  1505.         break;
  1506.     }
  1507.       x_default_font = copy;
  1508.     }
  1509.   }
  1510.   PRIMITIVE_RETURN (SHARP_T);
  1511. }
  1512.  
  1513. /* Event Processing Primitives */
  1514.  
  1515. DEFINE_PRIMITIVE ("X-DISPLAY-DESCRIPTOR", Prim_x_display_descriptor, 1, 1, 0)
  1516. {
  1517.   PRIMITIVE_HEADER (1);
  1518.   PRIMITIVE_RETURN
  1519.     (long_to_integer (ConnectionNumber (XD_DISPLAY (x_display_arg (1)))));
  1520. }
  1521.  
  1522. DEFINE_PRIMITIVE ("X-MAX-REQUEST-SIZE", Prim_x_max_request_size, 1, 1, 0)
  1523. {
  1524.   PRIMITIVE_HEADER (1);
  1525.   PRIMITIVE_RETURN
  1526.     (long_to_integer (XMaxRequestSize (XD_DISPLAY (x_display_arg (1)))));
  1527. }
  1528.  
  1529. DEFINE_PRIMITIVE ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0)
  1530. {
  1531.   PRIMITIVE_HEADER (2);
  1532.   {
  1533.     struct xdisplay * xd = (x_display_arg (1));
  1534.     SCHEME_OBJECT how = (ARG_REF (2));
  1535.     if (how == SHARP_F)
  1536.       PRIMITIVE_RETURN (xd_process_events (xd, 0, 1));
  1537.     else if (how == (LONG_TO_UNSIGNED_FIXNUM (0)))
  1538.       PRIMITIVE_RETURN (xd_process_events (xd, 1, 1));
  1539.     else if (how == (LONG_TO_UNSIGNED_FIXNUM (1)))
  1540.       PRIMITIVE_RETURN (xd_process_events (xd, 0, 0));
  1541.     else
  1542.       PRIMITIVE_RETURN (xd_process_events (xd, 1, 0));
  1543.   }
  1544. }
  1545.  
  1546. DEFINE_PRIMITIVE ("X-SELECT-INPUT", Prim_x_select_input, 3, 3, 0)
  1547. {
  1548.   PRIMITIVE_HEADER (3);
  1549.   XSelectInput ((XD_DISPLAY (x_display_arg (1))),
  1550.         (arg_ulong_integer (2)),
  1551.         (arg_integer (3)));
  1552.   PRIMITIVE_RETURN (UNSPECIFIC);
  1553. }
  1554.  
  1555. DEFINE_PRIMITIVE ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0)
  1556. {
  1557.   PRIMITIVE_HEADER (1);
  1558.   PRIMITIVE_RETURN (ulong_to_integer (XW_EVENT_MASK (x_window_arg (1))));
  1559. }
  1560.  
  1561. DEFINE_PRIMITIVE ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0)
  1562. {
  1563.   PRIMITIVE_HEADER (2);
  1564.   {
  1565.     struct xwindow * xw = (x_window_arg (1));
  1566.     (XW_EVENT_MASK (xw)) = (EVENT_MASK_ARG (2));
  1567.     update_input_mask (xw);
  1568.   }
  1569.   PRIMITIVE_RETURN (UNSPECIFIC);
  1570. }
  1571.  
  1572. DEFINE_PRIMITIVE ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0)
  1573. {
  1574.   PRIMITIVE_HEADER (2);
  1575.   {
  1576.     struct xwindow * xw = (x_window_arg (1));
  1577.     (XW_EVENT_MASK (xw)) |= (EVENT_MASK_ARG (2));
  1578.     update_input_mask (xw);
  1579.   }
  1580.   PRIMITIVE_RETURN (UNSPECIFIC);
  1581. }
  1582.  
  1583. DEFINE_PRIMITIVE ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0)
  1584. {
  1585.   PRIMITIVE_HEADER (2);
  1586.   {
  1587.     struct xwindow * xw = (x_window_arg (1));
  1588.     (XW_EVENT_MASK (xw)) &=~ (EVENT_MASK_ARG (2));
  1589.     update_input_mask (xw);
  1590.   }
  1591.   PRIMITIVE_RETURN (UNSPECIFIC);
  1592. }
  1593.  
  1594. /* Miscellaneous Primitives */
  1595.  
  1596. DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0)
  1597. {
  1598.   PRIMITIVE_HEADER (1);
  1599.   PRIMITIVE_RETURN (XD_TO_OBJECT (XW_XD (x_window_arg (1))));
  1600. }
  1601.  
  1602. DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0)
  1603. {
  1604.   PRIMITIVE_HEADER (1);
  1605.   PRIMITIVE_RETURN (ulong_to_integer (XW_X_SIZE (x_window_arg (1))));
  1606. }
  1607.  
  1608. DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0)
  1609. {
  1610.   PRIMITIVE_HEADER (1);
  1611.   PRIMITIVE_RETURN (ulong_to_integer (XW_Y_SIZE (x_window_arg (1))));
  1612. }
  1613.  
  1614. DEFINE_PRIMITIVE ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0)
  1615. {
  1616.   PRIMITIVE_HEADER (1);
  1617.   XBell ((XW_DISPLAY (x_window_arg (1))), 0); /* base value */
  1618.   PRIMITIVE_RETURN (UNSPECIFIC);
  1619. }
  1620.  
  1621. DEFINE_PRIMITIVE ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0)
  1622. {
  1623.   PRIMITIVE_HEADER (1);
  1624.   {
  1625.     struct xwindow * xw = (x_window_arg (1));
  1626.     if (((XW_CLIP_X (xw)) == 0)
  1627.     && ((XW_CLIP_Y (xw)) == 0)
  1628.     && ((XW_CLIP_WIDTH (xw)) == (XW_X_SIZE (xw)))
  1629.     && ((XW_CLIP_HEIGHT (xw)) == (XW_Y_SIZE (xw))))
  1630.       XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  1631.     else
  1632.       XClearArea ((XW_DISPLAY (xw)),
  1633.           (XW_WINDOW (xw)),
  1634.           ((XW_CLIP_X (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
  1635.           ((XW_CLIP_Y (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
  1636.           (XW_CLIP_WIDTH (xw)),
  1637.           (XW_CLIP_HEIGHT (xw)),
  1638.           False);
  1639.   }
  1640.   PRIMITIVE_RETURN (UNSPECIFIC);
  1641. }
  1642.  
  1643. DEFINE_PRIMITIVE ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0)
  1644. {
  1645.   PRIMITIVE_HEADER (1);
  1646.   XFlush (XD_DISPLAY (x_display_arg (1)));
  1647.   PRIMITIVE_RETURN (UNSPECIFIC);
  1648. }
  1649.  
  1650. DEFINE_PRIMITIVE ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0)
  1651. {
  1652.   PRIMITIVE_HEADER (1);
  1653.   XFlush (XW_DISPLAY (x_window_arg (1)));
  1654.   PRIMITIVE_RETURN (UNSPECIFIC);
  1655. }
  1656.  
  1657. DEFINE_PRIMITIVE ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0)
  1658. {
  1659.   PRIMITIVE_HEADER (2);
  1660.   XSync ((XD_DISPLAY (x_display_arg (1))), (BOOLEAN_ARG (2)));
  1661.   PRIMITIVE_RETURN (UNSPECIFIC);
  1662. }
  1663.  
  1664. DEFINE_PRIMITIVE ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0)
  1665. {
  1666.   PRIMITIVE_HEADER (3);
  1667.   {
  1668.     char * result =
  1669.       (XGetDefault
  1670.        ((XD_DISPLAY (x_display_arg (1))), (STRING_ARG (2)), (STRING_ARG (3))));
  1671.     PRIMITIVE_RETURN
  1672.       ((result == 0) ? SHARP_F
  1673.        : (char_pointer_to_string ((unsigned char *) result)));
  1674.   }
  1675. }
  1676.  
  1677. DEFINE_PRIMITIVE ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0)
  1678. {
  1679.   PRIMITIVE_HEADER (3);
  1680.   {
  1681.     SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
  1682.     struct xwindow * xw = (x_window_arg (1));
  1683.     Display * display = (XW_DISPLAY (xw));
  1684.     int rx = (arg_integer (2));
  1685.     int ry = (arg_integer (3));
  1686.     int wx;
  1687.     int wy;
  1688.     Window child;
  1689.     if (! (XTranslateCoordinates
  1690.        (display,
  1691.         (RootWindow (display, (DefaultScreen (display)))),
  1692.         (XW_WINDOW (xw)),
  1693.         rx, ry, (&wx), (&wy), (&child))))
  1694.       error_bad_range_arg (1);
  1695.     SET_PAIR_CAR (result, (long_to_integer (wx)));
  1696.     SET_PAIR_CDR (result, (long_to_integer (wy)));
  1697.     PRIMITIVE_RETURN (result);
  1698.   }
  1699. }
  1700.  
  1701. DEFINE_PRIMITIVE ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0)
  1702. {
  1703.   PRIMITIVE_HEADER (3);
  1704.   {
  1705.     SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
  1706.     struct xwindow * xw = (x_window_arg (1));
  1707.     Display * display = (XW_DISPLAY (xw));
  1708.     int wx = (arg_integer (2));
  1709.     int wy = (arg_integer (3));
  1710.     int rx;
  1711.     int ry;
  1712.     Window child;
  1713.     if (! (XTranslateCoordinates
  1714.        (display,
  1715.         (XW_WINDOW (xw)),
  1716.         (RootWindow (display, (DefaultScreen (display)))),
  1717.         wx, wy, (&rx), (&ry), (&child))))
  1718.       error_bad_range_arg (1);
  1719.     SET_PAIR_CAR (result, (long_to_integer (rx)));
  1720.     SET_PAIR_CDR (result, (long_to_integer (ry)));
  1721.     PRIMITIVE_RETURN (result);
  1722.   }
  1723. }
  1724.  
  1725. DEFINE_PRIMITIVE ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0)
  1726. {
  1727.   PRIMITIVE_HEADER (1);
  1728.   {
  1729.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1));
  1730.     struct xwindow * xw = (x_window_arg (1));
  1731.     Window root;
  1732.     Window child;
  1733.     int root_x;
  1734.     int root_y;
  1735.     int win_x;
  1736.     int win_y;
  1737.     unsigned int keys_buttons;
  1738.     if (! (XQueryPointer
  1739.        ((XW_DISPLAY (xw)),
  1740.         (XW_WINDOW (xw)),
  1741.         (&root), (&child),
  1742.         (&root_x), (&root_y),
  1743.         (&win_x), (&win_y),
  1744.         (&keys_buttons))))
  1745.       PRIMITIVE_RETURN (SHARP_F);
  1746.     VECTOR_SET (result, 0, (long_to_integer (root_x)));
  1747.     VECTOR_SET (result, 1, (long_to_integer (root_y)));
  1748.     VECTOR_SET (result, 2, (long_to_integer (win_x)));
  1749.     VECTOR_SET (result, 3, (long_to_integer (win_y)));
  1750.     VECTOR_SET (result, 4, (convert_bucky_bits (keys_buttons, 1)));
  1751.     PRIMITIVE_RETURN (result);
  1752.   }
  1753. }
  1754.  
  1755. DEFINE_PRIMITIVE ("X-WINDOW-ID", Prim_x_window_id, 1, 1, 0)
  1756. {
  1757.   PRIMITIVE_HEADER (1);
  1758.   PRIMITIVE_RETURN (ulong_to_integer (XW_WINDOW (x_window_arg (1))));
  1759. }
  1760.  
  1761. DEFINE_PRIMITIVE ("X-ID->WINDOW", Prim_x_id_to_window, 2, 2, 0)
  1762. {
  1763.   PRIMITIVE_HEADER (2);
  1764.   {
  1765.     struct xwindow * xw
  1766.       = (x_window_to_xw ((XD_DISPLAY (x_display_arg (1))),
  1767.              (arg_ulong_integer (2))));
  1768.     PRIMITIVE_RETURN ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw)));
  1769.   }
  1770. }
  1771.  
  1772. /* Appearance Control Primitives */
  1773.  
  1774. DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0)
  1775. {
  1776.   PRIMITIVE_HEADER (2);
  1777.   {
  1778.     struct xwindow * xw = (x_window_arg (1));
  1779.     Display * display = (XW_DISPLAY (xw));
  1780.     unsigned long foreground_pixel = (arg_window_color (2, display, xw));
  1781.     (XW_FOREGROUND_PIXEL (xw)) = foreground_pixel;
  1782.     XSetForeground (display, (XW_NORMAL_GC (xw)), foreground_pixel);
  1783.     XSetBackground (display, (XW_REVERSE_GC (xw)), foreground_pixel);
  1784.   }
  1785.   PRIMITIVE_RETURN (UNSPECIFIC);
  1786. }
  1787.  
  1788. DEFINE_PRIMITIVE ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0)
  1789. {
  1790.   PRIMITIVE_HEADER (2);
  1791.   {
  1792.     struct xwindow * xw = (x_window_arg (1));
  1793.     Display * display = (XW_DISPLAY (xw));
  1794.     unsigned long background_pixel = (arg_window_color (2, display, xw));
  1795.     (XW_BACKGROUND_PIXEL (xw)) = background_pixel;
  1796.     XSetWindowBackground (display, (XW_WINDOW (xw)), background_pixel);
  1797.     XSetBackground (display, (XW_NORMAL_GC (xw)), background_pixel);
  1798.     XSetForeground (display, (XW_REVERSE_GC (xw)), background_pixel);
  1799.     XSetForeground (display, (XW_CURSOR_GC (xw)), background_pixel);
  1800.     x_set_mouse_colors
  1801.       (display,
  1802.        (xw_color_map (xw)),
  1803.        (XW_MOUSE_CURSOR (xw)),
  1804.        (XW_MOUSE_PIXEL (xw)),
  1805.        background_pixel);
  1806.   }
  1807.   PRIMITIVE_RETURN (UNSPECIFIC);
  1808. }
  1809.  
  1810. DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0)
  1811. {
  1812.   PRIMITIVE_HEADER (2);
  1813.   {
  1814.     struct xwindow * xw = (x_window_arg (1));
  1815.     Display * display = (XW_DISPLAY (xw));
  1816.     unsigned long border_pixel = (arg_window_color (2, display, xw));
  1817.     (XW_BORDER_PIXEL (xw)) = border_pixel;
  1818.     XSetWindowBorder (display, (XW_WINDOW (xw)), border_pixel);
  1819.   }
  1820.   PRIMITIVE_RETURN (UNSPECIFIC);
  1821. }
  1822.  
  1823. DEFINE_PRIMITIVE ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0)
  1824. {
  1825.   PRIMITIVE_HEADER (2);
  1826.   {
  1827.     struct xwindow * xw = (x_window_arg (1));
  1828.     Display * display = (XW_DISPLAY (xw));
  1829.     unsigned long cursor_pixel = (arg_window_color (2, display, xw));
  1830.     (XW_CURSOR_PIXEL (xw)) = cursor_pixel;
  1831.     XSetBackground (display, (XW_CURSOR_GC (xw)), cursor_pixel);
  1832.   }
  1833.   PRIMITIVE_RETURN (UNSPECIFIC);
  1834. }
  1835.  
  1836. DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0)
  1837. {
  1838.   PRIMITIVE_HEADER (2);
  1839.   {
  1840.     struct xwindow * xw = (x_window_arg (1));
  1841.     Display * display = (XW_DISPLAY (xw));
  1842.     unsigned long mouse_pixel = (arg_window_color (2, display, xw));
  1843.     (XW_MOUSE_PIXEL (xw)) = mouse_pixel;
  1844.     x_set_mouse_colors
  1845.       (display,
  1846.        (xw_color_map (xw)),
  1847.        (XW_MOUSE_CURSOR (xw)),
  1848.        mouse_pixel,
  1849.        (XW_BACKGROUND_PIXEL (xw)));
  1850.   }
  1851.   PRIMITIVE_RETURN (UNSPECIFIC);
  1852. }
  1853.  
  1854. DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0)
  1855. {
  1856.   PRIMITIVE_HEADER (2);
  1857.   {
  1858.     struct xwindow * xw = (x_window_arg (1));
  1859.     Display * display = (XW_DISPLAY (xw));
  1860.     Window window = (XW_WINDOW (xw));
  1861.     {
  1862.       Cursor old_cursor = (XW_MOUSE_CURSOR (xw));
  1863.       Cursor mouse_cursor =
  1864.     (XCreateFontCursor
  1865.      (display, (2 * (arg_index_integer (2, (XC_num_glyphs / 2))))));
  1866.       x_set_mouse_colors
  1867.     (display,
  1868.      (xw_color_map (xw)),
  1869.      mouse_cursor,
  1870.      (XW_MOUSE_PIXEL (xw)),
  1871.      (XW_BACKGROUND_PIXEL (xw)));
  1872.       (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
  1873.       XDefineCursor (display, window, mouse_cursor);
  1874.       XFreeCursor (display, old_cursor);
  1875.     }
  1876.   }
  1877.   PRIMITIVE_RETURN (UNSPECIFIC);
  1878. }
  1879.  
  1880. DEFINE_PRIMITIVE ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0)
  1881. {
  1882.   PRIMITIVE_HEADER (2);
  1883.   {
  1884.     struct xwindow * xw = (x_window_arg (1));
  1885.     Display * display = (XW_DISPLAY (xw));
  1886.     XFontStruct * font = (XLoadQueryFont (display, (STRING_ARG (2))));
  1887.     if (font == 0)
  1888.       PRIMITIVE_RETURN (SHARP_F);
  1889.     XFreeFont (display, (XW_FONT (xw)));
  1890.     (XW_FONT (xw)) = font;
  1891.     {
  1892.       Font fid = (font -> fid);
  1893.       XSetFont (display, (XW_NORMAL_GC (xw)), fid);
  1894.       XSetFont (display, (XW_REVERSE_GC (xw)), fid);
  1895.       XSetFont (display, (XW_CURSOR_GC (xw)), fid);
  1896.     }
  1897.     if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
  1898.       (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
  1899.   }
  1900.   PRIMITIVE_RETURN (SHARP_T);
  1901. }
  1902.  
  1903. DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0)
  1904. {
  1905.   PRIMITIVE_HEADER (2);
  1906.   {
  1907.     struct xwindow * xw = (x_window_arg (1));
  1908.     Display * display = (XW_DISPLAY (xw));
  1909.     unsigned int border_width = (arg_nonnegative_integer (2));
  1910.     (XW_BORDER_WIDTH (xw)) = border_width;
  1911.     XSetWindowBorderWidth (display, (XW_WINDOW (xw)), border_width);
  1912.   }
  1913.   PRIMITIVE_RETURN (UNSPECIFIC);
  1914. }
  1915.  
  1916. DEFINE_PRIMITIVE ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0)
  1917. {
  1918.   PRIMITIVE_HEADER (2);
  1919.   {
  1920.     struct xwindow * xw = (x_window_arg (1));
  1921.     unsigned int internal_border_width = (arg_nonnegative_integer (2));
  1922.     (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width;
  1923.     if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
  1924.       (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
  1925.     XResizeWindow
  1926.       ((XW_DISPLAY (xw)),
  1927.        (XW_WINDOW (xw)),
  1928.        ((XW_X_SIZE (xw)) + (2 * internal_border_width)),
  1929.        ((XW_Y_SIZE (xw)) + (2 * internal_border_width)));
  1930.   }
  1931.   PRIMITIVE_RETURN (UNSPECIFIC);
  1932. }
  1933.  
  1934. /* WM Communication Primitives */
  1935.  
  1936. DEFINE_PRIMITIVE ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2,
  1937.   "Set the name of WINDOW to STRING.")
  1938. {
  1939.   PRIMITIVE_HEADER (2);
  1940.   xw_set_wm_name ((x_window_arg (1)), (STRING_ARG (2)));
  1941.   PRIMITIVE_RETURN (UNSPECIFIC);
  1942. }
  1943.  
  1944. DEFINE_PRIMITIVE ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2,
  1945.   "Set the icon name of WINDOW to STRING.")
  1946. {
  1947.   PRIMITIVE_HEADER (2);
  1948.   xw_set_wm_icon_name ((x_window_arg (1)), (STRING_ARG (2)));
  1949.   PRIMITIVE_RETURN (UNSPECIFIC);
  1950. }
  1951.  
  1952. DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3,
  1953.   "Set the class hint of WINDOW to RESOURCE_NAME and RESOURCE_CLASS.")
  1954. {
  1955.   PRIMITIVE_HEADER (3);
  1956.   xw_set_class_hint ((x_window_arg (1)), (STRING_ARG (2)), (STRING_ARG (3)));
  1957.   PRIMITIVE_RETURN (UNSPECIFIC);
  1958. }
  1959.  
  1960. DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2,
  1961.   "Set the input hint of WINDOW to INPUT.")
  1962. {
  1963.   PRIMITIVE_HEADER (2);
  1964.   xw_set_wm_input_hint ((x_window_arg (1)), (BOOLEAN_ARG (2)));
  1965.   PRIMITIVE_RETURN (UNSPECIFIC);
  1966. }
  1967.  
  1968. DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0)
  1969. {
  1970.   PRIMITIVE_HEADER (2);
  1971.   {
  1972.     PTR VOLATILE position = dstack_position;
  1973.     struct xwindow * xw = (x_window_arg (1));
  1974.     unsigned char status;
  1975.  
  1976.     CATCH_X_ERRORS (status);
  1977.     if (status == 0)
  1978.       {
  1979.     Display * display = (XW_DISPLAY (xw));
  1980.     XSetInputFocus
  1981.       (display,
  1982.        (XW_WINDOW (xw)),
  1983.        RevertToParent,
  1984.        ((Time) (arg_ulong_integer (2))));
  1985.     /* Force the message out now; otherwise the error-catching
  1986.        code will be ineffective.  */
  1987.     XSync (display, 0);
  1988.       }
  1989.     else
  1990.       {
  1991.     dstack_set_position (position);
  1992.     error_bad_range_arg (1);
  1993.       }
  1994.     dstack_set_position (position);
  1995.   }
  1996.   PRIMITIVE_RETURN (UNSPECIFIC);
  1997. }
  1998.  
  1999. DEFINE_PRIMITIVE ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2,
  2000.   "Set the transient-for hint of WINDOW to PRIMARY-WINDOW.")
  2001. {
  2002.   PRIMITIVE_HEADER (2);
  2003.   {
  2004.     struct xwindow * xw = (x_window_arg (1));
  2005.     struct xwindow * transient_for = (x_window_arg (2));
  2006.     if ((xw == transient_for) || ((XW_XD (xw)) != (XW_XD (transient_for))))
  2007.       error_bad_range_arg (2);
  2008.     XSetTransientForHint
  2009.       ((XW_DISPLAY (xw)),
  2010.        (XW_WINDOW (xw)),
  2011.        (XW_WINDOW (transient_for)));
  2012.   }
  2013.   PRIMITIVE_RETURN (UNSPECIFIC);
  2014. }
  2015.  
  2016. /* WM Control Primitives */
  2017.  
  2018. DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0)
  2019. {
  2020.   PRIMITIVE_HEADER (1);
  2021.   {
  2022.     struct xwindow * xw = (x_window_arg (1));
  2023.     XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  2024.   }
  2025.   PRIMITIVE_RETURN (UNSPECIFIC);
  2026. }
  2027.  
  2028. DEFINE_PRIMITIVE ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0)
  2029. {
  2030.   PRIMITIVE_HEADER (1);
  2031.   {
  2032.     struct xwindow * xw = (x_window_arg (1));
  2033.     Display * display = (XW_DISPLAY (xw));
  2034.     XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
  2035.   }
  2036.   PRIMITIVE_RETURN (UNSPECIFIC);
  2037. }
  2038.  
  2039. DEFINE_PRIMITIVE ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0)
  2040. {
  2041.   PRIMITIVE_HEADER (1);
  2042.   {
  2043.     struct xwindow * xw = (x_window_arg (1));
  2044.     Display * display = (XW_DISPLAY (xw));
  2045.     XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
  2046.   }
  2047.   PRIMITIVE_RETURN (UNSPECIFIC);
  2048. }
  2049.  
  2050. /* The following shouldn't be used on top-level windows.  Instead use
  2051.    ICONIFY or WITHDRAW.  */
  2052. DEFINE_PRIMITIVE ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0)
  2053. {
  2054.   PRIMITIVE_HEADER (1);
  2055.   {
  2056.     struct xwindow * xw = (x_window_arg (1));
  2057.     XUnmapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  2058.   }
  2059.   PRIMITIVE_RETURN (UNSPECIFIC);
  2060. }
  2061.  
  2062. DEFINE_PRIMITIVE ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0)
  2063. {
  2064.   PRIMITIVE_HEADER (3);
  2065.   {
  2066.     struct xwindow * xw = (x_window_arg (1));
  2067.     unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
  2068.     XResizeWindow
  2069.       ((XW_DISPLAY (xw)),
  2070.        (XW_WINDOW (xw)),
  2071.        ((arg_ulong_integer (2)) + extra),
  2072.        ((arg_ulong_integer (3)) + extra));
  2073.   }
  2074.   PRIMITIVE_RETURN (UNSPECIFIC);
  2075. }
  2076.  
  2077. DEFINE_PRIMITIVE ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0)
  2078. {
  2079.   PRIMITIVE_HEADER (1);
  2080.   {
  2081.     struct xwindow * xw = (x_window_arg (1));
  2082.     XRaiseWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  2083.   }
  2084.   PRIMITIVE_RETURN (UNSPECIFIC);
  2085. }
  2086.  
  2087. DEFINE_PRIMITIVE ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0)
  2088. {
  2089.   PRIMITIVE_HEADER (1);
  2090.   {
  2091.     struct xwindow * xw = (x_window_arg (1));
  2092.     XLowerWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
  2093.   }
  2094.   PRIMITIVE_RETURN (UNSPECIFIC);
  2095. }
  2096.  
  2097. static Window
  2098. DEFUN (get_window_frame, (display, w), Display * display AND Window w)
  2099. {
  2100.   Window root;
  2101.   Window parent;
  2102.   Window * children;
  2103.   unsigned int n_children;
  2104.   while (1)
  2105.     {
  2106.       if (! (XQueryTree (display, w,
  2107.              (&root), (&parent), (&children), (&n_children))))
  2108.     error_external_return ();
  2109.       XFree ((PTR) children);
  2110.       if (parent == root)
  2111.     return (w);
  2112.       w = parent;
  2113.     }
  2114. }
  2115.  
  2116. DEFINE_PRIMITIVE ("X-WINDOW-GET-SIZE", Prim_x_window_get_size, 1, 1, 0)
  2117. {
  2118.   PRIMITIVE_HEADER (1);
  2119.   {
  2120.     struct xwindow * xw = (x_window_arg (1));
  2121.     Display * display = (XW_DISPLAY (xw));
  2122.     Window w = (get_window_frame (display, (XW_WINDOW (xw))));
  2123.     XWindowAttributes a;
  2124.     int extra;
  2125.     if (! (XGetWindowAttributes (display, w, (&a))))
  2126.       error_external_return ();
  2127.     extra = (2 * (a . border_width));
  2128.     PRIMITIVE_RETURN (cons ((long_to_integer ((a . width) + extra)),
  2129.                 (long_to_integer ((a . height) + extra))));
  2130.   }
  2131. }
  2132.  
  2133. DEFINE_PRIMITIVE ("X-WINDOW-GET-POSITION", Prim_x_window_get_position, 1, 1, 0)
  2134. {
  2135.   PRIMITIVE_HEADER (1);
  2136.   {
  2137.     struct xwindow * xw = (x_window_arg (1));
  2138.     Display * display = (XW_DISPLAY (xw));
  2139.     Window w = (get_window_frame (display, (XW_WINDOW (xw))));
  2140.     XWindowAttributes a;
  2141.     if (! (XGetWindowAttributes (display, w, (&a))))
  2142.       error_external_return ();
  2143.     PRIMITIVE_RETURN (cons ((long_to_integer (a . x)),
  2144.                 (long_to_integer (a . y))));
  2145.   }
  2146. }
  2147.  
  2148. DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0)
  2149. {
  2150.   PRIMITIVE_HEADER (3);
  2151.   {
  2152.     struct xwindow * xw = (x_window_arg (1));
  2153.     int x = (arg_integer (2));
  2154.     int y = (arg_integer (3));
  2155.     Display * display = (XW_DISPLAY (xw));
  2156.     Window me = (XW_WINDOW (xw));
  2157.     Window frame = (get_window_frame (display, me));
  2158.     if (me != frame)
  2159.       {
  2160.     int px;
  2161.     int py;
  2162.     Window child;
  2163.  
  2164.     if (! (XTranslateCoordinates
  2165.            (display, me, frame, x, y, (&px), (&py), (&child))))
  2166.       error_bad_range_arg (1);
  2167.     x = px;
  2168.     y = py;
  2169.       }
  2170.     /* This is a kludge; Emacs does the same thing.  Apparently,
  2171.        failing to do this results in incorrect behavior, but the need
  2172.        for this offset is not documented and the Emacs maintainers are
  2173.        mystified as to why it is necessary.  */
  2174.     {
  2175.       XWindowAttributes a;
  2176.       if (! (XGetWindowAttributes (display, frame, (&a))))
  2177.     error_external_return ();
  2178.       x += (a . border_width);
  2179.       y += (a . border_width);
  2180.     }
  2181.     XMoveWindow (display, me, x, y);
  2182.   }
  2183.   PRIMITIVE_RETURN (UNSPECIFIC);
  2184. }
  2185.  
  2186. /* Font Structure Primitive */
  2187.  
  2188. #define FONT_STRUCTURE_MAX_CONVERTED_SIZE (10+1 + 256+1 + ((5+1) * (256+2)))
  2189.   /* font-structure-words  +
  2190.      char-struct-vector +
  2191.      char-struct-words * maximum-number-possible */
  2192.  
  2193. static SCHEME_OBJECT
  2194. DEFUN (convert_char_struct, (char_struct), XCharStruct * char_struct)
  2195. {
  2196.   if (((char_struct -> lbearing) == 0)
  2197.       && ((char_struct -> rbearing) == 0)
  2198.       && ((char_struct -> width) == 0)
  2199.       && ((char_struct -> ascent) == 0)
  2200.       && ((char_struct -> descent) == 0))
  2201.     return (SHARP_F);
  2202.   {
  2203.     SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, true));
  2204.     VECTOR_SET (result, 0, (long_to_integer (char_struct -> lbearing)));
  2205.     VECTOR_SET (result, 1, (long_to_integer (char_struct -> rbearing)));
  2206.     VECTOR_SET (result, 2, (long_to_integer (char_struct -> width)));
  2207.     VECTOR_SET (result, 3, (long_to_integer (char_struct -> ascent)));
  2208.     VECTOR_SET (result, 4, (long_to_integer (char_struct -> descent)));
  2209.     return (result);
  2210.   }
  2211. }
  2212.  
  2213. static SCHEME_OBJECT
  2214. DEFUN (convert_font_struct, (font_name, font),
  2215.        SCHEME_OBJECT font_name AND
  2216.        XFontStruct * font)
  2217. {
  2218.   SCHEME_OBJECT result;
  2219.   if (font == 0)
  2220.     return  SHARP_F;
  2221.   /* Handle only 8-bit fonts because of laziness. */
  2222.   if (((font -> min_byte1) != 0) || ((font -> max_byte1) != 0))
  2223.     return  SHARP_F;
  2224.  
  2225.   result = (allocate_marked_vector (TC_VECTOR, 10, true));
  2226.   if ((font -> per_char) == NULL)
  2227.     VECTOR_SET (result, 6, SHARP_F);
  2228.   else
  2229.     {
  2230.       unsigned int start_index = (font -> min_char_or_byte2);
  2231.       unsigned int length = ((font -> max_char_or_byte2) - start_index + 1);
  2232.       SCHEME_OBJECT character_vector =
  2233.     (allocate_marked_vector (TC_VECTOR, length, true));
  2234.       unsigned int index;
  2235.       for (index = 0; (index < length); index += 1)
  2236.     VECTOR_SET (character_vector,
  2237.             index,
  2238.             (convert_char_struct ((font -> per_char) + index)));
  2239.       VECTOR_SET (result, 6, (ulong_to_integer (start_index)));
  2240.       VECTOR_SET (result, 7, character_vector);
  2241.     }
  2242.   VECTOR_SET (result, 0, font_name);
  2243.   VECTOR_SET (result, 1, (ulong_to_integer (font -> direction)));
  2244.   VECTOR_SET (result, 2,
  2245.           (BOOLEAN_TO_OBJECT ((font -> all_chars_exist) == True)));
  2246.   VECTOR_SET (result, 3, (ulong_to_integer (font -> default_char)));
  2247.   VECTOR_SET (result, 4, convert_char_struct (& (font -> min_bounds)));
  2248.   VECTOR_SET (result, 5, convert_char_struct (& (font -> max_bounds)));
  2249.   VECTOR_SET (result, 8, (long_to_integer (font -> ascent)));
  2250.   VECTOR_SET (result, 9, (long_to_integer (font -> descent)));
  2251.  
  2252.   return  result;
  2253. }
  2254.  
  2255. DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2,
  2256.  "(display font)\n\
  2257.   FONT is either a font name or a font ID.")
  2258. {
  2259.   PRIMITIVE_HEADER (2);
  2260.   Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE);
  2261.   {
  2262.     SCHEME_OBJECT font_name = (ARG_REF (2));
  2263.     Display * display = (XD_DISPLAY (x_display_arg (1)));
  2264.     XFontStruct * font = 0;
  2265.     Boolean  by_name  =  STRING_P (font_name);
  2266.     SCHEME_OBJECT result;
  2267.  
  2268.     if (by_name)
  2269.       font = XLoadQueryFont (display, ((char *) (STRING_LOC (font_name, 0))));
  2270.     else
  2271.       font = XQueryFont (display, ((XID) (integer_to_ulong (ARG_REF (2)))));
  2272.  
  2273.     if (font == 0)
  2274.       PRIMITIVE_RETURN (SHARP_F);
  2275.     
  2276.     result = convert_font_struct (font_name, font);
  2277.  
  2278.     if (by_name)
  2279.       XFreeFont (display, font);
  2280.     PRIMITIVE_RETURN (result);
  2281.   }
  2282. }
  2283.  
  2284. DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1,
  2285.  "(x-window)\n\
  2286.   Returns the font-structure for the font currently associated with X-WINDOW")
  2287. {
  2288.   XFontStruct *font;
  2289.   PRIMITIVE_HEADER (1);
  2290.   Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE);
  2291.   font = XW_FONT (x_window_arg (1));
  2292.   PRIMITIVE_RETURN (convert_font_struct (ulong_to_integer (font->fid), font));
  2293. }
  2294.  
  2295. DEFINE_PRIMITIVE ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3,
  2296.  "(display pattern limit)\n\
  2297.   LIMIT is an exact non-negative integer or #F for no limit.\n\
  2298.   Returns #F or a vector of at least one string.")
  2299. {
  2300.   PRIMITIVE_HEADER (1);
  2301.   {
  2302.     int actual_count = 0;
  2303.     char ** names =
  2304.       (XListFonts ((XD_DISPLAY (x_display_arg (1))),
  2305.            (STRING_ARG (2)),
  2306.            ((FIXNUM_P (ARG_REF (3)))
  2307.             ? (FIXNUM_TO_LONG (ARG_REF (3)))
  2308.             : 1000000),
  2309.            (&actual_count)));
  2310.     if (names == 0)
  2311.       PRIMITIVE_RETURN (SHARP_F);
  2312.     {
  2313.       unsigned int words = (actual_count + 1); /* the vector of strings */
  2314.       unsigned int i;
  2315.       for (i = 0; (i < actual_count); i += 1)
  2316.     words += (STRING_LENGTH_TO_GC_LENGTH (strlen (names[i])));
  2317.       if (GC_Check (words))
  2318.     {
  2319.       /* this causes the primitive to be restarted, so deallocate names */
  2320.       XFreeFontNames (names);
  2321.       Primitive_GC (words);
  2322.       /* notreached */
  2323.     }
  2324.     }
  2325.     {
  2326.       SCHEME_OBJECT result =
  2327.     (allocate_marked_vector (TC_VECTOR, actual_count, false));
  2328.       unsigned int i;
  2329.       for (i = 0;  (i < actual_count);  i += 1)
  2330.     VECTOR_SET (result, i,
  2331.             (char_pointer_to_string ((unsigned char *) (names[i]))));
  2332.       XFreeFontNames (names);
  2333.       PRIMITIVE_RETURN (result);
  2334.     }
  2335.   }
  2336. }
  2337.  
  2338. /* Atoms */
  2339.  
  2340. DEFINE_PRIMITIVE ("X-INTERN-ATOM", Prim_x_intern_atom, 3, 3, 0)
  2341. {
  2342.   PRIMITIVE_HEADER (3);
  2343.   PRIMITIVE_RETURN
  2344.     (ulong_to_integer (XInternAtom ((XD_DISPLAY (x_display_arg (1))),
  2345.                     (STRING_ARG (2)),
  2346.                     (BOOLEAN_ARG (3)))));
  2347. }
  2348.  
  2349. DEFINE_PRIMITIVE ("X-GET-ATOM-NAME", Prim_x_get_atom_name, 2, 2, 0)
  2350. {
  2351.   PRIMITIVE_HEADER (2);
  2352.   {
  2353.     PTR VOLATILE position = dstack_position;
  2354.     unsigned char status;
  2355.     SCHEME_OBJECT result;
  2356.  
  2357.     CATCH_X_ERRORS (status);
  2358.     if (status == 0)
  2359.       {
  2360.     char * name
  2361.       = (XGetAtomName ((XD_DISPLAY (x_display_arg (1))),
  2362.                (arg_ulong_integer (2))));
  2363.     result = (char_pointer_to_string ((unsigned char *) name));
  2364.     XFree (name);
  2365.       }
  2366.     else
  2367.       result = (ulong_to_integer (status));
  2368.     dstack_set_position (position);
  2369.     PRIMITIVE_RETURN (result);
  2370.   }
  2371. }
  2372.  
  2373. /* Window Properties */
  2374.  
  2375. static SCHEME_OBJECT
  2376. DEFUN (char_ptr_to_prop_data_32, (data, nitems),
  2377.        CONST unsigned char * data AND
  2378.        unsigned long nitems)
  2379. {
  2380.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
  2381.   unsigned long index;
  2382.   for (index = 0; (index < nitems); index += 1)
  2383.     VECTOR_SET (result, index, (ulong_to_integer (((CARD32 *) data) [index])));
  2384.   return (result);
  2385. }
  2386.  
  2387. static SCHEME_OBJECT
  2388. DEFUN (char_ptr_to_prop_data_16, (data, nitems),
  2389.        CONST unsigned char * data AND
  2390.        unsigned long nitems)
  2391. {
  2392.   SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
  2393.   unsigned long index;
  2394.   for (index = 0; (index < nitems); index += 1)
  2395.     VECTOR_SET (result, index, (ulong_to_integer (((CARD16 *) data) [index])));
  2396.   return (result);
  2397. }
  2398.  
  2399. static CONST char *
  2400. DEFUN (prop_data_32_to_char_ptr, (vector, length_return),
  2401.        SCHEME_OBJECT vector AND
  2402.        unsigned long * length_return)
  2403. {
  2404.   unsigned long nitems = (VECTOR_LENGTH (vector));
  2405.   unsigned long length = (nitems * 4);
  2406.   char * data = (dstack_alloc (length));
  2407.   unsigned long index;
  2408.   for (index = 0; (index < nitems); index += 1)
  2409.     {
  2410.       SCHEME_OBJECT n = (VECTOR_REF (vector, index));
  2411.       if (! (integer_to_ulong_p (n)))
  2412.     return (0);
  2413.       (((CARD32 *) data) [index]) = (integer_to_ulong (n));
  2414.     }
  2415.   (*length_return) = length;
  2416.   return (data);
  2417. }
  2418.  
  2419. static CONST char *
  2420. DEFUN (prop_data_16_to_char_ptr, (vector, length_return),
  2421.        SCHEME_OBJECT vector AND
  2422.        unsigned long * length_return)
  2423. {
  2424.   unsigned long nitems = (VECTOR_LENGTH (vector));
  2425.   unsigned long length = (nitems * 2);
  2426.   char * data = (dstack_alloc (length));
  2427.   unsigned long index;
  2428.   for (index = 0; (index < nitems); index += 1)
  2429.     {
  2430.       SCHEME_OBJECT n = (VECTOR_REF (vector, index));
  2431.       unsigned long un;
  2432.       if (! (integer_to_ulong_p (n)))
  2433.     return (0);
  2434.       un = (integer_to_ulong (n));
  2435.       if (un >= 65536)
  2436.     return (0);
  2437.       (((CARD16 *) data) [index]) = un;
  2438.     }
  2439.   (*length_return) = length;
  2440.   return (data);
  2441. }
  2442.  
  2443. DEFINE_PRIMITIVE ("X-GET-WINDOW-PROPERTY", Prim_x_get_window_property, 7, 7, 0)
  2444. {
  2445.   PRIMITIVE_HEADER (7);
  2446.   {
  2447.     Display * display = (XD_DISPLAY (x_display_arg (1)));
  2448.     Window window = (arg_ulong_integer (2));
  2449.     Atom property = (arg_ulong_integer (3));
  2450.     long long_offset = (arg_nonnegative_integer (4));
  2451.     long long_length = (arg_nonnegative_integer (5));
  2452.     Bool delete = (BOOLEAN_ARG (6));
  2453.     Atom req_type = (arg_ulong_integer (7));
  2454.  
  2455.     Atom actual_type;
  2456.     int actual_format;
  2457.     unsigned long nitems;
  2458.     unsigned long bytes_after;
  2459.     unsigned char * data;
  2460.  
  2461.     if ((XGetWindowProperty (display, window, property, long_offset,
  2462.                  long_length, delete, req_type, (&actual_type),
  2463.                  (&actual_format), (&nitems), (&bytes_after),
  2464.                  (&data)))
  2465.     != Success)
  2466.       error_external_return ();
  2467.     if (actual_format == 0)
  2468.       {
  2469.     XFree (data);
  2470.     PRIMITIVE_RETURN (SHARP_F);
  2471.       }
  2472.     if (! ((actual_format == 8)
  2473.        || (actual_format == 16)
  2474.        || (actual_format == 32)))
  2475.       error_external_return ();
  2476.     {
  2477.       SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, 1));
  2478.       VECTOR_SET (result, 0, (ulong_to_integer (actual_type)));
  2479.       VECTOR_SET (result, 1, (long_to_integer (actual_format)));
  2480.       VECTOR_SET (result, 2, (ulong_to_integer (bytes_after)));
  2481.       VECTOR_SET (result, 3,
  2482.           (((req_type != AnyPropertyType)
  2483.             && (req_type != actual_type))
  2484.            ? SHARP_F
  2485.            : (actual_format == 32)
  2486.            ? (char_ptr_to_prop_data_32 (data, nitems))
  2487.            : (actual_format == 16)
  2488.            ? (char_ptr_to_prop_data_16 (data, nitems))
  2489.            : (memory_to_string (nitems, data))));
  2490.       XFree (data);
  2491.       PRIMITIVE_RETURN (result);
  2492.     }
  2493.   }
  2494. }
  2495.  
  2496. DEFINE_PRIMITIVE ("X-CHANGE-PROPERTY", Prim_x_change_property, 7, 7, 0)
  2497. {
  2498.   PRIMITIVE_HEADER (7);
  2499.   {
  2500.     PTR VOLATILE position = dstack_position;
  2501.     Display * display = (XD_DISPLAY (x_display_arg (1)));
  2502.     Window window = (arg_ulong_integer (2));
  2503.     Atom property = (arg_ulong_integer (3));
  2504.     Atom type = (arg_ulong_integer (4));
  2505.     int format = (arg_nonnegative_integer (5));
  2506.     int mode = (arg_index_integer (6, 3));
  2507.     CONST char * VOLATILE data = 0;
  2508.     unsigned long dlen;
  2509.     unsigned char status;
  2510.  
  2511.     switch (format)
  2512.       {
  2513.       case 8:
  2514.     CHECK_ARG (7, STRING_P);
  2515.     data = (STRING_LOC ((ARG_REF (7)), 0));
  2516.     dlen = (STRING_LENGTH (ARG_REF (7)));
  2517.     break;
  2518.       case 16:
  2519.     CHECK_ARG (7, VECTOR_P);
  2520.     data = (prop_data_16_to_char_ptr ((ARG_REF (7)), (&dlen)));
  2521.     if (data == 0)
  2522.       error_bad_range_arg (7);
  2523.     break;
  2524.       case 32:
  2525.     CHECK_ARG (7, VECTOR_P);
  2526.     data = (prop_data_32_to_char_ptr ((ARG_REF (7)), (&dlen)));
  2527.     if (data == 0)
  2528.       error_bad_range_arg (7);
  2529.     break;
  2530.       default:
  2531.     error_bad_range_arg (5);
  2532.     break;
  2533.       }
  2534.     CATCH_X_ERRORS (status);
  2535.     if (status == 0)
  2536.       {
  2537.     XChangeProperty (display, window, property, type, format, mode,
  2538.              data, dlen);
  2539.     /* Flush the display queue, because we need to see the errors
  2540.        immediately while we're looking for them.  */
  2541.     XFlush (display);
  2542.       }
  2543.     dstack_set_position (position);
  2544.     PRIMITIVE_RETURN (ulong_to_integer (status));
  2545.   }
  2546. }
  2547.  
  2548. DEFINE_PRIMITIVE ("X-DELETE-PROPERTY", Prim_x_delete_property, 3, 3, 0)
  2549. {
  2550.   PRIMITIVE_HEADER (3);
  2551.   XDeleteProperty ((XD_DISPLAY (x_display_arg (1))),
  2552.            (arg_ulong_integer (2)),
  2553.            (arg_ulong_integer (3)));
  2554.   PRIMITIVE_RETURN (UNSPECIFIC);
  2555. }
  2556.  
  2557. /* Selections */
  2558.  
  2559. DEFINE_PRIMITIVE ("X-SET-SELECTION-OWNER", Prim_x_set_selection_owner, 4, 4, 0)
  2560. {
  2561.   PRIMITIVE_HEADER (4);
  2562.   XSetSelectionOwner ((XD_DISPLAY (x_display_arg (1))),
  2563.               (arg_ulong_integer (2)),
  2564.               (arg_ulong_integer (3)),
  2565.               (arg_ulong_integer (4)));
  2566.   PRIMITIVE_RETURN (UNSPECIFIC);
  2567. }
  2568.  
  2569. DEFINE_PRIMITIVE ("X-GET-SELECTION-OWNER", Prim_x_get_selection_owner, 2, 2, 0)
  2570. {
  2571.   PRIMITIVE_HEADER (2);
  2572.   PRIMITIVE_RETURN
  2573.     (ulong_to_integer (XGetSelectionOwner ((XD_DISPLAY (x_display_arg (1))),
  2574.                        (arg_ulong_integer (2)))));
  2575. }
  2576.  
  2577. DEFINE_PRIMITIVE ("X-CONVERT-SELECTION", Prim_x_convert_selection, 6, 6, 0)
  2578. {
  2579.   PRIMITIVE_HEADER (6);
  2580.   XConvertSelection ((XD_DISPLAY (x_display_arg (1))),
  2581.              (arg_ulong_integer (2)),
  2582.              (arg_ulong_integer (3)),
  2583.              (arg_ulong_integer (4)),
  2584.              (arg_ulong_integer (5)),
  2585.              (arg_ulong_integer (6)));
  2586.   PRIMITIVE_RETURN (UNSPECIFIC);
  2587. }
  2588.  
  2589. DEFINE_PRIMITIVE ("X-SEND-SELECTION-NOTIFY", Prim_x_send_selection_notify, 6, 6, 0)
  2590. {
  2591.   PRIMITIVE_HEADER (6);
  2592.   {
  2593.     struct xdisplay * xd = (x_display_arg (1));
  2594.     Window requestor = (arg_ulong_integer (2));
  2595.     XSelectionEvent event;
  2596.     (event . type) = SelectionNotify;
  2597.     (event . display) = (XD_DISPLAY (xd));
  2598.     (event . requestor) = requestor;
  2599.     (event . selection) = (arg_ulong_integer (3));
  2600.     (event . target) = (arg_ulong_integer (4));
  2601.     (event . property) = (arg_ulong_integer (5));
  2602.     (event . time) = (arg_ulong_integer (6));
  2603.     XSendEvent ((XD_DISPLAY (xd)), requestor, False, 0, ((XEvent *) (&event)));
  2604.   }
  2605.   PRIMITIVE_RETURN (UNSPECIFIC);
  2606. }
  2607.