From: Matt Birkholz Date: Fri, 22 Jun 2018 11:10:28 +0000 (-0700) Subject: Punt x11 µmodule; autoload x11 plugin version 1.0. X-Git-Tag: mit-scheme-pucked-9.2.15~10^2~3 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=eabbb5521c6f90d870260c4f2952ad3e297f5e92;p=mit-scheme.git Punt x11 µmodule; autoload x11 plugin version 1.0. --- diff --git a/src/microcode/configure.ac b/src/microcode/configure.ac index 75040e89a..e74988495 100644 --- a/src/microcode/configure.ac +++ b/src/microcode/configure.ac @@ -805,21 +805,6 @@ no) ;; 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], [], diff --git a/src/microcode/makegen/Makefile.in.in b/src/microcode/makegen/Makefile.in.in index c1dc434c2..a5c02e7fa 100644 --- a/src/microcode/makegen/Makefile.in.in +++ b/src/microcode/makegen/Makefile.in.in @@ -190,10 +190,6 @@ extract-liarc-decls: extract-liarc-decls.o 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 diff --git a/src/microcode/makegen/files-optional.scm b/src/microcode/makegen/files-optional.scm index 8972e85df..d09d62319 100644 --- a/src/microcode/makegen/files-optional.scm +++ b/src/microcode/makegen/files-optional.scm @@ -30,13 +30,8 @@ USA. "comutl" "pruxdld" "pruxffi" -"prx11" "svm1-interp" "tterm" "termcap" "terminfo" "tparam" -"x11base" -"x11color" -"x11graph" -"x11term" diff --git a/src/microcode/prx11.c b/src/microcode/prx11.c deleted file mode 100644 index f36d1f059..000000000 --- a/src/microcode/prx11.c +++ /dev/null @@ -1,54 +0,0 @@ -/* -*-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) */ diff --git a/src/microcode/x11.h b/src/microcode/x11.h deleted file mode 100644 index 2d3014553..000000000 --- a/src/microcode/x11.h +++ /dev/null @@ -1,346 +0,0 @@ -/* -*-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 -#include -#include -#include -#include - -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; -}; - -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); - -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); - -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) */ diff --git a/src/microcode/x11base.c b/src/microcode/x11base.c deleted file mode 100644 index 5677cfbe9..000000000 --- a/src/microcode/x11base.c +++ /dev/null @@ -1,2792 +0,0 @@ -/* -*-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 -#include - -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); -} - -/* 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); -} - -/* 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); -} - -/* 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))); -} - -/* 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); -} - -/* 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); - } -} - -/* 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)); - } -} - -/* 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); -} - -/* 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); -} - -/* 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); -} - -/* 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))); - } -} - -/* 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); -} - -/* 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); -} - -/* 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); -} - -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; -} - -/* 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); - } - } -} - -/* 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); - } -} - -/* 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); -} - -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); - } - } -} - -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); -} - -/* 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); -} - -#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) */ diff --git a/src/microcode/x11color.c b/src/microcode/x11color.c deleted file mode 100644 index d7c015b1d..000000000 --- a/src/microcode/x11color.c +++ /dev/null @@ -1,571 +0,0 @@ -/* -*-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" - -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); - } - } -} - -/* 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); -} - -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); - } -} - -/* 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); -} - -#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); -} - -#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); -} - -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); - } - } -} - -/* 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); -} - -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); -} - -#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) */ diff --git a/src/microcode/x11graph.c b/src/microcode/x11graph.c deleted file mode 100644 index 5120920d0..000000000 --- a/src/microcode/x11graph.c +++ /dev/null @@ -1,1187 +0,0 @@ -/* -*-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" - -#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))))); -} - -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); -} - -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); -} - -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); -} - -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)); - } - } - } -} - -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); -} - -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 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) - ***********************************************************************/ - -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); -} - -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); -} - -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); - } -} - -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); - } -} - -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); - } -} - -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); - } -} - -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))); - } -} - -#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) */ diff --git a/src/microcode/x11term.c b/src/microcode/x11term.c deleted file mode 100644 index bf331aafc..000000000 --- a/src/microcode/x11term.c +++ /dev/null @@ -1,1021 +0,0 @@ -/* -*-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" - -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 - -#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) -{ -} - -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++); - } -} - -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); - } - } -} - -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)); -} - -#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)); - } -} - -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)))))); - } -} - -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)); - } -} - -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); -} - -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); -} - -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); -} - -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); -} - -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); -} - -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); -} - -#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) */ diff --git a/src/runtime/make.scm b/src/runtime/make.scm index 882d20d9e..ea07502c7 100644 --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@ -545,10 +545,6 @@ USA. (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 diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 3ae5c2491..781f883b2 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -4250,7 +4250,7 @@ USA. ((unix) "x11graph") (else)) (parent (runtime)) - (export () + (export () deprecated:x11graph create-x-colormap create-x-image x-character-bounds/ascent @@ -4366,8 +4366,7 @@ USA. 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") diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm index 080270d44..f0f02b787 100644 --- a/src/runtime/x11graph.scm +++ b/src/runtime/x11graph.scm @@ -28,1004 +28,259 @@ USA. ;;; package: (runtime x-graphics) (declare (usual-integrations)) -(declare (integrate-external "graphics")) -(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)) - -;; 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) - -;;;; 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) - -;;;; 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)) - -(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))) - -(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)) - -(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)) - -;;;; 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)) - ""))) - -(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)))) - -(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))) - -(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)) - -;;;; 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))) - -;;;; 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))) - -;;;; 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)) - -;;;; 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))) - -;; 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)) - -;;;; Colormaps - -(define-record-type - (%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)) - -(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 diff --git a/src/x11/NEWS b/src/x11/NEWS index 32310520b..05bc0b55d 100644 --- a/src/x11/NEWS +++ b/src/x11/NEWS @@ -22,6 +22,12 @@ along with MIT/GNU Scheme; if not, write to the Free Software 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 ============================================== diff --git a/src/x11/README b/src/x11/README index e58025ab8..d9160eb0a 100644 --- a/src/x11/README +++ b/src/x11/README @@ -1,19 +1,20 @@ 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: diff --git a/src/x11/compile.sh b/src/x11/compile.sh index ed575d1d3..b1b88e76d 100755 --- a/src/x11/compile.sh +++ b/src/x11/compile.sh @@ -34,6 +34,7 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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) diff --git a/src/x11/configure.ac b/src/x11/configure.ac index f97b3aba5..f3626a50d 100644 --- a/src/x11/configure.ac +++ b/src/x11/configure.ac @@ -2,7 +2,7 @@ dnl Process this file with autoconf to produce a configure script. 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]) @@ -96,7 +96,7 @@ os_suffix=`echo "(display (microcode-id/operating-system-suffix))" \ 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} diff --git a/src/x11/make.scm b/src/x11/make.scm index 43f82e59a..13c9216fb 100644 --- a/src/x11/make.scm +++ b/src/x11/make.scm @@ -5,112 +5,4 @@ Load the X11 option. |# (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 diff --git a/src/x11/x11-device.scm b/src/x11/x11-device.scm index 1ab932bcd..d523dbeae 100644 --- a/src/x11/x11-device.scm +++ b/src/x11/x11-device.scm @@ -48,7 +48,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -127,7 +127,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -187,7 +187,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (set! registration (permanently-register-io-thread-event (x-display-descriptor (x-display/xd display)) - 'READ + 'read (current-thread) (lambda (mode) mode @@ -230,11 +230,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -289,7 +289,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -310,9 +310,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -337,7 +337,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -398,7 +398,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -500,7 +500,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -532,7 +532,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -751,7 +751,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/x11/x11.pkg b/src/x11/x11.pkg index 42220b175..0d5941ed5 100644 --- a/src/x11/x11.pkg +++ b/src/x11/x11.pkg @@ -28,6 +28,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (global-definitions runtime/) (define-package (x11) + (files "x11") (parent ())) (define-package (x11 base) diff --git a/src/x11/x11.scm b/src/x11/x11.scm new file mode 100644 index 000000000..65703a4d6 --- /dev/null +++ b/src/x11/x11.scm @@ -0,0 +1,150 @@ +#| -*-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