;;
esac
-dnl Add support for X if present.
-if test "${no_x}" != yes; then
- if test "x${x_includes}" != x; then
- FOO=-I`echo ${x_includes} | sed -e "s/:/ -I/g"`
- CPPFLAGS="${CPPFLAGS} ${FOO}"
- fi
- if test "x${x_libraries}" != x; then
- FOO=-L`echo ${x_libraries} | sed -e "s/:/ -L/g"`
- LDFLAGS="${LDFLAGS} ${FOO}"
- fi
- MODULE_LIBS="-lX11 ${MODULE_LIBS}"
- MODULE_BASES="${MODULE_BASES} prx11"
- MODULE_AUX_BASES="${MODULE_AUX_BASES} x11base x11color x11graph x11term"
-fi
-
dnl Check for dynamic loader support.
AC_CHECK_FUNC([dlopen],
[],
macosx-starter: macosx-starter.o
$(LINK) macosx-starter.o
-prx11.so: prx11.o x11base.o x11color.o x11graph.o x11term.o @MODULE_LOADER@
- $(LINK_MODULE) prx11.o x11base.o x11color.o x11graph.o x11term.o \
- -lX11 $(MODULE_LIBS)
-
@MODULE_RULES@
tags: TAGS
"comutl"
"pruxdld"
"pruxffi"
-"prx11"
"svm1-interp"
"tterm"
"termcap"
"terminfo"
"tparam"
-"x11base"
-"x11color"
-"x11graph"
-"x11term"
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifdef COMPILE_AS_MODULE
-
-#include "scheme.h"
-
-extern void dload_initialize_x11base (void);
-extern void dload_initialize_x11color (void);
-extern void dload_initialize_x11graph (void);
-extern void dload_initialize_x11term (void);
-
-const char *
-dload_initialize_file (void)
-{
- dload_initialize_x11base ();
- dload_initialize_x11color ();
- dload_initialize_x11graph ();
- dload_initialize_x11term ();
- return ("#prx11");
-}
-
-extern void dload_finalize_x11base (void);
-
-void
-dload_finalize_file (void)
-{
- dload_finalize_x11base ();
-}
-
-#endif /* defined (COMPILE_AS_MODULE) */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-#ifndef SCHEME_X11_H
-#define SCHEME_X11_H
-
-#include <X11/Xlib.h>
-#include <X11/cursorfont.h>
-#include <X11/keysym.h>
-#include <X11/Xutil.h>
-#include <X11/Xatom.h>
-\f
-struct xdisplay
-{
- unsigned int allocation_index;
- Display * display;
- unsigned int server_ping_timer;
- Atom wm_protocols;
- Atom wm_delete_window;
- Atom wm_take_focus;
- XEvent cached_event;
- char cached_event_p;
-
- /* X key events have 8-bit modifier masks, three bits of which are
- defined to be Shift, Lock, and Control, identified with ShiftMask,
- LockMask, and ControlMask; and five bits of which are unspecified
- named only mod1 to mod5. Which ones mean Meta, Super, Hyper, &c.,
- vary from system to system, however, so, on initializing the display
- record, we grovel through some tables (XGetKeyboardMapping and
- XGetModifierMapping) to find which ones the various modifier
- keysyms are assigned to, and cache them here.
-
- Scheme knows about Shift, Control, Meta, Super, and Hyper. Of
- these, only Meta, Super, and Hyper are identified by numbered
- modifier masks. All other modifiers are ignored. */
- int modifier_mask_meta;
- int modifier_mask_super;
- int modifier_mask_hyper;
-
- /* The type of window manager we have. If we move FRAME_OUTER_WINDOW
- to x/y 0/0, some window managers (type A) puts the window manager
- decorations outside the screen and FRAME_OUTER_WINDOW exactly at 0/0.
- Other window managers (type B) puts the window including decorations
- at 0/0, so FRAME_OUTER_WINDOW is a bit below 0/0.
- Record the type of WM in use so we can compensate for type A WMs. */
- enum
- {
- X_WMTYPE_UNKNOWN,
- X_WMTYPE_A,
- X_WMTYPE_B
- } wm_type;
-};
-
-#define XD_ALLOCATION_INDEX(xd) ((xd) -> allocation_index)
-#define XD_DISPLAY(xd) ((xd) -> display)
-#define XD_SERVER_PING_TIMER(xd) ((xd) -> server_ping_timer)
-#define XD_WM_PROTOCOLS(xd) ((xd) -> wm_protocols)
-#define XD_WM_DELETE_WINDOW(xd) ((xd) -> wm_delete_window)
-#define XD_WM_TAKE_FOCUS(xd) ((xd) -> wm_take_focus)
-#define XD_CACHED_EVENT(xd) ((xd) -> cached_event)
-#define XD_CACHED_EVENT_P(xd) ((xd) -> cached_event_p)
-#define XD_MODIFIER_MASK_SHIFT(xd) (ShiftMask)
-#define XD_MODIFIER_MASK_CONTROL(xd) (ControlMask)
-#define XD_MODIFIER_MASK_LOCK(xd) (LockMask)
-#define XD_MODIFIER_MASK_META(xd) ((xd) -> modifier_mask_meta)
-#define XD_MODIFIER_MASK_SUPER(xd) ((xd) -> modifier_mask_super)
-#define XD_MODIFIER_MASK_HYPER(xd) ((xd) -> modifier_mask_hyper)
-#define XD_WM_TYPE(xd) ((xd) -> wm_type)
-#define XD_TO_OBJECT(xd) (LONG_TO_UNSIGNED_FIXNUM (XD_ALLOCATION_INDEX (xd)))
-
-#define X_MODIFIER_MASK_SHIFT_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_SHIFT (xd)))
-#define X_MODIFIER_MASK_CONTROL_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_CONTROL (xd)))
-#define X_MODIFIER_MASK_LOCK_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_LOCK (xd)))
-#define X_MODIFIER_MASK_META_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_META (xd)))
-#define X_MODIFIER_MASK_SUPER_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_SUPER (xd)))
-#define X_MODIFIER_MASK_HYPER_P(modifier_mask, xd) \
- ((modifier_mask) & (XD_MODIFIER_MASK_HYPER (xd)))
-
-extern struct xdisplay * x_display_arg (unsigned int arg);
-
-struct drawing_attributes
-{
- /* Width of the borders, in pixels. */
- int border_width;
- int internal_border_width;
-
- /* The primary font. */
- XFontStruct * font;
-
- /* Standard pixel values. */
- unsigned long background_pixel;
- unsigned long foreground_pixel;
- unsigned long border_pixel;
- unsigned long cursor_pixel;
- unsigned long mouse_pixel;
-};
-
-/* This incomplete type definition is needed because the scope of the
- implicit definition in the following typedefs is incorrect. */
-struct xwindow;
-
-typedef void (*x_deallocator_t) (struct xwindow *);
-typedef void (*x_event_processor_t) (struct xwindow *, XEvent *);
-typedef SCHEME_OBJECT (*x_coordinate_map_t)
- (struct xwindow *, unsigned int);
-typedef void (*x_update_normal_hints_t) (struct xwindow *);
-
-struct xwindow_methods
-{
- /* Deallocation procedure to do window-specific deallocation. */
- x_deallocator_t deallocator;
-
- /* Procedure to call on each received event. */
- x_event_processor_t event_processor;
-
- /* Procedures to map coordinates to Scheme objects. */
- x_coordinate_map_t x_coordinate_map;
- x_coordinate_map_t y_coordinate_map;
-
- /* Procedure that is called to inform the window manager of
- adjustments to the window's internal border or font. */
- x_update_normal_hints_t update_normal_hints;
-};
-\f
-struct xwindow
-{
- unsigned int allocation_index;
- Window window;
- struct xdisplay * xd;
-
- /* Dimensions of the drawing region in pixels. */
- unsigned int x_size;
- unsigned int y_size;
-
- /* The clip rectangle. */
- unsigned int clip_x;
- unsigned int clip_y;
- unsigned int clip_width;
- unsigned int clip_height;
-
- struct drawing_attributes attributes;
-
- /* Standard graphics contexts. */
- GC normal_gc;
- GC reverse_gc;
- GC cursor_gc;
-
- /* The mouse cursor. */
- Cursor mouse_cursor;
-
- struct xwindow_methods methods;
-
- unsigned long event_mask;
-
- /* Geometry parameters for window-manager decoration window. */
- int wm_decor_x;
- int wm_decor_y;
- unsigned int wm_decor_pixel_width;
- unsigned int wm_decor_pixel_height;
- unsigned int wm_decor_border_width;
-
- /* The latest move we made to the window. Saved so we can
- compensate for type A WMs (see wm_type above). */
- int expected_x;
- int expected_y;
-
- /* Nonzero if we have made a move and need to check if the WM placed
- us at the right position. */
- int check_expected_move_p;
-
- /* The offset we need to add to compensate for type A WMs. */
- int move_offset_x;
- int move_offset_y;
-};
-
-#define XW_ALLOCATION_INDEX(xw) ((xw) -> allocation_index)
-#define XW_XD(xw) ((xw) -> xd)
-#define XW_WINDOW(xw) ((xw) -> window)
-#define XW_X_SIZE(xw) ((xw) -> x_size)
-#define XW_Y_SIZE(xw) ((xw) -> y_size)
-#define XW_CLIP_X(xw) ((xw) -> clip_x)
-#define XW_CLIP_Y(xw) ((xw) -> clip_y)
-#define XW_CLIP_WIDTH(xw) ((xw) -> clip_width)
-#define XW_CLIP_HEIGHT(xw) ((xw) -> clip_height)
-#define XW_BORDER_WIDTH(xw) (((xw) -> attributes) . border_width)
-#define XW_INTERNAL_BORDER_WIDTH(xw) \
- (((xw) -> attributes) . internal_border_width)
-#define XW_FONT(xw) (((xw) -> attributes) . font)
-#define XW_BACKGROUND_PIXEL(xw) (((xw) -> attributes) . background_pixel)
-#define XW_FOREGROUND_PIXEL(xw) (((xw) -> attributes) . foreground_pixel)
-#define XW_BORDER_PIXEL(xw) (((xw) -> attributes) . border_pixel)
-#define XW_CURSOR_PIXEL(xw) (((xw) -> attributes) . cursor_pixel)
-#define XW_MOUSE_PIXEL(xw) (((xw) -> attributes) . mouse_pixel)
-#define XW_NORMAL_GC(xw) ((xw) -> normal_gc)
-#define XW_REVERSE_GC(xw) ((xw) -> reverse_gc)
-#define XW_CURSOR_GC(xw) ((xw) -> cursor_gc)
-#define XW_MOUSE_CURSOR(xw) ((xw) -> mouse_cursor)
-#define XW_DEALLOCATOR(xw) (((xw) -> methods) . deallocator)
-#define XW_EVENT_PROCESSOR(xw) (((xw) -> methods) . event_processor)
-#define XW_X_COORDINATE_MAP(xw) (((xw) -> methods) . x_coordinate_map)
-#define XW_Y_COORDINATE_MAP(xw) (((xw) -> methods) . y_coordinate_map)
-#define XW_UPDATE_NORMAL_HINTS(xw) (((xw) -> methods) . update_normal_hints)
-#define XW_EVENT_MASK(xw) ((xw) -> event_mask)
-#define XW_WM_DECOR_X(xw) ((xw) -> wm_decor_x)
-#define XW_WM_DECOR_Y(xw) ((xw) -> wm_decor_y)
-#define XW_WM_DECOR_PIXEL_WIDTH(xw) ((xw) -> wm_decor_pixel_width)
-#define XW_WM_DECOR_PIXEL_HEIGHT(xw) ((xw) -> wm_decor_pixel_height)
-#define XW_WM_DECOR_BORDER_WIDTH(xw) ((xw) -> wm_decor_border_width)
-#define XW_EXPECTED_X(xw) ((xw) -> expected_x)
-#define XW_EXPECTED_Y(xw) ((xw) -> expected_y)
-#define XW_CHECK_EXPECTED_MOVE_P(xw) ((xw) -> check_expected_move_p)
-#define XW_MOVE_OFFSET_X(xw) ((xw) -> move_offset_x)
-#define XW_MOVE_OFFSET_Y(xw) ((xw) -> move_offset_y)
-
-#define XW_TO_OBJECT(xw) (LONG_TO_UNSIGNED_FIXNUM (XW_ALLOCATION_INDEX (xw)))
-#define XW_DISPLAY(xw) (XD_DISPLAY (XW_XD (xw)))
-#define XW_WM_TYPE(xw) (XD_WM_TYPE (XW_XD (xw)))
-
-#define FONT_WIDTH(f) (((f) -> max_bounds) . width)
-#define FONT_HEIGHT(f) (((f) -> ascent) + ((f) -> descent))
-#define FONT_BASE(f) ((f) -> ascent)
-
-extern struct xwindow * x_window_arg (unsigned int arg);
-\f
-struct ximage
-{
- unsigned int allocation_index;
- XImage * image;
-};
-
-#define XI_ALLOCATION_INDEX(xi) ((xi) -> allocation_index)
-#define XI_IMAGE(xi) ((xi) -> image)
-#define X_IMAGE_TO_OBJECT(image) \
- (LONG_TO_UNSIGNED_FIXNUM (allocate_x_image (image)))
-
-extern struct ximage * x_image_arg (unsigned int arg);
-extern unsigned int allocate_x_image (XImage * image);
-extern void deallocate_x_image (struct ximage * xi);
-
-struct xvisual
-{
- unsigned int allocation_index;
- Visual * visual;
-};
-
-#define XV_ALLOCATION_INDEX(xv) ((xv) -> allocation_index)
-#define XV_VISUAL(xv) ((xv) -> visual)
-#define X_VISUAL_TO_OBJECT(visual) \
- (LONG_TO_UNSIGNED_FIXNUM (allocate_x_visual (visual)))
-
-extern struct xvisual * x_visual_arg (unsigned int arg);
-extern unsigned int allocate_x_visual (Visual * visual);
-extern void deallocate_x_visual (struct xvisual * xv);
-
-struct xcolormap
-{
- unsigned int allocation_index;
- Colormap colormap;
- struct xdisplay * xd;
-};
-
-#define XCM_ALLOCATION_INDEX(xcm) ((xcm) -> allocation_index)
-#define XCM_COLORMAP(xcm) ((xcm) -> colormap)
-#define XCM_XD(xcm) ((xcm) -> xd)
-#define X_COLORMAP_TO_OBJECT(colormap, xd) \
- (LONG_TO_UNSIGNED_FIXNUM (allocate_x_colormap ((colormap), (xd))))
-#define XCM_DISPLAY(xcm) (XD_DISPLAY (XCM_XD (xcm)))
-
-extern struct xcolormap * x_colormap_arg (unsigned int arg);
-extern unsigned int allocate_x_colormap
- (Colormap colormap, struct xdisplay * xd);
-extern void deallocate_x_colormap (struct xcolormap * xcm);
-\f
-extern int x_debug;
-
-extern void * x_malloc (unsigned int size);
-extern void * x_realloc (void * ptr, unsigned int size);
-
-extern const char * x_get_default
- (Display * display,
- const char * resource_name,
- const char * resource_class,
- const char * property_name,
- const char * property_class,
- const char * sdefault);
-
-extern void x_default_attributes
- (Display * display,
- const char * resource_name,
- const char * resource_class,
- struct drawing_attributes * attributes);
-
-extern struct xwindow * x_make_window
- (struct xdisplay * xd,
- Window window,
- int x_size,
- int y_size,
- struct drawing_attributes * attributes,
- struct xwindow_methods * methods,
- unsigned int size);
-
-extern void xw_set_wm_input_hint (struct xwindow * xw, int input_hint);
-extern void xw_set_wm_name (struct xwindow * xw, const char * name);
-extern void xw_set_wm_icon_name (struct xwindow * xw, const char * name);
-
-extern void x_decode_window_map_arg
- (SCHEME_OBJECT map_arg,
- const char ** resource_class,
- const char ** resource_name,
- int * map_p);
-
-extern void xw_make_window_map
- (struct xwindow * xw,
- const char * resource_name,
- const char * resource_class,
- int map_p);
-
-#endif /* defined (SCHEME_X11_H) */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Common X11 support. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "ux.h"
-#include "osio.h"
-#include "x11.h"
-#include <X11/Xmd.h>
-#include <X11/keysym.h>
-
-extern void block_signals (void);
-extern void unblock_signals (void);
-
-#ifndef X_DEFAULT_FONT
-# define X_DEFAULT_FONT "fixed"
-#endif
-
-int x_debug = 0;
-static int initialization_done = 0;
-static const char * x_default_font = 0;
-
-#define INITIALIZE_ONCE() \
-{ \
- if (!initialization_done) \
- initialize_once (); \
-}
-
-static void initialize_once (void);
-
-static void move_window (struct xwindow *, int, int);
-static void check_expected_move (struct xwindow *);
-
-void *
-x_malloc (unsigned int size)
-{
- void * result = (UX_malloc (size));
- if (result == 0)
- error_external_return ();
- return (result);
-}
-
-void *
-x_realloc (void * ptr, unsigned int size)
-{
- void * result = (UX_realloc (ptr, size));
- if (result == 0)
- error_external_return ();
- return (result);
-}
-\f
-/* Allocation Tables */
-
-struct allocation_table
-{
- void ** items;
- int length;
-};
-
-static struct allocation_table x_display_table;
-static struct allocation_table x_window_table;
-static struct allocation_table x_image_table;
-static struct allocation_table x_visual_table;
-static struct allocation_table x_colormap_table;
-
-static void
-allocation_table_initialize (struct allocation_table * table)
-{
- (table->length) = 0;
-}
-
-static unsigned int
-allocate_table_index (struct allocation_table * table, void * item)
-{
- unsigned int length = (table->length);
- unsigned int new_length;
- void ** items = (table->items);
- void ** new_items;
- void ** scan;
- void ** end;
- if (length == 0)
- {
- new_length = 4;
- new_items = (x_malloc ((sizeof (void *)) * new_length));
- }
- else
- {
- scan = items;
- end = (scan + length);
- while (scan < end)
- if ((*scan++) == 0)
- {
- (*--scan) = item;
- return (scan - items);
- }
- new_length = (length * 2);
- new_items = (x_realloc (items, ((sizeof (void *)) * new_length)));
- }
- scan = (new_items + length);
- end = (new_items + new_length);
- (*scan++) = item;
- while (scan < end)
- (*scan++) = 0;
- (table->items) = new_items;
- (table->length) = new_length;
- return (length);
-}
-
-static void *
-allocation_item_arg (unsigned int arg, struct allocation_table * table)
-{
- unsigned int index = (arg_index_integer (arg, (table->length)));
- void * item = ((table->items) [index]);
- if (item == 0)
- error_bad_range_arg (arg);
- return (item);
-}
-
-struct xdisplay *
-x_display_arg (unsigned int arg)
-{
- INITIALIZE_ONCE ();
- return (allocation_item_arg (arg, (&x_display_table)));
-}
-
-struct xwindow *
-x_window_arg (unsigned int arg)
-{
- INITIALIZE_ONCE ();
- return (allocation_item_arg (arg, (&x_window_table)));
-}
-
-static struct xwindow *
-x_window_to_xw (Display * display, Window window)
-{
- struct xwindow ** scan = ((struct xwindow **) (x_window_table.items));
- struct xwindow ** end = (scan + (x_window_table.length));
- while (scan < end)
- {
- struct xwindow * xw = (*scan++);
- if ((xw != 0)
- && ((XW_DISPLAY (xw)) == display)
- && ((XW_WINDOW (xw)) == window))
- return (xw);
- }
- return (0);
-}
-
-struct ximage *
-x_image_arg (unsigned int arg)
-{
- INITIALIZE_ONCE ();
- return (allocation_item_arg (arg, (&x_image_table)));
-}
-
-unsigned int
-allocate_x_image (XImage * image)
-{
- struct ximage * xi = (x_malloc (sizeof (struct ximage)));
- unsigned int index = (allocate_table_index ((&x_image_table), xi));
- (XI_ALLOCATION_INDEX (xi)) = index;
- (XI_IMAGE (xi)) = image;
- return (index);
-}
-
-void
-deallocate_x_image (struct ximage * xi)
-{
- ((x_image_table.items) [XI_ALLOCATION_INDEX (xi)]) = 0;
- free (xi);
-}
-
-struct xvisual *
-x_visual_arg (unsigned int arg)
-{
- INITIALIZE_ONCE ();
- return (allocation_item_arg (arg, (&x_visual_table)));
-}
-
-unsigned int
-allocate_x_visual (Visual * visual)
-{
- struct xvisual * xv = (x_malloc (sizeof (struct xvisual)));
- unsigned int index = (allocate_table_index ((&x_visual_table), xv));
- (XV_ALLOCATION_INDEX (xv)) = index;
- (XV_VISUAL (xv)) = visual;
- return (index);
-}
-
-void
-deallocate_x_visual (struct xvisual * xv)
-{
- ((x_visual_table.items) [XV_ALLOCATION_INDEX (xv)]) = 0;
- free (xv);
-}
-
-struct xcolormap *
-x_colormap_arg (unsigned int arg)
-{
- INITIALIZE_ONCE ();
- return (allocation_item_arg (arg, (&x_colormap_table)));
-}
-
-unsigned int
-allocate_x_colormap (Colormap colormap, struct xdisplay * xd)
-{
- struct xcolormap * xcm = (x_malloc (sizeof (struct xcolormap)));
- unsigned int index = (allocate_table_index ((&x_colormap_table), xcm));
- (XCM_ALLOCATION_INDEX (xcm)) = index;
- (XCM_COLORMAP (xcm)) = colormap;
- (XCM_XD (xcm)) = xd;
- return (index);
-}
-
-void
-deallocate_x_colormap (struct xcolormap * xcm)
-{
- ((x_colormap_table.items) [XCM_ALLOCATION_INDEX (xcm)]) = 0;
- free (xcm);
-}
-\f
-/* Error Handlers */
-
-static int
-x_io_error_handler (Display * display)
-{
- fprintf (stderr, "\nX IO Error\n");
- fflush (stderr);
- termination_eof ();
- return (0);
-}
-
-typedef struct
-{
- char message [2048];
- char terminate_p;
- unsigned char code;
-} x_error_info_t;
-
-static x_error_info_t x_error_info;
-
-static int
-x_error_handler (Display * display, XErrorEvent * error_event)
-{
- (x_error_info.code) = (error_event->error_code);
- XGetErrorText (display,
- (error_event->error_code),
- (x_error_info.message),
- (sizeof (x_error_info.message)));
- if (x_error_info.terminate_p)
- {
- fprintf (stderr, "\nX Error: %s\n", (x_error_info.message));
- fprintf (stderr, " Request code: %d\n",
- (error_event->request_code));
- fprintf (stderr, " Error serial: %lx\n", (error_event->serial));
- fflush (stderr);
- termination_eof ();
- }
- return (0);
-}
-
-static void
-unbind_x_error_info (void * storage)
-{
- x_error_info = (* ((x_error_info_t *) storage));
-}
-
-static void *
-push_x_error_info (Display * display)
-{
- void * handle;
- x_error_info_t * storage;
-
- XSync (display, False);
- handle = dstack_position;
- storage = (dstack_alloc (sizeof (x_error_info_t)));
- (*storage) = x_error_info;
- ((x_error_info.message) [0]) = '\0';
- (x_error_info.terminate_p) = 0;
- (x_error_info.code) = 0;
- dstack_protect (unbind_x_error_info, storage);
- return (handle);
-}
-
-static void
-pop_x_error_info (void * handle)
-{
- dstack_set_position (handle);
-}
-
-static unsigned char
-x_error_code (Display * display)
-{
- XSync (display, False);
- return (x_error_info.code);
-}
-
-static int
-any_x_errors_p (Display * display)
-{
- return ((x_error_code (display)) != 0);
-}
-\f
-/* Defaults and Attributes */
-
-static int
-x_decode_color (Display * display,
- Colormap color_map,
- const char * color_name,
- unsigned long * color_return)
-{
- XColor cdef;
- if ((XParseColor (display, color_map, color_name, (&cdef)))
- && (XAllocColor (display, color_map, (&cdef))))
- {
- (*color_return) = (cdef.pixel);
- return (1);
- }
- return (0);
-}
-
-Colormap
-xw_color_map (struct xwindow * xw)
-{
- XWindowAttributes a;
- if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
- error_external_return ();
- return (a.colormap);
-}
-
-static unsigned long
-arg_window_color (unsigned int arg, Display * display, struct xwindow * xw)
-{
- unsigned long result;
- SCHEME_OBJECT object = (ARG_REF (arg));
- if (INTEGER_P (object))
- {
- if (! (integer_to_ulong_p (object)))
- error_bad_range_arg (arg);
- result = (integer_to_ulong (object));
- }
- else if (! (x_decode_color
- (display, (xw_color_map (xw)), (STRING_ARG (arg)), (&result))))
- error_bad_range_arg (arg);
- return (result);
-}
-
-static void
-x_set_mouse_colors (Display * display,
- Colormap color_map,
- Cursor mouse_cursor,
- unsigned long mouse_pixel,
- unsigned long background_pixel)
-{
- XColor mouse_color;
- XColor background_color;
- (mouse_color.pixel) = mouse_pixel;
- XQueryColor (display, color_map, (&mouse_color));
- (background_color.pixel) = background_pixel;
- XQueryColor (display, color_map, (&background_color));
- XRecolorCursor (display, mouse_cursor, (&mouse_color), (&background_color));
-}
-
-const char *
-x_get_default (Display * display,
- const char * resource_name,
- const char * resource_class,
- const char * property_name,
- const char * property_class,
- const char * sdefault)
-{
- const char * result = (XGetDefault (display, resource_name, property_name));
- if (result != 0)
- return (result);
- result = (XGetDefault (display, resource_class, property_name));
- if (result != 0)
- return (result);
- result = (XGetDefault (display, resource_name, property_class));
- if (result != 0)
- return (result);
- result = (XGetDefault (display, resource_class, property_class));
- if (result != 0)
- return (result);
- return (sdefault);
-}
-
-static unsigned long
-x_default_color (Display * display,
- const char * resource_name,
- const char * resource_class,
- const char * property_name,
- const char * property_class,
- unsigned long default_color)
-{
- const char * color_name
- = (x_get_default (display, resource_name, resource_class,
- property_name, property_class, 0));
- unsigned long result;
- return
- (((color_name != 0)
- && (x_decode_color (display,
- (DefaultColormap (display,
- (DefaultScreen (display)))),
- color_name,
- (&result))))
- ? result
- : default_color);
-}
-
-void
-x_default_attributes (Display * display,
- const char * resource_name,
- const char * resource_class,
- struct drawing_attributes * attributes)
-{
- int screen_number = (DefaultScreen (display));
- (attributes->font)
- = (XLoadQueryFont (display,
- ((x_default_font != 0)
- ? x_default_font
- : (x_get_default (display,
- resource_name, resource_class,
- "font", "Font",
- X_DEFAULT_FONT)))));
- if ((attributes->font) == 0)
- error_external_return ();
- {
- const char * s
- = (x_get_default (display,
- resource_name, resource_class,
- "borderWidth", "BorderWidth",
- 0));
- (attributes->border_width) = ((s == 0) ? 0 : (atoi (s)));
- }
- {
- const char * s
- = (x_get_default (display,
- resource_name, resource_class,
- "internalBorder", "BorderWidth",
- 0));
- (attributes->internal_border_width)
- = ((s == 0) ? (attributes->border_width) : (atoi (s)));
- }
- {
- unsigned long white_pixel = (WhitePixel (display, screen_number));
- unsigned long black_pixel = (BlackPixel (display, screen_number));
- unsigned long foreground_pixel;
- (attributes->background_pixel)
- = (x_default_color (display,
- resource_name, resource_class,
- "background", "Background",
- white_pixel));
- foreground_pixel
- = (x_default_color (display,
- resource_name, resource_class,
- "foreground", "Foreground",
- black_pixel));
- (attributes->foreground_pixel) = foreground_pixel;
- (attributes->border_pixel)
- = (x_default_color (display,
- resource_name, resource_class,
- "borderColor", "BorderColor",
- foreground_pixel));
- (attributes->cursor_pixel)
- = (x_default_color (display,
- resource_name, resource_class,
- "cursorColor", "Foreground",
- foreground_pixel));
- (attributes->mouse_pixel)
- = (x_default_color (display,
- resource_name, resource_class,
- "pointerColor", "Foreground",
- foreground_pixel));
- }
-}
-
-static int
-get_wm_decor_geometry (struct xwindow * xw)
-{
- Display * display = (XW_DISPLAY (xw));
- Window decor = (XW_WINDOW (xw));
- void * handle = (push_x_error_info (display));
- Window root;
- unsigned int depth;
-
- {
- Window parent;
- Window * children;
- unsigned int n_children;
- while (1)
- {
- if ((!XQueryTree (display, decor,
- (&root), (&parent), (&children), (&n_children)))
- || (any_x_errors_p (display)))
- {
- pop_x_error_info (handle);
- error_external_return ();
- }
- if (children != 0)
- XFree (children);
- if (parent == root)
- break;
- decor = parent;
- }
- }
- if ((!XGetGeometry (display,
- decor,
- (&root),
- (& (XW_WM_DECOR_X (xw))),
- (& (XW_WM_DECOR_Y (xw))),
- (& (XW_WM_DECOR_PIXEL_WIDTH (xw))),
- (& (XW_WM_DECOR_PIXEL_HEIGHT (xw))),
- (& (XW_WM_DECOR_BORDER_WIDTH (xw))),
- (&depth)))
- || (any_x_errors_p (display)))
- {
- pop_x_error_info (handle);
- error_external_return ();
- }
- pop_x_error_info (handle);
- /* Return true iff the window has been reparented by the WM. */
- return (decor != (XW_WINDOW (xw)));
-}
-\f
-/* Open/Close Windows */
-
-#define MAKE_GC(gc, fore, back) \
-{ \
- XGCValues gcv; \
- (gcv.font) = fid; \
- (gcv.foreground) = (fore); \
- (gcv.background) = (back); \
- (gc) = \
- (XCreateGC (display, \
- window, \
- (GCFont | GCForeground | GCBackground), \
- (& gcv))); \
-}
-
-struct xwindow *
-x_make_window (struct xdisplay * xd,
- Window window,
- int x_size,
- int y_size,
- struct drawing_attributes * attributes,
- struct xwindow_methods * methods,
- unsigned int size)
-{
- GC normal_gc;
- GC reverse_gc;
- GC cursor_gc;
- struct xwindow * xw;
- Display * display = (XD_DISPLAY (xd));
- Font fid = ((attributes->font) -> fid);
- unsigned long foreground_pixel = (attributes->foreground_pixel);
- unsigned long background_pixel = (attributes->background_pixel);
- Cursor mouse_cursor = (XCreateFontCursor (display, XC_left_ptr));
- MAKE_GC (normal_gc, foreground_pixel, background_pixel);
- MAKE_GC (reverse_gc, background_pixel, foreground_pixel);
- MAKE_GC (cursor_gc, background_pixel, (attributes->cursor_pixel));
- x_set_mouse_colors
- (display,
- (DefaultColormap (display, (DefaultScreen (display)))),
- mouse_cursor,
- (attributes->mouse_pixel),
- background_pixel);
- XDefineCursor (display, window, mouse_cursor);
- XSelectInput (display, window, 0);
- if (size < (sizeof (struct xwindow)))
- error_external_return ();
- xw = (x_malloc (size));
- (XW_ALLOCATION_INDEX (xw)) = (allocate_table_index ((&x_window_table), xw));
- (XW_XD (xw)) = xd;
- (XW_WINDOW (xw)) = window;
- (XW_X_SIZE (xw)) = x_size;
- (XW_Y_SIZE (xw)) = y_size;
- (XW_CLIP_X (xw)) = 0;
- (XW_CLIP_Y (xw)) = 0;
- (XW_CLIP_WIDTH (xw)) = x_size;
- (XW_CLIP_HEIGHT (xw)) = y_size;
- (xw->attributes) = (*attributes);
- (xw->methods) = (*methods);
- (XW_NORMAL_GC (xw)) = normal_gc;
- (XW_REVERSE_GC (xw)) = reverse_gc;
- (XW_CURSOR_GC (xw)) = cursor_gc;
- (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
- (XW_EVENT_MASK (xw)) = 0;
- (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0;
- (XW_MOVE_OFFSET_X (xw)) = 0;
- (XW_MOVE_OFFSET_Y (xw)) = 0;
- return (xw);
-}
-
-static jmp_buf x_close_window_jmp_buf;
-
-static int
-x_close_window_io_error (Display * display)
-{
- longjmp (x_close_window_jmp_buf, 1);
- /*NOTREACHED*/
- return (0);
-}
-
-static void
-x_close_window (struct xwindow * xw)
-{
- Display * display = (XW_DISPLAY (xw));
- ((x_window_table.items) [XW_ALLOCATION_INDEX (xw)]) = 0;
- if ((setjmp (x_close_window_jmp_buf)) == 0)
- {
- XSetIOErrorHandler (x_close_window_io_error);
- {
- x_deallocator_t deallocator = (XW_DEALLOCATOR (xw));
- if (deallocator != 0)
- (*deallocator) (xw);
- }
- {
- XFontStruct * font = (XW_FONT (xw));
- if (font != 0)
- XFreeFont (display, font);
- }
- XDestroyWindow (display, (XW_WINDOW (xw)));
- /* Guarantee that the IO error occurs while the IO error handler
- is rebound, if at all. */
- XFlush (display);
- }
- XSetIOErrorHandler (x_io_error_handler);
- free (xw);
-}
-\f
-/* Initialize/Close Displays */
-
-#define MODIFIER_INDEX_TO_MASK(N) (1 << (N))
-
-/* Grovel through the X server's keycode and modifier mappings to find
- out what we ought to interpret as Meta, Hyper, and Super, based on
- what modifiers are associated with keycodes that are associated with
- keysyms Meta_L, Meta_R, Alt_L, Alt_R, Hyper_L, &c.
-
- Adapted from GNU Emacs. */
-
-static void
-x_initialize_display_modifier_masks (struct xdisplay * xd)
-{
- int min_keycode;
- int max_keycode;
- XModifierKeymap * modifier_keymap;
- KeyCode * modifier_to_keycodes_table;
- int keycodes_per_modifier;
- KeySym * keycode_to_keysyms_table;
- int keysyms_per_keycode;
-
- (XD_MODIFIER_MASK_META (xd)) = 0;
- (XD_MODIFIER_MASK_SUPER (xd)) = 0;
- (XD_MODIFIER_MASK_HYPER (xd)) = 0;
-
- modifier_keymap = (XGetModifierMapping ((XD_DISPLAY (xd))));
- modifier_to_keycodes_table = (modifier_keymap->modifiermap);
- keycodes_per_modifier = (modifier_keymap->max_keypermod);
-
- XDisplayKeycodes ((XD_DISPLAY (xd)), (& min_keycode), (& max_keycode));
-
- keycode_to_keysyms_table
- = (XGetKeyboardMapping ((XD_DISPLAY (xd)),
- min_keycode,
- (max_keycode - min_keycode + 1),
- (& keysyms_per_keycode)));
-
- /* Go through each of the 8 non-preassigned modifiers, which start at
- 3 (Mod1), after Shift, Control, and Lock. For each modifier, go
- through all of the (non-zero) keycodes attached to it; for each
- keycode, go through all of the keysyms attached to it; check each
- keysym for the modifiers that we're interested in (Meta, Hyper,
- and Super). */
-
- {
- int modifier_index;
-
- for (modifier_index = 3; (modifier_index < 8); modifier_index += 1)
- {
- int modifier_mask = (MODIFIER_INDEX_TO_MASK (modifier_index));
- KeyCode * keycodes
- = (& (modifier_to_keycodes_table
- [modifier_index * keycodes_per_modifier]));
-
- /* This is a flag specifying whether the modifier has already
- been identified as Meta, which takes precedence over Hyper
- and Super. (What about precedence between Hyper and
- Super...? This is GNU Emacs's behaviour.) */
- int modifier_is_meta_p = 0;
-
- int keycode_index;
-
- for (keycode_index = 0;
- (keycode_index < keycodes_per_modifier);
- keycode_index += 1)
- {
- KeyCode keycode = (keycodes [keycode_index]);
-
- if (keycode == 0)
- continue;
-
- {
- int keysym_index;
- KeySym * keysyms
- = (& (keycode_to_keysyms_table
- [(keycode - min_keycode) * keysyms_per_keycode]));
-
- for (keysym_index = 0;
- (keysym_index < keysyms_per_keycode);
- keysym_index += 1)
- switch (keysyms [keysym_index])
- {
- case XK_Meta_L:
- case XK_Meta_R:
- case XK_Alt_L:
- case XK_Alt_R:
- modifier_is_meta_p = 1;
- (XD_MODIFIER_MASK_META (xd)) |= modifier_mask;
- break;
-
- case XK_Hyper_L:
- case XK_Hyper_R:
- if (! modifier_is_meta_p)
- (XD_MODIFIER_MASK_HYPER (xd)) |= modifier_mask;
- goto next_modifier;
-
- case XK_Super_L:
- case XK_Super_R:
- if (! modifier_is_meta_p)
- (XD_MODIFIER_MASK_SUPER (xd)) |= modifier_mask;
- goto next_modifier;
- }
- }
- }
-
- next_modifier:
- continue;
- }
- }
-
- XFree (((char *) keycode_to_keysyms_table));
- XFreeModifiermap (modifier_keymap);
-}
-
-static void
-x_close_display (struct xdisplay * xd)
-{
- struct xwindow ** scan = ((struct xwindow **) (x_window_table.items));
- struct xwindow ** end = (scan + (x_window_table.length));
- while (scan < end)
- {
- struct xwindow * xw = (*scan++);
- if ((xw != 0) && ((XW_XD (xw)) == xd))
- x_close_window (xw);
- }
- ((x_display_table.items) [XD_ALLOCATION_INDEX (xd)]) = 0;
- XCloseDisplay (XD_DISPLAY (xd));
-}
-
-static void
-x_close_all_displays (void)
-{
- struct xdisplay ** scan = ((struct xdisplay **) (x_display_table.items));
- struct xdisplay ** end = (scan + (x_display_table.length));
- while (scan < end)
- {
- struct xdisplay * xd = (*scan++);
- if (xd != 0)
- x_close_display (xd);
- }
-}
-\f
-/* Window Manager Properties */
-
-static void
-xw_set_class_hint (struct xwindow * xw, const char * name, const char * class)
-{
- XClassHint * class_hint = (XAllocClassHint ());
- if (class_hint == 0)
- error_external_return ();
- /* This structure is misdeclared, so cast the args. */
- (class_hint->res_name) = ((char *) name);
- (class_hint->res_class) = ((char *) class);
- XSetClassHint ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), class_hint);
- XFree (class_hint);
-}
-
-void
-xw_set_wm_input_hint (struct xwindow * xw, int input_hint)
-{
- XWMHints * hints = (XAllocWMHints ());
- if (hints == 0)
- error_external_return ();
- (hints->flags) = InputHint;
- (hints->input) = (input_hint != 0);
- XSetWMHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), hints);
- XFree (hints);
-}
-
-void
-xw_set_wm_name (struct xwindow * xw, const char * name)
-{
- XTextProperty property;
- if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
- error_external_return ();
- XSetWMName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
-}
-
-void
-xw_set_wm_icon_name (struct xwindow * xw, const char * name)
-{
- XTextProperty property;
- if ((XStringListToTextProperty (((char **) (&name)), 1, (&property))) == 0)
- error_external_return ();
- XSetWMIconName ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&property));
-}
-
-void
-x_decode_window_map_arg (SCHEME_OBJECT map_arg,
- const char ** resource_name,
- const char ** resource_class,
- int * map_p)
-{
- (*map_p) = 0;
- if (map_arg == SHARP_F)
- (*map_p) = 1;
- else if ((PAIR_P (map_arg))
- && (STRING_P (PAIR_CAR (map_arg)))
- && (STRING_P (PAIR_CDR (map_arg))))
- {
- (*resource_name) = (STRING_POINTER (PAIR_CAR (map_arg)));
- (*resource_class) = (STRING_POINTER (PAIR_CDR (map_arg)));
- (*map_p) = 1;
- }
- else if ((VECTOR_P (map_arg))
- && ((VECTOR_LENGTH (map_arg)) == 3)
- && (BOOLEAN_P (VECTOR_REF (map_arg, 0)))
- && (STRING_P (VECTOR_REF (map_arg, 1)))
- && (STRING_P (VECTOR_REF (map_arg, 2))))
- {
- (*resource_name) = (STRING_POINTER (VECTOR_REF (map_arg, 1)));
- (*resource_class) = (STRING_POINTER (VECTOR_REF (map_arg, 2)));
- (*map_p) = (OBJECT_TO_BOOLEAN (VECTOR_REF (map_arg, 0)));
- }
-}
-
-void
-xw_make_window_map (struct xwindow * xw,
- const char * resource_name,
- const char * resource_class,
- int map_p)
-{
- xw_set_class_hint (xw, resource_name, resource_class);
- if (map_p)
- {
- XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- XFlush (XW_DISPLAY (xw));
- }
-}
-\f
-/* Event Processing */
-
-/* Returns non-zero value if caller should ignore the event. */
-
-static int
-xw_process_event (struct xwindow * xw, XEvent * event)
-{
- if (x_debug > 0)
- {
- const char * type_name;
- fprintf (stderr, "\nX event on 0x%lx: ", ((event->xany) . window));
- switch (event->type)
- {
- case ButtonPress: type_name = "ButtonPress"; break;
- case ButtonRelease: type_name = "ButtonRelease"; break;
- case CirculateNotify: type_name = "CirculateNotify"; break;
- case CreateNotify: type_name = "CreateNotify"; break;
- case DestroyNotify: type_name = "DestroyNotify"; break;
- case EnterNotify: type_name = "EnterNotify"; break;
- case Expose: type_name = "Expose"; break;
- case FocusIn: type_name = "FocusIn"; break;
- case FocusOut: type_name = "FocusOut"; break;
- case GraphicsExpose: type_name = "GraphicsExpose"; break;
- case GravityNotify: type_name = "GravityNotify"; break;
- case KeyPress: type_name = "KeyPress"; break;
- case KeyRelease: type_name = "KeyRelease"; break;
- case LeaveNotify: type_name = "LeaveNotify"; break;
- case MapNotify: type_name = "MapNotify"; break;
- case MappingNotify: type_name = "MappingNotify"; break;
- case MotionNotify: type_name = "MotionNotify"; break;
- case NoExpose: type_name = "NoExpose"; break;
- case ReparentNotify: type_name = "ReparentNotify"; break;
- case SelectionClear: type_name = "SelectionClear"; break;
- case SelectionRequest: type_name = "SelectionRequest"; break;
- case UnmapNotify: type_name = "UnmapNotify"; break;
-
- case VisibilityNotify:
- fprintf (stderr, "VisibilityNotify; state=");
- switch ((event->xvisibility) . state)
- {
- case VisibilityUnobscured:
- fprintf (stderr, "unobscured");
- break;
- case VisibilityPartiallyObscured:
- fprintf (stderr, "partially-obscured");
- break;
- case VisibilityFullyObscured:
- fprintf (stderr, "fully-obscured");
- break;
- default:
- fprintf (stderr, "%d", ((event->xvisibility) . state));
- break;
- }
- goto debug_done;
-
- case ConfigureNotify:
- fprintf (stderr, "ConfigureNotify; x=%d y=%d width=%d height=%d",
- ((event->xconfigure) . x),
- ((event->xconfigure) . y),
- ((event->xconfigure) . width),
- ((event->xconfigure) . height));
- goto debug_done;
-
- case ClientMessage:
- {
- struct xdisplay * xd = (XW_XD (xw));
- if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
- && (((event->xclient) . format) == 32))
- {
- if (((Atom) (((event->xclient) . data . l) [0]))
- == (XD_WM_DELETE_WINDOW (xd)))
- type_name = "WM_DELETE_WINDOW";
- else if (((Atom) (((event->xclient) . data . l) [0]))
- == (XD_WM_TAKE_FOCUS (xd)))
- type_name = "WM_TAKE_FOCUS";
- else
- type_name = "WM_PROTOCOLS";
- }
- else
- {
- fprintf (stderr, "ClientMessage; message_type=0x%x format=%d",
- ((unsigned int) ((event->xclient) . message_type)),
- ((event->xclient) . format));
- goto debug_done;
- }
- }
- break;
- case PropertyNotify:
- {
- fprintf (stderr, "PropertyNotify; atom=%ld time=%ld state=%d",
- ((event->xproperty) . atom),
- ((event->xproperty) . time),
- ((event->xproperty) . state));
- goto debug_done;
- }
- case SelectionNotify:
- {
- fprintf
- (stderr, "SelectionNotify; sel=%ld targ=%ld prop=%ld t=%ld",
- ((event->xselection) . selection),
- ((event->xselection) . target),
- ((event->xselection) . property),
- ((event->xselection) . time));
- goto debug_done;
- }
- default: type_name = 0; break;
- }
- if (type_name != 0)
- fprintf (stderr, "%s", type_name);
- else
- fprintf (stderr, "%d", (event->type));
- debug_done:
- fprintf (stderr, "%s\n",
- (((event->xany) . send_event) ? "; synthetic" : ""));
- fflush (stderr);
- }
- switch (event->type)
- {
- case MappingNotify:
- switch ((event->xmapping) . request)
- {
- case MappingModifier:
- x_initialize_display_modifier_masks ((XW_XD (xw)));
- /* Fall through. */
- case MappingKeyboard:
- XRefreshKeyboardMapping (& (event->xmapping));
- break;
- }
- break;
- }
- if (xw != 0)
- {
- switch (event->type)
- {
- case ReparentNotify:
- get_wm_decor_geometry (xw);
- /* Perhaps reparented due to a WM restart. Reset this. */
- (XW_WM_TYPE (xw)) = X_WMTYPE_UNKNOWN;
- break;
-
- case ConfigureNotify:
- /* If the window has been reparented, don't check
- non-synthetic events. */
- if ((XW_CHECK_EXPECTED_MOVE_P (xw))
- && (! ((get_wm_decor_geometry (xw))
- && (! ((event->xconfigure) . send_event)))))
- check_expected_move (xw);
- break;
- }
- (* (XW_EVENT_PROCESSOR (xw))) (xw, event);
- }
- return (0);
-}
-
-enum event_type
-{
- event_type_button_down,
- event_type_button_up,
- event_type_configure,
- event_type_enter,
- event_type_focus_in,
- event_type_focus_out,
- event_type_key_press,
- event_type_leave,
- event_type_motion,
- event_type_expose,
- event_type_delete_window,
- event_type_map,
- event_type_unmap,
- event_type_take_focus,
- event_type_visibility,
- event_type_selection_clear,
- event_type_selection_notify,
- event_type_selection_request,
- event_type_property_notify,
- event_type_supremum
-};
-
-#define EVENT_MASK_ARG(arg) \
- (arg_ulong_index_integer \
- ((arg), (1 << ((unsigned int) event_type_supremum))))
-
-#define EVENT_ENABLED(xw, type) \
- (((XW_EVENT_MASK (xw)) & (1 << ((unsigned int) (type)))) != 0)
-
-#define EVENT_0 2
-#define EVENT_1 3
-#define EVENT_2 4
-#define EVENT_3 5
-#define EVENT_4 6
-
-#define EVENT_INTEGER(event, slot, number) \
- VECTOR_SET ((event), (slot), (long_to_integer (number)))
-
-#define EVENT_ULONG_INTEGER(event, slot, number) \
- VECTOR_SET ((event), (slot), (ulong_to_integer (number)))
-
-static SCHEME_OBJECT
-make_event_object (struct xwindow * xw,
- enum event_type type,
- unsigned int extra)
-{
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, (2 + extra), 1));
- VECTOR_SET (result, 0, (LONG_TO_UNSIGNED_FIXNUM ((long) type)));
- VECTOR_SET (result, 1, ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw))));
- return (result);
-}
-
-/* This handles only the modifier bits that Scheme supports.
- At the moment, these are Control, Meta, Super, and Hyper.
- This might want to change if the character abstraction were ever to
- change, or if the X11 interface were to be changed to use something
- other than Scheme characters to convey key presses. */
-
-static unsigned long
-x_modifier_mask_to_bucky_bits (unsigned int mask, struct xdisplay * xd)
-{
- unsigned long bucky = 0;
- if (X_MODIFIER_MASK_CONTROL_P (mask, xd)) bucky |= CHAR_BITS_CONTROL;
- if (X_MODIFIER_MASK_META_P (mask, xd)) bucky |= CHAR_BITS_META;
- if (X_MODIFIER_MASK_SUPER_P (mask, xd)) bucky |= CHAR_BITS_SUPER;
- if (X_MODIFIER_MASK_HYPER_P (mask, xd)) bucky |= CHAR_BITS_HYPER;
- return (bucky);
-}
-
-/* I'm not sure why we have a function for this. */
-
-static SCHEME_OBJECT
-x_key_button_mask_to_scheme (unsigned int x_state)
-{
- unsigned long scheme_state = 0;
- if (x_state & ControlMask) scheme_state |= 0x0001;
- if (x_state & Mod1Mask) scheme_state |= 0x0002;
- if (x_state & Mod2Mask) scheme_state |= 0x0004;
- if (x_state & Mod3Mask) scheme_state |= 0x0008;
- if (x_state & ShiftMask) scheme_state |= 0x0010;
- if (x_state & LockMask) scheme_state |= 0x0020;
- if (x_state & Mod4Mask) scheme_state |= 0x0040;
- if (x_state & Mod5Mask) scheme_state |= 0x0080;
- if (x_state & Button1Mask) scheme_state |= 0x0100;
- if (x_state & Button2Mask) scheme_state |= 0x0200;
- if (x_state & Button3Mask) scheme_state |= 0x0400;
- if (x_state & Button4Mask) scheme_state |= 0x0800;
- if (x_state & Button5Mask) scheme_state |= 0x1000;
- return (ULONG_TO_FIXNUM (scheme_state));
-}
-
-static SCHEME_OBJECT
-button_event (struct xwindow * xw, XButtonEvent * event, enum event_type type)
-{
- SCHEME_OBJECT result = (make_event_object (xw, type, 4));
- EVENT_INTEGER (result, EVENT_0, (event->x));
- EVENT_INTEGER (result, EVENT_1, (event->y));
- VECTOR_SET
- (result, EVENT_2,
- ((((event->button) >= 1) && ((event->button) <= 256))
- ? (ULONG_TO_FIXNUM
- (((event->button) - 1)
- | ((x_modifier_mask_to_bucky_bits ((event->state), (XW_XD (xw))))
- << 8)))
- : SHARP_F));
- EVENT_ULONG_INTEGER (result, EVENT_3, (event->time));
- return (result);
-}
-
-static XComposeStatus compose_status;
-
-static SCHEME_OBJECT
-key_event (struct xwindow * xw, XKeyEvent * event, enum event_type type)
-{
- char copy_buffer [80];
- KeySym keysym;
- int nbytes;
- SCHEME_OBJECT result;
-
- /* Make ShiftLock modifier not affect keys with other modifiers. */
- if ((event->state)
- & (ShiftMask | ControlMask
- | Mod1Mask | Mod2Mask | Mod3Mask | Mod4Mask | Mod5Mask))
- {
- if (((event->state) & LockMask) != 0)
- (event->state) &=~ LockMask;
- }
- nbytes
- = (XLookupString (event,
- copy_buffer,
- (sizeof (copy_buffer)),
- (&keysym),
- (&compose_status)));
- if (keysym == NoSymbol)
- return (SHARP_F);
- /* If the BackSpace keysym is received, and XLookupString has
- translated it into ASCII backspace, substitute ASCII DEL
- instead. */
- if ((keysym == XK_BackSpace)
- && (nbytes == 1)
- && ((copy_buffer[0]) == '\b'))
- (copy_buffer[0]) = '\177';
- if (IsModifierKey (keysym))
- return (SHARP_F);
-
- result = (make_event_object (xw, type, 4));
- VECTOR_SET (result, EVENT_0,
- (memory_to_string (nbytes, ((unsigned char *) copy_buffer))));
- /* Create Scheme bucky bits (kept independent of the character).
- X has already controlified, so Scheme may choose to ignore
- the control bucky bit. */
- VECTOR_SET (result, EVENT_1,
- (ULONG_TO_FIXNUM
- (x_modifier_mask_to_bucky_bits ((event->state),
- (XW_XD (xw))))));
- VECTOR_SET (result, EVENT_2, (ulong_to_integer (keysym)));
- EVENT_ULONG_INTEGER (result, EVENT_3, (event->time));
- return (result);
-}
-
-#define CONVERT_TRIVIAL_EVENT(scheme_name) \
- if (EVENT_ENABLED (xw, scheme_name)) \
- result = (make_event_object (xw, scheme_name, 0)); \
- break
-
-static SCHEME_OBJECT
-x_event_to_object (XEvent * event)
-{
- struct xwindow * xw
- = (x_window_to_xw (((event->xany) . display),
- ((event->xany) . window)));
- SCHEME_OBJECT result = SHARP_F;
- if (xw == 0)
- return result;
- switch (event->type)
- {
- case KeyPress:
- if (EVENT_ENABLED (xw, event_type_key_press))
- result = (key_event (xw, (& (event->xkey)), event_type_key_press));
- break;
- case ButtonPress:
- if (EVENT_ENABLED (xw, event_type_button_down))
- result
- = (button_event (xw, (& (event->xbutton)), event_type_button_down));
- break;
- case ButtonRelease:
- if (EVENT_ENABLED (xw, event_type_button_up))
- result
- = (button_event (xw, (& (event->xbutton)), event_type_button_up));
- break;
- case MotionNotify:
- if (EVENT_ENABLED (xw, event_type_motion))
- {
- result = (make_event_object (xw, event_type_motion, 3));
- EVENT_INTEGER (result, EVENT_0, ((event->xmotion) . x));
- EVENT_INTEGER (result, EVENT_1, ((event->xmotion) . y));
- VECTOR_SET (result, EVENT_2,
- (x_key_button_mask_to_scheme
- (((event->xmotion) . state))));
- }
- break;
- case ConfigureNotify:
- if (EVENT_ENABLED (xw, event_type_configure))
- {
- result = (make_event_object (xw, event_type_configure, 2));
- EVENT_ULONG_INTEGER
- (result, EVENT_0, ((event->xconfigure) . width));
- EVENT_ULONG_INTEGER
- (result, EVENT_1, ((event->xconfigure) . height));
- }
- break;
- case Expose:
- if (EVENT_ENABLED (xw, event_type_expose))
- {
- result = (make_event_object (xw, event_type_expose, 5));
- EVENT_INTEGER (result, EVENT_0, ((event->xexpose) . x));
- EVENT_INTEGER (result, EVENT_1, ((event->xexpose) . y));
- EVENT_ULONG_INTEGER (result, EVENT_2, ((event->xexpose) . width));
- EVENT_ULONG_INTEGER (result, EVENT_3, ((event->xexpose) . height));
- VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (0)));
- }
- break;
- case GraphicsExpose:
- if (EVENT_ENABLED (xw, event_type_expose))
- {
- result = (make_event_object (xw, event_type_expose, 5));
- EVENT_INTEGER (result, EVENT_0, ((event->xgraphicsexpose) . x));
- EVENT_INTEGER (result, EVENT_1, ((event->xgraphicsexpose) . y));
- EVENT_ULONG_INTEGER
- (result, EVENT_2, ((event->xgraphicsexpose) . width));
- EVENT_ULONG_INTEGER
- (result, EVENT_3, ((event->xgraphicsexpose) . height));
- VECTOR_SET (result, EVENT_4, (LONG_TO_UNSIGNED_FIXNUM (1)));
- }
- break;
- case ClientMessage:
- {
- struct xdisplay * xd = (XW_XD (xw));
- if ((((event->xclient) . message_type) == (XD_WM_PROTOCOLS (xd)))
- && (((event->xclient) . format) == 32))
- {
- if (((Atom) (((event->xclient) . data . l) [0]))
- == (XD_WM_DELETE_WINDOW (xd)))
- {
- if (EVENT_ENABLED (xw, event_type_delete_window))
- result
- = (make_event_object (xw, event_type_delete_window, 0));
- }
- else if (((Atom) (((event->xclient) . data . l) [0]))
- == (XD_WM_TAKE_FOCUS (xd)))
- {
- if (EVENT_ENABLED (xw, event_type_take_focus))
- {
- result
- = (make_event_object (xw, event_type_take_focus, 1));
- EVENT_ULONG_INTEGER
- (result, EVENT_0, (((event->xclient) . data . l) [1]));
- }
- }
- }
- }
- break;
- case VisibilityNotify:
- if (EVENT_ENABLED (xw, event_type_visibility))
- {
- unsigned int state;
- switch ((event->xvisibility) . state)
- {
- case VisibilityUnobscured:
- state = 0;
- break;
- case VisibilityPartiallyObscured:
- state = 1;
- break;
- case VisibilityFullyObscured:
- state = 2;
- break;
- default:
- state = 3;
- break;
- }
- result = (make_event_object (xw, event_type_visibility, 1));
- EVENT_ULONG_INTEGER (result, EVENT_0, state);
- }
- break;
- case SelectionClear:
- if (EVENT_ENABLED (xw, event_type_selection_clear))
- {
- result = (make_event_object (xw, event_type_selection_clear, 2));
- EVENT_ULONG_INTEGER
- (result, EVENT_0, ((event->xselectionclear) . selection));
- EVENT_ULONG_INTEGER
- (result, EVENT_1, ((event->xselectionclear) . time));
- }
- break;
- case SelectionNotify:
- if (EVENT_ENABLED (xw, event_type_selection_notify))
- {
- result = (make_event_object (xw, event_type_selection_notify, 5));
- EVENT_ULONG_INTEGER
- (result, EVENT_0, ((event->xselection) . requestor));
- EVENT_ULONG_INTEGER
- (result, EVENT_1, ((event->xselection) . selection));
- EVENT_ULONG_INTEGER
- (result, EVENT_2, ((event->xselection) . target));
- EVENT_ULONG_INTEGER
- (result, EVENT_3, ((event->xselection) . property));
- EVENT_ULONG_INTEGER
- (result, EVENT_4, ((event->xselection) . time));
- }
- break;
- case SelectionRequest:
- if (EVENT_ENABLED (xw, event_type_selection_request))
- {
- result = (make_event_object (xw, event_type_selection_request, 5));
- EVENT_ULONG_INTEGER
- (result, EVENT_0, ((event->xselectionrequest) . requestor));
- EVENT_ULONG_INTEGER
- (result, EVENT_1, ((event->xselectionrequest) . selection));
- EVENT_ULONG_INTEGER
- (result, EVENT_2, ((event->xselectionrequest) . target));
- EVENT_ULONG_INTEGER
- (result, EVENT_3, ((event->xselectionrequest) . property));
- EVENT_ULONG_INTEGER
- (result, EVENT_4, ((event->xselectionrequest) . time));
- }
- break;
- case PropertyNotify:
- if (EVENT_ENABLED (xw, event_type_property_notify))
- {
- result = (make_event_object (xw, event_type_property_notify, 4));
- /* Must store window element separately because this window
- might not have a corresponding XW object. */
- EVENT_ULONG_INTEGER
- (result, EVENT_0, ((event->xproperty) . window));
- EVENT_ULONG_INTEGER
- (result, EVENT_1, ((event->xproperty) . atom));
- EVENT_ULONG_INTEGER
- (result, EVENT_2, ((event->xproperty) . time));
- EVENT_ULONG_INTEGER
- (result, EVENT_3, ((event->xproperty) . state));
- }
- break;
- case EnterNotify: CONVERT_TRIVIAL_EVENT (event_type_enter);
- case LeaveNotify: CONVERT_TRIVIAL_EVENT (event_type_leave);
- case FocusIn: CONVERT_TRIVIAL_EVENT (event_type_focus_in);
- case FocusOut: CONVERT_TRIVIAL_EVENT (event_type_focus_out);
- case MapNotify: CONVERT_TRIVIAL_EVENT (event_type_map);
- case UnmapNotify: CONVERT_TRIVIAL_EVENT (event_type_unmap);
- }
- return (result);
-}
-
-static void
-update_input_mask (struct xwindow * xw)
-{
- {
- unsigned long event_mask = 0;
- if (EVENT_ENABLED (xw, event_type_expose))
- event_mask |= ExposureMask;
- if ((EVENT_ENABLED (xw, event_type_configure))
- || (EVENT_ENABLED (xw, event_type_map))
- || (EVENT_ENABLED (xw, event_type_unmap)))
- event_mask |= StructureNotifyMask;
- if (EVENT_ENABLED (xw, event_type_button_down))
- event_mask |= ButtonPressMask;
- if (EVENT_ENABLED (xw, event_type_button_up))
- event_mask |= ButtonReleaseMask;
- if (EVENT_ENABLED (xw, event_type_key_press))
- event_mask |= KeyPressMask;
- if (EVENT_ENABLED (xw, event_type_enter))
- event_mask |= EnterWindowMask;
- if (EVENT_ENABLED (xw, event_type_leave))
- event_mask |= LeaveWindowMask;
- if ((EVENT_ENABLED (xw, event_type_focus_in))
- || (EVENT_ENABLED (xw, event_type_focus_out)))
- event_mask |= FocusChangeMask;
- if (EVENT_ENABLED (xw, event_type_motion))
- event_mask |= (PointerMotionMask | PointerMotionHintMask);
- if (EVENT_ENABLED (xw, event_type_visibility))
- event_mask |= VisibilityChangeMask;
- if (EVENT_ENABLED (xw, event_type_property_notify))
- event_mask |= PropertyChangeMask;
- XSelectInput ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), event_mask);
- }
- {
- struct xdisplay * xd = (XW_XD (xw));
- Atom protocols [2];
- unsigned int n_protocols = 0;
- if (EVENT_ENABLED (xw, event_type_delete_window))
- (protocols[n_protocols++]) = (XD_WM_DELETE_WINDOW (xd));
- if (EVENT_ENABLED (xw, event_type_take_focus))
- (protocols[n_protocols++]) = (XD_WM_TAKE_FOCUS (xd));
- if (n_protocols > 0)
- XSetWMProtocols
- ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&protocols[0]), n_protocols);
- }
-}
-
-static void
-ping_server (struct xdisplay * xd)
-{
- /* Periodically ping the server connection to see if it has died. */
- (XD_SERVER_PING_TIMER (xd)) += 1;
- if ((XD_SERVER_PING_TIMER (xd)) >= 100)
- {
- (XD_SERVER_PING_TIMER (xd)) = 0;
- XNoOp (XD_DISPLAY (xd));
- XFlush (XD_DISPLAY (xd));
- }
-}
-
-/* The use of `XD_CACHED_EVENT' prevents an event from being lost due
- to garbage collection. First `XD_CACHED_EVENT' is set to hold the
- current event, then the allocations are performed. If one of them
- fails, the primitive will exit, and when it reenters it will notice
- the cached event and use it. It is important that this be the only
- entry that reads events -- or else that all other event readers
- cooperate with this strategy. */
-
-static SCHEME_OBJECT
-xd_process_events (struct xdisplay * xd)
-{
- Display * display = (XD_DISPLAY (xd));
- unsigned int events_queued;
- XEvent event;
- SCHEME_OBJECT result = SHARP_F;
- if (x_debug > 1)
- {
- fprintf (stderr, "Enter xd_process_events\n");
- fflush (stderr);
- }
- if (XD_CACHED_EVENT_P (xd))
- {
- events_queued = (XEventsQueued (display, QueuedAlready));
- event = (XD_CACHED_EVENT (xd));
- goto restart;
- }
- ping_server (xd);
- events_queued = (XEventsQueued (display, QueuedAfterReading));
- while (0 < events_queued)
- {
- events_queued -= 1;
- XNextEvent (display, (&event));
- if ((event.type) == KeymapNotify)
- continue;
- {
- struct xwindow * xw
- = (x_window_to_xw (display, (event.xany.window)));
- if ((xw == 0)
- && (! (((event.type) == PropertyNotify)
- || ((event.type) == SelectionClear)
- || ((event.type) == SelectionNotify)
- || ((event.type) == SelectionRequest))))
- continue;
- if (xw_process_event (xw, (&event)))
- continue;
- }
- (XD_CACHED_EVENT (xd)) = event;
- (XD_CACHED_EVENT_P (xd)) = 1;
- restart:
- result = (x_event_to_object (&event));
- (XD_CACHED_EVENT_P (xd)) = 0;
- if (result != SHARP_F)
- break;
- }
- if (x_debug > 1)
- {
- fprintf (stderr, "Return from xd_process_events: ");
- if (result == SHARP_F)
- fprintf (stderr, "#f");
- else if (VECTOR_P (result))
- fprintf (stderr, "[vector]");
- else
- fprintf (stderr, "[other: 0x%lx]", ((unsigned long) result));
- fprintf (stderr, "\n");
- fflush (stderr);
- }
- return (result);
-}
-\f
-/* Open/Close Primitives */
-
-static void
-initialize_once (void)
-{
- allocation_table_initialize (&x_display_table);
- allocation_table_initialize (&x_window_table);
- allocation_table_initialize (&x_image_table);
- ((x_error_info.message) [0]) = '\0';
- (x_error_info.terminate_p) = 1;
- (x_error_info.code) = 0;
- XSetErrorHandler (x_error_handler);
- XSetIOErrorHandler (x_io_error_handler);
-#ifndef COMPILE_AS_MODULE
- add_reload_cleanup (x_close_all_displays);
-#endif
- initialization_done = 1;
-}
-
-DEFINE_PRIMITIVE ("X-DEBUG", Prim_x_debug, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT object = (ARG_REF (1));
- if (object == SHARP_F)
- x_debug = 0;
- else if (UNSIGNED_FIXNUM_P (object))
- x_debug = (UNSIGNED_FIXNUM_TO_LONG (object));
- else
- x_debug = 1;
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- INITIALIZE_ONCE ();
- {
- struct xdisplay * xd = (x_malloc (sizeof (struct xdisplay)));
- /* Added 7/95 by Nick in an attempt to fix problem Hal was having
- with SWAT over PPP (i.e. slow connections). */
- block_signals ();
- (XD_DISPLAY (xd))
- = (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? 0 : (STRING_ARG (1))));
- unblock_signals ();
- if ((XD_DISPLAY (xd)) == 0)
- {
- free (xd);
- PRIMITIVE_RETURN (SHARP_F);
- }
- (XD_ALLOCATION_INDEX (xd))
- = (allocate_table_index ((&x_display_table), xd));
- (XD_SERVER_PING_TIMER (xd)) = 0;
- (XD_WM_PROTOCOLS (xd))
- = (XInternAtom ((XD_DISPLAY (xd)), "WM_PROTOCOLS", False));
- (XD_WM_DELETE_WINDOW (xd))
- = (XInternAtom ((XD_DISPLAY (xd)), "WM_DELETE_WINDOW", False));
- (XD_WM_TAKE_FOCUS (xd))
- = (XInternAtom ((XD_DISPLAY (xd)), "WM_TAKE_FOCUS", False));
- (XD_CACHED_EVENT_P (xd)) = 0;
- x_initialize_display_modifier_masks (xd);
- XRebindKeysym ((XD_DISPLAY (xd)), XK_BackSpace, 0, 0,
- ((unsigned char *) "\177"), 1);
- PRIMITIVE_RETURN (XD_TO_OBJECT (xd));
- }
-}
-
-DEFINE_PRIMITIVE ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- x_close_display (x_display_arg (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- INITIALIZE_ONCE ();
- x_close_all_displays ();
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-GET-SIZE", Prim_x_display_get_size, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Display * display = (XD_DISPLAY (xd));
- long screen = (arg_nonnegative_integer (2));
- PRIMITIVE_RETURN
- (cons ((ulong_to_integer (DisplayWidth (display, screen))),
- (ulong_to_integer (DisplayHeight (display, screen)))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- x_close_window (xw);
- XFlush (display);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-SET-DEFAULT-FONT", Prim_x_set_default_font, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Display * display = (XD_DISPLAY (xd));
- const char * name = (STRING_ARG (2));
- XFontStruct * font = (XLoadQueryFont (display, name));
- if (font == 0)
- PRIMITIVE_RETURN (SHARP_F);
- XFreeFont (display, font);
- if (x_default_font != 0)
- OS_free ((void *) x_default_font);
- {
- char * copy = (OS_malloc ((strlen (name)) + 1));
- const char * s1 = name;
- char * s2 = copy;
- while (1)
- {
- char c = (*s1++);
- (*s2++) = c;
- if (c == '\0')
- break;
- }
- x_default_font = copy;
- }
- }
- PRIMITIVE_RETURN (SHARP_T);
-}
-\f
-/* Event Processing Primitives */
-
-DEFINE_PRIMITIVE ("X-DISPLAY-DESCRIPTOR", Prim_x_display_descriptor, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (long_to_integer (ConnectionNumber (XD_DISPLAY (x_display_arg (1)))));
-}
-
-DEFINE_PRIMITIVE ("X-MAX-REQUEST-SIZE", Prim_x_max_request_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN
- (long_to_integer (XMaxRequestSize (XD_DISPLAY (x_display_arg (1)))));
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xdisplay * xd = (x_display_arg (1));
- SCHEME_OBJECT how = (ARG_REF (2));
- /* Previously, the `how' argument could be #F (block, select), 0
- (don't block, select), 1 (block, don't select), 2 (don't block,
- don't select). Now we never select or block -- it is up to the
- caller to do that. #F and 0 have been unused for a long time,
- and the only caller that used 1 in the system already selected
- and blocked anyway. */
- if ((how != (LONG_TO_UNSIGNED_FIXNUM (1)))
- && (how != (LONG_TO_UNSIGNED_FIXNUM (2))))
- error_bad_range_arg (2);
- PRIMITIVE_RETURN (xd_process_events (xd));
- }
-}
-
-DEFINE_PRIMITIVE ("X-SELECT-INPUT", Prim_x_select_input, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- XSelectInput ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2)),
- (arg_integer (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_EVENT_MASK (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- (XW_EVENT_MASK (xw)) = (EVENT_MASK_ARG (2));
- update_input_mask (xw);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- (XW_EVENT_MASK (xw)) |= (EVENT_MASK_ARG (2));
- update_input_mask (xw);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- (XW_EVENT_MASK (xw)) &=~ (EVENT_MASK_ARG (2));
- update_input_mask (xw);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Miscellaneous Primitives */
-
-DEFINE_PRIMITIVE ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (XD_TO_OBJECT (XW_XD (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_X_SIZE (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_Y_SIZE (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- XBell ((XW_DISPLAY (x_window_arg (1))), 0); /* base value */
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- if (((XW_CLIP_X (xw)) == 0)
- && ((XW_CLIP_Y (xw)) == 0)
- && ((XW_CLIP_WIDTH (xw)) == (XW_X_SIZE (xw)))
- && ((XW_CLIP_HEIGHT (xw)) == (XW_Y_SIZE (xw))))
- XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- else
- XClearArea ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- ((XW_CLIP_X (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
- ((XW_CLIP_Y (xw)) + (XW_INTERNAL_BORDER_WIDTH (xw))),
- (XW_CLIP_WIDTH (xw)),
- (XW_CLIP_HEIGHT (xw)),
- False);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- XFlush (XD_DISPLAY (x_display_arg (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- XFlush (XW_DISPLAY (x_window_arg (1)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- XSync ((XD_DISPLAY (x_display_arg (1))), (BOOLEAN_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- char * result
- = (XGetDefault ((XD_DISPLAY (x_display_arg (1))),
- (STRING_ARG (2)),
- (STRING_ARG (3))));
- PRIMITIVE_RETURN
- ((result == 0)
- ? SHARP_F
- : (char_pointer_to_string (result)));
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- int rx = (arg_integer (2));
- int ry = (arg_integer (3));
- int wx;
- int wy;
- Window child;
- if (! (XTranslateCoordinates
- (display,
- (RootWindow (display, (DefaultScreen (display)))),
- (XW_WINDOW (xw)),
- rx, ry, (&wx), (&wy), (&child))))
- error_bad_range_arg (1);
- SET_PAIR_CAR (result, (long_to_integer (wx)));
- SET_PAIR_CDR (result, (long_to_integer (wy)));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- SCHEME_OBJECT result = (cons (SHARP_F, SHARP_F));
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- int wx = (arg_integer (2));
- int wy = (arg_integer (3));
- int rx;
- int ry;
- Window child;
- if (! (XTranslateCoordinates
- (display,
- (XW_WINDOW (xw)),
- (RootWindow (display, (DefaultScreen (display)))),
- wx, wy, (&rx), (&ry), (&child))))
- error_bad_range_arg (1);
- SET_PAIR_CAR (result, (long_to_integer (rx)));
- SET_PAIR_CDR (result, (long_to_integer (ry)));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, 1));
- struct xwindow * xw = (x_window_arg (1));
- Window root;
- Window child;
- int root_x;
- int root_y;
- int win_x;
- int win_y;
- unsigned int keys_buttons;
- if (!XQueryPointer ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (&root), (&child),
- (&root_x), (&root_y),
- (&win_x), (&win_y),
- (&keys_buttons)))
- PRIMITIVE_RETURN (SHARP_F);
- VECTOR_SET (result, 0, (long_to_integer (root_x)));
- VECTOR_SET (result, 1, (long_to_integer (root_y)));
- VECTOR_SET (result, 2, (long_to_integer (win_x)));
- VECTOR_SET (result, 3, (long_to_integer (win_y)));
- VECTOR_SET (result, 4, (x_key_button_mask_to_scheme (keys_buttons)));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-ID", Prim_x_window_id, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_WINDOW (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("X-ID->WINDOW", Prim_x_id_to_window, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw
- = (x_window_to_xw ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2))));
- PRIMITIVE_RETURN ((xw == 0) ? SHARP_F : (XW_TO_OBJECT (xw)));
- }
-}
-\f
-/* Appearance Control Primitives */
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned long foreground_pixel = (arg_window_color (2, display, xw));
- (XW_FOREGROUND_PIXEL (xw)) = foreground_pixel;
- XSetForeground (display, (XW_NORMAL_GC (xw)), foreground_pixel);
- XSetBackground (display, (XW_REVERSE_GC (xw)), foreground_pixel);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned long background_pixel = (arg_window_color (2, display, xw));
- (XW_BACKGROUND_PIXEL (xw)) = background_pixel;
- XSetWindowBackground (display, (XW_WINDOW (xw)), background_pixel);
- XSetBackground (display, (XW_NORMAL_GC (xw)), background_pixel);
- XSetForeground (display, (XW_REVERSE_GC (xw)), background_pixel);
- XSetForeground (display, (XW_CURSOR_GC (xw)), background_pixel);
- x_set_mouse_colors (display,
- (xw_color_map (xw)),
- (XW_MOUSE_CURSOR (xw)),
- (XW_MOUSE_PIXEL (xw)),
- background_pixel);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned long border_pixel = (arg_window_color (2, display, xw));
- (XW_BORDER_PIXEL (xw)) = border_pixel;
- XSetWindowBorder (display, (XW_WINDOW (xw)), border_pixel);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned long cursor_pixel = (arg_window_color (2, display, xw));
- (XW_CURSOR_PIXEL (xw)) = cursor_pixel;
- XSetBackground (display, (XW_CURSOR_GC (xw)), cursor_pixel);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned long mouse_pixel = (arg_window_color (2, display, xw));
- (XW_MOUSE_PIXEL (xw)) = mouse_pixel;
- x_set_mouse_colors (display,
- (xw_color_map (xw)),
- (XW_MOUSE_CURSOR (xw)),
- mouse_pixel,
- (XW_BACKGROUND_PIXEL (xw)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- Window window = (XW_WINDOW (xw));
- {
- Cursor old_cursor = (XW_MOUSE_CURSOR (xw));
- Cursor mouse_cursor
- = (XCreateFontCursor
- (display, (2 * (arg_index_integer (2, (XC_num_glyphs / 2))))));
- x_set_mouse_colors (display,
- (xw_color_map (xw)),
- mouse_cursor,
- (XW_MOUSE_PIXEL (xw)),
- (XW_BACKGROUND_PIXEL (xw)));
- (XW_MOUSE_CURSOR (xw)) = mouse_cursor;
- XDefineCursor (display, window, mouse_cursor);
- XFreeCursor (display, old_cursor);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- XFontStruct * font = (XLoadQueryFont (display, (STRING_ARG (2))));
- if (font == 0)
- PRIMITIVE_RETURN (SHARP_F);
- XFreeFont (display, (XW_FONT (xw)));
- (XW_FONT (xw)) = font;
- {
- Font fid = (font->fid);
- XSetFont (display, (XW_NORMAL_GC (xw)), fid);
- XSetFont (display, (XW_REVERSE_GC (xw)), fid);
- XSetFont (display, (XW_CURSOR_GC (xw)), fid);
- }
- if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
- (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
- }
- PRIMITIVE_RETURN (SHARP_T);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned int border_width = (arg_nonnegative_integer (2));
- (XW_BORDER_WIDTH (xw)) = border_width;
- XSetWindowBorderWidth (display, (XW_WINDOW (xw)), border_width);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int internal_border_width = (arg_nonnegative_integer (2));
- (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width;
- if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
- (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
- XResizeWindow ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- ((XW_X_SIZE (xw)) + (2 * internal_border_width)),
- ((XW_Y_SIZE (xw)) + (2 * internal_border_width)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* WM Communication Primitives */
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2,
- "Set the name of WINDOW to STRING.")
-{
- PRIMITIVE_HEADER (2);
- xw_set_wm_name ((x_window_arg (1)), (STRING_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2,
- "Set the icon name of WINDOW to STRING.")
-{
- PRIMITIVE_HEADER (2);
- xw_set_wm_icon_name ((x_window_arg (1)), (STRING_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3,
- "Set the class hint of WINDOW to RESOURCE_NAME and RESOURCE_CLASS.")
-{
- PRIMITIVE_HEADER (3);
- xw_set_class_hint ((x_window_arg (1)), (STRING_ARG (2)), (STRING_ARG (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2,
- "Set the input hint of WINDOW to INPUT.")
-{
- PRIMITIVE_HEADER (2);
- xw_set_wm_input_hint ((x_window_arg (1)), (BOOLEAN_ARG (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- void * handle = (push_x_error_info (display));
-
- XSetInputFocus (display,
- (XW_WINDOW (xw)),
- RevertToParent,
- ((Time) (arg_ulong_integer (2))));
- if (any_x_errors_p (display))
- {
- pop_x_error_info (handle);
- error_bad_range_arg (1);
- }
- pop_x_error_info (handle);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2,
- "Set the transient-for hint of WINDOW to PRIMARY-WINDOW.")
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- struct xwindow * transient_for = (x_window_arg (2));
- if ((xw == transient_for) || ((XW_XD (xw)) != (XW_XD (transient_for))))
- error_bad_range_arg (2);
- XSetTransientForHint
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_WINDOW (transient_for)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* WM Control Primitives */
-
-DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XMapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- XIconifyWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- XWithdrawWindow (display, (XW_WINDOW (xw)), (DefaultScreen (display)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* The following shouldn't be used on top-level windows. Instead use
- ICONIFY or WITHDRAW. */
-DEFINE_PRIMITIVE ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XUnmapWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
- XResizeWindow ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- ((arg_ulong_integer (2)) + extra),
- ((arg_ulong_integer (3)) + extra));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XRaiseWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XLowerWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("X-WINDOW-GET-SIZE", Prim_x_window_get_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int extra;
-
- get_wm_decor_geometry (xw);
- extra = (2 * (XW_WM_DECOR_BORDER_WIDTH (xw)));
- PRIMITIVE_RETURN
- (cons ((ulong_to_integer ((XW_WM_DECOR_PIXEL_WIDTH (xw)) + extra)),
- (ulong_to_integer ((XW_WM_DECOR_PIXEL_HEIGHT (xw)) + extra))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-GET-POSITION", Prim_x_window_get_position, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- get_wm_decor_geometry (xw);
- PRIMITIVE_RETURN (cons ((long_to_integer (XW_WM_DECOR_X (xw))),
- (long_to_integer (XW_WM_DECOR_Y (xw)))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- move_window ((x_window_arg (1)),
- (arg_integer (2)),
- (arg_integer (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-move_window (struct xwindow * xw, int x, int y)
-{
- if ((XW_UPDATE_NORMAL_HINTS (xw)) != 0)
- (* (XW_UPDATE_NORMAL_HINTS (xw))) (xw);
- if ((XW_WM_TYPE (xw)) == X_WMTYPE_A)
- {
- x += (XW_MOVE_OFFSET_X (xw));
- y += (XW_MOVE_OFFSET_Y (xw));
- }
- XMoveWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), x, y);
- if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN)
- {
- (XW_EXPECTED_X (xw)) = x;
- (XW_EXPECTED_Y (xw)) = y;
- (XW_CHECK_EXPECTED_MOVE_P (xw)) = 1;
- }
-}
-
-static void
-check_expected_move (struct xwindow * xw)
-{
- if (((XW_WM_DECOR_X (xw)) == (XW_EXPECTED_X (xw)))
- && ((XW_WM_DECOR_Y (xw)) == (XW_EXPECTED_Y (xw))))
- {
- if ((XW_WM_TYPE (xw)) == X_WMTYPE_UNKNOWN)
- (XW_WM_TYPE (xw)) = X_WMTYPE_B;
- }
- else
- {
- (XW_WM_TYPE (xw)) = X_WMTYPE_A;
- (XW_MOVE_OFFSET_X (xw)) = ((XW_EXPECTED_X (xw)) - (XW_WM_DECOR_X (xw)));
- (XW_MOVE_OFFSET_Y (xw)) = ((XW_EXPECTED_Y (xw)) - (XW_WM_DECOR_Y (xw)));
- move_window (xw, (XW_EXPECTED_X (xw)), (XW_EXPECTED_Y (xw)));
- }
- (XW_CHECK_EXPECTED_MOVE_P (xw)) = 0;
-}
-\f
-/* Font Structure Primitive */
-
-#define FONT_STRUCTURE_MAX_CONVERTED_SIZE (10+1 + 256+1 + ((5+1) * (256+2)))
- /* font-structure-words +
- char-struct-vector +
- char-struct-words * maximum-number-possible */
-
-static SCHEME_OBJECT
-convert_char_struct (XCharStruct * char_struct)
-{
- if (((char_struct->lbearing) == 0)
- && ((char_struct->rbearing) == 0)
- && ((char_struct->width) == 0)
- && ((char_struct->ascent) == 0)
- && ((char_struct->descent) == 0))
- return (SHARP_F);
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 5, true));
- VECTOR_SET (result, 0, (long_to_integer (char_struct->lbearing)));
- VECTOR_SET (result, 1, (long_to_integer (char_struct->rbearing)));
- VECTOR_SET (result, 2, (long_to_integer (char_struct->width)));
- VECTOR_SET (result, 3, (long_to_integer (char_struct->ascent)));
- VECTOR_SET (result, 4, (long_to_integer (char_struct->descent)));
- return (result);
- }
-}
-
-static SCHEME_OBJECT
-convert_font_struct (SCHEME_OBJECT font_name, XFontStruct * font)
-{
- SCHEME_OBJECT result;
- if (font == 0)
- return SHARP_F;
- /* Handle only 8-bit fonts because of laziness. */
- if (((font->min_byte1) != 0) || ((font->max_byte1) != 0))
- return SHARP_F;
-
- result = (allocate_marked_vector (TC_VECTOR, 10, true));
- if ((font->per_char) == 0)
- VECTOR_SET (result, 6, SHARP_F);
- else
- {
- unsigned int start_index = (font->min_char_or_byte2);
- unsigned int length = ((font->max_char_or_byte2) - start_index + 1);
- SCHEME_OBJECT character_vector
- = (allocate_marked_vector (TC_VECTOR, length, true));
- unsigned int index;
- for (index = 0; (index < length); index += 1)
- VECTOR_SET (character_vector,
- index,
- (convert_char_struct ((font->per_char) + index)));
- VECTOR_SET (result, 6, (ulong_to_integer (start_index)));
- VECTOR_SET (result, 7, character_vector);
- }
- VECTOR_SET (result, 0, font_name);
- VECTOR_SET (result, 1, (ulong_to_integer (font->direction)));
- VECTOR_SET (result, 2,
- (BOOLEAN_TO_OBJECT ((font->all_chars_exist) == True)));
- VECTOR_SET (result, 3, (ulong_to_integer (font->default_char)));
- VECTOR_SET (result, 4, (convert_char_struct (& (font->min_bounds))));
- VECTOR_SET (result, 5, (convert_char_struct (& (font->max_bounds))));
- VECTOR_SET (result, 8, (long_to_integer (font->ascent)));
- VECTOR_SET (result, 9, (long_to_integer (font->descent)));
-
- return result;
-}
-
-DEFINE_PRIMITIVE ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2,
- "(DISPLAY FONT)\n\
-FONT is either a font name or a font ID.")
-{
- PRIMITIVE_HEADER (2);
- Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE);
- {
- SCHEME_OBJECT font_name = (ARG_REF (2));
- Display * display = (XD_DISPLAY (x_display_arg (1)));
- XFontStruct * font = 0;
- bool by_name = STRING_P (font_name);
- SCHEME_OBJECT result;
-
- if (by_name)
- font = XLoadQueryFont (display, (STRING_POINTER (font_name)));
- else
- font = XQueryFont (display, ((XID) (integer_to_ulong (ARG_REF (2)))));
-
- if (font == 0)
- PRIMITIVE_RETURN (SHARP_F);
-
- result = convert_font_struct (font_name, font);
-
- if (by_name)
- XFreeFont (display, font);
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1,
- "(X-WINDOW)\n\
-Returns the font-structure for the font currently associated with X-WINDOW.")
-{
- XFontStruct *font;
- PRIMITIVE_HEADER (1);
- Primitive_GC_If_Needed (FONT_STRUCTURE_MAX_CONVERTED_SIZE);
- font = XW_FONT (x_window_arg (1));
- PRIMITIVE_RETURN (convert_font_struct (ulong_to_integer (font->fid), font));
-}
-
-DEFINE_PRIMITIVE ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3,
- "(DISPLAY PATTERN LIMIT)\n\
-LIMIT is an exact non-negative integer or #F for no limit.\n\
-Returns #F or a vector of at least one string.")
-{
- PRIMITIVE_HEADER (1);
- {
- int actual_count = 0;
- char ** names
- = (XListFonts ((XD_DISPLAY (x_display_arg (1))),
- (STRING_ARG (2)),
- ((FIXNUM_P (ARG_REF (3)))
- ? (FIXNUM_TO_LONG (ARG_REF (3)))
- : 1000000),
- (&actual_count)));
- if (names == 0)
- PRIMITIVE_RETURN (SHARP_F);
- {
- unsigned int words = (actual_count + 1); /* the vector of strings */
- unsigned int i;
- for (i = 0; (i < actual_count); i += 1)
- words += (STRING_LENGTH_TO_GC_LENGTH (strlen (names[i])));
- if (GC_NEEDED_P (words))
- {
- /* this causes the primitive to be restarted, so deallocate names */
- XFreeFontNames (names);
- Primitive_GC (words);
- /* notreached */
- }
- }
- {
- SCHEME_OBJECT result
- = (allocate_marked_vector (TC_VECTOR, actual_count, false));
- unsigned int i;
- for (i = 0; (i < actual_count); i += 1)
- VECTOR_SET (result, i, (char_pointer_to_string (names[i])));
- XFreeFontNames (names);
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-/* Atoms */
-
-DEFINE_PRIMITIVE ("X-INTERN-ATOM", Prim_x_intern_atom, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- PRIMITIVE_RETURN
- (ulong_to_integer (XInternAtom ((XD_DISPLAY (x_display_arg (1))),
- (STRING_ARG (2)),
- (BOOLEAN_ARG (3)))));
-}
-
-DEFINE_PRIMITIVE ("X-GET-ATOM-NAME", Prim_x_get_atom_name, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Display * display = (XD_DISPLAY (xd));
- void * handle = (push_x_error_info (display));
- char * name = (XGetAtomName (display, (arg_ulong_integer (2))));
- unsigned char error_code = (x_error_code (display));
- SCHEME_OBJECT result
- = ((error_code == 0)
- ? (char_pointer_to_string (name))
- : (ulong_to_integer (error_code)));
- if (name != 0)
- XFree (name);
- pop_x_error_info (handle);
- PRIMITIVE_RETURN (result);
- }
-}
-\f
-/* Window Properties */
-
-static SCHEME_OBJECT
-char_ptr_to_prop_data_32 (const unsigned char * data, unsigned long nitems)
-{
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
- unsigned long index;
- for (index = 0; (index < nitems); index += 1)
- VECTOR_SET (result, index, (ulong_to_integer ((CARD32) ((long *) data) [index])));
- return (result);
-}
-
-static SCHEME_OBJECT
-char_ptr_to_prop_data_16 (const unsigned char * data, unsigned long nitems)
-{
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, nitems, 1));
- unsigned long index;
- for (index = 0; (index < nitems); index += 1)
- VECTOR_SET (result, index, (ulong_to_integer (((CARD16 *) data) [index])));
- return (result);
-}
-
-static const unsigned char *
-prop_data_32_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return)
-{
- unsigned long nitems = (VECTOR_LENGTH (vector));
- unsigned long length = (nitems * 4);
- unsigned char * data = (dstack_alloc (length));
- unsigned long index;
- for (index = 0; (index < nitems); index += 1)
- {
- SCHEME_OBJECT n = (VECTOR_REF (vector, index));
- if (!integer_to_ulong_p (n))
- return (0);
- (((CARD32 *) data) [index]) = (integer_to_ulong (n));
- }
- (*length_return) = length;
- return (data);
-}
-
-static const unsigned char *
-prop_data_16_to_char_ptr (SCHEME_OBJECT vector, unsigned long * length_return)
-{
- unsigned long nitems = (VECTOR_LENGTH (vector));
- unsigned long length = (nitems * 2);
- unsigned char * data = (dstack_alloc (length));
- unsigned long index;
- for (index = 0; (index < nitems); index += 1)
- {
- SCHEME_OBJECT n = (VECTOR_REF (vector, index));
- unsigned long un;
- if (!integer_to_ulong_p (n))
- return (0);
- un = (integer_to_ulong (n));
- if (un >= 65536)
- return (0);
- (((CARD16 *) data) [index]) = un;
- }
- (*length_return) = length;
- return (data);
-}
-\f
-DEFINE_PRIMITIVE ("X-GET-WINDOW-PROPERTY", Prim_x_get_window_property, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- {
- Display * display = (XD_DISPLAY (x_display_arg (1)));
- Window window = (arg_ulong_integer (2));
- Atom property = (arg_ulong_integer (3));
- long long_offset = (arg_nonnegative_integer (4));
- long long_length = (arg_nonnegative_integer (5));
- Bool delete = (BOOLEAN_ARG (6));
- Atom req_type = (arg_ulong_integer (7));
-
- Atom actual_type;
- int actual_format;
- unsigned long nitems;
- unsigned long bytes_after;
- unsigned char * data;
-
- if ((XGetWindowProperty (display, window, property, long_offset,
- long_length, delete, req_type, (&actual_type),
- (&actual_format), (&nitems), (&bytes_after),
- (&data)))
- != Success)
- error_external_return ();
- if (actual_format == 0)
- {
- XFree (data);
- PRIMITIVE_RETURN (SHARP_F);
- }
- if (! ((actual_format == 8)
- || (actual_format == 16)
- || (actual_format == 32)))
- error_external_return ();
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, 1));
- VECTOR_SET (result, 0, (ulong_to_integer (actual_type)));
- VECTOR_SET (result, 1, (long_to_integer (actual_format)));
- VECTOR_SET (result, 2, (ulong_to_integer (bytes_after)));
- VECTOR_SET (result, 3,
- (((req_type != AnyPropertyType)
- && (req_type != actual_type))
- ? SHARP_F
- : (actual_format == 32)
- ? (char_ptr_to_prop_data_32 (data, nitems))
- : (actual_format == 16)
- ? (char_ptr_to_prop_data_16 (data, nitems))
- : (memory_to_string (nitems, data))));
- XFree (data);
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-DEFINE_PRIMITIVE ("X-CHANGE-PROPERTY", Prim_x_change_property, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- {
- Display * display = (XD_DISPLAY (x_display_arg (1)));
- Window window = (arg_ulong_integer (2));
- Atom property = (arg_ulong_integer (3));
- Atom type = (arg_ulong_integer (4));
- int format = (arg_nonnegative_integer (5));
- int mode = (arg_index_integer (6, 3));
- unsigned long dlen = 0;
- const unsigned char * data = 0;
- void * handle;
- unsigned char error_code;
-
- handle = (push_x_error_info (display));
- switch (format)
- {
- case 8:
- CHECK_ARG (7, STRING_P);
- data = (STRING_BYTE_PTR (ARG_REF (7)));
- dlen = (STRING_LENGTH (ARG_REF (7)));
- break;
- case 16:
- CHECK_ARG (7, VECTOR_P);
- data = (prop_data_16_to_char_ptr ((ARG_REF (7)), (&dlen)));
- if (data == 0)
- error_bad_range_arg (7);
- break;
- case 32:
- CHECK_ARG (7, VECTOR_P);
- data = (prop_data_32_to_char_ptr ((ARG_REF (7)), (&dlen)));
- if (data == 0)
- error_bad_range_arg (7);
- break;
- default:
- error_bad_range_arg (5);
- break;
- }
- XChangeProperty (display, window, property, type, format, mode, data, dlen);
- error_code = (x_error_code (display));
- pop_x_error_info (handle);
- PRIMITIVE_RETURN (ulong_to_integer (error_code));
- }
-}
-
-DEFINE_PRIMITIVE ("X-DELETE-PROPERTY", Prim_x_delete_property, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- XDeleteProperty ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/* Selections */
-
-DEFINE_PRIMITIVE ("X-SET-SELECTION-OWNER", Prim_x_set_selection_owner, 4, 4, 0)
-{
- PRIMITIVE_HEADER (4);
- XSetSelectionOwner ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)),
- (arg_ulong_integer (4)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GET-SELECTION-OWNER", Prim_x_get_selection_owner, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (ulong_to_integer (XGetSelectionOwner ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("X-CONVERT-SELECTION", Prim_x_convert_selection, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- XConvertSelection ((XD_DISPLAY (x_display_arg (1))),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)),
- (arg_ulong_integer (4)),
- (arg_ulong_integer (5)),
- (arg_ulong_integer (6)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-SEND-SELECTION-NOTIFY", Prim_x_send_selection_notify, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Window requestor = (arg_ulong_integer (2));
- XSelectionEvent event;
- (event.type) = SelectionNotify;
- (event.display) = (XD_DISPLAY (xd));
- (event.requestor) = requestor;
- (event.selection) = (arg_ulong_integer (3));
- (event.target) = (arg_ulong_integer (4));
- (event.property) = (arg_ulong_integer (5));
- (event.time) = (arg_ulong_integer (6));
- XSendEvent ((XD_DISPLAY (xd)), requestor, False, 0, ((XEvent *) (&event)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#ifdef COMPILE_AS_MODULE
-
-/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \
- -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */
-
-void
-dload_initialize_x11base (void)
-{
- declare_primitive ("X-CHANGE-PROPERTY", Prim_x_change_property, 7, 7, 0);
- declare_primitive ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0);
- declare_primitive ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0);
- declare_primitive ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0);
- declare_primitive ("X-CONVERT-SELECTION", Prim_x_convert_selection, 6, 6, 0);
- declare_primitive ("X-DEBUG", Prim_x_debug, 1, 1, 0);
- declare_primitive ("X-DELETE-PROPERTY", Prim_x_delete_property, 3, 3, 0);
- declare_primitive ("X-DISPLAY-DESCRIPTOR", Prim_x_display_descriptor, 1, 1, 0);
- declare_primitive ("X-DISPLAY-FLUSH", Prim_x_display_flush, 1, 1, 0);
- declare_primitive ("X-DISPLAY-GET-DEFAULT", Prim_x_display_get_default, 3, 3, 0);
- declare_primitive ("X-DISPLAY-GET-SIZE", Prim_x_display_get_size, 2, 2, 0);
- declare_primitive ("X-DISPLAY-PROCESS-EVENTS", Prim_x_display_process_events, 2, 2, 0);
- declare_primitive ("X-DISPLAY-SYNC", Prim_x_display_sync, 2, 2, 0);
- declare_primitive ("X-FONT-STRUCTURE", Prim_x_font_structure, 2, 2, 0);
- declare_primitive ("X-GET-ATOM-NAME", Prim_x_get_atom_name, 2, 2, 0);
- declare_primitive ("X-GET-SELECTION-OWNER", Prim_x_get_selection_owner, 2, 2, 0);
- declare_primitive ("X-GET-WINDOW-PROPERTY", Prim_x_get_window_property, 7, 7, 0);
- declare_primitive ("X-ID->WINDOW", Prim_x_id_to_window, 2, 2, 0);
- declare_primitive ("X-INTERN-ATOM", Prim_x_intern_atom, 3, 3, 0);
- declare_primitive ("X-LIST-FONTS", Prim_x_list_fonts, 3, 3, 0);
- declare_primitive ("X-MAX-REQUEST-SIZE", Prim_x_max_request_size, 1, 1, 0);
- declare_primitive ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0);
- declare_primitive ("X-SELECT-INPUT", Prim_x_select_input, 3, 3, 0);
- declare_primitive ("X-SEND-SELECTION-NOTIFY", Prim_x_send_selection_notify, 6, 6, 0);
- declare_primitive ("X-SET-DEFAULT-FONT", Prim_x_set_default_font, 2, 2, 0);
- declare_primitive ("X-SET-SELECTION-OWNER", Prim_x_set_selection_owner, 4, 4, 0);
- declare_primitive ("X-WINDOW-ANDC-EVENT-MASK", Prim_x_window_andc_event_mask, 2, 2, 0);
- declare_primitive ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0);
- declare_primitive ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0);
- declare_primitive ("X-WINDOW-COORDS-LOCAL->ROOT", Prim_x_window_coords_local2root, 3, 3, 0);
- declare_primitive ("X-WINDOW-COORDS-ROOT->LOCAL", Prim_x_window_coords_root2local, 3, 3, 0);
- declare_primitive ("X-WINDOW-DISPLAY", Prim_x_window_display, 1, 1, 0);
- declare_primitive ("X-WINDOW-EVENT-MASK", Prim_x_window_event_mask, 1, 1, 0);
- declare_primitive ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0);
- declare_primitive ("X-WINDOW-FONT-STRUCTURE", Prim_x_window_font_structure, 1, 1, 0);
- declare_primitive ("X-WINDOW-GET-POSITION", Prim_x_window_get_position, 1, 1, 0);
- declare_primitive ("X-WINDOW-GET-SIZE", Prim_x_window_get_size, 1, 1, 0);
- declare_primitive ("X-WINDOW-ICONIFY", Prim_x_window_iconify, 1, 1, 0);
- declare_primitive ("X-WINDOW-ID", Prim_x_window_id, 1, 1, 0);
- declare_primitive ("X-WINDOW-LOWER", Prim_x_window_lower, 1, 1, 0);
- declare_primitive ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0);
- declare_primitive ("X-WINDOW-OR-EVENT-MASK", Prim_x_window_or_event_mask, 2, 2, 0);
- declare_primitive ("X-WINDOW-QUERY-POINTER", Prim_x_window_query_pointer, 1, 1, 0);
- declare_primitive ("X-WINDOW-RAISE", Prim_x_window_raise, 1, 1, 0);
- declare_primitive ("X-WINDOW-SET-BACKGROUND-COLOR", Prim_x_window_set_background_color, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-BORDER-COLOR", Prim_x_window_set_border_color, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-CLASS-HINT", Prim_x_window_set_class_hint, 3, 3, 0);
- declare_primitive ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-EVENT-MASK", Prim_x_window_set_event_mask, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-ICON-NAME", Prim_x_window_set_icon_name, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-INPUT-FOCUS", Prim_x_window_set_input_focus, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-INPUT-HINT", Prim_x_window_set_input_hint, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-INTERNAL-BORDER-WIDTH", Prim_x_window_set_internal_border_width, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-MOUSE-COLOR", Prim_x_window_set_mouse_color, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-MOUSE-SHAPE", Prim_x_window_set_mouse_shape, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-NAME", Prim_x_window_set_name, 2, 2, 0);
- declare_primitive ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0);
- declare_primitive ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0);
- declare_primitive ("X-WINDOW-SET-TRANSIENT-FOR-HINT", Prim_x_window_set_transient_for, 2, 2, 0);
- declare_primitive ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0);
- declare_primitive ("X-WINDOW-WITHDRAW", Prim_x_window_withdraw, 1, 1, 0);
- declare_primitive ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0);
- declare_primitive ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0);
-}
-
-void
-dload_finalize_x11base (void)
-{
- if (initialization_done)
- x_close_all_displays ();
-}
-
-#endif /* defined (COMPILE_AS_MODULE) */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Primitives for dealing with colors and color maps */
-
-#include "scheme.h"
-#include "prims.h"
-#include "x11.h"
-\f
-DEFINE_PRIMITIVE ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0)
-{
- PRIMITIVE_HEADER(1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XWindowAttributes a;
- if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
- error_external_return ();
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 23, true));
- VECTOR_SET (result, 0, (long_to_integer (a . x)));
- VECTOR_SET (result, 1, (long_to_integer (a . y)));
- VECTOR_SET (result, 2, (long_to_integer (a . width)));
- VECTOR_SET (result, 3, (long_to_integer (a . height)));
- VECTOR_SET (result, 4, (long_to_integer (a . border_width)));
- VECTOR_SET (result, 5, (long_to_integer (a . depth)));
- VECTOR_SET (result, 6, (X_VISUAL_TO_OBJECT (a . visual)));
- VECTOR_SET (result, 7, (long_to_integer (a . root)));
- VECTOR_SET (result, 8, (long_to_integer (a . class)));
- VECTOR_SET (result, 9, (long_to_integer (a . bit_gravity)));
- VECTOR_SET (result, 10, (long_to_integer (a . win_gravity)));
- VECTOR_SET (result, 11, (long_to_integer (a . backing_store)));
- VECTOR_SET (result, 12, (long_to_integer (a . backing_planes)));
- VECTOR_SET (result, 13, (long_to_integer (a . backing_pixel)));
- VECTOR_SET (result, 14, (BOOLEAN_TO_OBJECT (a . save_under)));
- VECTOR_SET (result, 15,
- (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw)))));
- VECTOR_SET (result, 16, (BOOLEAN_TO_OBJECT (a . map_installed)));
- VECTOR_SET (result, 17, (long_to_integer (a . map_state)));
- VECTOR_SET (result, 18, (long_to_integer (a . all_event_masks)));
- VECTOR_SET (result, 19, (long_to_integer (a . your_event_mask)));
- VECTOR_SET (result, 20, (long_to_integer (a . do_not_propagate_mask)));
- VECTOR_SET (result, 21, (BOOLEAN_TO_OBJECT (a . override_redirect)));
- VECTOR_SET (result, 22,
- (long_to_integer (XScreenNumberOfScreen (a . screen))));
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-/* Visuals */
-
-DEFINE_PRIMITIVE ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN
- (X_VISUAL_TO_OBJECT
- (XDefaultVisual ((XD_DISPLAY (x_display_arg (1))), (arg_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XWindowAttributes a;
- if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
- error_external_return ();
- PRIMITIVE_RETURN (X_VISUAL_TO_OBJECT (a . visual));
- }
-}
-
-DEFINE_PRIMITIVE ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- deallocate_x_visual (x_visual_arg (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0)
-/* Inputs: Scheme window or display
- (the remaining are either #F or a valid value)
- Visual-ID
- Screen number (or #F is window supplied)
- Depth
- Class
- Red-mask (integer)
- Green-mask (integer)
- Blue-mask (integer)
- Colormap size
- Bits per RGB
-
- Returns a vector of vectors, each of which has the following format:
- Visual (Scheme format, for use in later calls)
- Visual-ID
- Screen number
- Depth
- Class
- Red-mask (integer)
- Green-mask (integer)
- Blue-mask (integer)
- Colormap size
- Bits per RGB
-*/
-#define LOAD_IF(argno, type, field, mask_bit) \
- if (ARG_REF(argno) != SHARP_F) \
- { VI.field = type arg_integer(argno); \
- VIMask |= mask_bit; \
- }
-{ PRIMITIVE_HEADER (10);
- { Display *dpy;
- long ScreenNumber;
- XVisualInfo VI, *VIList, *ThisVI;
- long VIMask = VisualNoMask;
- long AnswerSize, i;
- int AnswerCount;
- SCHEME_OBJECT Result, This_Vector;
-
- if (ARG_REF(3) == SHARP_F)
- { struct xwindow * xw = x_window_arg (1);
- XWindowAttributes attrs;
-
- dpy = XW_DISPLAY(xw);
- XGetWindowAttributes(dpy, XW_WINDOW(xw), &attrs);
- ScreenNumber = XScreenNumberOfScreen(attrs.screen);
- }
- else
- { struct xdisplay * xd = x_display_arg (1);
- ScreenNumber = arg_integer(3);
- dpy = XD_DISPLAY(xd);
- }
- VI.screen = ScreenNumber;
- LOAD_IF(2, (VisualID), visualid, VisualIDMask);
- LOAD_IF(4, (unsigned int), depth, VisualDepthMask);
- LOAD_IF(5, (int), class, VisualClassMask);
- LOAD_IF(6, (unsigned long), red_mask, VisualRedMaskMask);
- LOAD_IF(7, (unsigned long), green_mask, VisualGreenMaskMask);
- LOAD_IF(8, (unsigned long), blue_mask, VisualBlueMaskMask);
- LOAD_IF(9, (int), colormap_size, VisualColormapSizeMask);
- LOAD_IF(10, (int), bits_per_rgb, VisualBitsPerRGBMask);
- VIList = XGetVisualInfo(dpy, VIMask, &VI, &AnswerCount);
- AnswerSize = (AnswerCount + 1) + (11 * AnswerCount);
- if (GC_NEEDED_P (AnswerSize))
- { XFree((void *) VIList);
- Primitive_GC (AnswerSize);
- }
- Result = allocate_marked_vector (TC_VECTOR, AnswerCount, false);
- for (i=0, ThisVI=VIList; i < AnswerCount; i++, ThisVI++)
- { This_Vector = allocate_marked_vector(TC_VECTOR, 10, false);
- VECTOR_SET(This_Vector, 0, (X_VISUAL_TO_OBJECT (ThisVI->visual)));
- VECTOR_SET(This_Vector, 1, long_to_integer((long) ThisVI->visualid));
- VECTOR_SET(This_Vector, 2, long_to_integer(ThisVI->screen));
- VECTOR_SET(This_Vector, 3, long_to_integer(ThisVI->depth));
- VECTOR_SET(This_Vector, 4, long_to_integer(ThisVI->class));
- VECTOR_SET(This_Vector, 5, long_to_integer(ThisVI->red_mask));
- VECTOR_SET(This_Vector, 6, long_to_integer(ThisVI->green_mask));
- VECTOR_SET(This_Vector, 7, long_to_integer(ThisVI->blue_mask));
- VECTOR_SET(This_Vector, 8, long_to_integer(ThisVI->colormap_size));
- VECTOR_SET(This_Vector, 9, long_to_integer(ThisVI->bits_per_rgb));
- VECTOR_SET(Result, i, This_Vector);
- }
- XFree((void *) VIList);
- PRIMITIVE_RETURN(Result);
- }
-}
-\f
-/* Colormaps */
-
-DEFINE_PRIMITIVE ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2,
- "Given DISPLAY and SCREEN-NUMBER, return default colormap for screen.")
-{
- PRIMITIVE_HEADER (2);
- {
- struct xdisplay * xd = (x_display_arg (1));
- PRIMITIVE_RETURN
- (X_COLORMAP_TO_OBJECT
- ((XDefaultColormap ((XD_DISPLAY (xd)), (arg_integer (2)))), xd));
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1,
- "Return WINDOW's colormap.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XWindowAttributes a;
- if (! (XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&a))))
- error_external_return ();
- PRIMITIVE_RETURN (X_COLORMAP_TO_OBJECT ((a . colormap), (XW_XD (xw))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2,
- "Set WINDOW's colormap to COLORMAP.")
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- XSetWindowColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
- (XCM_COLORMAP (x_colormap_arg (2))));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3,
- "Given WINDOW, and VISUAL, create and return a colormap.\n\
-If third arg WRITEABLE is true, returned colormap may be modified.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- PRIMITIVE_RETURN
- (X_COLORMAP_TO_OBJECT
- ((XCreateColormap ((XW_DISPLAY (xw)), (XW_WINDOW (xw)),
- (XV_VISUAL (x_visual_arg (2))), (BOOLEAN_ARG (3)))),
- (XW_XD (xw))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1,
- "Return a new copy of COLORMAP.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- PRIMITIVE_RETURN
- (X_COLORMAP_TO_OBJECT
- ((XCopyColormapAndFree ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)))),
- (XCM_XD (xcm))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1,
- "Deallocate COLORMAP.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- XFreeColormap ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)));
- deallocate_x_colormap (xcm);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#define ARG_RGB_VALUE(argno) (arg_index_integer ((argno), 65536))
-
-DEFINE_PRIMITIVE ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0)
-{
- /* Input: colormap, red, green, blue
- Returns: pixel, or #F if unable to allocate color cell. */
- PRIMITIVE_HEADER (4);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- XColor c;
- (c . red) = (ARG_RGB_VALUE (2));
- (c . green) = (ARG_RGB_VALUE (3));
- (c . blue) = (ARG_RGB_VALUE (4));
- PRIMITIVE_RETURN
- ((XAllocColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c)))
- ? (long_to_integer (c . pixel))
- : SHARP_F);
- }
-}
-
-DEFINE_PRIMITIVE ("X-STORE-COLOR", Prim_x_store_color, 5, 5,
- "Input: colormap, pixel, r, g, b (r/g/b may be #f).")
-{
- PRIMITIVE_HEADER (5);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- XColor c;
- (c . pixel) = (arg_nonnegative_integer (2));
- (c . flags) = 0;
- if ((ARG_REF (3)) != SHARP_F)
- {
- (c . red) = (arg_index_integer (3, 65536));
- (c . flags) |= DoRed;
- }
- if ((ARG_REF (4)) != SHARP_F)
- {
- (c . green) = (arg_index_integer (4, 65536));
- (c . flags) |= DoGreen;
- }
- if ((ARG_REF (5)) != SHARP_F)
- {
- (c . blue) = (arg_index_integer (5, 65536));
- (c . flags) |= DoBlue;
- }
- XStoreColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#define CONVERT_COLOR_OBJECT(index, color, flag) \
-{ \
- SCHEME_OBJECT object = (VECTOR_REF (color_object, (index))); \
- if (object != SHARP_F) \
- { \
- if (! ((INTEGER_P (object)) && (integer_to_long_p (object)))) \
- goto losing_color_object; \
- { \
- long value = (integer_to_long (object)); \
- if ((value < 0) || (value > 65535)) \
- goto losing_color_object; \
- (colors_scan -> color) = value; \
- (colors_scan -> flags) |= (flag); \
- } \
- } \
-}
-
-DEFINE_PRIMITIVE ("X-STORE-COLORS", Prim_x_store_colors, 2, 2,
- "Input: colormap, vector of vectors, each of\n\
-which contains pixel, r, g, b (where r/g/b can be #f or integer).")
-{
- PRIMITIVE_HEADER (2);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- SCHEME_OBJECT color_vector = (VECTOR_ARG (2));
- unsigned long n_colors = (VECTOR_LENGTH (color_vector));
- XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
- {
- SCHEME_OBJECT * vector_scan = (VECTOR_LOC (color_vector, 0));
- SCHEME_OBJECT * vector_end = (vector_scan + n_colors);
- XColor * colors_scan = colors;
- while (vector_scan < vector_end)
- {
- SCHEME_OBJECT color_object = (*vector_scan++);
- if (! ((VECTOR_P (color_object))
- && ((VECTOR_LENGTH (color_object)) == 4)))
- {
- losing_color_object:
- error_wrong_type_arg (3);
- }
- {
- SCHEME_OBJECT pixel_object = (VECTOR_REF (color_object, 0));
- if (! ((INTEGER_P (pixel_object))
- && (integer_to_long_p (pixel_object))))
- goto losing_color_object;
- (colors_scan -> pixel) = (integer_to_long (pixel_object));
- }
- (colors_scan -> flags) = 0;
- CONVERT_COLOR_OBJECT (1, red, DoRed);
- CONVERT_COLOR_OBJECT (2, green, DoGreen);
- CONVERT_COLOR_OBJECT (3, blue, DoBlue);
- colors_scan += 1;
- }
- }
- XStoreColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0)
-{
- /* Input: colormap, pixel ... */
- PRIMITIVE_HEADER (LEXPR);
- if (GET_LEXPR_ACTUALS < 1)
- signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- unsigned int n_pixels = (GET_LEXPR_ACTUALS - 1);
- unsigned long * pixels =
- (dstack_alloc ((sizeof (unsigned long)) * n_pixels));
- unsigned int i;
- for (i = 0; (i < n_pixels); i += 1)
- (pixels[i]) = (arg_integer (i + 2));
- XFreeColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
- pixels, n_pixels, 0);
- }
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0)
-{
- /* Input: colormap, pixel
- Output: vector of red, green, blue */
- PRIMITIVE_HEADER (2);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 3, true));
- XColor c;
- c . pixel = (arg_integer (2));
- XQueryColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), (&c));
- VECTOR_SET (result, 0, (long_to_integer (c . red)));
- VECTOR_SET (result, 1, (long_to_integer (c . green)));
- VECTOR_SET (result, 2, (long_to_integer (c . blue)));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0)
-{
- /* Input: colormap, pixel ...
- Output: a vector of vectors, each with #(red, green, blue) */
- PRIMITIVE_HEADER (LEXPR);
- if (GET_LEXPR_ACTUALS < 1)
- signal_error_from_primitive (ERR_WRONG_NUMBER_OF_ARGUMENTS);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- unsigned int n_colors = (GET_LEXPR_ACTUALS - 1);
- XColor * colors = (dstack_alloc ((sizeof (XColor)) * n_colors));
- unsigned int i;
- for (i = 0; (i < n_colors); i += 1)
- ((colors[i]) . pixel) = (arg_integer (i + 2));
- XQueryColors ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)), colors, n_colors);
- {
- SCHEME_OBJECT result =
- (allocate_marked_vector (TC_VECTOR, n_colors, true));
- for (i = 0; (i < n_colors); i += 1)
- {
- SCHEME_OBJECT cv = (allocate_marked_vector (TC_VECTOR, 3, true));
- VECTOR_SET (cv, 0, (long_to_integer ((colors[i]) . red)));
- VECTOR_SET (cv, 1, (long_to_integer ((colors[i]) . green)));
- VECTOR_SET (cv, 2, (long_to_integer ((colors[i]) . blue)));
- VECTOR_SET (result, i, cv);
- }
- PRIMITIVE_RETURN (result);
- }
- }
-}
-\f
-/* Named colors */
-
-DEFINE_PRIMITIVE ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0)
-{ /* Input: colormap, string
- Output: vector of pixel, red, green, blue
- */
- PRIMITIVE_HEADER (2);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- XColor TheColor;
- if (! (XParseColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
- (STRING_ARG (2)), (&TheColor))))
- PRIMITIVE_RETURN (SHARP_F);
- {
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
- VECTOR_SET(result, 0, long_to_integer(TheColor.pixel));
- VECTOR_SET(result, 1, long_to_integer(TheColor.red));
- VECTOR_SET(result, 2, long_to_integer(TheColor.green));
- VECTOR_SET(result, 3, long_to_integer(TheColor.blue));
- PRIMITIVE_RETURN (result);
- }
- }
-}
-
-DEFINE_PRIMITIVE ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0)
-{ /* Input: colormap, name
- Returns: vector of closest pixel, red, green, blue
- exact pixel, red, green, blue
- */
-
- SCHEME_OBJECT Result;
- XColor Exact, Closest;
- struct xcolormap * xcm;
- PRIMITIVE_HEADER (2);
-
- xcm = (x_colormap_arg (1));
- XAllocNamedColor
- ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
- (STRING_ARG (2)), &Exact, &Closest);
- Result = allocate_marked_vector(TC_VECTOR, 8, true);
- VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
- VECTOR_SET(Result, 1, long_to_integer(Closest.red));
- VECTOR_SET(Result, 2, long_to_integer(Closest.green));
- VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
- VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
- VECTOR_SET(Result, 5, long_to_integer(Exact.red));
- VECTOR_SET(Result, 6, long_to_integer(Exact.green));
- VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
- PRIMITIVE_RETURN(Result);
-}
-
-DEFINE_PRIMITIVE("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0)
-{
- /* Input: colormap, color name, pixel, DoRed, DoGreen, DoBlue */
- PRIMITIVE_HEADER(6);
- {
- struct xcolormap * xcm = (x_colormap_arg (1));
- XStoreNamedColor ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
- (STRING_ARG (2)), (arg_integer (4)),
- (((BOOLEAN_ARG (4)) ? DoRed : 0)
- | ((BOOLEAN_ARG (5)) ? DoGreen : 0)
- | ((BOOLEAN_ARG (6)) ? DoBlue : 0)));
- }
- PRIMITIVE_RETURN(UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0)
-{
- /* Input: colormap, name
- Returns: vector of closest pixel, red, green, blue
- exact pixel, red, green, blue
- */
-
- SCHEME_OBJECT Result;
- XColor Exact, Closest;
- struct xcolormap * xcm;
- PRIMITIVE_HEADER (2);
-
- xcm = (x_colormap_arg (1));
- if (! (XAllocNamedColor
- ((XCM_DISPLAY (xcm)), (XCM_COLORMAP (xcm)),
- (STRING_ARG (2)), &Exact, &Closest)))
- PRIMITIVE_RETURN (SHARP_F);
- Result = allocate_marked_vector(TC_VECTOR, 8, true);
- VECTOR_SET(Result, 0, long_to_integer(Closest.pixel));
- VECTOR_SET(Result, 1, long_to_integer(Closest.red));
- VECTOR_SET(Result, 2, long_to_integer(Closest.green));
- VECTOR_SET(Result, 3, long_to_integer(Closest.blue));
- VECTOR_SET(Result, 4, long_to_integer(Exact.pixel));
- VECTOR_SET(Result, 5, long_to_integer(Exact.red));
- VECTOR_SET(Result, 6, long_to_integer(Exact.green));
- VECTOR_SET(Result, 7, long_to_integer(Exact.blue));
- PRIMITIVE_RETURN(Result);
-}
-\f
-#ifdef COMPILE_AS_MODULE
-
-/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \
- -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */
-
-void
-dload_initialize_x11color (void)
-{
- declare_primitive ("X-ALLOCATE-COLOR", Prim_x_allocate_color, 4, 4, 0);
- declare_primitive ("X-ALLOCATE-NAMED-COLOR", Prim_x_allocate_named_color, 2, 2, 0);
- declare_primitive ("X-COPY-COLORMAP-AND-FREE", Prim_x_copy_colormap_and_free, 1, 1, 0);
- declare_primitive ("X-CREATE-COLORMAP", Prim_x_create_colormap, 3, 3, 0);
- declare_primitive ("X-FREE-COLORMAP", Prim_x_free_colormap, 1, 1, 0);
- declare_primitive ("X-FREE-COLORS", Prim_x_free_colors, 1, -1, 0);
- declare_primitive ("X-GET-DEFAULT-COLORMAP", Prim_x_get_default_colormap, 2, 2, 0);
- declare_primitive ("X-GET-DEFAULT-VISUAL", Prim_x_get_default_visual, 2, 2, 0);
- declare_primitive ("X-GET-VISUAL-INFO", Prim_x_get_visual_info, 10, 10, 0);
- declare_primitive ("X-GET-WINDOW-ATTRIBUTES", Prim_x_get_window_attributes, 1, 1, 0);
- declare_primitive ("X-LOOKUP-COLOR", Prim_x_lookup_color, 2, 2, 0);
- declare_primitive ("X-PARSE-COLOR", Prim_x_parse_color, 2, 2, 0);
- declare_primitive ("X-QUERY-COLOR", Prim_x_query_color, 2, 2, 0);
- declare_primitive ("X-QUERY-COLORS", Prim_x_query_colors, 1, -1, 0);
- declare_primitive ("X-SET-WINDOW-COLORMAP", Prim_x_set_window_colormap, 2, 2, 0);
- declare_primitive ("X-STORE-COLOR", Prim_x_store_color, 5, 5, 0);
- declare_primitive ("X-STORE-COLORS", Prim_x_store_colors, 2, 2, 0);
- declare_primitive ("X-STORE-NAMED-COLOR", Prim_x_store_named_color, 6, 6, 0);
- declare_primitive ("X-VISUAL-DEALLOCATE", Prim_x_visual_deallocate, 1, 1, 0);
- declare_primitive ("X-WINDOW-COLORMAP", Prim_x_window_colormap, 1, 1, 0);
- declare_primitive ("X-WINDOW-VISUAL", Prim_x_window_visual, 1, 1, 0);
-}
-
-#endif /* defined (COMPILE_AS_MODULE) */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* Simple graphics for X11 */
-
-#include "scheme.h"
-#include "prims.h"
-#include "x11.h"
-\f
-#define RESOURCE_NAME "schemeGraphics"
-#define RESOURCE_CLASS "SchemeGraphics"
-#define DEFAULT_GEOMETRY "512x384+0+0"
-
-struct gw_extra
-{
- float x_left;
- float x_right;
- float y_bottom;
- float y_top;
- float x_slope;
- float y_slope;
- int x_cursor;
- int y_cursor;
-};
-
-struct xwindow_graphics
-{
- struct xwindow xw;
- struct gw_extra extra;
-};
-
-#define XW_EXTRA(xw) (& (((struct xwindow_graphics *) xw) -> extra))
-
-#define XW_X_LEFT(xw) ((XW_EXTRA (xw)) -> x_left)
-#define XW_X_RIGHT(xw) ((XW_EXTRA (xw)) -> x_right)
-#define XW_Y_BOTTOM(xw) ((XW_EXTRA (xw)) -> y_bottom)
-#define XW_Y_TOP(xw) ((XW_EXTRA (xw)) -> y_top)
-#define XW_X_SLOPE(xw) ((XW_EXTRA (xw)) -> x_slope)
-#define XW_Y_SLOPE(xw) ((XW_EXTRA (xw)) -> y_slope)
-#define XW_X_CURSOR(xw) ((XW_EXTRA (xw)) -> x_cursor)
-#define XW_Y_CURSOR(xw) ((XW_EXTRA (xw)) -> y_cursor)
-
-#define ROUND_FLOAT(flonum) \
- ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5)))
-
-#define X_COORDINATE(virtual_device_x, xw, direction) \
- (((XW_X_SLOPE (xw)) == FLT_MAX) \
- ? ((direction <= 0) ? 0 : ((int) ((XW_X_SIZE (xw)) - 1))) \
- : (ROUND_FLOAT \
- (((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw)))))))
-
-#define Y_COORDINATE(virtual_device_y, xw, direction) \
- (((XW_Y_SLOPE (xw)) == FLT_MAX) \
- ? ((direction <= 0) ? ((int) ((XW_Y_SIZE (xw)) - 1)) : 0) \
- : (((int) ((XW_Y_SIZE (xw)) - 1)) \
- + (ROUND_FLOAT \
- ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw)))))))
-
-#define X_LENGTH(virtual_length, xw) \
- (((XW_X_SLOPE (xw)) == 0.0) \
- ? 0 \
- : ((XW_X_SLOPE (xw)) == FLT_MAX) \
- ? ((int) ((XW_X_SIZE (xw)) - 1)) \
- : (ROUND_FLOAT ((fabs (XW_X_SLOPE (xw))) * (virtual_length))))
-
-#define Y_LENGTH(virtual_length, xw) \
- (((XW_Y_SLOPE (xw)) == 0.0) \
- ? 0 \
- : ((XW_Y_SLOPE (xw)) == FLT_MAX) \
- ? ((int) ((XW_Y_SIZE (xw)) - 1)) \
- : (ROUND_FLOAT ((fabs (XW_Y_SLOPE (xw))) * (virtual_length))))
-
-static int
-arg_x_coordinate (unsigned int arg, struct xwindow * xw, int direction)
-{
- return (X_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
-}
-
-static int
-arg_y_coordinate (unsigned int arg, struct xwindow * xw, int direction)
-{
- return (Y_COORDINATE (((float) (arg_real_number (arg))), xw, direction));
-}
-
-static SCHEME_OBJECT
-x_coordinate_map (struct xwindow * xw, unsigned int x)
-{
- return
- (FLOAT_TO_FLONUM
- ((((XW_X_SLOPE (xw)) == 0.0) || ((XW_X_SLOPE (xw)) == FLT_MAX))
- ? (XW_X_LEFT (xw))
- : ((((float) x) / (XW_X_SLOPE (xw))) + (XW_X_LEFT (xw)))));
-}
-
-static SCHEME_OBJECT
-y_coordinate_map (struct xwindow * xw, unsigned int y)
-{
- return
- (FLOAT_TO_FLONUM
- ((((XW_Y_SLOPE (xw)) == 0.0) || ((XW_Y_SLOPE (xw)) == FLT_MAX))
- ? (XW_Y_BOTTOM (xw))
- : (((((float) y) - ((XW_Y_SIZE (xw)) - 1)) / (XW_Y_SLOPE (xw)))
- + (XW_Y_BOTTOM (xw)))));
-}
-\f
-static void
-set_clip_rectangle (struct xwindow * xw,
- int x_left,
- int y_bottom,
- int x_right,
- int y_top)
-{
- XRectangle rectangles [1];
- Display * display = (XW_DISPLAY (xw));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- if (x_left > x_right)
- {
- unsigned int x = x_left;
- x_left = x_right;
- x_right = x;
- }
- if (y_top > y_bottom)
- {
- unsigned int y = y_top;
- y_top = y_bottom;
- y_bottom = y;
- }
- {
- unsigned int width = ((x_right + 1) - x_left);
- unsigned int height = ((y_bottom + 1) - y_top);
- (XW_CLIP_X (xw)) = x_left;
- (XW_CLIP_Y (xw)) = y_top;
- (XW_CLIP_WIDTH (xw)) = width;
- (XW_CLIP_HEIGHT (xw)) = height;
- ((rectangles[0]) . x) = x_left;
- ((rectangles[0]) . y) = y_top;
- ((rectangles[0]) . width) = width;
- ((rectangles[0]) . height) = height;
- }
- XSetClipRectangles
- (display,
- (XW_NORMAL_GC (xw)),
- internal_border_width,
- internal_border_width,
- rectangles, 1, Unsorted);
- XSetClipRectangles
- (display,
- (XW_REVERSE_GC (xw)),
- internal_border_width,
- internal_border_width,
- rectangles, 1, Unsorted);
-}
-
-static void
-reset_clip_rectangle (struct xwindow * xw)
-{
- set_clip_rectangle
- (xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0);
-}
-
-static void
-reset_virtual_device_coordinates (struct xwindow * xw)
-{
- /* Note that the expression ((XW_c_SIZE (xw)) - 1) guarantees that
- both limits of the device coordinates will be inside the window. */
- (XW_X_SLOPE (xw))
- = (((XW_X_RIGHT (xw)) == (XW_X_LEFT (xw)))
- ? FLT_MAX
- : ((XW_X_SIZE (xw)) <= 1)
- ? 0.0
- : (((float) ((XW_X_SIZE (xw)) - 1))
- / ((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw)))));
- (XW_Y_SLOPE (xw))
- = (((XW_Y_BOTTOM (xw)) == (XW_Y_TOP (xw)))
- ? FLT_MAX
- : ((XW_Y_SIZE (xw)) <= 1)
- ? 0.0
- : (((float) ((XW_Y_SIZE (xw)) - 1))
- / ((XW_Y_BOTTOM (xw)) - (XW_Y_TOP (xw)))));
- reset_clip_rectangle (xw);
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5,
- "(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)\n\
-Set the virtual device coordinates to the given values.")
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- float x_left = (arg_real_number (2));
- float y_bottom = (arg_real_number (3));
- float x_right = (arg_real_number (4));
- float y_top = (arg_real_number (5));
- (XW_X_LEFT (xw)) = x_left;
- (XW_Y_BOTTOM (xw)) = y_bottom;
- (XW_X_RIGHT (xw)) = x_right;
- (XW_Y_TOP (xw)) = y_top;
- reset_virtual_device_coordinates (xw);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0)
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, 4, true));
- VECTOR_SET (result, 0, (double_to_flonum ((double) (XW_X_LEFT (xw)))));
- VECTOR_SET (result, 1, (double_to_flonum ((double) (XW_Y_BOTTOM (xw)))));
- VECTOR_SET (result, 2, (double_to_flonum ((double) (XW_X_RIGHT (xw)))));
- VECTOR_SET (result, 3, (double_to_flonum ((double) (XW_Y_TOP (xw)))));
- PRIMITIVE_RETURN (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- reset_clip_rectangle (x_window_arg (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5,
- "(X-GRAPHICS-SET-CLIP-RECTANGLE WINDOW X-LEFT Y-BOTTOM X-RIGHT Y-TOP)\n\
-Set the clip rectangle to the given coordinates.")
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- set_clip_rectangle
- (xw,
- (arg_x_coordinate (2, xw, -1)),
- (arg_y_coordinate (3, xw, -1)),
- (arg_x_coordinate (4, xw, 1)),
- (arg_y_coordinate (5, xw, 1)));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-static void
-process_event (struct xwindow * xw, XEvent * event)
-{
-}
-
-static void
-reconfigure (struct xwindow * xw, unsigned int width, unsigned int height)
-{
- unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
- unsigned int x_size = ((width < extra) ? 0 : (width - extra));
- unsigned int y_size = ((height < extra) ? 0 : (height - extra));
- if ((x_size != (XW_X_SIZE (xw))) || (y_size != (XW_Y_SIZE (xw))))
- {
- (XW_X_SIZE (xw)) = x_size;
- (XW_Y_SIZE (xw)) = y_size;
- reset_virtual_device_coordinates (xw);
- XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-RECONFIGURE", Prim_x_graphics_reconfigure, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- reconfigure ((x_window_arg (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-static void
-wm_set_size_hint (struct xwindow * xw, int geometry_mask, int x, int y)
-{
- unsigned int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
- XSizeHints * size_hints = (XAllocSizeHints ());
- if (size_hints == 0)
- error_external_return ();
- (size_hints -> flags) =
- (PResizeInc | PMinSize | PBaseSize
- | (((geometry_mask & XValue) && (geometry_mask & YValue))
- ? USPosition : PPosition)
- | (((geometry_mask & WidthValue) && (geometry_mask & HeightValue))
- ? USSize : PSize));
- (size_hints -> x) = x;
- (size_hints -> y) = y;
- (size_hints -> width) = ((XW_X_SIZE (xw)) + extra);
- (size_hints -> height) = ((XW_Y_SIZE (xw)) + extra);
- (size_hints -> width_inc) = 1;
- (size_hints -> height_inc) = 1;
- (size_hints -> min_width) = extra;
- (size_hints -> min_height) = extra;
- (size_hints -> base_width) = extra;
- (size_hints -> base_height) = extra;
- XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints);
- XFree ((caddr_t) size_hints);
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3,
- "(X-GRAPHICS-OPEN-WINDOW DISPLAY GEOMETRY SUPPRESS-MAP?)\n\
-Open a window on DISPLAY using GEOMETRY.\n\
-If GEOMETRY is false map window interactively.\n\
-If third argument SUPPRESS-MAP? is true, do not map the window immediately.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Display * display = (XD_DISPLAY (xd));
- struct drawing_attributes attributes;
- struct xwindow_methods methods;
- XSetWindowAttributes wattributes;
- const char * resource_name = RESOURCE_NAME;
- const char * resource_class = RESOURCE_CLASS;
- int map_p;
-
- x_decode_window_map_arg
- ((ARG_REF (3)), (&resource_name), (&resource_class), (&map_p));
- x_default_attributes
- (display, resource_name, resource_class, (&attributes));
- (wattributes . background_pixel) = (attributes . background_pixel);
- (wattributes . border_pixel) = (attributes . border_pixel);
- (wattributes . backing_store) = Always;
- (methods . deallocator) = 0;
- (methods . event_processor) = process_event;
- (methods . x_coordinate_map) = x_coordinate_map;
- (methods . y_coordinate_map) = y_coordinate_map;
- (methods . update_normal_hints) = 0;
- {
- unsigned int extra = (2 * (attributes . internal_border_width));
- int x_pos = (-1);
- int y_pos = (-1);
- int x_size = 512;
- int y_size = 384;
- int geometry_mask =
- (XGeometry (display, (DefaultScreen (display)),
- (((ARG_REF (2)) == SHARP_F)
- ? (x_get_default
- (display, resource_name, resource_class,
- "geometry", "Geometry", 0))
- : (STRING_ARG (2))),
- DEFAULT_GEOMETRY, (attributes . border_width),
- 1, 1, extra, extra,
- (&x_pos), (&y_pos), (&x_size), (&y_size)));
- Window window =
- (XCreateWindow
- (display,
- (RootWindow (display, (DefaultScreen (display)))),
- x_pos, y_pos, (x_size + extra), (y_size + extra),
- (attributes . border_width),
- CopyFromParent, CopyFromParent, CopyFromParent,
- (CWBackPixel | CWBorderPixel | CWBackingStore),
- (&wattributes)));
- if (window == 0)
- error_external_return ();
- {
- struct xwindow * xw =
- (x_make_window
- (xd, window, x_size, y_size, (&attributes), (&methods),
- (sizeof (struct xwindow_graphics))));
- (XW_X_LEFT (xw)) = ((float) (-1));
- (XW_X_RIGHT (xw)) = ((float) 1);
- (XW_Y_BOTTOM (xw)) = ((float) (-1));
- (XW_Y_TOP (xw)) = ((float) 1);
- reset_virtual_device_coordinates (xw);
- (XW_X_CURSOR (xw)) = 0;
- (XW_Y_CURSOR (xw)) = 0;
- wm_set_size_hint (xw, geometry_mask, x_pos, y_pos);
- xw_set_wm_input_hint (xw, 0);
- xw_set_wm_name (xw, "scheme-graphics");
- xw_set_wm_icon_name (xw, "scheme-graphics");
- XSelectInput (display, window, StructureNotifyMask);
- xw_make_window_map (xw, resource_name, resource_class, map_p);
- PRIMITIVE_RETURN (XW_TO_OBJECT (xw));
- }
- }
- }
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5,
- "(X-GRAPHICS-DRAW-LINE WINDOW X-START Y-START X-END Y-END)\n\
-Draw a line from the start coordinates to the end coordinates.\n\
-Subsequently move the graphics cursor to the end coordinates.")
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int new_x_cursor = (arg_x_coordinate (4, xw, 0));
- unsigned int new_y_cursor = (arg_y_coordinate (5, xw, 0));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawLine
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw, 0))),
- (internal_border_width + (arg_y_coordinate (3, xw, 0))),
- (internal_border_width + new_x_cursor),
- (internal_border_width + new_y_cursor));
- (XW_X_CURSOR (xw)) = new_x_cursor;
- (XW_Y_CURSOR (xw)) = new_y_cursor;
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3,
- "(X-GRAPHICS-MOVE-CURSOR WINDOW X Y)\n\
-Move the graphics cursor to the given coordinates.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- (XW_X_CURSOR (xw)) = (arg_x_coordinate (2, xw, 0));
- (XW_Y_CURSOR (xw)) = (arg_y_coordinate (3, xw, 0));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3,
- "(X-GRAPHICS-DRAG-CURSOR WINDOW X Y)\n\
-Draw a line from the graphics cursor to the given coordinates.\n\
-Subsequently move the graphics cursor to those coordinates.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int new_x_cursor = (arg_x_coordinate (2, xw, 0));
- unsigned int new_y_cursor = (arg_y_coordinate (3, xw, 0));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawLine
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (XW_X_CURSOR (xw))),
- (internal_border_width + (XW_Y_CURSOR (xw))),
- (internal_border_width + new_x_cursor),
- (internal_border_width + new_y_cursor));
- (XW_X_CURSOR (xw)) = new_x_cursor;
- (XW_Y_CURSOR (xw)) = new_y_cursor;
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3,
- "(X-GRAPHICS-DRAW-POINT WINDOW X Y)\n\
-Draw one point at the given coordinates.\n\
-Subsequently move the graphics cursor to those coordinates.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- XDrawPoint
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw, 0))),
- (internal_border_width + (arg_y_coordinate (3, xw, 0))));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-ARC", Prim_x_graphics_draw_arc, 8, 8,
- "(X-GRAPHICS-DRAW-ARC WINDOW X Y RADIUS-X RADIUS-Y START-ANGLE SWEEP-ANGLE FILL?)\n\
-Draw an arc at the given coordinates, with given X and Y radii.\n\
-START-ANGLE and SWEEP-ANGLE are in degrees, anti-clocwise.\n\
-START-ANGLE is from 3 o'clock, and SWEEP-ANGLE is relative to the START-ANGLE\n\
-If FILL? is true, the arc is filled.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- float virtual_device_x = arg_real_number (2);
- float virtual_device_y = arg_real_number (3);
- float radius_x = arg_real_number (4);
- float radius_y = arg_real_number (5);
- float angle_start = arg_real_number (6);
- float angle_sweep = arg_real_number (7);
-
- /* we assume a virtual coordinate system with X increasing left to
- * right and Y increasing top to bottom. If we are wrong then we
- * have to flip the axes and adjust the angles */
-
- int x1 = (X_COORDINATE (virtual_device_x - radius_x, xw, 0));
- int x2 = (X_COORDINATE (virtual_device_x + radius_x, xw, 0));
- int y1 = (Y_COORDINATE (virtual_device_y + radius_y, xw, 0));
- int y2 = (Y_COORDINATE (virtual_device_y - radius_y, xw, 0));
- int width, height;
- int angle1 = ((int)(angle_start * 64)) % (64*360);
- int angle2 = ((int)(angle_sweep * 64));
- if (angle1 < 0)
- angle1 = (64*360) + angle1;
- /* angle1 is now 0..359 */
- if (x2<x1) { /* x-axis flip */
- int t=x1; x1=x2; x2=t;
- if (angle1 < 64*180)
- angle1 = 64*180 - angle1;
- else
- angle1 = 64*540 - angle1;
- angle2 = -angle2;
- }
- if (y2<y1) { /* y-axis flip */
- int t=y1; y1=y2; y2=t;
- angle1 = 64*360 - angle1;
- angle2 = -angle2;
- }
- width = x2 - x1;
- height = y2 - y1;
- if (ARG_REF(8) == SHARP_F)
- XDrawArc
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + x1),
- (internal_border_width + y1),
- width, height, angle1, angle2);
- else
- XFillArc
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + x1),
- (internal_border_width + y1),
- width, height, angle1, angle2);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-/************** TEST PROGRAM FOR X-GRAPHICS-DRAW-ARC *****************
-(define g (make-graphics-device))
-
-(define (test dx dy a1 a2)
- (let ((x .3)
- (y .4)
- (r .2))
- (define (fx a) (+ x (* r (cos (* a (asin 1) 1/90)))))
- (define (fy a) (+ y (* r (sin (* a (asin 1) 1/90)))))
- (graphics-set-coordinate-limits g (- dx) (- dy) dx dy)
- (graphics-operation g 'set-foreground-color "black")
- (graphics-clear g)
-
- (graphics-draw-text g 0 0 ".")
-
- (graphics-draw-line g -1 0 1 0)
- (graphics-draw-line g 0 -1 0 1)
- (graphics-draw-line g 0 0 1 1)
- (graphics-draw-text g .5 0 "+X")
- (graphics-draw-text g -.5 0 "-X")
- (graphics-draw-text g 0 .5 "+Y")
- (graphics-draw-text g 0 -.5 "-Y")
-
- ;; The grey wedge is that that 10 degrees of the arc.
- (graphics-operation g 'set-foreground-color "grey")
- (graphics-operation g 'draw-arc x y r r a1 a2 #T)
- (graphics-operation g 'set-foreground-color "black")
- (graphics-operation g 'draw-arc x y r r a1 (+ a2 (if (< a2 0) 10 -10)) #T)
-
- (graphics-operation g 'set-foreground-color "red")
- (graphics-draw-text g x y ".O")
-
- (let ((b1 (min a1 (+ a1 a2)))
- (b2 (max a1 (+ a1 a2))))
- (do ((a b1 (+ a 5)))
- ((> a b2))
- (graphics-draw-text g (fx a) (fy a) ".")))
-
- (graphics-draw-text g (fx a1) (fy a1) ".Start")
- (graphics-draw-text g (fx (+ a1 a2)) (fy (+ a1 a2)) ".End")))
-
-;; Test axes
-(test 1 1 30 90)
-(test -1 1 30 90)
-(test 1 -1 30 90)
-(test -1 -1 30 90)
-
-;; Test angles
-(test 1 1 30 90)
-(test 1 1 30 -90)
-(test 1 1 -30 90)
-(test 1 1 -30 -90)
- ***********************************************************************/
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4,
- "(X-GRAPHICS-DRAW-STRING WINDOW X Y STRING)\n\
-Draw characters in the current font at the given coordinates, with\n\
-transparent background.")
-{
- PRIMITIVE_HEADER (4);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- char * s = (STRING_ARG (4));
- XDrawString
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw, 0))),
- (internal_border_width + (arg_y_coordinate (3, xw, 0))),
- s,
- (STRING_LENGTH (ARG_REF (4))));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-IMAGE-STRING", Prim_x_graphics_draw_image_string, 4, 4,
- "(X-GRAPHICS-DRAW-IMAGE-STRING WINDOW X Y STRING)\n\
-Draw characters in the current font at the given coordinates, with\n\
-solid background.")
-{
- PRIMITIVE_HEADER (4);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
- char * s = (STRING_ARG (4));
- XDrawImageString
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (internal_border_width + (arg_x_coordinate (2, xw, 0))),
- (internal_border_width + (arg_y_coordinate (3, xw, 0))),
- s,
- (STRING_LENGTH (ARG_REF (4))));
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned int function = (arg_ulong_index_integer (2, 16));
- XSetFunction (display, (XW_NORMAL_GC (xw)), function);
- XSetFunction (display, (XW_REVERSE_GC (xw)), function);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-static XPoint *
-floating_vector_point_args (struct xwindow * xw,
- unsigned int x_index,
- unsigned int y_index,
- unsigned int * return_n_points)
-{
- SCHEME_OBJECT x_vector = (ARG_REF (x_index));
- SCHEME_OBJECT y_vector = (ARG_REF (y_index));
- unsigned int n_points;
-
- if (!FLONUM_P (x_vector))
- error_wrong_type_arg (x_index);
- if (!FLONUM_P (y_vector))
- error_wrong_type_arg (y_index);
- n_points = (FLOATING_VECTOR_LENGTH (x_vector));
- if (n_points != (FLOATING_VECTOR_LENGTH (y_vector)))
- error_bad_range_arg (x_index);
- {
- XPoint * points = (dstack_alloc (n_points * (sizeof (XPoint))));
- double * scan_x = (FLOATING_VECTOR_LOC (x_vector, 0));
- double * end_x = (FLOATING_VECTOR_LOC (x_vector, n_points));
- double * scan_y = (FLOATING_VECTOR_LOC (y_vector, 0));
- XPoint * scan_points = points;
- unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw));
- while (scan_x < end_x)
- {
- (scan_points -> x) = (border + (X_COORDINATE ((*scan_x++), xw, 0)));
- (scan_points -> y) = (border + (X_COORDINATE ((*scan_y++), xw, 0)));
- scan_points += 1;
- }
- (*return_n_points) = n_points;
- return (points);
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINTS", Prim_x_graphics_draw_points, 3, 3,
- "(X-GRAPHICS-DRAW-POINTS WINDOW X-VECTOR Y-VECTOR)\n\
-Draw multiple points.")
-{
- PRIMITIVE_HEADER (3);
- {
- void * position = dstack_position;
- struct xwindow * xw = (x_window_arg (1));
- unsigned int n_points;
- XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
- while (n_points > 0)
- {
- unsigned int this_send = ((n_points <= 4093) ? n_points : 4093);
- n_points -= this_send;
- XDrawPoints ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- points,
- this_send,
- CoordModeOrigin);
- points += this_send;
- }
- dstack_set_position (position);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINES", Prim_x_graphics_draw_lines, 3, 3,
- "(X-GRAPHICS-DRAW-LINES WINDOW X-VECTOR Y-VECTOR)\n\
-Draw multiple lines.")
-{
- PRIMITIVE_HEADER (3);
- {
- void * position = dstack_position;
- struct xwindow * xw = (x_window_arg (1));
- unsigned int n_points;
- XPoint * points = (floating_vector_point_args (xw, 2, 3, (&n_points)));
- while (n_points > 0)
- {
- unsigned int this_send = ((n_points <= 2047) ? n_points : 2047);
- n_points -= this_send;
- XDrawLines ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- points,
- this_send,
- CoordModeOrigin);
- points += (this_send - 1);
- }
- dstack_set_position (position);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned int fill_style = (arg_ulong_index_integer (2, 4));
- XSetFillStyle (display, (XW_NORMAL_GC (xw)), fill_style);
- XSetFillStyle (display, (XW_REVERSE_GC (xw)), fill_style);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- unsigned int style = (arg_ulong_index_integer (2, 3));
- XSetLineAttributes
- (display, (XW_NORMAL_GC (xw)), 0, style, CapButt, JoinMiter);
- XSetLineAttributes
- (display, (XW_REVERSE_GC (xw)), 0, style, CapButt, JoinMiter);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- Display * display = (XW_DISPLAY (xw));
- char * dash_list = (STRING_ARG (3));
- unsigned int dash_list_length = (STRING_LENGTH (ARG_REF (3)));
- unsigned int dash_offset = (arg_ulong_index_integer (2, dash_list_length));
- XSetDashes
- (display, (XW_NORMAL_GC (xw)), dash_offset, dash_list, dash_list_length);
- XSetDashes
- (display, (XW_REVERSE_GC (xw)), dash_offset, dash_list,
- dash_list_length);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-COPY-AREA", Prim_x_graphics_copy_area, 8, 8, 0)
-{
- PRIMITIVE_HEADER (7);
- {
- struct xwindow * source_xw = x_window_arg (1);
- struct xwindow * destination_xw = x_window_arg (2);
- unsigned int source_internal_border_width
- = (XW_INTERNAL_BORDER_WIDTH (source_xw));
- unsigned int destination_internal_border_width
- = (XW_INTERNAL_BORDER_WIDTH (destination_xw));
- Display *source_display = XW_DISPLAY (source_xw);
- Display *destination_display = XW_DISPLAY (destination_xw);
- if (source_display != destination_display)
- error_bad_range_arg (2);
- XCopyArea (source_display,
- (XW_WINDOW (source_xw)),
- (XW_WINDOW (destination_xw)),
- (XW_NORMAL_GC (source_xw)),
- (source_internal_border_width
- + (arg_x_coordinate (3, source_xw, -1))),
- (source_internal_border_width
- + (arg_y_coordinate (4, source_xw, 1))),
- (X_LENGTH ((arg_real_number (5)), source_xw)),
- (Y_LENGTH ((arg_real_number (6)), source_xw)),
- (destination_internal_border_width
- + (arg_x_coordinate (7, destination_xw, -1))),
- (destination_internal_border_width
- + (arg_y_coordinate (8, destination_xw, 1))));
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-static XPoint *
-x_polygon_vector_arg (struct xwindow * xw, unsigned int argno)
-{
- SCHEME_OBJECT vector = (VECTOR_ARG (argno));
- unsigned long length = (VECTOR_LENGTH (vector));
- unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw));
- if ((length % 2) != 0)
- error_bad_range_arg (argno);
- {
- XPoint * result = (x_malloc ((length / 2) * (sizeof (XPoint))));
- XPoint * scan_result = result;
- SCHEME_OBJECT * scan = (& (VECTOR_REF (vector, 0)));
- SCHEME_OBJECT * end = (scan + length);
- SCHEME_OBJECT coord;
- while (scan < end)
- {
- coord = (*scan++);
- if (! ((REAL_P (coord)) && (real_number_to_double_p (coord))))
- error_bad_range_arg (argno);
- (scan_result -> x)
- = (border
- + (X_COORDINATE ((real_number_to_double (coord)), xw, 0)));
- coord = (*scan++);
- if (! ((REAL_P (coord)) && (real_number_to_double_p (coord))))
- error_bad_range_arg (argno);
- (scan_result -> y)
- = (border
- + (Y_COORDINATE ((real_number_to_double (coord)), xw, 0)));
- scan_result += 1;
- }
- return (result);
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-FILL-POLYGON", Prim_x_graphics_fill_polygon, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = x_window_arg (1);
- XPoint * points = (x_polygon_vector_arg (xw, 2));
- unsigned long length = VECTOR_LENGTH (VECTOR_ARG (2));
- XFillPolygon ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- points,
- (length / 2),
- Nonconvex,
- CoordModeOrigin);
- free (points);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-static int
-find_pixmap_format (Display * dpy, int depth, XPixmapFormatValues * format)
-{
- XPixmapFormatValues * pixmap_formats;
- int n_pixmap_formats;
- XPixmapFormatValues * scan_pixmap_formats;
- XPixmapFormatValues * end_pixmap_formats;
-
- pixmap_formats = (XListPixmapFormats (dpy, (&n_pixmap_formats)));
- if (pixmap_formats == 0)
- return (0);
- scan_pixmap_formats = pixmap_formats;
- end_pixmap_formats = (pixmap_formats + n_pixmap_formats);
- while (1)
- {
- if (scan_pixmap_formats >= end_pixmap_formats)
- return (0);
- if ((scan_pixmap_formats -> depth) == depth)
- {
- (*format) = (*scan_pixmap_formats);
- XFree (pixmap_formats);
- return (1);
- }
- scan_pixmap_formats += 1;
- }
-}
-
-DEFINE_PRIMITIVE ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3,
- "(window width height)\n\
-Creates and returns an XImage object, of dimensions WIDTH by HEIGHT.\n\
-WINDOW is used to set the Display, Visual, and Depth characteristics.\n\
-The image is created by calling XCreateImage.")
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- Window window = (XW_WINDOW (xw));
- Display * dpy = (XW_DISPLAY (xw));
- unsigned int width = (arg_ulong_integer (2));
- unsigned int height = (arg_ulong_integer (3));
- XWindowAttributes attrs;
- XPixmapFormatValues pixmap_format;
- unsigned int bits_per_line;
- unsigned int bitmap_pad;
- unsigned int bytes_per_line;
-
- XGetWindowAttributes (dpy, window, (&attrs));
- if (!find_pixmap_format (dpy, (attrs . depth), (&pixmap_format)))
- error_external_return ();
- bits_per_line = ((pixmap_format . bits_per_pixel) * width);
- bitmap_pad = (pixmap_format . scanline_pad);
- if ((bits_per_line % bitmap_pad) != 0)
- bits_per_line += (bitmap_pad - (bits_per_line % bitmap_pad));
- bytes_per_line = ((bits_per_line + (CHAR_BIT - 1)) / CHAR_BIT);
- PRIMITIVE_RETURN
- (X_IMAGE_TO_OBJECT
- (XCreateImage
- (dpy,
- (DefaultVisualOfScreen (attrs . screen)),
- (attrs . depth),
- ZPixmap,
- 0,
- ((char *) (x_malloc (height * bytes_per_line))),
- width,
- height,
- bitmap_pad,
- bytes_per_line)));
- }
-}
-
-DEFINE_PRIMITIVE ("X-BYTES-INTO-IMAGE", Prim_x_bytes_into_image, 2, 2,
- "(vector image)\n\
-VECTOR is a vector or vector-8b of pixel values stored in row-major\n\
-order; it must have the same number of pixels as IMAGE.\n\
-These pixels are written onto IMAGE by repeated calls to XPutPixel.\n\
-This procedure is equivalent to calling X-SET-PIXEL-IN-IMAGE for each\n\
-pixel in VECTOR.")
-{
- PRIMITIVE_HEADER (2);
- {
- SCHEME_OBJECT vector = (ARG_REF (1));
- XImage * image = (XI_IMAGE (x_image_arg (2)));
- unsigned long width = (image -> width);
- unsigned long height = (image -> height);
- if (STRING_P (vector))
- {
- unsigned char * vscan;
- unsigned long x;
- unsigned long y;
-
- if ((STRING_LENGTH (vector)) != (width * height))
- error_bad_range_arg (1);
- vscan = (STRING_BYTE_PTR (vector));
- for (y = 0; (y < height); y += 1)
- for (x = 0; (x < width); x += 1)
- XPutPixel (image, x, y, ((unsigned long) (*vscan++)));
- }
- else if (VECTOR_P (vector))
- {
- unsigned long vlen;
- SCHEME_OBJECT * vscan;
- SCHEME_OBJECT * vend;
- unsigned long x;
- unsigned long y;
-
- vlen = (VECTOR_LENGTH (vector));
- if (vlen != (width * height))
- error_bad_range_arg (1);
- vscan = (VECTOR_LOC (vector, 0));
- vend = (VECTOR_LOC (vector, vlen));
- while (vscan < vend)
- {
- SCHEME_OBJECT elt = (*vscan++);
- if (! ((INTEGER_P (elt)) && (integer_to_ulong_p (elt))))
- error_bad_range_arg (1);
- }
- vscan = (VECTOR_LOC (vector, 0));
- for (y = 0; (y < height); y += 1)
- for (x = 0; (x < width); x += 1)
- XPutPixel (image, x, y, (integer_to_ulong (*vscan++)));
- }
- else
- error_wrong_type_arg (1);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-DEFINE_PRIMITIVE ("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3,
- "(image x y)\n\
-The value of pixel (X,Y) of IMAGE is returned as an integer.\n\
-This is accomplished by calling XGetPixel.")
-{
- PRIMITIVE_HEADER (3);
- {
- XImage * image = (XI_IMAGE (x_image_arg (1)));
- PRIMITIVE_RETURN
- (ulong_to_integer
- (XGetPixel (image,
- (arg_index_integer (2, (image -> width))),
- (arg_index_integer (3, (image -> height))))));
- }
-}
-
-DEFINE_PRIMITIVE ("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4,
- "(image x y pixel-value)\n\
-The pixel (X,Y) of IMAGE is modified to contain PIXEL-VALUE.\n\
-This is accomplished by calling XPutPixel.")
-{
- PRIMITIVE_HEADER (4);
- {
- XImage * image = (XI_IMAGE (x_image_arg (1)));
- XPutPixel (image,
- (arg_index_integer (2, (image -> width))),
- (arg_index_integer (3, (image -> height))),
- (arg_ulong_integer (4)));
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-DEFINE_PRIMITIVE ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1,
- "(image)\n\
-IMAGE is deallocated by calling XDestroyImage.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct ximage * xi = (x_image_arg (1));
- XDestroyImage (XI_IMAGE (xi));
- deallocate_x_image (xi);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-DEFINE_PRIMITIVE ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8,
- "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\
-IMAGE is drawn on WINDOW by calling XPutImage.")
-{
- PRIMITIVE_HEADER (8);
- {
- XImage * image = (XI_IMAGE (x_image_arg (1)));
- unsigned int image_width = (image -> width);
- unsigned int image_height = (image -> height);
- unsigned int x_offset = (arg_ulong_index_integer (2, image_width));
- unsigned int y_offset = (arg_ulong_index_integer (3, image_height));
- struct xwindow * xw = (x_window_arg (4));
- XPutImage
- ((XW_DISPLAY (xw)),(XW_WINDOW (xw)),(XW_NORMAL_GC (xw)),
- image, x_offset, y_offset,
- (arg_x_coordinate (5, xw, -1)),
- (arg_y_coordinate (6, xw, 1)),
- (arg_index_integer (7, ((image_width - x_offset) + 1))),
- (arg_index_integer (8, ((image_height - y_offset) + 1))));
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-\f
-DEFINE_PRIMITIVE ("X-READ-IMAGE", Prim_x_read_image, 8, 8,
- "(image image-xoff image-yoff window window_xoff window_yoff width height)\n\
-Reads the specified rectangle of WINDOW into IMAGE by calling XGetSubImage.")
-{
- /* Called with Image, X-offset in image, Y-offset in image,
- Window, X-offset in window, Y-offset in window,
- Width, Height */
- PRIMITIVE_HEADER (8);
- { struct ximage * xi = x_image_arg (1);
- long XImageOffset = arg_integer(2);
- long YImageOffset = arg_integer(3);
- struct xwindow * xw = x_window_arg(4);
- long XWindowOffset = arg_integer(5);
- long YWindowOffset = arg_integer(6);
- long Width = arg_integer(7);
- long Height = arg_integer(8);
-
- XGetSubImage(XW_DISPLAY(xw), XW_WINDOW(xw), XWindowOffset, YWindowOffset,
- Width, Height, -1, ZPixmap,
- XI_IMAGE(xi), XImageOffset, YImageOffset);
- PRIMITIVE_RETURN (UNSPECIFIC);
- }
-}
-
-DEFINE_PRIMITIVE ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1,
- "(window)\n\
-Returns the pixel depth of WINDOW as an integer.")
-{
- PRIMITIVE_HEADER (1);
- {
- struct xwindow * xw = (x_window_arg (1));
- XWindowAttributes attrs;
- XGetWindowAttributes ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (&attrs));
- PRIMITIVE_RETURN (long_to_integer (attrs . depth));
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int signed_xp = (arg_integer (2));
- unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp));
- int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw)));
- PRIMITIVE_RETURN
- (x_coordinate_map
- (xw,
- ((bx < 0) ? 0
- : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1)
- : bx)));
- }
-}
-
-DEFINE_PRIMITIVE ("X-GRAPHICS-MAP-Y-COORDINATE", Prim_x_graphics_map_y_coordinate, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int signed_yp = (arg_integer (2));
- unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp));
- int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw)));
- PRIMITIVE_RETURN
- (y_coordinate_map
- (xw,
- ((by < 0) ? 0
- : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1)
- : by)));
- }
-}
-\f
-#ifdef COMPILE_AS_MODULE
-
-/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \
- -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */
-
-void
-dload_initialize_x11graph (void)
-{
- declare_primitive ("X-BYTES-INTO-IMAGE", Prim_x_bytes_into_image, 2, 2, 0);
- declare_primitive ("X-CREATE-IMAGE", Prim_x_create_image, 3, 3, 0);
- declare_primitive ("X-DESTROY-IMAGE", Prim_x_destroy_image, 1, 1, 0);
- declare_primitive ("X-DISPLAY-IMAGE", Prim_x_display_image, 8, 8, 0);
- declare_primitive ("X-GET-PIXEL-FROM-IMAGE", Prim_x_get_image_pixel, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-COPY-AREA", Prim_x_graphics_copy_area, 8, 8, 0);
- declare_primitive ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-DRAW-ARC", Prim_x_graphics_draw_arc, 8, 8, 0);
- declare_primitive ("X-GRAPHICS-DRAW-IMAGE-STRING", Prim_x_graphics_draw_image_string, 4, 4, 0);
- declare_primitive ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5, 0);
- declare_primitive ("X-GRAPHICS-DRAW-LINES", Prim_x_graphics_draw_lines, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-DRAW-POINTS", Prim_x_graphics_draw_points, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4, 0);
- declare_primitive ("X-GRAPHICS-FILL-POLYGON", Prim_x_graphics_fill_polygon, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-MAP-X-COORDINATE", Prim_x_graphics_map_x_coordinate, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-MAP-Y-COORDINATE", Prim_x_graphics_map_y_coordinate, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-RECONFIGURE", Prim_x_graphics_reconfigure, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0);
- declare_primitive ("X-GRAPHICS-SET-CLIP-RECTANGLE", Prim_x_graphics_set_clip_rectangle, 5, 5, 0);
- declare_primitive ("X-GRAPHICS-SET-DASHES", Prim_x_graphics_set_dashes, 3, 3, 0);
- declare_primitive ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-SET-LINE-STYLE", Prim_x_graphics_set_line_style, 2, 2, 0);
- declare_primitive ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5, 0);
- declare_primitive ("X-GRAPHICS-VDC-EXTENT", Prim_x_graphics_vdc_extent, 1, 1, 0);
- declare_primitive ("X-READ-IMAGE", Prim_x_read_image, 8, 8, 0);
- declare_primitive ("X-SET-PIXEL-IN-IMAGE", Prim_x_set_image_pixel, 4, 4, 0);
- declare_primitive ("X-WINDOW-DEPTH", Prim_x_window_depth, 1, 1, 0);
-}
-
-#endif /* defined (COMPILE_AS_MODULE) */
+++ /dev/null
-/* -*-C-*-
-
-Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
- 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
- 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
- 2017, 2018 Massachusetts Institute of Technology
-
-This file is part of MIT/GNU Scheme.
-
-MIT/GNU Scheme is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or (at
-your option) any later version.
-
-MIT/GNU Scheme is distributed in the hope that it will be useful, but
-WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with MIT/GNU Scheme; if not, write to the Free Software
-Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
-USA.
-
-*/
-
-/* X11 terminal for Edwin. */
-
-#include "scheme.h"
-#include "prims.h"
-#include "x11.h"
-\f
-struct xterm_extra
-{
- /* Dimensions of the window, in characters. Valid character
- coordinates are nonnegative integers strictly less than these
- limits. */
- unsigned int x_size;
- unsigned int y_size;
-
- /* Position of the cursor, in character coordinates. */
- unsigned int cursor_x;
- unsigned int cursor_y;
-
- /* Character map of the window's contents. See `XTERM_CHAR_LOC' for
- the address arithmetic. */
- char * character_map;
-
- /* Bit map of the window's highlighting. */
- char * highlight_map;
-
- /* Nonzero iff the cursor is drawn on the window. */
- char cursor_visible_p;
-
- /* Nonzero iff the cursor should be drawn on the window. */
- char cursor_enabled_p;
-};
-
-struct xwindow_term
-{
- struct xwindow xw;
- struct xterm_extra extra;
-};
-
-#define XW_EXTRA(xw) (& (((struct xwindow_term *) xw) -> extra))
-
-#define XW_X_CSIZE(xw) ((XW_EXTRA (xw)) -> x_size)
-#define XW_Y_CSIZE(xw) ((XW_EXTRA (xw)) -> y_size)
-#define XW_CURSOR_X(xw) ((XW_EXTRA (xw)) -> cursor_x)
-#define XW_CURSOR_Y(xw) ((XW_EXTRA (xw)) -> cursor_y)
-#define XW_CHARACTER_MAP(xw) ((XW_EXTRA (xw)) -> character_map)
-#define XW_HIGHLIGHT_MAP(xw) ((XW_EXTRA (xw)) -> highlight_map)
-#define XW_CURSOR_VISIBLE_P(xw) ((XW_EXTRA (xw)) -> cursor_visible_p)
-#define XW_CURSOR_ENABLED_P(xw) ((XW_EXTRA (xw)) -> cursor_enabled_p)
-
-#define XTERM_CHAR_INDEX(xw, x, y) (((y) * (XW_X_CSIZE (xw))) + (x))
-#define XTERM_CHAR_LOC(xw, index) ((XW_CHARACTER_MAP (xw)) + (index))
-#define XTERM_CHAR(xw, index) (* (XTERM_CHAR_LOC (xw, index)))
-#define XTERM_HL_LOC(xw, index) ((XW_HIGHLIGHT_MAP (xw)) + (index))
-#define XTERM_HL(xw, index) (* (XTERM_HL_LOC (xw, index)))
-
-#define XTERM_HL_GC(xw, hl) (hl ? (XW_REVERSE_GC (xw)) : (XW_NORMAL_GC (xw)))
-
-#define HL_ARG(arg) arg_index_integer (arg, 2)
-
-#define RESOURCE_NAME "schemeTerminal"
-#define RESOURCE_CLASS "SchemeTerminal"
-#define DEFAULT_GEOMETRY "80x40+0+0"
-#define BLANK_CHAR ' '
-#define DEFAULT_HL 0
-\f
-#define XTERM_X_PIXEL(xw, x) \
- (((x) * (FONT_WIDTH (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw)))
-
-#define XTERM_Y_PIXEL(xw, y) \
- (((y) * (FONT_HEIGHT (XW_FONT (xw)))) + (XW_INTERNAL_BORDER_WIDTH (xw)))
-
-#define XTERM_DRAW_CHARS(xw, x, y, s, n, gc) \
- XDrawImageString \
- ((XW_DISPLAY (xw)), \
- (XW_WINDOW (xw)), \
- gc, \
- (XTERM_X_PIXEL (xw, x)), \
- ((XTERM_Y_PIXEL (xw, y)) + (FONT_BASE (XW_FONT (xw)))), \
- s, \
- n)
-
-#define CURSOR_IN_RECTANGLE(xw, x_start, x_end, y_start, y_end) \
- (((x_start) <= (XW_CURSOR_X (xw))) \
- && ((XW_CURSOR_X (xw)) < (x_end)) \
- && ((y_start) <= (XW_CURSOR_Y (xw))) \
- && ((XW_CURSOR_Y (xw)) < (y_end)))
-
-static void
-xterm_erase_cursor (struct xwindow * xw)
-{
- if (XW_CURSOR_VISIBLE_P (xw))
- {
- unsigned int x = (XW_CURSOR_X (xw));
- unsigned int y = (XW_CURSOR_Y (xw));
- unsigned int index = (XTERM_CHAR_INDEX (xw, x, y));
- XTERM_DRAW_CHARS
- (xw, x, y,
- (XTERM_CHAR_LOC (xw, index)),
- 1,
- (XTERM_HL_GC (xw, (XTERM_HL (xw, index)))));
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- }
-}
-
-static void
-xterm_draw_cursor (struct xwindow * xw)
-{
- if ((XW_CURSOR_ENABLED_P (xw)) && (! (XW_CURSOR_VISIBLE_P (xw))))
- {
- unsigned int x = (XW_CURSOR_X (xw));
- unsigned int y = (XW_CURSOR_Y (xw));
- unsigned int index = (XTERM_CHAR_INDEX (xw, x, y));
- int hl = (XTERM_HL (xw, index));
- XTERM_DRAW_CHARS
- (xw, x, y,
- (XTERM_CHAR_LOC (xw, index)),
- 1,
- ((hl && ((XW_FOREGROUND_PIXEL (xw)) == (XW_CURSOR_PIXEL (xw))))
- ? (XW_NORMAL_GC (xw))
- : (XW_CURSOR_GC (xw))));
- (XW_CURSOR_VISIBLE_P (xw)) = 1;
- }
-}
-
-static void
-xterm_process_event (struct xwindow * xw, XEvent * event)
-{
-}
-\f
-static XSizeHints *
-xterm_make_size_hints (XFontStruct * font, unsigned int extra)
-{
- XSizeHints * size_hints = (XAllocSizeHints ());
- if (size_hints == 0)
- error_external_return ();
- (size_hints -> flags) = (PResizeInc | PMinSize | PBaseSize);
- (size_hints -> width_inc) = (FONT_WIDTH (font));
- (size_hints -> height_inc) = (FONT_HEIGHT (font));
- (size_hints -> min_width) = extra;
- (size_hints -> min_height) = extra;
- (size_hints -> base_width) = extra;
- (size_hints -> base_height) = extra;
- return (size_hints);
-}
-
-static void
-xterm_set_wm_normal_hints (struct xwindow * xw, XSizeHints * size_hints)
-{
- XSetWMNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), size_hints);
- XFree (size_hints);
-}
-
-static void
-xterm_update_normal_hints (struct xwindow * xw)
-{
- xterm_set_wm_normal_hints
- (xw,
- (xterm_make_size_hints
- ((XW_FONT (xw)),
- (2 * (XW_INTERNAL_BORDER_WIDTH (xw))))));
-}
-
-static void
-xterm_deallocate (struct xwindow * xw)
-{
- free (XW_CHARACTER_MAP (xw));
- free (XW_HIGHLIGHT_MAP (xw));
-}
-
-static SCHEME_OBJECT
-xterm_x_coordinate_map (struct xwindow * xw, unsigned int x)
-{
- return (ulong_to_integer (x / (FONT_WIDTH (XW_FONT (xw)))));
-}
-
-static SCHEME_OBJECT
-xterm_y_coordinate_map (struct xwindow * xw, unsigned int y)
-{
- return (ulong_to_integer (y / (FONT_HEIGHT (XW_FONT (xw)))));
-}
-
-static void
-xterm_copy_map_line (struct xwindow * xw,
- unsigned int x_start,
- unsigned int x_end,
- unsigned int y_from,
- unsigned int y_to)
-{
- {
- char * from_scan =
- (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from))));
- char * from_end =
- (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from))));
- char * to_scan =
- (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to))));
- while (from_scan < from_end)
- (*to_scan++) = (*from_scan++);
- }
- {
- char * from_scan =
- (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_from))));
- char * from_end =
- (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_end, y_from))));
- char * to_scan =
- (XTERM_HL_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y_to))));
- while (from_scan < from_end)
- (*to_scan++) = (*from_scan++);
- }
-}
-\f
-static void
-xterm_dump_contents (struct xwindow * xw,
- unsigned int x_start,
- unsigned int x_end,
- unsigned int y_start,
- unsigned int y_end)
-{
- char * character_map = (XW_CHARACTER_MAP (xw));
- char * highlight_map = (XW_HIGHLIGHT_MAP (xw));
- if (x_start < x_end)
- {
- unsigned int yi;
- for (yi = y_start; (yi < y_end); yi += 1)
- {
- unsigned int index = (XTERM_CHAR_INDEX (xw, 0, yi));
- char * line_char = (&character_map[index]);
- char * line_hl = (&highlight_map[index]);
- unsigned int xi = x_start;
- while (1)
- {
- unsigned int hl = (line_hl[xi]);
- unsigned int xj = (xi + 1);
- while ((xj < x_end) && ((line_hl[xj]) == hl))
- xj += 1;
- XTERM_DRAW_CHARS (xw, xi, yi,
- (&line_char[xi]),
- (xj - xi),
- (XTERM_HL_GC (xw, hl)));
- if (xj == x_end)
- break;
- xi = xj;
- }
- }
- if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
-}
-\f
-static void
-xterm_dump_rectangle (struct xwindow * xw,
- int signed_x,
- int signed_y,
- unsigned int width,
- unsigned int height)
-{
- XFontStruct * font = (XW_FONT (xw));
- unsigned int x = ((signed_x < 0) ? 0 : ((unsigned int) signed_x));
- unsigned int y = ((signed_y < 0) ? 0 : ((unsigned int) signed_y));
- unsigned int fwidth = (FONT_WIDTH (font));
- unsigned int fheight = (FONT_HEIGHT (font));
- unsigned int border = (XW_INTERNAL_BORDER_WIDTH (xw));
- if (x < border)
- {
- width -= (border - x);
- x = 0;
- }
- else
- x -= border;
- if ((x + width) > (XW_X_SIZE (xw)))
- width = ((XW_X_SIZE (xw)) - x);
- if (y < border)
- {
- height -= (border - y);
- y = 0;
- }
- else
- y -= border;
- if ((y + height) > (XW_Y_SIZE (xw)))
- height = ((XW_Y_SIZE (xw)) - y);
- {
- unsigned int x_start = (x / fwidth);
- unsigned int x_end = (((x + width) + (fwidth - 1)) / fwidth);
- unsigned int y_start = (y / fheight);
- unsigned int y_end = (((y + height) + (fheight - 1)) / fheight);
- if (x_end > (XW_X_CSIZE (xw)))
- x_end = (XW_X_CSIZE (xw));
- if (y_end > (XW_Y_CSIZE (xw)))
- y_end = (XW_Y_CSIZE (xw));
- xterm_dump_contents (xw, x_start, x_end, y_start, y_end);
- }
- XFlush (XW_DISPLAY (xw));
-}
-\f
-#define MIN(x, y) (((x) < (y)) ? (x) : (y))
-
-static void
-xterm_reconfigure (struct xwindow * xw,
- unsigned int x_csize,
- unsigned int y_csize)
-{
- if ((x_csize != (XW_X_CSIZE (xw))) || (y_csize != (XW_Y_CSIZE (xw))))
- {
- char * new_char_map = (x_malloc (x_csize * y_csize));
- char * new_hl_map = (x_malloc (x_csize * y_csize));
- unsigned int old_x_csize = (XW_X_CSIZE (xw));
- unsigned int min_x_csize = (MIN (x_csize, old_x_csize));
- unsigned int min_y_csize = (MIN (y_csize, (XW_Y_CSIZE (xw))));
- int x_clipped = (old_x_csize - x_csize);
- char * new_scan_char = new_char_map;
- char * new_scan_hl = new_hl_map;
- char * new_end;
- char * old_scan_char = (XW_CHARACTER_MAP (xw));
- char * old_scan_hl = (XW_HIGHLIGHT_MAP (xw));
- char * old_end;
- unsigned int new_y = 0;
- for (; (new_y < min_y_csize); new_y += 1)
- {
- old_end = (old_scan_char + min_x_csize);
- while (old_scan_char < old_end)
- {
- (*new_scan_char++) = (*old_scan_char++);
- (*new_scan_hl++) = (*old_scan_hl++);
- }
- if (x_clipped < 0)
- {
- new_end = (new_scan_char + ((unsigned int) (- x_clipped)));
- while (new_scan_char < new_end)
- {
- (*new_scan_char++) = BLANK_CHAR;
- (*new_scan_hl++) = DEFAULT_HL;
- }
- }
- else if (x_clipped > 0)
- {
- old_scan_char += ((unsigned int) x_clipped);
- old_scan_hl += ((unsigned int) x_clipped);
- }
- }
- for (; (new_y < y_csize); new_y += 1)
- {
- new_end = (new_scan_char + x_csize);
- while (new_scan_char < new_end)
- {
- (*new_scan_char++) = BLANK_CHAR;
- (*new_scan_hl++) = DEFAULT_HL;
- }
- }
- free (XW_CHARACTER_MAP (xw));
- free (XW_HIGHLIGHT_MAP (xw));
- {
- unsigned int x_size = (XTERM_X_PIXEL (xw, x_csize));
- unsigned int y_size = (XTERM_Y_PIXEL (xw, x_csize));
- (XW_X_SIZE (xw)) = x_size;
- (XW_Y_SIZE (xw)) = y_size;
- (XW_CLIP_X (xw)) = 0;
- (XW_CLIP_Y (xw)) = 0;
- (XW_CLIP_WIDTH (xw)) = x_size;
- (XW_CLIP_HEIGHT (xw)) = y_size;
- }
- (XW_X_CSIZE (xw)) = x_csize;
- (XW_Y_CSIZE (xw)) = y_csize;
- (XW_CHARACTER_MAP (xw))= new_char_map;
- (XW_HIGHLIGHT_MAP (xw))= new_hl_map;
- XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- xterm_dump_contents (xw, 0, 0, x_csize, y_csize);
- xterm_update_normal_hints (xw);
- XFlush (XW_DISPLAY (xw));
- }
-}
-\f
-DEFINE_PRIMITIVE ("XTERM-RECONFIGURE", Prim_xterm_reconfigure, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- xterm_reconfigure ((x_window_arg (1)),
- (arg_ulong_integer (2)),
- (arg_ulong_integer (3)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-DUMP-RECTANGLE", Prim_xterm_dump_rectangle, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- xterm_dump_rectangle ((x_window_arg (1)),
- (arg_integer (2)),
- (arg_integer (3)),
- (arg_ulong_integer (4)),
- (arg_ulong_integer (5)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-MAP-X-COORDINATE", Prim_xterm_map_x_coordinate, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int signed_xp = (arg_integer (2));
- unsigned int xp = ((signed_xp < 0) ? 0 : ((unsigned int) signed_xp));
- int bx = (xp - (XW_INTERNAL_BORDER_WIDTH (xw)));
- PRIMITIVE_RETURN
- (long_to_integer
- (((bx < 0) ? 0
- : (bx >= (XW_X_SIZE (xw))) ? ((XW_X_SIZE (xw)) - 1)
- : bx)
- / (FONT_WIDTH (XW_FONT (xw)))));
- }
-}
-
-DEFINE_PRIMITIVE ("XTERM-MAP-Y-COORDINATE", Prim_xterm_map_y_coordinate, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int signed_yp = (arg_integer (2));
- unsigned int yp = ((signed_yp < 0) ? 0 : ((unsigned int) signed_yp));
- int by = (yp - (XW_INTERNAL_BORDER_WIDTH (xw)));
- PRIMITIVE_RETURN
- (long_to_integer
- (((by < 0) ? 0
- : (by >= (XW_Y_SIZE (xw))) ? ((XW_Y_SIZE (xw)) - 1)
- : by)
- / (FONT_HEIGHT (XW_FONT (xw)))));
- }
-}
-
-DEFINE_PRIMITIVE ("XTERM-MAP-X-SIZE", Prim_xterm_map_x_size, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int width =
- ((arg_nonnegative_integer (2)) - (2 * (XW_INTERNAL_BORDER_WIDTH (xw))));
- PRIMITIVE_RETURN
- (ulong_to_integer
- ((width < 0) ? 0 : (width / (FONT_WIDTH (XW_FONT (xw))))));
- }
-}
-
-DEFINE_PRIMITIVE ("XTERM-MAP-Y-SIZE", Prim_xterm_map_y_size, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- {
- struct xwindow * xw = (x_window_arg (1));
- int height =
- ((arg_nonnegative_integer (2)) - (2 * (XW_INTERNAL_BORDER_WIDTH (xw))));
- PRIMITIVE_RETURN
- (ulong_to_integer
- ((height < 0) ? 0 : (height / (FONT_HEIGHT (XW_FONT (xw))))));
- }
-}
-\f
-DEFINE_PRIMITIVE ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- struct xdisplay * xd = (x_display_arg (1));
- Display * display = (XD_DISPLAY (xd));
- struct drawing_attributes attributes;
- struct xwindow_methods methods;
- const char * resource_name = RESOURCE_NAME;
- const char * resource_class = RESOURCE_CLASS;
- int map_p;
- XSizeHints * size_hints;
- int x_pos;
- int y_pos;
- int x_size;
- int y_size;
- unsigned int x_csize;
- unsigned int y_csize;
- Window window;
- struct xwindow * xw;
- unsigned int map_size;
-
- x_decode_window_map_arg
- ((ARG_REF (3)), (&resource_name), (&resource_class), (&map_p));
- x_default_attributes
- (display, resource_name, resource_class, (&attributes));
- (methods.deallocator) = xterm_deallocate;
- (methods.event_processor) = xterm_process_event;
- (methods.x_coordinate_map) = xterm_x_coordinate_map;
- (methods.y_coordinate_map) = xterm_y_coordinate_map;
- (methods.update_normal_hints) = xterm_update_normal_hints;
-
- size_hints
- = (xterm_make_size_hints ((attributes.font),
- (2 * (attributes.internal_border_width))));
- XWMGeometry (display,
- (DefaultScreen (display)),
- (((ARG_REF (2)) == SHARP_F)
- ? (x_get_default
- (display, resource_name, resource_class,
- "geometry", "Geometry", 0))
- : (STRING_ARG (2))),
- DEFAULT_GEOMETRY,
- (attributes.border_width),
- size_hints,
- (&x_pos), (&y_pos), (&x_size), (&y_size),
- (& (size_hints->win_gravity)));
- x_csize
- = ((x_size - (size_hints->base_width)) / (size_hints->width_inc));
- y_csize
- = ((y_size - (size_hints->base_height)) / (size_hints->height_inc));
-
- window = (XCreateSimpleWindow
- (display, (RootWindow (display, (DefaultScreen (display)))),
- x_pos, y_pos, x_size, y_size,
- (attributes.border_width),
- (attributes.border_pixel),
- (attributes.background_pixel)));
- if (window == 0)
- error_external_return ();
-
- xw = (x_make_window
- (xd,
- window,
- (x_size - (size_hints->base_width)),
- (y_size - (size_hints->base_height)),
- (&attributes),
- (&methods),
- (sizeof (struct xwindow_term))));
- (XW_X_CSIZE (xw)) = x_csize;
- (XW_Y_CSIZE (xw)) = y_csize;
- (XW_CURSOR_X (xw)) = 0;
- (XW_CURSOR_Y (xw)) = 0;
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- (XW_CURSOR_ENABLED_P (xw)) = 1;
-
- map_size = (x_csize * y_csize);
- (XW_CHARACTER_MAP (xw)) = (x_malloc (map_size));
- memset ((XW_CHARACTER_MAP (xw)), BLANK_CHAR, map_size);
- (XW_HIGHLIGHT_MAP (xw)) = (x_malloc (map_size));
- memset ((XW_CHARACTER_MAP (xw)), DEFAULT_HL, map_size);
-
- (size_hints->flags) |= PWinGravity;
- xterm_set_wm_normal_hints (xw, size_hints);
- xw_set_wm_input_hint (xw, 1);
- xw_set_wm_name (xw, "scheme-terminal");
- xw_set_wm_icon_name (xw, "scheme-terminal");
- xw_make_window_map (xw, resource_name, resource_class, map_p);
- PRIMITIVE_RETURN (XW_TO_OBJECT (xw));
- }
-}
-\f
-DEFINE_PRIMITIVE ("XTERM-X-SIZE", Prim_xterm_x_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_X_CSIZE (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("XTERM-Y-SIZE", Prim_xterm_y_size, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN (ulong_to_integer (XW_Y_CSIZE (x_window_arg (1))));
-}
-
-DEFINE_PRIMITIVE ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0)
-{
- struct xwindow * xw;
- int extra;
- XFontStruct * font;
- PRIMITIVE_HEADER (3);
- xw = (x_window_arg (1));
- extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
-#ifdef __APPLE__
- extra += 1;
-#endif
- font = (XW_FONT (xw));
- XResizeWindow
- ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (((arg_ulong_integer (2)) * (FONT_WIDTH (font))) + extra),
- (((arg_ulong_integer (3)) * (FONT_HEIGHT (font))) + extra));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-ENABLE-CURSOR", Prim_xterm_enable_cursor, 2, 2, 0)
-{
- PRIMITIVE_HEADER (2);
- (XW_CURSOR_ENABLED_P (x_window_arg (1))) = (BOOLEAN_ARG (2));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-ERASE-CURSOR", Prim_xterm_erase_cursor, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- xterm_erase_cursor (x_window_arg (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-DRAW-CURSOR", Prim_xterm_draw_cursor, 1, 1, 0)
-{
- PRIMITIVE_HEADER (1);
- xterm_draw_cursor (x_window_arg (1));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-WRITE-CURSOR!", Prim_xterm_write_cursor, 3, 3, 0)
-{
- PRIMITIVE_HEADER (3);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw))));
- unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw))));
- if ((x != (XW_CURSOR_X (xw))) || (y != (XW_CURSOR_Y (xw))))
- {
- xterm_erase_cursor (xw);
- (XW_CURSOR_X (xw)) = x;
- (XW_CURSOR_Y (xw)) = y;
- }
- xterm_draw_cursor (xw);
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("XTERM-WRITE-CHAR!", Prim_xterm_write_char, 5, 5, 0)
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw))));
- unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw))));
- int c = (arg_ascii_char (4));
- unsigned int hl = (HL_ARG (5));
- unsigned int index = (XTERM_CHAR_INDEX (xw, x, y));
- char * map_ptr = (XTERM_CHAR_LOC (xw, index));
- (*map_ptr) = c;
- (XTERM_HL (xw, index)) = hl;
- XTERM_DRAW_CHARS (xw, x, y, map_ptr, 1, (XTERM_HL_GC (xw, hl)));
- if (((XW_CURSOR_X (xw)) == x) && ((XW_CURSOR_Y (xw)) == y))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-DEFINE_PRIMITIVE ("XTERM-WRITE-SUBSTRING!", Prim_xterm_write_substring, 7, 7, 0)
-{
- PRIMITIVE_HEADER (7);
- CHECK_ARG (4, STRING_P);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x = (arg_ulong_index_integer (2, (XW_X_CSIZE (xw))));
- unsigned int y = (arg_ulong_index_integer (3, (XW_Y_CSIZE (xw))));
- SCHEME_OBJECT string = (ARG_REF (4));
- unsigned int end
- = (arg_ulong_index_integer (6, ((STRING_LENGTH (string)) + 1)));
- unsigned int start = (arg_ulong_index_integer (5, (end + 1)));
- unsigned int hl = (HL_ARG (7));
- unsigned int length = (end - start);
- unsigned int index = (XTERM_CHAR_INDEX (xw, x, y));
- if ((x + length) > (XW_X_CSIZE (xw)))
- error_bad_range_arg (2);
- {
- unsigned char * string_scan = (STRING_LOC (string, start));
- unsigned char * string_end = (STRING_LOC (string, end));
- char * char_scan = (XTERM_CHAR_LOC (xw, index));
- char * hl_scan = (XTERM_HL_LOC (xw, index));
- while (string_scan < string_end)
- {
- (*char_scan++) = (*string_scan++);
- (*hl_scan++) = hl;
- }
- }
- XTERM_DRAW_CHARS
- (xw, x, y, (XTERM_CHAR_LOC (xw, index)), length, (XTERM_HL_GC (xw, hl)));
- if ((x <= (XW_CURSOR_X (xw))) && ((XW_CURSOR_X (xw)) < (x + length))
- && (y == (XW_CURSOR_Y (xw))))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-static void
-xterm_clear_rectangle (struct xwindow * xw,
- unsigned int x_start,
- unsigned int x_end,
- unsigned int y_start,
- unsigned int y_end,
- unsigned int hl)
-{
- unsigned int x_length = (x_end - x_start);
- unsigned int y;
- for (y = y_start; (y < y_end); y += 1)
- {
- unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y));
- {
- char * scan = (XTERM_CHAR_LOC (xw, index));
- char * end = (scan + x_length);
- while (scan < end)
- (*scan++) = BLANK_CHAR;
- }
- {
- char * scan = (XTERM_HL_LOC (xw, index));
- char * end = (scan + x_length);
- while (scan < end)
- (*scan++) = hl;
- }
- }
- if (hl != 0)
- {
- GC hl_gc = (XTERM_HL_GC (xw, hl));
- for (y = y_start; (y < y_end); y += 1)
- XTERM_DRAW_CHARS
- (xw, x_start, y,
- (XTERM_CHAR_LOC (xw, (XTERM_CHAR_INDEX (xw, x_start, y)))),
- x_length, hl_gc);
- }
- else if ((x_start == 0)
- && (y_start == 0)
- && (x_end == (XW_X_CSIZE (xw)))
- && (y_end == (XW_Y_CSIZE (xw))))
- XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
- else
- XClearArea ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XTERM_X_PIXEL (xw, x_start)),
- (XTERM_Y_PIXEL (xw, y_start)),
- (x_length * (FONT_WIDTH (XW_FONT (xw)))),
- ((y_end - y_start) * (FONT_HEIGHT (XW_FONT (xw)))),
- False);
-}
-
-DEFINE_PRIMITIVE ("XTERM-CLEAR-RECTANGLE!", Prim_xterm_clear_rectangle, 6, 6, 0)
-{
- PRIMITIVE_HEADER (6);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x_end
- = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1)));
- unsigned int y_end
- = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1)));
- unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1)));
- unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1)));
- unsigned int hl = (HL_ARG (6));
- if ((x_start < x_end) && (y_start < y_end))
- {
- xterm_clear_rectangle (xw, x_start, x_end, y_start, y_end, hl);
- if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, y_end))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-static void
-xterm_scroll_lines_up (struct xwindow * xw,
- unsigned int x_start,
- unsigned int x_end,
- unsigned int y_start,
- unsigned int y_end,
- unsigned int lines)
-{
- {
- unsigned int y_to = y_start;
- unsigned int y_from = (y_to + lines);
- while (y_from < y_end)
- xterm_copy_map_line (xw, x_start, x_end, (y_from++), (y_to++));
- }
- XCopyArea ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (XTERM_X_PIXEL (xw, x_start)),
- (XTERM_Y_PIXEL (xw, (y_start + lines))),
- ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))),
- (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))),
- (XTERM_X_PIXEL (xw, x_start)),
- (XTERM_Y_PIXEL (xw, y_start)));
-}
-
-DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-UP", Prim_xterm_scroll_lines_up, 6, 6,
- "(XTERM-SCROLL-LINES-UP XTERM X-START X-END Y-START Y-END LINES)\n\
-Scroll the contents of the region up by LINES.")
-{
- PRIMITIVE_HEADER (6);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x_end
- = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1)));
- unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1)));
- unsigned int y_end
- = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1)));
- unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1)));
- unsigned int lines = (arg_ulong_index_integer (6, (y_end - y_start)));
- if ((0 < lines) && (x_start < x_end) && (y_start < y_end))
- {
- if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, (y_start + lines), y_end))
- {
- xterm_erase_cursor (xw);
- xterm_scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines);
- xterm_draw_cursor (xw);
- }
- else
- {
- xterm_scroll_lines_up (xw, x_start, x_end, y_start, y_end, lines);
- if (CURSOR_IN_RECTANGLE
- (xw, x_start, x_end, y_start, (y_end - lines)))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-static void
-xterm_scroll_lines_down (struct xwindow * xw,
- unsigned int x_start,
- unsigned int x_end,
- unsigned int y_start,
- unsigned int y_end,
- unsigned int lines)
-{
- {
- unsigned int y_to = y_end;
- unsigned int y_from = (y_to - lines);
- while (y_from > y_start)
- xterm_copy_map_line (xw, x_start, x_end, (--y_from), (--y_to));
- }
- XCopyArea ((XW_DISPLAY (xw)),
- (XW_WINDOW (xw)),
- (XW_WINDOW (xw)),
- (XW_NORMAL_GC (xw)),
- (XTERM_X_PIXEL (xw, x_start)),
- (XTERM_Y_PIXEL (xw, y_start)),
- ((x_end - x_start) * (FONT_WIDTH (XW_FONT (xw)))),
- (((y_end - y_start) - lines) * (FONT_HEIGHT (XW_FONT (xw)))),
- (XTERM_X_PIXEL (xw, x_start)),
- (XTERM_Y_PIXEL (xw, (y_start + lines))));
-}
-
-DEFINE_PRIMITIVE ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down, 6, 6,
- "(XTERM-SCROLL-LINES-DOWN XTERM X-START X-END Y-START Y-END LINES)\n\
-Scroll the contents of the region down by LINES.")
-{
- PRIMITIVE_HEADER (6);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x_end
- = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1)));
- unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1)));
- unsigned int y_end
- = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1)));
- unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1)));
- unsigned int lines = (arg_ulong_index_integer (6, (y_end - y_start)));
- if ((0 < lines) && (x_start < x_end) && (y_start < y_end))
- {
- if (CURSOR_IN_RECTANGLE (xw, x_start, x_end, y_start, (y_end - lines)))
- {
- xterm_erase_cursor (xw);
- xterm_scroll_lines_down
- (xw, x_start, x_end, y_start, y_end, lines);
- xterm_draw_cursor (xw);
- }
- else
- {
- xterm_scroll_lines_down
- (xw, x_start, x_end, y_start, y_end, lines);
- if (CURSOR_IN_RECTANGLE
- (xw, x_start, x_end, (y_start + lines), y_end))
- {
- (XW_CURSOR_VISIBLE_P (xw)) = 0;
- xterm_draw_cursor (xw);
- }
- }
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-DEFINE_PRIMITIVE ("XTERM-SAVE-CONTENTS", Prim_xterm_save_contents, 5, 5,
- "(XTERM-SAVE-CONTENTS XW X-START X-END Y-START Y-END)\n\
-Get the contents of the terminal screen rectangle as a string.\n\
-The string contains alternating (CHARACTER, HIGHLIGHT) pairs.\n\
-The pairs are organized in row-major order from (X-START, Y-START).")
-{
- PRIMITIVE_HEADER (5);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x_end
- = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1)));
- unsigned int y_end
- = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1)));
- unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1)));
- unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1)));
- unsigned int x_length = (x_end - x_start);
- unsigned int string_length = (2 * x_length * (y_end - y_start));
- SCHEME_OBJECT string = (allocate_string (string_length));
- if (string_length > 0)
- {
- char * string_scan = (STRING_POINTER (string));
- unsigned int y;
- for (y = y_start; (y < y_end); y += 1)
- {
- unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y));
- char * char_scan = (XTERM_CHAR_LOC (xw, index));
- char * char_end = (char_scan + x_length);
- char * hl_scan = (XTERM_HL_LOC (xw, index));
- while (char_scan < char_end)
- {
- (*string_scan++) = (*char_scan++);
- (*string_scan++) = (*hl_scan++);
- }
- }
- }
- PRIMITIVE_RETURN (string);
- }
-}
-
-DEFINE_PRIMITIVE ("XTERM-RESTORE-CONTENTS", Prim_xterm_restore_contents, 6, 6,
- "(xterm-restore-contents xterm x-start x-end y-start y-end contents)\n\
-Replace the terminal screen rectangle with CONTENTS.\n\
-See `XTERM-SCREEN-CONTENTS' for the format of CONTENTS.")
-{
- PRIMITIVE_HEADER (6);
- CHECK_ARG (6, STRING_P);
- {
- struct xwindow * xw = (x_window_arg (1));
- unsigned int x_end
- = (arg_ulong_index_integer (3, ((XW_X_CSIZE (xw)) + 1)));
- unsigned int y_end
- = (arg_ulong_index_integer (5, ((XW_Y_CSIZE (xw)) + 1)));
- unsigned int x_start = (arg_ulong_index_integer (2, (x_end + 1)));
- unsigned int y_start = (arg_ulong_index_integer (4, (y_end + 1)));
- unsigned int x_length = (x_end - x_start);
- unsigned int string_length = (2 * x_length * (y_end - y_start));
- SCHEME_OBJECT string = (ARG_REF (6));
- if ((STRING_LENGTH (string)) != string_length)
- error_bad_range_arg (6);
- if (string_length > 0)
- {
- char * string_scan = (STRING_POINTER (string));
- unsigned int y;
- for (y = y_start; (y < y_end); y += 1)
- {
- unsigned int index = (XTERM_CHAR_INDEX (xw, x_start, y));
- char * char_scan = (XTERM_CHAR_LOC (xw, index));
- char * char_end = (char_scan + x_length);
- char * hl_scan = (XTERM_HL_LOC (xw, index));
- while (char_scan < char_end)
- {
- (*char_scan++) = (*string_scan++);
- (*hl_scan++) = (*string_scan++);
- }
- }
- xterm_dump_contents (xw, x_start, x_end, y_start, y_end);
- }
- }
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-\f
-#ifdef COMPILE_AS_MODULE
-
-/* sed -n -e 's/^DEFINE_PRIMITIVE *(\([^)]*\))$/ declare_primitive (\1);/pg' \
- -e 's/^DEFINE_PRIMITIVE *(\([^)]*\)$/ declare_primitive (\1 0);/pg' */
-
-void
-dload_initialize_x11term (void)
-{
- declare_primitive ("XTERM-CLEAR-RECTANGLE!", Prim_xterm_clear_rectangle, 6, 6, 0);
- declare_primitive ("XTERM-DRAW-CURSOR", Prim_xterm_draw_cursor, 1, 1, 0);
- declare_primitive ("XTERM-DUMP-RECTANGLE", Prim_xterm_dump_rectangle, 5, 5, 0);
- declare_primitive ("XTERM-ENABLE-CURSOR", Prim_xterm_enable_cursor, 2, 2, 0);
- declare_primitive ("XTERM-ERASE-CURSOR", Prim_xterm_erase_cursor, 1, 1, 0);
- declare_primitive ("XTERM-MAP-X-COORDINATE", Prim_xterm_map_x_coordinate, 2, 2, 0);
- declare_primitive ("XTERM-MAP-X-SIZE", Prim_xterm_map_x_size, 2, 2, 0);
- declare_primitive ("XTERM-MAP-Y-COORDINATE", Prim_xterm_map_y_coordinate, 2, 2, 0);
- declare_primitive ("XTERM-MAP-Y-SIZE", Prim_xterm_map_y_size, 2, 2, 0);
- declare_primitive ("XTERM-OPEN-WINDOW", Prim_xterm_open_window, 3, 3, 0);
- declare_primitive ("XTERM-RECONFIGURE", Prim_xterm_reconfigure, 3, 3, 0);
- declare_primitive ("XTERM-RESTORE-CONTENTS", Prim_xterm_restore_contents, 6, 6, 0);
- declare_primitive ("XTERM-SAVE-CONTENTS", Prim_xterm_save_contents, 5, 5, 0);
- declare_primitive ("XTERM-SCROLL-LINES-DOWN", Prim_xterm_scroll_lines_down, 6, 6, 0);
- declare_primitive ("XTERM-SCROLL-LINES-UP", Prim_xterm_scroll_lines_up, 6, 6, 0);
- declare_primitive ("XTERM-SET-SIZE", Prim_xterm_set_size, 3, 3, 0);
- declare_primitive ("XTERM-WRITE-CHAR!", Prim_xterm_write_char, 5, 5, 0);
- declare_primitive ("XTERM-WRITE-CURSOR!", Prim_xterm_write_cursor, 3, 3, 0);
- declare_primitive ("XTERM-WRITE-SUBSTRING!", Prim_xterm_write_substring, 7, 7, 0);
- declare_primitive ("XTERM-X-SIZE", Prim_xterm_x_size, 1, 1, 0);
- declare_primitive ("XTERM-Y-SIZE", Prim_xterm_y_size, 1, 1, 0);
-}
-
-#endif /* defined (COMPILE_AS_MODULE) */
(runtime debugger)
;; Misc (e.g., version)
(runtime)
- ;; Graphics. The last type initialized is the default for
- ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the
- ;; operating system are actually loaded and initialized.
- (optional (runtime x-graphics))
;; Emacs -- last because it installs hooks everywhere which must be initted.
(runtime emacs-interface)
;; More debugging
((unix) "x11graph")
(else))
(parent (runtime))
- (export ()
+ (export () deprecated:x11graph
create-x-colormap
create-x-image
x-character-bounds/ascent
x-visual-info/red-mask
x-visual-info/screen
x-visual-info/visual
- x-visual-info/visual-id)
- (initialization (initialize-package!)))
+ x-visual-info/visual-id))
(define-package (runtime state-space)
(files "wind")
;;; package: (runtime x-graphics)
(declare (usual-integrations))
-(declare (integrate-external "graphics"))
\f
-(define-primitives
- (x-close-all-displays 0)
- (x-display-descriptor 1)
- (x-display-get-default 3)
- (x-display-process-events 2)
- (x-font-structure 2)
- (x-window-beep 1)
- (x-window-clear 1)
- (x-window-colormap 1)
- (x-window-depth 1)
- (x-window-event-mask 1)
- (x-window-flush 1)
- (x-window-iconify 1)
- (x-window-id 1)
- (x-window-lower 1)
- (x-window-map 1)
- (x-window-query-pointer 1)
- (x-window-raise 1)
- (x-window-set-background-color 2)
- (x-window-set-border-color 2)
- (x-window-set-border-width 2)
- (x-window-set-cursor-color 2)
- (x-window-set-event-mask 2)
- (x-window-set-font 2)
- (x-window-set-foreground-color 2)
- (x-window-set-icon-name 2)
- (x-window-set-input-hint 2)
- (x-window-set-internal-border-width 2)
- (x-window-set-mouse-color 2)
- (x-window-set-mouse-shape 2)
- (x-window-set-name 2)
- (x-window-set-position 3)
- (x-window-set-size 3)
- (x-window-visual 1)
- (x-window-withdraw 1)
- (x-window-x-size 1)
- (x-window-y-size 1)
- (x-graphics-copy-area 8)
- (x-graphics-drag-cursor 3)
- (x-graphics-draw-arc 8)
- (x-graphics-draw-line 5)
- (x-graphics-draw-lines 3)
- (x-graphics-draw-point 3)
- (x-graphics-draw-points 3)
- (x-graphics-draw-string 4)
- (x-graphics-draw-image-string 4)
- (x-graphics-fill-polygon 2)
- (x-graphics-map-x-coordinate 2)
- (x-graphics-map-y-coordinate 2)
- (x-graphics-move-cursor 3)
- (x-graphics-open-window 3)
- (x-graphics-reconfigure 3)
- (x-graphics-reset-clip-rectangle 1)
- (x-graphics-set-clip-rectangle 5)
- (x-graphics-set-dashes 3)
- (x-graphics-set-fill-style 2)
- (x-graphics-set-function 2)
- (x-graphics-set-line-style 2)
- (x-graphics-set-vdc-extent 5)
- (x-graphics-vdc-extent 1)
- (x-bytes-into-image 2)
- (x-create-image 3)
- (x-destroy-image 1)
- (x-display-image 8)
- (x-get-pixel-from-image 3)
- (x-set-pixel-in-image 4)
- (x-allocate-color 4)
- (x-create-colormap 3)
- (x-free-colormap 1)
- (x-query-color 2)
- (x-set-window-colormap 2)
- (x-store-color 5)
- (x-store-colors 2)
- (x-visual-deallocate 1))
-\f
-;; These constants must match "microcode/x11base.c"
-(define-integrable event-type:button-down 0)
-(define-integrable event-type:button-up 1)
-(define-integrable event-type:configure 2)
-(define-integrable event-type:enter 3)
-(define-integrable event-type:focus-in 4)
-(define-integrable event-type:focus-out 5)
-(define-integrable event-type:key-press 6)
-(define-integrable event-type:leave 7)
-(define-integrable event-type:motion 8)
-(define-integrable event-type:expose 9)
-(define-integrable event-type:delete-window 10)
-(define-integrable event-type:map 11)
-(define-integrable event-type:unmap 12)
-(define-integrable event-type:take-focus 13)
-(define-integrable event-type:visibility 14)
-(define-integrable event-type:selection-clear 15)
-(define-integrable event-type:selection-notify 16)
-(define-integrable event-type:selection-request 17)
-(define-integrable event-type:property-notify 18)
-(define-integrable number-of-event-types 19)
-
-;; This mask contains button-down, button-up,configure, enter,
-;; focus-in, focus-out, key-press, leave, motion, delete-window, map,
-;; unmap, and visibility.
-(define-integrable event-mask:normal #x5dff)
-
-;; This mask additionally contains take-focus.
-(define-integrable event-mask:ignore-focus #x7dff)
-
-;; This mask contains button-down.
-(define-integrable user-event-mask:default #x0001)
-\f
-;;;; X graphics device
+;;; Access to the X11 library is now accomplished with the FFI rather
+;;; than a microcode module. The bindings in this package are linked
+;;; to those in the (x11 graphics) package after the plugin is loaded.
-(define (initialize-package!)
- (set! x-graphics-device-type
- (make-graphics-device-type
- 'x
- `((available? ,x-graphics/available?)
- (clear ,x-graphics/clear)
- (close ,x-graphics/close-window)
- (color? ,x-graphics/color?)
- (coordinate-limits ,x-graphics/coordinate-limits)
- (copy-area ,x-graphics/copy-area)
- (create-colormap ,create-x-colormap)
- (create-image ,x-graphics/create-image)
- (device-coordinate-limits ,x-graphics/device-coordinate-limits)
- (drag-cursor ,x-graphics/drag-cursor)
- (draw-arc ,x-graphics/draw-arc)
- (draw-circle ,x-graphics/draw-circle)
- (draw-image ,image/draw)
- (draw-line ,x-graphics/draw-line)
- (draw-lines ,x-graphics/draw-lines)
- (draw-point ,x-graphics/draw-point)
- (draw-points ,x-graphics/draw-points)
- (draw-subimage ,image/draw-subimage)
- (draw-text ,x-graphics/draw-text)
- (draw-text-opaque ,x-graphics/draw-text-opaque)
- (fill-circle ,x-graphics/fill-circle)
- (fill-polygon ,x-graphics/fill-polygon)
- (flush ,x-graphics/flush)
- (font-structure ,x-graphics/font-structure)
- (get-colormap ,x-graphics/get-colormap)
- (get-default ,x-graphics/get-default)
- (iconify-window ,x-graphics/iconify-window)
- (image-depth ,x-graphics/image-depth)
- (lower-window ,x-graphics/lower-window)
- (map-window ,x-graphics/map-window)
- (move-cursor ,x-graphics/move-cursor)
- (move-window ,x-graphics/move-window)
- (open ,x-graphics/open)
- (open? ,x-graphics/open-window?)
- (query-pointer ,x-graphics/query-pointer)
- (raise-window ,x-graphics/raise-window)
- (reset-clip-rectangle ,x-graphics/reset-clip-rectangle)
- (resize-window ,x-graphics/resize-window)
- (set-background-color ,x-graphics/set-background-color)
- (set-border-color ,x-graphics/set-border-color)
- (set-border-width ,x-graphics/set-border-width)
- (set-clip-rectangle ,x-graphics/set-clip-rectangle)
- (set-colormap ,x-graphics/set-colormap)
- (set-coordinate-limits ,x-graphics/set-coordinate-limits)
- (set-drawing-mode ,x-graphics/set-drawing-mode)
- (set-font ,x-graphics/set-font)
- (set-foreground-color ,x-graphics/set-foreground-color)
- (set-icon-name ,x-graphics/set-icon-name)
- (set-input-hint ,x-graphics/set-input-hint)
- (set-internal-border-width ,x-graphics/set-internal-border-width)
- (set-line-style ,x-graphics/set-line-style)
- (set-mouse-color ,x-graphics/set-mouse-color)
- (set-mouse-shape ,x-graphics/set-mouse-shape)
- (set-window-name ,x-graphics/set-window-name)
- (visual-info ,x-graphics/visual-info)
- (withdraw-window ,x-graphics/withdraw-window))))
- (set! display-finalizer
- (make-gc-finalizer (ucode-primitive x-close-display 1)
- x-display?
- x-display/xd
- set-x-display/xd!))
- (initialize-image-datatype)
- (initialize-colormap-datatype))
+(define linked? #f)
(define (x-graphics/available?)
- (load-library-object-file "prx11" #f)
- (implemented-primitive-procedure?
- (ucode-primitive x-graphics-open-window 3)))
-
-(define x-graphics-device-type)
-\f
-;;;; Open/Close Displays
-
-(define display-finalizer)
-
-(define-structure (x-display
- (conc-name x-display/)
- (constructor make-x-display (name xd))
- (print-procedure
- (standard-print-method 'x-display
- (lambda (display)
- (list (x-display/name display))))))
- (name #f read-only #t)
- xd
- (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1)
- x-window?
- x-window/xw
- set-x-window/xw!)
- read-only #t)
- (previewer-registration #f)
- (event-queue (make-queue))
- (properties (make-1d-table) read-only #t))
-
-(define (x-graphics/open-display name)
- (let ((name
- (cond ((not name)
- (or x-graphics-default-display-name
- (let ((name (get-environment-variable "DISPLAY")))
- (if (not name)
- (error "No DISPLAY environment variable."))
- name)))
- ((string? name)
- name)
- (else
- (error:wrong-type-argument name
- "string or #f"
- x-graphics/open-display)))))
- (or (search-gc-finalizer display-finalizer
- (lambda (display)
- (string=? (x-display/name display) name)))
- (let ((xd ((ucode-primitive x-open-display 1) name)))
- (if (not xd)
- (error "Unable to open display:" name))
- (let ((display (make-x-display name xd)))
- (add-to-gc-finalizer! display-finalizer display)
- (register-event-previewer! display)
- display)))))
-
-(define (x-graphics/close-display display)
- (without-interruption
- (lambda ()
- (if (x-display/xd display)
- (begin
- (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
- (let ((registration (x-display/previewer-registration display)))
- (if registration
- (begin
- (deregister-io-thread-event registration)
- (set-x-display/previewer-registration! display #f))))
- (remove-from-gc-finalizer! display-finalizer display))))))
-
-(define (x-graphics/open-display? display)
- (if (x-display/xd display) #t #f))
-\f
-(define (register-event-previewer! display)
- (let ((registration))
- (set! registration
- (permanently-register-io-thread-event
- (x-display-descriptor (x-display/xd display))
- 'read
- (current-thread)
- (lambda (mode)
- mode
- (call-with-current-continuation
- (lambda (continuation)
- (bind-condition-handler
- (list condition-type:bad-range-argument
- condition-type:wrong-type-argument)
- (lambda (condition)
- ;; If X-DISPLAY-PROCESS-EVENTS or
- ;; X-DISPLAY-DESCRIPTOR signals an argument error
- ;; on its display argument, that means the
- ;; display has been closed.
- condition
- (deregister-io-thread-event registration)
- (continuation unspecific))
- (lambda ()
- (let loop ()
- (let ((event
- (x-display-process-events (x-display/xd display)
- 2)))
- (if event
- (begin (if (not (eq? #t event))
- (process-event display event))
- (loop))))))))))))
- (set-x-display/previewer-registration! display registration)))
-
-(define (read-event display)
- (letrec ((loop
- (let ((queue (x-display/event-queue display)))
- (lambda ()
- (if (queue-empty? queue)
- (begin
- (%read-and-process-event display)
- (loop))
- (dequeue! queue))))))
- (with-thread-events-blocked loop)))
-
-(define (%read-and-process-event display)
- (let ((event
- (or (x-display-process-events (x-display/xd display) 2)
- (and (eq? 'read
- (test-for-io-on-descriptor
- (x-display-descriptor (x-display/xd display))
- #t
- 'read))
- (x-display-process-events (x-display/xd display) 1)))))
- (if (and event (not (eq? #t event)))
- (process-event display event))))
-
-(define (discard-events display)
- (letrec ((loop
- (let ((queue (x-display/event-queue display)))
- (lambda ()
- (cond ((not (queue-empty? queue))
- (dequeue! queue)
- (loop))
- ((x-display-process-events (x-display/xd display) 2)
- =>
- (lambda (event)
- (if (not (eq? #t event))
- (process-event display event))
- (loop))))))))
- (with-thread-events-blocked loop)))
-\f
-(define (process-event display event)
- (without-interruption
- (lambda ()
- (let ((window
- (search-gc-finalizer (x-display/window-finalizer display)
- (let ((xw (vector-ref event 1)))
- (lambda (window)
- (eq? (x-window/xw window) xw))))))
- (if window
- (let ((type (vector-ref event 0)))
- (let ((handler (vector-ref event-handlers type)))
- (if handler
- (handler window event)))
- (if (or (fix:= event-type:delete-window type)
- (not (fix:= 0
- (fix:and (fix:lsh 1 type)
- (x-window/user-event-mask window)))))
- (begin
- ;; This would prefer to be the graphics device, but
- ;; that's not available from here.
- (vector-set! event 1 window)
- (enqueue!/unsafe (x-display/event-queue display)
- event)))))))))
-
-(define event-handlers
- (make-vector number-of-event-types #f))
-
-(define-integrable (define-event-handler event-type handler)
- (vector-set! event-handlers event-type handler))
-\f
-(define-event-handler event-type:configure
- (lambda (window event)
- (x-graphics-reconfigure (vector-ref event 1)
- (vector-ref event 2)
- (vector-ref event 3))
- (if (eq? 'never (x-window/mapped? window))
- (set-x-window/mapped?! window #t))))
-
-(define-event-handler event-type:delete-window
- (lambda (window event)
- event
- (close-x-window window)))
-
-(define-event-handler event-type:map
- (lambda (window event)
- event
- (set-x-window/mapped?! window #t)))
-
-(define-event-handler event-type:unmap
- (lambda (window event)
- event
- (set-x-window/mapped?! window #f)))
-
-(define-event-handler event-type:visibility
- (lambda (window event)
- (case (vector-ref event 2)
- ((0) (set-x-window/visibility! window 'unobscured))
- ((1) (set-x-window/visibility! window 'partially-obscured))
- ((2) (set-x-window/visibility! window 'obscured)))))
-
-(let ((mouse-event-handler
- (lambda (window event)
- window
- (let ((xw (vector-ref event 1)))
- (vector-set! event 2
- (x-graphics-map-x-coordinate xw
- (vector-ref event 2)))
- (vector-set! event 3
- (x-graphics-map-y-coordinate xw
- (vector-ref event 3)))))))
- ;; ENTER and LEAVE events should be modified to have X,Y coordinates.
- (define-event-handler event-type:button-down mouse-event-handler)
- (define-event-handler event-type:button-up mouse-event-handler)
- (define-event-handler event-type:motion mouse-event-handler))
-\f
-;;;; Standard Operations
-
-(define x-graphics:auto-raise? #f)
-
-(define-structure (x-window (conc-name x-window/)
- (constructor make-x-window (xw display)))
- xw
- (display #f read-only #t)
- (mapped? 'never)
- (visibility #f)
- (user-event-mask user-event-mask:default))
-
-(define-integrable (x-graphics-device/xw device)
- (x-window/xw (graphics-device/descriptor device)))
-
-(define (x-graphics/display device)
- (x-window/display (graphics-device/descriptor device)))
-
-(define-integrable (x-graphics-device/xd device)
- (x-display/xd (x-window/display (graphics-device/descriptor device))))
-
-(define-integrable (x-graphics-device/mapped? device)
- (eq? #t (x-window/mapped? (graphics-device/descriptor device))))
-
-(define-integrable (x-graphics-device/visibility device)
- (x-window/visibility (graphics-device/descriptor device)))
-
-(define (x-graphics/open-window? device)
- (if (x-graphics-device/xw device) #t #f))
-
-(define (x-graphics/close-window device)
- (without-interruption
- (lambda ()
- (close-x-window (graphics-device/descriptor device)))))
-
-(define (close-x-window window)
- (remove-from-gc-finalizer!
- (x-display/window-finalizer (x-window/display window))
- window))
-
-(define (x-geometry-string x y width height)
- (string-append (if (and width height)
- (string-append (number->string width)
- "x"
- (number->string height))
- "")
- (if (and x y)
- (string-append (if (negative? x) "" "+")
- (number->string x)
- (if (negative? y) "" "+")
- (number->string y))
- "")))
-\f
-(define x-graphics-default-geometry "512x512")
-(define x-graphics-default-display-name #f)
-
-(define (x-graphics/open descriptor->device
- #!optional display geometry suppress-map?)
- (let ((display
- (let ((display
- (and (not (default-object? display))
- display)))
- (if (x-display? display)
- display
- (x-graphics/open-display display)))))
- (call-with-values
- (lambda ()
- (decode-suppress-map-arg (and (not (default-object? suppress-map?))
- suppress-map?)
- 'make-graphics-device))
- (lambda (map? resource class)
- (let ((xw
- (x-graphics-open-window
- (x-display/xd display)
- (if (default-object? geometry)
- x-graphics-default-geometry
- geometry)
- (vector #f resource class))))
- (x-window-set-event-mask xw event-mask:normal)
- (let ((window (make-x-window xw display)))
- (add-to-gc-finalizer! (x-display/window-finalizer display) window)
- (if map? (map-window window))
- (descriptor->device window)))))))
-
-(define (map-window window)
- (let ((xw (x-window/xw window)))
- (x-window-map xw)
- ;; If this is the first time that this window has been mapped, we
- ;; need to wait for a MAP event before continuing.
- (if (not (boolean? (x-window/mapped? window)))
- (begin
- (x-window-flush xw)
- (letrec ((loop
- (let ((display (x-window/display window)))
- (lambda ()
- (if (not (eq? #t (x-window/mapped? window)))
- (begin
- (%read-and-process-event display)
- (loop)))))))
- (with-thread-events-blocked loop))))))
-
-(define (decode-suppress-map-arg suppress-map? procedure)
- (cond ((boolean? suppress-map?)
- (values (not suppress-map?) "schemeGraphics" "SchemeGraphics"))
- ((and (pair? suppress-map?)
- (string? (car suppress-map?))
- (string? (cdr suppress-map?)))
- (values #f (car suppress-map?) (cdr suppress-map?)))
- ((and (vector? suppress-map?)
- (fix:= (vector-length suppress-map?) 3)
- (boolean? (vector-ref suppress-map? 0))
- (string? (vector-ref suppress-map? 1))
- (string? (vector-ref suppress-map? 2)))
- (values (vector-ref suppress-map? 0)
- (vector-ref suppress-map? 1)
- (vector-ref suppress-map? 2)))
- (else
- (error:wrong-type-argument suppress-map?
- "X suppress-map arg"
- procedure))))
-\f
-(define (x-graphics/clear device)
- (x-window-clear (x-graphics-device/xw device)))
-
-(define (x-graphics/coordinate-limits device)
- (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device))))
- (values (vector-ref limits 0) (vector-ref limits 1)
- (vector-ref limits 2) (vector-ref limits 3))))
-
-(define (x-graphics/device-coordinate-limits device)
- (let ((xw (x-graphics-device/xw device)))
- (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0)))
-
-(define (x-graphics/drag-cursor device x y)
- (x-graphics-drag-cursor (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)))
-
-(define (x-graphics/draw-line device x-start y-start x-end y-end)
- (x-graphics-draw-line (x-graphics-device/xw device)
- (->flonum x-start)
- (->flonum y-start)
- (->flonum x-end)
- (->flonum y-end)))
-
-(define (x-graphics/draw-lines device xv yv)
- (x-graphics-draw-lines (x-graphics-device/xw device) xv yv))
-
-(define (x-graphics/draw-point device x y)
- (x-graphics-draw-point (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)))
-
-(define (x-graphics/draw-points device xv yv)
- (x-graphics-draw-points (x-graphics-device/xw device) xv yv))
-
-(define (x-graphics/draw-text device x y string)
- (x-graphics-draw-string (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- string))
-
-(define (x-graphics/draw-text-opaque device x y string)
- (x-graphics-draw-image-string (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- string))
-
-(define (x-graphics/flush device)
- (if (and x-graphics:auto-raise?
- (x-graphics-device/mapped? device)
- (not (eq? 'unobscured (x-graphics-device/visibility device))))
- (x-graphics/raise-window device))
- ((ucode-primitive x-display-flush 1) (x-graphics-device/xd device)))
-
-(define (x-graphics/move-cursor device x y)
- (x-graphics-move-cursor (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)))
-
-(define (x-graphics/reset-clip-rectangle device)
- (x-graphics-reset-clip-rectangle (x-graphics-device/xw device)))
-\f
-(define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
- (x-graphics-set-clip-rectangle (x-graphics-device/xw device)
- (->flonum x-left)
- (->flonum y-bottom)
- (->flonum x-right)
- (->flonum y-top)))
-
-(define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
- (x-graphics-set-vdc-extent (x-graphics-device/xw device)
- (->flonum x-left)
- (->flonum y-bottom)
- (->flonum x-right)
- (->flonum y-top)))
-
-(define (x-graphics/set-drawing-mode device mode)
- (x-graphics-set-function (x-graphics-device/xw device) mode))
-
-(define (x-graphics/set-line-style device line-style)
- (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
- (error:wrong-type-argument line-style "graphics line style"
- 'set-line-style))
- (let ((xw (x-graphics-device/xw device)))
- (if (zero? line-style)
- (x-graphics-set-line-style xw 0)
- (begin
- (x-graphics-set-line-style xw 2)
- (x-graphics-set-dashes xw
- 0
- (vector-ref '#("\010\010"
- "\001\001"
- "\015\001\001\001"
- "\013\001\001\001\001\001"
- "\013\005"
- "\014\001\002\001"
- "\011\001\002\001\002\001")
- (- line-style 1)))))))
-
-;;;; Appearance Operations
-
-(define (x-graphics/set-background-color device color)
- (x-window-set-background-color (x-graphics-device/xw device) color))
-
-(define (x-graphics/set-border-color device color)
- (x-window-set-border-color (x-graphics-device/xw device) color))
-
-(define (x-graphics/set-border-width device width)
- (x-window-set-border-width (x-graphics-device/xw device) width))
-
-(define (x-graphics/set-font device font)
- (x-window-set-font (x-graphics-device/xw device) font))
-
-(define (x-graphics/set-foreground-color device color)
- (x-window-set-foreground-color (x-graphics-device/xw device) color))
-
-(define (x-graphics/set-internal-border-width device width)
- (x-window-set-internal-border-width (x-graphics-device/xw device) width))
-
-(define (x-graphics/set-mouse-color device color)
- (x-window-set-mouse-color (x-graphics-device/xw device) color))
-
-(define (x-graphics/set-mouse-shape device shape)
- (x-window-set-mouse-shape (x-graphics-device/xw device) shape))
-\f
-;;;; Miscellaneous Operations
-
-(define (x-graphics/draw-arc device x y radius-x radius-y
- angle-start angle-sweep fill?)
- (x-graphics-draw-arc (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- (->flonum radius-x)
- (->flonum radius-y)
- (->flonum angle-start)
- (->flonum angle-sweep)
- fill?))
-
-(define (x-graphics/draw-circle device x y radius)
- (x-graphics-draw-arc (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- (->flonum radius)
- (->flonum radius)
- 0.
- 360.
- #f))
-
-(define (x-graphics/fill-circle device x y radius)
- (x-graphics-draw-arc (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- (->flonum radius)
- (->flonum radius)
- 0.
- 360.
- #t))
-
-(define (x-graphics/fill-polygon device point-vector)
- (x-graphics-fill-polygon (x-graphics-device/xw device)
- (vector-map ->flonum point-vector)))
-
-(define (x-graphics/copy-area device source-x-left source-y-top width height
- destination-x-left destination-y-top)
- (let ((xw (x-graphics-device/xw device)))
- (x-graphics-copy-area xw xw
- (->flonum source-x-left)
- (->flonum source-y-top)
- (->flonum width)
- (->flonum height)
- (->flonum destination-x-left)
- (->flonum destination-y-top))))
-
-(define (x-graphics/get-default device resource-name class-name)
- (x-display-get-default (x-graphics-device/xd device)
- resource-name class-name))
-
-(define (x-graphics/window-id device)
- (x-window-id (x-graphics-device/xw device)))
-\f
-;;;; Event-Handling Operations
-
-(define (x-graphics/set-input-hint device input?)
- (x-window-set-input-hint (x-graphics-device/xw device) input?))
-
-(define (x-graphics/disable-keyboard-focus device)
- ;; Tell the window to participate in the TAKE-FOCUS protocol. Since
- ;; there is no handler for this event, focus will never be given to
- ;; the window.
- (x-window-set-event-mask (x-graphics-device/xw device)
- event-mask:ignore-focus))
-
-(define (x-graphics/enable-keyboard-focus device)
- (x-window-set-event-mask (x-graphics-device/xw device) event-mask:normal))
-
-(define (x-graphics/select-user-events device mask)
- (set-x-window/user-event-mask! (graphics-device/descriptor device) mask))
-
-(define (x-graphics/query-pointer device)
- (let* ((window (x-graphics-device/xw device))
- (result (x-window-query-pointer window)))
- (values (x-graphics-map-x-coordinate window (vector-ref result 2))
- (x-graphics-map-y-coordinate window (vector-ref result 3))
- (vector-ref result 4))))
-
-(define (x-graphics/read-button device)
- (let ((event (read-event-of-type device event-type:button-down)))
- (values (vector-ref event 2)
- (vector-ref event 3)
- (vector-ref event 4))))
-
-(define (read-event-of-type device event-type)
- (let ((window (graphics-device/descriptor device))
- (display (x-graphics/display device)))
- (let loop ()
- (let ((event (read-event display)))
- (if (eq? window (vector-ref event 1))
- (begin
- (if (fix:= (vector-ref event 0) event-type:delete-window)
- (error "Window closed while waiting to read event."))
- (if (fix:= (vector-ref event 0) event-type)
- event
- (loop)))
- (loop))))))
-
-(define (x-graphics/read-user-event device)
- (read-event (x-graphics/display device)))
-
-(define (x-graphics/discard-events device)
- (discard-events (x-graphics/display device)))
-\f
-;;;; Font Operations
-
-(define (x-graphics/font-structure device string)
- (x-font-structure (x-graphics-device/xd device) string))
-
-(define-structure (x-font-structure (conc-name x-font-structure/)
- (type vector))
- (name #f read-only #t)
- (direction #f read-only #t)
- (all-chars-exist? #f read-only #t)
- (default-char #f read-only #t)
- (min-bounds #f read-only #t)
- (max-bounds #f read-only #t)
- (start-index #f read-only #t)
- (character-bounds #f read-only #t)
- (max-ascent #f read-only #t)
- (max-descent #f read-only #t))
-
-(define-structure (x-character-bounds (conc-name x-character-bounds/)
- (type vector))
- (lbearing #f read-only #t)
- (rbearing #f read-only #t)
- (width #f read-only #t)
- (ascent #f read-only #t)
- (descent #f read-only #t))
-
-;;;; Window Management Operations
-
-(define (x-graphics/map-window device)
- (map-window (graphics-device/descriptor device)))
-
-(define (x-graphics/withdraw-window device)
- (x-window-withdraw (x-graphics-device/xw device)))
-
-(define (x-graphics/iconify-window device)
- (x-window-iconify (x-graphics-device/xw device)))
-
-(define (x-graphics/raise-window device)
- (x-window-raise (x-graphics-device/xw device)))
-
-(define (x-graphics/lower-window device)
- (x-window-lower (x-graphics-device/xw device)))
-
-(define (x-graphics/set-icon-name device name)
- (x-window-set-icon-name (x-graphics-device/xw device) name))
-
-(define (x-graphics/set-window-name device name)
- (x-window-set-name (x-graphics-device/xw device) name))
-
-(define (x-graphics/move-window device x y)
- (x-window-set-position (x-graphics-device/xw device) x y))
-
-(define (x-graphics/resize-window device width height)
- (x-window-set-size (x-graphics-device/xw device) width height))
-\f
-;;;; Images
-
-;; X-IMAGE is the descriptor of the generic images.
-
-(define-structure (x-image (conc-name x-image/))
- descriptor
- window
- width
- height)
-
-(define image-list)
-
-(define (initialize-image-datatype)
- (1d-table/put!
- (graphics-type-properties x-graphics-device-type)
- 'image-type
- (make-image-type
- `((create ,create-x-image)
- (destroy ,x-graphics-image/destroy)
- (width ,x-graphics-image/width)
- (height ,x-graphics-image/height)
- (draw ,x-graphics-image/draw)
- (draw-subimage ,x-graphics-image/draw-subimage)
- (fill-from-byte-vector ,x-graphics-image/fill-from-byte-vector))))
- (set! image-list
- (make-gc-finalizer x-destroy-image
- x-image?
- x-image/descriptor
- set-x-image/descriptor!))
- unspecific)
-
-(define (create-x-image device width height)
- (let ((window (x-graphics-device/xw device)))
- (add-to-gc-finalizer! image-list
- (make-x-image (x-create-image window width height)
- window width height))))
-
-(define (x-image/destroy image)
- (remove-from-gc-finalizer! image-list image))
-
-(define (x-image/get-pixel image x y)
- (x-get-pixel-from-image (x-image/descriptor image) x y))
-
-(define (x-image/set-pixel image x y value)
- (x-set-pixel-in-image (x-image/descriptor image) x y value))
-
-(define (x-image/draw image window-x window-y)
- (x-display-image (x-image/descriptor image)
- 0
- 0
- (x-image/window image)
- (->flonum window-x)
- (->flonum window-y)
- (x-image/width image)
- (x-image/height image)))
-
-(define (x-image/draw-subimage image x y width height window-x window-y)
- (x-display-image (x-image/descriptor image)
- x
- y
- (x-image/window image)
- (->flonum window-x)
- (->flonum window-y)
- width
- height))
-
-(define (x-image/fill-from-byte-vector image byte-vector)
- (x-bytes-into-image byte-vector (x-image/descriptor image)))
-\f
-;; Abstraction layer for generic images
-
-(define (x-graphics/create-image device width height)
- (image/create device width height))
-
-;;(define x-graphics-image/create create-x-image)
-
-(define (x-graphics-image/destroy image)
- (x-image/destroy (image/descriptor image)))
-
-(define (x-graphics-image/width image)
- (x-image/width (image/descriptor image)))
-
-(define (x-graphics-image/height image)
- (x-image/height (image/descriptor image)))
-
-(define (x-graphics-image/draw device x y image)
- (let* ((x-image (image/descriptor image))
- (w (x-image/width x-image))
- (h (x-image/height x-image)))
- (x-display-image (x-image/descriptor x-image)
- 0
- 0
- (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- w
- h)))
-
-(define (x-graphics-image/draw-subimage device x y image im-x im-y w h)
- (let ((x-image (image/descriptor image)))
- (x-display-image (x-image/descriptor x-image)
- im-x
- im-y
- (x-graphics-device/xw device)
- (->flonum x)
- (->flonum y)
- w
- h)))
-
-(define (x-graphics-image/fill-from-byte-vector image byte-vector)
- (x-image/fill-from-byte-vector (image/descriptor image) byte-vector))
-\f
-;;;; Colormaps
-
-(define-record-type <colormap>
- (%make-colormap descriptor)
+ (and (plugin-available? "x11")
+ (or linked?
+ (begin
+ (load-option 'x11)
+ (link!)
+ #t))))
+
+(define (link!)
+ (for-each
+ (let ((runtime (->environment '(runtime x-graphics)))
+ (x11 (->environment '(x11))))
+ (lambda (name)
+ (environment-link-name runtime x11 name)))
+ names)
+ (set! linked? #t))
+
+(define names
+ '(create-x-colormap
+ create-x-image
+ x-character-bounds/ascent
+ x-character-bounds/descent
+ x-character-bounds/lbearing
+ x-character-bounds/rbearing
+ x-character-bounds/width
+ x-close-all-displays
+ x-colormap/allocate-color
+ x-colormap/free
+ x-colormap/query-color
+ x-colormap/store-color
+ x-colormap/store-colors
x-colormap?
- (descriptor colormap/descriptor set-colormap/descriptor!))
-
-(define colormap-list)
-
-(define (initialize-colormap-datatype)
- (set! colormap-list
- (make-gc-finalizer x-free-colormap
- x-colormap?
- colormap/descriptor
- set-colormap/descriptor!))
- unspecific)
-
-(define (make-colormap descriptor)
- (add-to-gc-finalizer! colormap-list (%make-colormap descriptor)))
-
-(define (x-graphics/get-colormap device)
- (make-colormap (x-window-colormap (x-graphics-device/xw device))))
-
-(define (x-graphics/set-colormap device colormap)
- (x-set-window-colormap (x-graphics-device/xw device)
- (colormap/descriptor colormap)))
-
-(define (create-x-colormap device writeable?)
- (let ((window (x-graphics-device/xw device)))
- (let ((visual (x-window-visual window)))
- (let ((descriptor (x-create-colormap window visual writeable?)))
- (x-visual-deallocate visual)
- (make-colormap descriptor)))))
-
-(define (x-colormap/free colormap)
- (remove-from-gc-finalizer! colormap-list colormap))
-
-(define (x-colormap/allocate-color colormap r g b)
- (x-allocate-color (colormap/descriptor colormap) r g b))
-
-(define (x-colormap/query-color colormap position)
- (x-query-color (colormap/descriptor colormap) position))
-
-(define (x-colormap/store-color colormap position r g b)
- (x-store-color (colormap/descriptor colormap) position r g b))
-
-(define (x-colormap/store-colors colormap color-vector)
- (x-store-colors (colormap/descriptor colormap) color-vector))
-\f
-(define (x-graphics/color? device)
- (let ((info (x-graphics/visual-info device)))
- (let ((n (vector-length info)))
- (let loop ((index 0))
- (and (not (fix:= index n))
- (or (let ((class (x-visual-info/class (vector-ref info index))))
- (or (eq? x-visual-class:static-color class)
- (eq? x-visual-class:pseudo-color class)
- (eq? x-visual-class:true-color class)
- (eq? x-visual-class:direct-color class)))
- (loop (fix:+ index 1))))))))
-
-(define (x-graphics/image-depth device)
- (x-window-depth (x-graphics-device/xw device)))
-
-(define (x-graphics/visual-info device)
- ((ucode-primitive x-get-visual-info 10) (x-graphics-device/xw device)
- #f #f #f #f #f #f #f #f #f))
-
-(define-structure (visual-info (type vector) (conc-name x-visual-info/))
- (visual #f read-only #t)
- (visual-id #f read-only #t)
- (screen #f read-only #t)
- (depth #f read-only #t)
- (class #f read-only #t)
- (red-mask #f read-only #t)
- (green-mask #f read-only #t)
- (blue-mask #f read-only #t)
- (colormap-size #f read-only #t)
- (bits-per-rgb #f read-only #t))
-
-(define-integrable x-visual-class:static-gray 0)
-(define-integrable x-visual-class:gray-scale 1)
-(define-integrable x-visual-class:static-color 2)
-(define-integrable x-visual-class:pseudo-color 3)
-(define-integrable x-visual-class:true-color 4)
-(define-integrable x-visual-class:direct-color 5)
\ No newline at end of file
+ x-display/name
+ x-display/properties
+ x-font-structure/all-chars-exist?
+ x-font-structure/character-bounds
+ x-font-structure/default-char
+ x-font-structure/direction
+ x-font-structure/max-ascent
+ x-font-structure/max-bounds
+ x-font-structure/max-descent
+ x-font-structure/min-bounds
+ x-font-structure/name
+ x-font-structure/start-index
+ x-geometry-string
+ x-graphics-default-display-name
+ x-graphics-default-geometry
+ x-graphics-device-type
+ x-graphics/clear
+ x-graphics/close-display
+ x-graphics/close-window
+ x-graphics/color?
+ x-graphics/coordinate-limits
+ x-graphics/copy-area
+ x-graphics/device-coordinate-limits
+ x-graphics/disable-keyboard-focus
+ x-graphics/discard-events
+ x-graphics/display
+ x-graphics/drag-cursor
+ x-graphics/draw-arc
+ x-graphics/draw-circle
+ x-graphics/draw-line
+ x-graphics/draw-lines
+ x-graphics/draw-point
+ x-graphics/draw-points
+ x-graphics/draw-text
+ x-graphics/enable-keyboard-focus
+ x-graphics/fill-circle
+ x-graphics/flush
+ x-graphics/font-structure
+ x-graphics/get-colormap
+ x-graphics/get-default
+ x-graphics/iconify-window
+ x-graphics/image-depth
+ x-graphics/lower-window
+ x-graphics/map-window
+ x-graphics/move-cursor
+ x-graphics/move-window
+ x-graphics/open-display
+ x-graphics/open-display?
+ x-graphics/open-window?
+ x-graphics/query-pointer
+ x-graphics/raise-window
+ x-graphics/read-button
+ x-graphics/read-user-event
+ x-graphics/reset-clip-rectangle
+ x-graphics/resize-window
+ x-graphics/select-user-events
+ x-graphics/set-background-color
+ x-graphics/set-border-color
+ x-graphics/set-border-width
+ x-graphics/set-clip-rectangle
+ x-graphics/set-colormap
+ x-graphics/set-coordinate-limits
+ x-graphics/set-drawing-mode
+ x-graphics/set-font
+ x-graphics/set-foreground-color
+ x-graphics/set-icon-name
+ x-graphics/set-input-hint
+ x-graphics/set-internal-border-width
+ x-graphics/set-line-style
+ x-graphics/set-mouse-color
+ x-graphics/set-mouse-shape
+ x-graphics/set-window-name
+ x-graphics/visual-info
+ x-graphics/window-id
+ x-graphics/withdraw-window
+ x-graphics:auto-raise?
+ x-image/destroy
+ x-image/draw
+ x-image/draw-subimage
+ x-image/fill-from-byte-vector
+ x-image/get-pixel
+ x-image/height
+ x-image/set-pixel
+ x-image/width
+ x-image?
+ x-visual-class:direct-color
+ x-visual-class:gray-scale
+ x-visual-class:pseudo-color
+ x-visual-class:static-color
+ x-visual-class:static-gray
+ x-visual-class:true-color
+ x-visual-info/bits-per-rgb
+ x-visual-info/blue-mask
+ x-visual-info/class
+ x-visual-info/colormap-size
+ x-visual-info/depth
+ x-visual-info/green-mask
+ x-visual-info/red-mask
+ x-visual-info/screen
+ x-visual-info/visual
+ x-visual-info/visual-id))
+
+(define create-x-colormap)
+(define create-x-image)
+(define x-character-bounds/ascent)
+(define x-character-bounds/descent)
+(define x-character-bounds/lbearing)
+(define x-character-bounds/rbearing)
+(define x-character-bounds/width)
+(define x-close-all-displays)
+(define x-colormap/allocate-color)
+(define x-colormap/free)
+(define x-colormap/query-color)
+(define x-colormap/store-color)
+(define x-colormap/store-colors)
+(define x-colormap?)
+(define x-display/name)
+(define x-display/properties)
+(define x-font-structure/all-chars-exist?)
+(define x-font-structure/character-bounds)
+(define x-font-structure/default-char)
+(define x-font-structure/direction)
+(define x-font-structure/max-ascent)
+(define x-font-structure/max-bounds)
+(define x-font-structure/max-descent)
+(define x-font-structure/min-bounds)
+(define x-font-structure/name)
+(define x-font-structure/start-index)
+(define x-geometry-string)
+(define x-graphics-default-display-name)
+(define x-graphics-default-geometry)
+(define x-graphics-device-type)
+(define x-graphics/clear)
+(define x-graphics/close-display)
+(define x-graphics/close-window)
+(define x-graphics/color?)
+(define x-graphics/coordinate-limits)
+(define x-graphics/copy-area)
+(define x-graphics/device-coordinate-limits)
+(define x-graphics/disable-keyboard-focus)
+(define x-graphics/discard-events)
+(define x-graphics/display)
+(define x-graphics/drag-cursor)
+(define x-graphics/draw-arc)
+(define x-graphics/draw-circle)
+(define x-graphics/draw-line)
+(define x-graphics/draw-lines)
+(define x-graphics/draw-point)
+(define x-graphics/draw-points)
+(define x-graphics/draw-text)
+(define x-graphics/enable-keyboard-focus)
+(define x-graphics/fill-circle)
+(define x-graphics/flush)
+(define x-graphics/font-structure)
+(define x-graphics/get-colormap)
+(define x-graphics/get-default)
+(define x-graphics/iconify-window)
+(define x-graphics/image-depth)
+(define x-graphics/lower-window)
+(define x-graphics/map-window)
+(define x-graphics/move-cursor)
+(define x-graphics/move-window)
+(define x-graphics/open-display)
+(define x-graphics/open-display?)
+(define x-graphics/open-window?)
+(define x-graphics/query-pointer)
+(define x-graphics/raise-window)
+(define x-graphics/read-button)
+(define x-graphics/read-user-event)
+(define x-graphics/reset-clip-rectangle)
+(define x-graphics/resize-window)
+(define x-graphics/select-user-events)
+(define x-graphics/set-background-color)
+(define x-graphics/set-border-color)
+(define x-graphics/set-border-width)
+(define x-graphics/set-clip-rectangle)
+(define x-graphics/set-colormap)
+(define x-graphics/set-coordinate-limits)
+(define x-graphics/set-drawing-mode)
+(define x-graphics/set-font)
+(define x-graphics/set-foreground-color)
+(define x-graphics/set-icon-name)
+(define x-graphics/set-input-hint)
+(define x-graphics/set-internal-border-width)
+(define x-graphics/set-line-style)
+(define x-graphics/set-mouse-color)
+(define x-graphics/set-mouse-shape)
+(define x-graphics/set-window-name)
+(define x-graphics/visual-info)
+(define x-graphics/window-id)
+(define x-graphics/withdraw-window)
+(define x-graphics:auto-raise?)
+(define x-image/destroy)
+(define x-image/draw)
+(define x-image/draw-subimage)
+(define x-image/fill-from-byte-vector)
+(define x-image/get-pixel)
+(define x-image/height)
+(define x-image/set-pixel)
+(define x-image/width)
+(define x-image?)
+(define x-visual-class:direct-color)
+(define x-visual-class:gray-scale)
+(define x-visual-class:pseudo-color)
+(define x-visual-class:static-color)
+(define x-visual-class:static-gray)
+(define x-visual-class:true-color)
+(define x-visual-info/bits-per-rgb)
+(define x-visual-info/blue-mask)
+(define x-visual-info/class)
+(define x-visual-info/colormap-size)
+(define x-visual-info/depth)
+(define x-visual-info/green-mask)
+(define x-visual-info/red-mask)
+(define x-visual-info/screen)
+(define x-visual-info/visual)
+(define x-visual-info/visual-id)
\ No newline at end of file
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
02110-1301, USA.
+mit-scheme-x11 1.0 - Matt Birkholz, 2018-06-21
+==============================================
+
+Replace the prx11.so µcode module. Add an import-x11 procedure. The
+deprecated (runtimem x-graphics) package now autoloads this plugin.
+
mit-scheme-x11 0.3 - Matt Birkholz, 2018-06-01
==============================================
The X11 option.
-This plugin creates an (x11) package, a drop-in replacement for the
-microcode module based (runtime x-graphics) package. It is built in
-the customary GNU way:
+This plugin creates an (x11) package. It is built in the customary
+GNU way:
./configure ...
make all check install
-To load:
+To use:
(load-option 'x11)
+ (import-x11)
-Loading this plugin re-assigns the bindings in (runtime x-graphics).
-Any existing X graphics devices will stop working, and make-graphics-
-device will begin creating X11 graphics devices instead.
+Import-x11 will modify the REPL's current environment by adding
+bindings linked to the plugin's exports. They are not exported to the
+global environment because they would conflict with the deprecated
+exports from (runtime x-graphics).
To import into a CREF package set, add this to your .pkg file:
(load-option 'FFI)
(let ((runtime (->environment '(runtime))))
+ (compile-file "x11" '() runtime)
(compile-file "x11-base" '() runtime)
(compile-file "x11-color" '() runtime)
(compile-file "x11-graphics" '() runtime)
AC_PREREQ([2.69])
AC_INIT([MIT/GNU Scheme x11 plugin],
- [0.3],
+ [1.0],
[bug-mit-scheme@gnu.org],
[mit-scheme-x11])
AC_CONFIG_SRCDIR([x11.pkg])
MIT_SCHEME_PKD="x11-${os_suffix}.pkd"
-for f in x11-base x11-color x11-graphics x11-terminal x11-device; do
+for f in x11 x11-base x11-color x11-graphics x11-terminal x11-device; do
MIT_SCHEME_SCMs="${MIT_SCHEME_SCMs} ${f}.scm"
MIT_SCHEME_BCIs="${MIT_SCHEME_BCIs} ${f}.bci"
MIT_SCHEME_DEPS="${MIT_SCHEME_DEPS}
(with-loader-base-uri (system-library-uri "x11/")
(lambda ()
(load-package-set "x11")))
-(add-subsystem-identification! "X11" '(0 3))
-
-;; Until the microcode module based X Graphics system is removed,
-;; reassign the define-primitives bindings in (runtime x-graphics) to
-;; their replacements in (x11).
-(let ((x-graphics (->environment '(runtime x-graphics)))
- (x11 (->environment '(x11))))
- (for-each (lambda (name)
- (environment-assign! x-graphics name
- (environment-lookup x11 name)))
- '(
- x-close-all-displays
- x-display-descriptor
- x-display-get-default
- x-display-process-events
- x-font-structure
- x-window-beep
- x-window-clear
- x-window-colormap
- x-window-depth
- x-window-event-mask
- x-window-flush
- x-window-iconify
- x-window-id
- x-window-lower
- x-window-map
- x-window-query-pointer
- x-window-raise
- x-window-set-background-color
- x-window-set-border-color
- x-window-set-border-width
- x-window-set-cursor-color
- x-window-set-event-mask
- x-window-set-font
- x-window-set-foreground-color
- x-window-set-icon-name
- x-window-set-input-hint
- x-window-set-internal-border-width
- x-window-set-mouse-color
- x-window-set-mouse-shape
- x-window-set-name
- x-window-set-position
- x-window-set-size
- x-window-visual
- x-window-withdraw
- x-window-x-size
- x-window-y-size
- x-graphics-copy-area
- x-graphics-drag-cursor
- x-graphics-draw-arc
- x-graphics-draw-line
- x-graphics-draw-lines
- x-graphics-draw-point
- x-graphics-draw-points
- x-graphics-draw-string
- x-graphics-draw-image-string
- x-graphics-fill-polygon
- x-graphics-map-x-coordinate
- x-graphics-map-y-coordinate
- x-graphics-move-cursor
- x-graphics-open-window
- x-graphics-reconfigure
- x-graphics-reset-clip-rectangle
- x-graphics-set-clip-rectangle
- x-graphics-set-dashes
- x-graphics-set-fill-style
- x-graphics-set-function
- x-graphics-set-line-style
- x-graphics-set-vdc-extent
- x-graphics-vdc-extent
- x-bytes-into-image
- x-create-image
- x-destroy-image
- x-display-image
- x-get-pixel-from-image
- x-set-pixel-in-image
- x-allocate-color
- x-create-colormap
- x-free-colormap
- x-query-color
- x-set-window-colormap
- x-store-color
- x-store-colors
- x-visual-deallocate)))
-
-;; Check that these (integrated!) constants DO "match" the C
-;; constants, just because we can (with the FFI's help).
-(let ((x-graphics (->environment '(runtime x-graphics)))
- (x11 (->environment '(x11))))
- (for-each (lambda (name)
- (if (not (equal? (environment-lookup x-graphics name)
- (environment-lookup x11 name)))
- (warn "Incorrect C constant in (runtime x-graphics):" name)))
- '(event-type:button-down
- event-type:button-up
- event-type:configure
- event-type:enter
- event-type:focus-in
- event-type:focus-out
- event-type:key-press
- event-type:leave
- event-type:motion
- event-type:expose
- event-type:delete-window
- event-type:map
- event-type:unmap
- event-type:take-focus
- event-type:visibility
- number-of-event-types)))
\ No newline at end of file
+(add-subsystem-identification! "X11" '(1 0))
\ No newline at end of file
(define (initialize-package!)
(set! x-graphics-device-type
(make-graphics-device-type
- 'X11
+ 'x11
`((available? ,x-graphics/available?)
(clear ,x-graphics/clear)
(close ,x-graphics/close-window)
(conc-name x-display/)
(constructor make-x-display (name xd))
(print-procedure
- (standard-print-method 'X-DISPLAY
+ (standard-print-method 'x-display
(lambda (display)
(list (x-display/name display))))))
(name #f read-only #t)
(set! registration
(permanently-register-io-thread-event
(x-display-descriptor (x-display/xd display))
- 'READ
+ 'read
(current-thread)
(lambda (mode)
mode
(define (%read-and-process-event display)
(let ((event
(or (x-display-process-events (x-display/xd display) 2)
- (and (eq? 'READ
+ (and (eq? 'read
(test-for-io-on-descriptor
(x-display-descriptor (x-display/xd display))
#t
- 'READ))
+ 'read))
(x-display-process-events (x-display/xd display) 1)))))
(if (and event (not (eq? #t event)))
(process-event display event))))
(x-graphics-reconfigure (vector-ref event 1)
(vector-ref event 2)
(vector-ref event 3))
- (if (eq? 'NEVER (x-window/mapped? window))
+ (if (eq? 'never (x-window/mapped? window))
(set-x-window/mapped?! window #t))))
(define-event-handler event-type:delete-window
(define-event-handler event-type:visibility
(lambda (window event)
(case (vector-ref event 2)
- ((0) (set-x-window/visibility! window 'UNOBSCURED))
- ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED))
- ((2) (set-x-window/visibility! window 'OBSCURED)))))
+ ((0) (set-x-window/visibility! window 'unobscured))
+ ((1) (set-x-window/visibility! window 'partially-obscured))
+ ((2) (set-x-window/visibility! window 'obscured)))))
(let ((mouse-event-handler
(lambda (window event)
(constructor make-x-window (xw display)))
xw
(display #f read-only #t)
- (mapped? 'NEVER)
+ (mapped? 'never)
(visibility #f)
(user-event-mask user-event-mask:default))
(lambda ()
(decode-suppress-map-arg (and (not (default-object? suppress-map?))
suppress-map?)
- 'MAKE-GRAPHICS-DEVICE))
+ 'make-graphics-device))
(lambda (map? resource class)
(let ((xw
(x-graphics-open-window
(define (x-graphics/flush device)
(if (and x-graphics:auto-raise?
(x-graphics-device/mapped? device)
- (not (eq? 'UNOBSCURED (x-graphics-device/visibility device))))
+ (not (eq? 'unobscured (x-graphics-device/visibility device))))
(x-graphics/raise-window device))
(x-display-flush (x-graphics-device/xd device)))
(define (x-graphics/set-line-style device line-style)
(if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
(error:wrong-type-argument line-style "graphics line style"
- 'SET-LINE-STYLE))
+ 'set-line-style))
(let ((xw (x-graphics-device/xw device)))
(if (zero? line-style)
(x-graphics-set-line-style xw 0)
(define (initialize-image-datatype)
(1d-table/put!
(graphics-type-properties x-graphics-device-type)
- 'IMAGE-TYPE
+ 'image-type
(make-image-type
`((create ,create-x-image)
(destroy ,x-graphics-image/destroy)
(global-definitions runtime/)
(define-package (x11)
+ (files "x11")
(parent ()))
(define-package (x11 base)
--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
+ 2017, 2018 Massachusetts Institute of Technology
+
+This file is part of an x11 plugin for MIT/GNU Scheme.
+
+This plugin is free software; you can redistribute it and/or modify it
+under the terms of the GNU General Public License as published by the
+Free Software Foundation; either version 2 of the License, or (at your
+option) any later version.
+
+This plugin is distributed in the hope that it will be useful, but
+WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this plugin; if not, write to the Free Software Foundation,
+Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA.
+
+|#
+
+;;;; X11 interface
+;;; package: (x11)
+
+(define (import-x11)
+ (let ((target-environment (nearest-repl/environment))
+ (source-environment (->environment '(x11))))
+ (for-each (lambda (name)
+ (link-variables target-environment name
+ source-environment name))
+ '(create-x-colormap
+ create-x-image
+ x-character-bounds/ascent
+ x-character-bounds/descent
+ x-character-bounds/lbearing
+ x-character-bounds/rbearing
+ x-character-bounds/width
+ x-close-all-displays
+ x-colormap/allocate-color
+ x-colormap/free
+ x-colormap/query-color
+ x-colormap/store-color
+ x-colormap/store-colors
+ x-colormap?
+ x-display/name
+ x-display/properties
+ x-font-structure/all-chars-exist?
+ x-font-structure/character-bounds
+ x-font-structure/default-char
+ x-font-structure/direction
+ x-font-structure/max-ascent
+ x-font-structure/max-bounds
+ x-font-structure/max-descent
+ x-font-structure/min-bounds
+ x-font-structure/name
+ x-font-structure/start-index
+ x-geometry-string
+ x-graphics-default-display-name
+ x-graphics-default-geometry
+ x-graphics-device-type
+ x-graphics/available?
+ x-graphics/clear
+ x-graphics/close-display
+ x-graphics/close-window
+ x-graphics/color?
+ x-graphics/coordinate-limits
+ x-graphics/copy-area
+ x-graphics/device-coordinate-limits
+ x-graphics/disable-keyboard-focus
+ x-graphics/discard-events
+ x-graphics/display
+ x-graphics/drag-cursor
+ x-graphics/draw-arc
+ x-graphics/draw-circle
+ x-graphics/draw-line
+ x-graphics/draw-lines
+ x-graphics/draw-point
+ x-graphics/draw-points
+ x-graphics/draw-text
+ x-graphics/enable-keyboard-focus
+ x-graphics/fill-circle
+ x-graphics/flush
+ x-graphics/font-structure
+ x-graphics/get-colormap
+ x-graphics/get-default
+ x-graphics/iconify-window
+ x-graphics/image-depth
+ x-graphics/lower-window
+ x-graphics/map-window
+ x-graphics/move-cursor
+ x-graphics/move-window
+ x-graphics/open-display
+ x-graphics/open-display?
+ x-graphics/open-window?
+ x-graphics/query-pointer
+ x-graphics/raise-window
+ x-graphics/read-button
+ x-graphics/read-user-event
+ x-graphics/reset-clip-rectangle
+ x-graphics/resize-window
+ x-graphics/select-user-events
+ x-graphics/set-background-color
+ x-graphics/set-border-color
+ x-graphics/set-border-width
+ x-graphics/set-clip-rectangle
+ x-graphics/set-colormap
+ x-graphics/set-coordinate-limits
+ x-graphics/set-drawing-mode
+ x-graphics/set-font
+ x-graphics/set-foreground-color
+ x-graphics/set-icon-name
+ x-graphics/set-input-hint
+ x-graphics/set-internal-border-width
+ x-graphics/set-line-style
+ x-graphics/set-mouse-color
+ x-graphics/set-mouse-shape
+ x-graphics/set-window-name
+ x-graphics/visual-info
+ x-graphics/window-id
+ x-graphics/withdraw-window
+ x-graphics:auto-raise?
+ x-image/destroy
+ x-image/draw
+ x-image/draw-subimage
+ x-image/fill-from-byte-vector
+ x-image/get-pixel
+ x-image/height
+ x-image/set-pixel
+ x-image/width
+ x-image?
+ x-visual-class:direct-color
+ x-visual-class:gray-scale
+ x-visual-class:pseudo-color
+ x-visual-class:static-color
+ x-visual-class:static-gray
+ x-visual-class:true-color
+ x-visual-info/bits-per-rgb
+ x-visual-info/blue-mask
+ x-visual-info/class
+ x-visual-info/colormap-size
+ x-visual-info/depth
+ x-visual-info/green-mask
+ x-visual-info/red-mask
+ x-visual-info/screen
+ x-visual-info/visual
+ x-visual-info/visual-id))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff