--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbase.c,v 1.1 1989/06/21 10:22:07 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Starbase graphics for HP 9000 machines. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "flonum.h"
+#include <starbase.c.h>
+\f
+static void
+set_vdc_extent (descriptor, xmin, ymin, xmax, ymax)
+ int descriptor;
+ float xmin, ymin, xmax, ymax;
+{
+ vdc_extent (descriptor, xmin, ymin, (0.0), xmax, ymax, (0.0));
+ clip_indicator (descriptor, CLIP_TO_VDC);
+ clear_control (descriptor, CLEAR_VDC_EXTENT);
+ return;
+}
+
+static void
+set_line_color_index (descriptor, color_index)
+ int descriptor;
+ long color_index;
+{
+ line_color_index (descriptor, color_index);
+ text_color_index (descriptor, color_index);
+ perimeter_color_index (descriptor, color_index);
+ fill_color_index (descriptor, color_index);
+ return;
+}
+
+static int
+inquire_cmap_size (fildes)
+ int fildes;
+{
+ float physical_limits [2][3];
+ float resolution [3];
+ float p1 [3];
+ float p2 [3];
+ int cmap_size;
+
+ inquire_sizes (fildes, physical_limits, resolution, p1, p2, (& cmap_size));
+ return (cmap_size);
+}
+
+#define SB_DEVICE_ARG(arg) (arg_nonnegative_integer (arg))
+
+#define FLONUM_ARG(argno, target) \
+{ \
+ fast Pointer argument; \
+ fast long fixnum_value; \
+ \
+ argument = (ARG_REF (argno)); \
+ switch (OBJECT_TYPE (argument)) \
+ { \
+ case TC_FIXNUM: \
+ FIXNUM_VALUE (argument, fixnum_value); \
+ target = ((float) fixnum_value); \
+ break; \
+ \
+ case TC_BIG_FLONUM: \
+ target = ((float) (Get_Float (argument))); \
+ break; \
+ \
+ default: \
+ error_wrong_type_arg (argno); \
+ } \
+}
+\f
+DEFINE_PRIMITIVE ("STARBASE-OPEN-DEVICE", Prim_starbase_open_device, 2, 2,
+ "(STARBASE-OPEN-DEVICE DEVICE-NAME DRIVER-NAME)")
+{
+ int descriptor;
+ PRIMITIVE_HEADER (2);
+
+ descriptor = (gopen ((STRING_ARG (1)), OUTDEV, (STRING_ARG (2)), 0));
+ if (descriptor == (-1))
+ PRIMITIVE_RETURN (SHARP_F);
+ set_vdc_extent (descriptor, (-1.0), (-1.0), (1.0), (1.0));
+ mapping_mode (descriptor, DISTORT);
+ set_line_color_index (descriptor, 1);
+ line_type (descriptor, 0);
+ drawing_mode (descriptor, 3);
+ text_alignment
+ (descriptor, TA_NORMAL_HORIZONTAL, TA_NORMAL_VERTICAL, (0.0), (0.0));
+ interior_style (descriptor, INT_HOLLOW, 1);
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (descriptor));
+}
+
+DEFINE_PRIMITIVE ("STARBASE-CLOSE-DEVICE", Prim_starbase_close_device, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ gclose (SB_DEVICE_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-FLUSH", Prim_starbase_flush, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ make_picture_current (SB_DEVICE_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-CLEAR", Prim_starbase_clear, 1, 1,
+ "(STARBASE-CLEAR DEVICE)
+Clear the graphics section of the screen.
+Uses the Starbase CLEAR_VIEW_SURFACE procedure.")
+{
+ PRIMITIVE_HEADER (1);
+
+ clear_view_surface (SB_DEVICE_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-DRAW-POINT", Prim_starbase_draw_point, 3, 3,
+ "(STARBASE-DRAW-POINT DEVICE X Y)
+Draw one point at the given coordinates.
+Subsequently move the graphics cursor to those coordinates.
+Uses the starbase procedures `move2d' and `draw2d'.")
+{
+ int descriptor;
+ fast float x, y;
+ PRIMITIVE_HEADER (3);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (2, x);
+ FLONUM_ARG (3, y);
+ move2d (descriptor, x, y);
+ draw2d (descriptor, x, y);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("STARBASE-MOVE-CURSOR", Prim_starbase_move_cursor, 3, 3,
+ "(STARBASE-MOVE-CURSOR DEVICE X Y)
+Move the graphics cursor to the given coordinates.
+Uses the starbase procedure `move2d'.")
+{
+ int descriptor;
+ fast float x, y;
+ PRIMITIVE_HEADER (3);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (2, x);
+ FLONUM_ARG (3, y);
+ move2d (descriptor, x, y);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-DRAG-CURSOR", Prim_starbase_drag_cursor, 3, 3,
+ "(STARBASE-DRAG-CURSOR DEVICE X Y)
+Draw a line from the graphics cursor to the given coordinates.
+Subsequently move the graphics cursor to those coordinates.
+Uses the starbase procedure `draw2d'.")
+{
+ int descriptor;
+ fast float x, y;
+ PRIMITIVE_HEADER (3);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (2, x);
+ FLONUM_ARG (3, y);
+ draw2d (descriptor, x, y);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-DRAW-LINE", Prim_starbase_draw_line, 5, 5,
+ "(STARBASE-DRAW-LINE DEVICE X-START Y-START X-END Y-END)
+Draw a line from the start coordinates to the end coordinates.
+Subsequently move the graphics cursor to the end coordinates.
+Uses the starbase procedures `move2d' and `draw2d'.")
+{
+ int descriptor;
+ fast float x_start, y_start, x_end, y_end;
+ PRIMITIVE_HEADER (5);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (2, x_start);
+ FLONUM_ARG (3, y_start);
+ FLONUM_ARG (4, x_end);
+ FLONUM_ARG (5, y_end);
+ move2d (descriptor, x_start, y_start);
+ draw2d (descriptor, x_end, y_end);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-LINE-STYLE", Prim_starbase_set_line_style, 2, 2,
+ "(STARBASE-SET-LINE-STYLE DEVICE STYLE)
+Changes the line drawing style.
+The STYLE argument is an integer in the range 0-7 inclusive.
+See the description of the starbase procedure `line_type'.")
+{
+ PRIMITIVE_HEADER (2);
+
+ line_type ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 8)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-DRAWING-MODE", Prim_starbase_set_drawing_mode, 2, 2,
+ "(STARBASE-SET-DRAWING-MODE DEVICE MODE)
+Changes the replacement rule used when drawing.
+The MODE argument is an integer in the range 0-15 inclusive.
+See the description of the starbase procedure `drawing_mode'.")
+{
+ PRIMITIVE_HEADER (2);
+
+ drawing_mode ((SB_DEVICE_ARG (1)), (arg_index_integer (2, 16)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("STARBASE-DEVICE-COORDINATES", Prim_starbase_device_coordinates, 1, 1, 0)
+{
+ float physical_limits [2][3];
+ float resolution [3];
+ float p1 [3];
+ float p2 [3];
+ int cmap_size;
+ Pointer result;
+ PRIMITIVE_HEADER (1);
+
+ inquire_sizes
+ ((SB_DEVICE_ARG (1)), physical_limits, resolution, p1, p2, (& cmap_size));
+ result = (allocate_marked_vector (TC_VECTOR, 4, true));
+ User_Vector_Set
+ (result, 0, (Allocate_Float ((double) (physical_limits [0][0]))));
+ User_Vector_Set
+ (result, 1, (Allocate_Float ((double) (physical_limits [0][1]))));
+ User_Vector_Set
+ (result, 2, (Allocate_Float ((double) (physical_limits [1][0]))));
+ User_Vector_Set
+ (result, 3, (Allocate_Float ((double) (physical_limits [1][1]))));
+ PRIMITIVE_RETURN (result);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-VDC-EXTENT", Prim_starbase_set_vdc_extent, 5, 5, 0)
+{
+ fast float xmin, ymin, xmax, ymax;
+ PRIMITIVE_HEADER (5);
+
+ FLONUM_ARG (2, xmin);
+ FLONUM_ARG (3, ymin);
+ FLONUM_ARG (4, xmax);
+ FLONUM_ARG (5, ymax);
+ set_vdc_extent ((SB_DEVICE_ARG (1)), xmin, ymin, xmax, ymax);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-RESET-CLIP-RECTANGLE", Prim_starbase_reset_clip_rectangle, 1, 1,
+ "(STARBASE-RESET-CLIP-RECTANGLE DEVICE)
+Undo the clip rectangle. Subsequently, clipping is not affected by it.")
+{
+ int descriptor;
+ PRIMITIVE_HEADER (1);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ clip_indicator (descriptor, CLIP_TO_VDC);
+ clear_control (descriptor, CLEAR_VDC_EXTENT);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-CLIP-RECTANGLE", Prim_starbase_set_clip_rectangle, 5, 5,
+ "(STARBASE-SET-CLIP-RECTANGLE X-LEFT Y-BOTTOM X-RIGHT Y-TOP)
+Restrict the graphics drawing primitives to the area in the given rectangle.")
+{
+ int descriptor;
+ fast float x_left, x_right, y_bottom, y_top;
+ PRIMITIVE_HEADER (5);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (2, x_left);
+ FLONUM_ARG (3, y_bottom);
+ FLONUM_ARG (4, x_right);
+ FLONUM_ARG (5, y_top);
+ clip_rectangle (descriptor, x_left, x_right, y_bottom, y_top);
+ clip_indicator (descriptor, CLIP_TO_RECT);
+ clear_control (descriptor, CLEAR_CLIP_RECTANGLE);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("STARBASE-DRAW-TEXT", Prim_starbase_draw_text, 4, 4,
+ "(STARBASE-DRAW-TEXT DEVICE X Y STRING)")
+{
+ fast float x, y;
+ PRIMITIVE_HEADER (4);
+
+ FLONUM_ARG (2, x);
+ FLONUM_ARG (3, y);
+ text2d ((SB_DEVICE_ARG (1)), x, y, (STRING_ARG (4)), VDC_TEXT, FALSE);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-HEIGHT", Prim_starbase_set_text_height, 2, 2,
+ "(STARBASE-SET-TEXT-HEIGHT DEVICE HEIGHT)")
+{
+ fast float height;
+ PRIMITIVE_HEADER (2);
+
+ FLONUM_ARG (2, height);
+ character_height ((SB_DEVICE_ARG (1)), height);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ASPECT", Prim_starbase_set_text_aspect, 2, 2,
+ "(STARBASE-SET-TEXT-ASPECT DEVICE ASPECT)")
+{
+ fast float aspect;
+ PRIMITIVE_HEADER (2);
+
+ FLONUM_ARG (2, aspect);
+ character_expansion_factor ((SB_DEVICE_ARG (1)), aspect);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-SLANT", Prim_starbase_set_text_slant, 2, 2,
+ "(STARBASE-SET-TEXT-SLANT DEVICE SLANT)")
+{
+ fast float slant;
+ PRIMITIVE_HEADER (2);
+
+ FLONUM_ARG (2, slant);
+ character_slant ((SB_DEVICE_ARG (1)), slant);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-TEXT-ROTATION", Prim_starbase_set_text_rotation, 2, 2,
+ "(STARBASE-SET-TEXT-ROTATION DEVICE ANGLE)")
+{
+ fast float angle;
+ fast int path_style;
+ PRIMITIVE_HEADER (2);
+
+ FLONUM_ARG (2, angle);
+ if ((angle > 315.0) || (angle <= 45.0))
+ path_style = PATH_RIGHT;
+ else if ((angle > 45.0) && (angle <= 135.0))
+ path_style = PATH_DOWN;
+ else if ((angle > 135.0) && (angle <= 225.0))
+ path_style = PATH_LEFT;
+ else if ((angle > 225.0) && (angle <= 315.0))
+ path_style = PATH_UP;
+ text_path ((SB_DEVICE_ARG (1)), path_style);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("STARBASE-COLOR-MAP-SIZE", Prim_starbase_color_map_size, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ PRIMITIVE_RETURN
+ (C_Integer_To_Scheme_Integer (inquire_cmap_size (SB_DEVICE_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("STARBASE-DEFINE-COLOR", Prim_starbase_define_color, 5, 5,
+ "(STARBASE-DEFINE-COLOR COLOR-INDEX RED GREEN BLUE)
+COLOR-INDEX must be a valid index for the current device's color map.
+RED, GREEN, and BLUE must be numbers between 0 and 1 inclusive.
+Changes the color map, defining COLOR-INDEX to be the given RGB color.")
+{
+ int descriptor;
+ float colors [1][3];
+ PRIMITIVE_HEADER (5);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ FLONUM_ARG (3, colors[0][0]);
+ FLONUM_ARG (4, colors[0][1]);
+ FLONUM_ARG (5, colors[0][2]);
+ define_color_table
+ (descriptor,
+ (arg_index_integer (2, (inquire_cmap_size (descriptor)))),
+ 1,
+ colors);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("STARBASE-SET-LINE-COLOR", Prim_starbase_set_line_color, 2, 2,
+ "(STARBASE-SET-LINE-COLOR DEVICE COLOR-INDEX)
+COLOR-INDEX must be a valid index for the current device's color map.
+Changes the color used for drawing most things.
+Does not take effect until the next starbase output operation.")
+{
+ int descriptor;
+ PRIMITIVE_HEADER (2);
+
+ descriptor = (SB_DEVICE_ARG (1));
+ set_line_color_index
+ (descriptor, (arg_index_integer (2, (inquire_cmap_size (descriptor)))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+/* Graphics Screen Dump */
+
+static void print_graphics ();
+
+DEFINE_PRIMITIVE ("STARBASE-WRITE-IMAGE-FILE", Prim_starbase_write_image_file, 3, 3,
+ "(STARBASE-WRITE-IMAGE-FILE DEVICE FILENAME INVERT?)
+Write a file containing an image of the DEVICE's screen, in a format
+suitable for printing on an HP laserjet printer.
+If INVERT? is not #F, invert black and white in the output.")
+{
+ PRIMITIVE_HEADER (3);
+
+ print_graphics
+ ((SB_DEVICE_ARG (2)), (STRING_ARG (2)), ((ARG_REF (3)) != SHARP_F));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+static char rasres[] = "\033*t100R";
+static char rastop[] = "\033&l2E";
+static char raslft[] = "\033&a2L";
+static char rasbeg[] = "\033*r0A";
+static char raslen[] = "\033*b96W";
+static char rasend[] = "\033*rB";
+
+static int
+inquire_cmap_mask (fildes)
+ int fildes;
+{
+ int cmap_size;
+
+ cmap_size = (inquire_cmap_size (fildes));
+ return (((cmap_size >= 0) && (cmap_size < 8)) ?
+ ((1 << cmap_size) - 1) :
+ (-1));
+}
+
+static int
+open_dumpfile (dumpname)
+ char * dumpname;
+{
+ int dumpfile;
+
+ dumpfile = (creat (dumpname, 0666));
+ if (dumpfile == (-1))
+ {
+ fprintf (stderr, "\nunable to create graphics dump file.");
+ error_external_return ();
+ }
+ dumpfile = (open (dumpname, OUTINDEV));
+ if (dumpfile == (-1))
+ {
+ fprintf (stderr, "\nunable to open graphics dump file.");
+ error_external_return ();
+ }
+ return (dumpfile);
+}
+\f
+static void
+print_graphics (descriptor, dumpname, inverse_p)
+ int descriptor;
+ char * dumpname;
+ int inverse_p;
+{
+ int dumpfile;
+
+ dumpfile = (open_dumpfile (dumpname));
+
+ write (dumpfile, rasres, (strlen (rasres)));
+ write (dumpfile, rastop, (strlen (rastop)));
+ write (dumpfile, raslft, (strlen (raslft)));
+ write (dumpfile, rasbeg, (strlen (rasbeg)));
+
+ {
+ fast unsigned char mask;
+ int col;
+
+ mask = (inquire_cmap_mask (descriptor));
+ for (col = (1024 - 16); (col >= 0); col = (col - 16))
+ {
+ unsigned char pixdata [(16 * 768)];
+
+ {
+ fast unsigned char * p;
+ fast unsigned char * pe;
+
+ p = (& (pixdata [0]));
+ pe = (& (pixdata [sizeof (pixdata)]));
+ while (p < pe)
+ (*p++) = '\0';
+ }
+ dcblock_read (descriptor, col, 0, 16, 768, pixdata, 0);
+ {
+ int x;
+
+ for (x = (16 - 1); (x >= 0); x -= 1)
+ {
+ unsigned char rasdata [96];
+ fast unsigned char * p;
+ fast unsigned char * r;
+ int n;
+
+ p = (& (pixdata [x]));
+ r = rasdata;
+ for (n = 0; (n < 96); n += 1)
+ {
+ fast unsigned char c;
+ int nn;
+
+ c = 0;
+ for (nn = 0; (nn < 8); nn += 1)
+ {
+ c <<= 1;
+ if (((* p) & mask) != 0)
+ c |= 1;
+ p += 16;
+ }
+ (*r++) = (inverse_p ? (~ c) : c);
+ }
+ write (dumpfile, raslen, (strlen (raslen)));
+ write (dumpfile, rasdata, 96);
+ }
+ }
+ }
+ }
+ write (dumpfile, rasend, (strlen (rasend)));
+ close (dumpfile);
+ return;
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/starbasx.c,v 1.1 1989/06/21 10:22:19 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Starbase/X11 interface */
+
+#include "scheme.h"
+#include "prims.h"
+#include "x11.h"
+#include <starbase.c.h>
+
+DEFINE_PRIMITIVE ("X11-WINDOW-STARBASE-FILENAME", Prim_x11_window_starbase_filename, 1, 1,
+ "Given a window, returns the name of a file which can be opened
+as a Starbase graphics device.")
+{
+ struct xwindow * xw;
+ char * starbase_filename;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ starbase_filename =
+ (make_X11_gopen_string ((XW_DISPLAY (xw)), (XW_WINDOW (xw))));
+ PRIMITIVE_RETURN
+ ((starbase_filename == ((char *) 0))
+ ? SHARP_F
+ : (C_String_To_Scheme_String (starbase_filename)));
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11.h,v 1.1 1989/06/21 10:17:42 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+#include <X11/Xlib.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+#include <X11/Xutil.h>
+\f
+struct allocation_table
+{
+ char ** items;
+ int length;
+};
+
+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;
+};
+
+struct event_queue_element
+{
+ XEvent event;
+ struct event_queue_element * next;
+};
+
+struct event_queue
+{
+ struct event_queue_element * head;
+ struct event_queue_element * tail;
+};
+
+struct xwindow
+{
+ Display * display;
+ Window window;
+
+ /* Dimensions of the drawing region in pixels. */
+ int x_size;
+ int y_size;
+
+ struct drawing_attributes attributes;
+
+ /* Standard graphics contexts. */
+ GC normal_gc;
+ GC reverse_gc;
+ GC cursor_gc;
+
+ /* The mouse cursor. */
+ Cursor mouse_cursor;
+
+ /* Event queue for this window. */
+ struct event_queue events;
+
+ /* Flags that can be set by event handlers. */
+ int event_flags;
+
+ /* Additional window-specific data. */
+ void * extra;
+
+ /* Deallocation procedure to do window-specific deallocation. */
+ void (* deallocator) ();
+
+ /* Nonzero iff this window is mapped. */
+ char visible_p;
+};
+\f
+extern struct allocation_table x_display_table;
+extern struct allocation_table x_window_table;
+extern int x_debug;
+
+extern int x_allocate_table_index ();
+extern char * x_allocation_item_arg ();
+extern int x_allocation_index_arg ();
+extern char * x_malloc ();
+extern char * x_realloc ();
+extern unsigned long x_decode_color ();
+extern unsigned long x_default_color ();
+extern void x_default_attributes ();
+extern struct xwindow * x_window_to_xw ();
+extern struct xwindow * x_make_window ();
+extern Pointer x_window_to_object ();
+extern Display * x_close_window ();
+extern void x_close_display ();
+extern void xw_enqueue_event ();
+extern int xw_dequeue_event ();
+extern void x_distribute_events ();
+extern void xw_wait_for_window_event ();
+
+#define DISPLAY_ARG(arg) \
+ ((Display *) (x_allocation_item_arg (arg, (& x_display_table))))
+
+#define WINDOW_ARG(arg) \
+ ((struct xwindow *) (x_allocation_item_arg (arg, (& x_window_table))))
+
+#define XW_DISPLAY(xw) ((xw) -> display)
+#define XW_WINDOW(xw) ((xw) -> window)
+#define XW_X_SIZE(xw) ((xw) -> x_size)
+#define XW_Y_SIZE(xw) ((xw) -> y_size)
+#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_EVENT_FLAGS(xw) ((xw) -> event_flags)
+#define XW_VISIBLE_P(xw) ((xw) -> visible_p)
+
+#define FONT_WIDTH(f) (((f) -> max_bounds) . width)
+#define FONT_HEIGHT(f) (((f) -> ascent) + ((f) -> descent))
+#define FONT_BASE(f) ((f) -> ascent)
+
+#define EVENT_FLAG_RESIZED 0x01
+#define EVENT_FLAG_BUTTON_DOWN 0x02
+#define EVENT_FLAG_BUTTON_UP 0x04
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11base.c,v 1.1 1989/06/21 10:18:27 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Common X11 support. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "x11.h"
+\f
+char *
+x_malloc (size)
+ int size;
+{
+ char * result;
+ extern char * malloc ();
+
+ result = (malloc (size));
+ if (result == ((char *) 0))
+ error_external_return ();
+ return (result);
+}
+
+char *
+x_realloc (ptr, size)
+ char * ptr;
+ int size;
+{
+ char * result;
+ extern char * realloc ();
+
+ result = (realloc (ptr, size));
+ if (result == ((char *) 0))
+ error_external_return ();
+ return (result);
+}
+\f
+int
+x_allocate_table_index (table, item)
+ struct allocation_table * table;
+ char * item;
+{
+ char ** items = (table -> items);
+ int length = (table -> length);
+ int i;
+
+ if (length == 0)
+ {
+ int new_length = 4;
+ char ** new_items =
+ ((char **) (x_malloc ((sizeof (char *)) * new_length)));
+ (new_items [0]) = item;
+ for (i = 1; (i < new_length); i += 1)
+ (new_items [i]) = ((char *) 0);
+ (table -> items) = new_items;
+ (table -> length) = new_length;
+ return (0);
+ }
+ for (i = 0; (i < length); i += 1)
+ if ((items [i]) == ((char *) 0))
+ {
+ (items [i]) = item;
+ return (i);
+ }
+ {
+ int new_length = (length * 2);
+ char ** new_items =
+ ((char **) (x_realloc (items, ((sizeof (char *)) * new_length))));
+ (new_items [length]) = item;
+ for (i = (length + 1); (i < new_length); i += 1)
+ (new_items [i]) = ((char *) 0);
+ (table -> items) = new_items;
+ (table -> length) = new_length;
+ }
+ return (length);
+}
+
+#define DEF_ALLOCATION_ARG(name, result_type, result) \
+result_type \
+name (arg, table) \
+ int arg; \
+ struct allocation_table * table; \
+{ \
+ fast Pointer object = (ARG_REF (arg)); \
+ \
+ if (! (FIXNUM_P (object))) \
+ error_wrong_type_arg (arg); \
+ if (! (FIXNUM_NEGATIVE_P (object))) \
+ { \
+ fast int length = (table -> length); \
+ fast char ** items = (table -> items); \
+ fast int index = (UNSIGNED_FIXNUM_VALUE (object)); \
+ if ((index < length) && ((items [index]) != ((char *) 0))) \
+ return (result); \
+ } \
+ error_bad_range_arg (arg); \
+ /* NOTREACHED */ \
+}
+
+DEF_ALLOCATION_ARG (x_allocation_item_arg, char *, (items [index]))
+DEF_ALLOCATION_ARG (x_allocation_index_arg, int, index)
+
+struct allocation_table x_display_table;
+struct allocation_table x_window_table;
+\f
+int x_debug = 0;
+
+DEFINE_PRIMITIVE ("X-DEBUG", Prim_x_debug, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ x_debug = ((ARG_REF (1)) != SHARP_F);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+static int
+x_io_error_handler (display)
+ Display * display;
+{
+ fprintf (stderr, "\nX IO Error\n");
+ error_external_return ();
+}
+
+static int
+x_error_handler (display, error_event)
+ Display * display;
+ XErrorEvent * error_event;
+{
+ char buffer [2048];
+
+ XGetErrorText (display, (error_event -> error_code),
+ (& buffer), (sizeof (buffer)));
+ fprintf (stderr, "\nX Error: %s\n", buffer);
+ fprintf (stderr, " Request code: %d\n",
+ (error_event -> request_code));
+ fprintf (stderr, " Error serial: %x\n", (error_event -> serial));
+ error_external_return ();
+}
+
+unsigned long
+x_decode_color (display, color_map, color_name, default_color)
+ Display * display;
+ Colormap color_map;
+ char * color_name;
+ unsigned long default_color;
+{
+ XColor cdef;
+
+ if ((strcmp (color_name, "black")) == 0)
+ return (BlackPixel (display, (DefaultScreen (display))));
+ if ((strcmp (color_name, "white")) == 0)
+ return (WhitePixel (display, (DefaultScreen (display))));
+ if (DisplayCells (display, (DefaultScreen (display))) <= 2)
+ return (default_color);
+ if ((XParseColor (display, color_map, color_name, (& cdef))) &&
+ (XAllocColor (display, color_map, (& cdef))))
+ return (cdef . pixel);
+ return (default_color);
+}
+
+unsigned long
+x_default_color (display, resource_name, property_name, default_color)
+ Display * display;
+ char * resource_name;
+ char * property_name;
+ unsigned long default_color;
+{
+ char * color_name;
+
+ color_name = (XGetDefault (display, resource_name, property_name));
+ if (color_name == ((char *) 0))
+ return (default_color);
+ return
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ color_name,
+ default_color));
+}
+\f
+void
+x_default_attributes (display, resource_name, attributes)
+ Display * display;
+ char * resource_name;
+ struct drawing_attributes * attributes;
+{
+ int screen_number = (DefaultScreen (display));
+
+ {
+ char * font_name;
+
+ font_name = (XGetDefault (display, resource_name, "BodyFont"));
+ if (font_name == ((char *) 0))
+ font_name = "9x15";
+ (attributes -> font) = (XLoadQueryFont (display, font_name));
+ if ((attributes -> font) == ((XFontStruct *) 0))
+ error_external_return ();
+ }
+ {
+ char * s;
+
+ s = (XGetDefault (display, resource_name, "BorderWidth"));
+ (attributes -> border_width) = ((s == ((char *) 0)) ? 2 : (atoi (s)));
+ s = (XGetDefault (display, resource_name, "InternalBorderWidth"));
+ (attributes -> internal_border_width) =
+ ((s == ((char *) 0)) ? 4 : (atoi (s)));
+ }
+ {
+ unsigned long white_pixel = (WhitePixel (display, screen_number));
+ unsigned long black_pixel = (BlackPixel (display, screen_number));
+
+ (attributes -> background_pixel) =
+ (x_default_color (display, resource_name, "Background", white_pixel));
+ (attributes -> foreground_pixel) =
+ (x_default_color (display, resource_name, "Foreground", black_pixel));
+ (attributes -> border_pixel) =
+ (x_default_color (display, resource_name, "Border", black_pixel));
+ (attributes -> cursor_pixel) =
+ (x_default_color (display, resource_name, "Cursor", black_pixel));
+ (attributes -> mouse_pixel) =
+ (x_default_color (display, resource_name, "Mouse", black_pixel));
+ }
+ return;
+}
+
+void
+x_set_mouse_colors (display, mouse_cursor, mouse_pixel, background_pixel)
+ Display * display;
+ Cursor mouse_cursor;
+ unsigned long mouse_pixel;
+ unsigned long background_pixel;
+{
+ Colormap color_map = (DefaultColormap (display, (DefaultScreen (display))));
+ 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));
+ return;
+}
+\f
+#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 (display, window, x_size, y_size, attributes, extra, deallocator)
+ Display * display;
+ Window window;
+ int x_size;
+ int y_size;
+ struct drawing_attributes * attributes;
+ int extra;
+ void (* deallocator) ();
+{
+ GC normal_gc;
+ GC reverse_gc;
+ GC cursor_gc;
+ struct xwindow * xw;
+ 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, mouse_cursor, (attributes -> mouse_pixel), background_pixel);
+ XDefineCursor (display, window, mouse_cursor);
+
+ xw = ((struct xwindow *) (x_malloc (sizeof (struct xwindow))));
+ (XW_DISPLAY (xw)) = display;
+ (XW_WINDOW (xw)) = window;
+ (XW_X_SIZE (xw)) = x_size;
+ (XW_Y_SIZE (xw)) = y_size;
+ (xw -> attributes) = (* attributes);
+ (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 -> events) . head) = ((struct event_queue_element *) 0);
+ ((xw -> events) . tail) = ((struct event_queue_element *) 0);
+ (XW_EVENT_FLAGS (xw)) = 0;
+ (XW_VISIBLE_P (xw)) = 0;
+
+ if (extra > 0)
+ (xw -> extra) = ((void *) (x_malloc (extra)));
+ (xw -> deallocator) = deallocator;
+ return (xw);
+}
+
+Pointer
+x_window_to_object (xw)
+ struct xwindow * xw;
+{
+ return
+ (MAKE_UNSIGNED_FIXNUM
+ (x_allocate_table_index ((& x_window_table), ((char *) xw))));
+}
+\f
+struct xwindow *
+x_window_to_xw (window)
+ Window window;
+{
+ int length = (x_window_table . length);
+ struct xwindow ** items = ((struct xwindow **) (x_window_table . items));
+ int i;
+ struct xwindow * xw;
+
+ for (i = 0; (i < length); i += 1)
+ {
+ xw = (items [i]);
+ if ((XW_WINDOW (xw)) == window)
+ return (xw);
+ }
+ return ((struct xwindow *) 0);
+}
+
+Display *
+x_close_window (index)
+ int index;
+{
+ struct xwindow * xw;
+ Display * display;
+
+ xw = ((struct xwindow *) ((x_window_table . items) [index]));
+ ((struct xwindow *) ((x_window_table . items) [index])) =
+ ((struct xwindow *) 0);
+ display = (XW_DISPLAY (xw));
+ {
+ void (* deallocator) () = (xw -> deallocator);
+ if (deallocator != ((void (*) ()) 0))
+ (* deallocator) (xw);
+ }
+ {
+ XFontStruct * font = (XW_FONT (xw));
+ if (font != ((XFontStruct *) 0))
+ XFreeFont (display, font);
+ }
+ XDestroyWindow (display, (XW_WINDOW (xw)));
+ free (xw);
+ return (display);
+}
+
+void
+x_close_display (index)
+ int index;
+{
+ Display * display;
+
+ display = ((Display *) ((x_display_table . items) [index]));
+ ((Display *) ((x_display_table . items) [index])) = ((Display *) 0);
+ {
+ struct xwindow ** items = ((struct xwindow **) (x_window_table . items));
+ int length = (x_window_table . length);
+ int i;
+
+ for (i = 0; (i < length); i += 1)
+ {
+ struct xwindow * xw = (items [i]);
+ if ((xw != ((struct xwindow *) 0)) &&
+ ((XW_DISPLAY (xw)) == display))
+ (void) x_close_window (i);
+ }
+ }
+ XCloseDisplay (display);
+ return;
+}
+\f
+static void
+x_enqueue_event (events, event)
+ struct event_queue * events;
+ XEvent * event;
+{
+ struct event_queue_element * element;
+
+ element =
+ ((struct event_queue_element *)
+ (x_malloc (sizeof (struct event_queue_element))));
+ (element -> event) = (* event);
+ (element -> next) = ((struct event_queue_element *) 0);
+ if ((events -> head) == ((struct event_queue_element *) 0))
+ (events -> head) = element;
+ else
+ ((events -> tail) -> next) = element;
+ (events -> tail) = element;
+ return;
+}
+
+static int
+x_dequeue_event (events, event)
+ struct event_queue * events;
+ XEvent * event;
+{
+ struct event_queue_element * element;
+
+ element = (events -> head);
+ if (element == ((struct event_queue_element *) 0))
+ return (0);
+ (* event) = (element -> event);
+ (events -> head) = (element -> next);
+ free (element);
+ return (1);
+}
+
+void
+xw_enqueue_event (xw, event)
+ struct xwindow * xw;
+ XEvent * event;
+{
+ x_enqueue_event ((& (xw -> events)), event);
+ return;
+}
+
+int
+xw_dequeue_event (xw, event)
+ struct xwindow * xw;
+ XEvent * event;
+{
+ if (x_dequeue_event ((& (xw -> events)), event))
+ return (1);
+ x_distribute_events (XW_DISPLAY (xw));
+ return (x_dequeue_event ((& (xw -> events)), event));
+}
+\f
+void
+x_distribute_events (display)
+ Display * display;
+{
+ int nevents;
+ XEvent event;
+ struct xwindow * exw;
+
+ nevents = (XEventsQueued (display, QueuedAfterReading));
+ while (nevents > 0)
+ {
+ XNextEvent (display, (& event));
+ nevents -= 1;
+
+ exw = (x_window_to_xw ((event . xany) . window));
+ if (exw == ((struct xwindow *) 0))
+ continue;
+ xw_enqueue_event (exw, (& event));
+ }
+ return;
+}
+
+void
+xw_wait_for_window_event (xw, event)
+ struct xwindow * xw;
+ XEvent * event;
+{
+ Display * display = (XW_DISPLAY (xw));
+ Window window = (XW_WINDOW (xw));
+ struct xwindow * exw;
+
+ while (1)
+ {
+ XNextEvent (display, event);
+
+ exw = (x_window_to_xw ((event -> xany) . window));
+ if (exw == xw)
+ {
+ x_distribute_events (display);
+ break;
+ }
+ if (exw != ((struct xwindow *) 0))
+ xw_enqueue_event (exw, event);
+ }
+ return;
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-READ-EVENT-FLAGS!", Prim_x_window_read_event_flags, 1, 1, 0)
+{
+ struct xwindow * xw;
+ int old;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ old = (XW_EVENT_FLAGS (xw));
+ (XW_EVENT_FLAGS (xw)) = 0;
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (old));
+}
+\f
+DEFINE_PRIMITIVE ("X-OPEN-DISPLAY", Prim_x_open_display, 1, 1, 0)
+{
+ Display * display;
+ int index;
+ PRIMITIVE_HEADER (1);
+
+ display =
+ (XOpenDisplay (((ARG_REF (1)) == SHARP_F) ? NULL : (STRING_ARG (1))));
+ if (display == NULL)
+ PRIMITIVE_RETURN (SHARP_F);
+
+ /* This only needs to be done once for this process, but it doesn't
+ hurt to run it every time we open the display. */
+ XSetErrorHandler (x_error_handler);
+ XSetIOErrorHandler (x_io_error_handler);
+
+ PRIMITIVE_RETURN
+ (MAKE_UNSIGNED_FIXNUM
+ (x_allocate_table_index ((& x_display_table), ((char *) display))));
+}
+
+DEFINE_PRIMITIVE ("X-CLOSE-DISPLAY", Prim_x_close_display, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ x_close_display (x_allocation_index_arg (1, (& x_display_table)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-CLOSE-ALL-DISPLAYS", Prim_x_close_all_displays, 0, 0, 0)
+{
+ PRIMITIVE_HEADER (0);
+
+ {
+ Display ** items = ((Display **) (x_display_table . items));
+ int length = (x_display_table . length);
+ int i;
+
+ for (i = 0; (i < length); i += 1)
+ if ((items [i]) != ((Display *) 0))
+ x_close_display (i);
+ }
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-CLOSE-WINDOW", Prim_x_close_window, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ XFlush (x_close_window (x_allocation_index_arg (1, (& x_window_table))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-X-SIZE", Prim_x_window_x_size, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_X_SIZE (WINDOW_ARG (1))));
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-Y-SIZE", Prim_x_window_y_size, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (XW_Y_SIZE (WINDOW_ARG (1))));
+}
+\f
+DEFINE_PRIMITIVE ("X-WINDOW-MAP", Prim_x_window_map, 1, 1, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ (XW_VISIBLE_P (xw)) = 1;
+ XMapWindow (display, (XW_WINDOW (xw)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-UNMAP", Prim_x_window_unmap, 1, 1, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ (XW_VISIBLE_P (xw)) = 0;
+ XUnmapWindow (display, (XW_WINDOW (xw)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-BEEP", Prim_x_window_beep, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ XBell ((XW_DISPLAY (WINDOW_ARG (1))), 100); /* 100% */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-CLEAR", Prim_x_window_clear, 1, 1, 0)
+{
+ struct xwindow * xw;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-FLUSH", Prim_x_window_flush, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ XFlush (XW_DISPLAY (WINDOW_ARG (1)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-GET-DEFAULT", Prim_x_get_default, 3, 3, 0)
+{
+ char * result;
+ PRIMITIVE_HEADER (3);
+
+ result =
+ (XGetDefault
+ ((XW_DISPLAY (WINDOW_ARG (1))), (STRING_ARG (2)), (STRING_ARG (3))));
+ PRIMITIVE_RETURN
+ ((result == ((char *) 0))
+ ? SHARP_F
+ : (C_String_To_Scheme_String (result)));
+}
+\f
+DEFINE_PRIMITIVE ("X-WINDOW-SET-FOREGROUND-COLOR", Prim_x_window_set_foreground_color, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ unsigned long foreground_pixel;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ foreground_pixel =
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ (STRING_ARG (2)),
+ (XW_FOREGROUND_PIXEL (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)
+{
+ struct xwindow * xw;
+ Display * display;
+ unsigned long background_pixel;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ background_pixel =
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ (STRING_ARG (2)),
+ (XW_BACKGROUND_PIXEL (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_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)
+{
+ struct xwindow * xw;
+ Display * display;
+ unsigned long border_pixel;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ border_pixel =
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ (STRING_ARG (2)),
+ (XW_BORDER_PIXEL (xw))));
+ (XW_BORDER_PIXEL (xw)) = border_pixel;
+ XSetWindowBorder (display, (XW_WINDOW (xw)), border_pixel);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("X-WINDOW-SET-CURSOR-COLOR", Prim_x_window_set_cursor_color, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ unsigned long cursor_pixel;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ cursor_pixel =
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ (STRING_ARG (2)),
+ (XW_CURSOR_PIXEL (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)
+{
+ struct xwindow * xw;
+ Display * display;
+ unsigned long mouse_pixel;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ mouse_pixel =
+ (x_decode_color
+ (display,
+ (DefaultColormap (display, (DefaultScreen (display)))),
+ (STRING_ARG (2)),
+ (XW_MOUSE_PIXEL (xw))));
+ (XW_MOUSE_PIXEL (xw)) = mouse_pixel;
+ x_set_mouse_colors
+ (display, (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)
+{
+ struct xwindow * xw;
+ Display * display;
+ Window window;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ 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,
+ 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);
+}
+\f
+DEFINE_PRIMITIVE ("X-WINDOW-SET-FONT", Prim_x_window_set_font, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ XFontStruct * font;
+ Font fid;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ font = (XLoadQueryFont (display, (STRING_ARG (2))));
+ if (font == ((XFontStruct *) 0))
+ PRIMITIVE_RETURN (SHARP_F);
+ XFreeFont (display, (XW_FONT (xw)));
+ (XW_FONT (xw)) = 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);
+ PRIMITIVE_RETURN (SHARP_T);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-SET-BORDER-WIDTH", Prim_x_window_set_border_width, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ int border_width;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ 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)
+{
+ struct xwindow * xw;
+ Display * display;
+ int internal_border_width;
+ int extra;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ internal_border_width = (arg_nonnegative_integer (2));
+ (XW_INTERNAL_BORDER_WIDTH (xw)) = internal_border_width;
+ extra = (2 * internal_border_width);
+ XResizeWindow
+ (display,
+ (XW_WINDOW (xw)),
+ ((XW_X_SIZE (xw)) + extra),
+ ((XW_Y_SIZE (xw)) + extra));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("X-WINDOW-SET-SIZE", Prim_x_window_set_size, 3, 3, 0)
+{
+ struct xwindow * xw;
+ int extra;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
+ XResizeWindow
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ ((arg_nonnegative_integer (2)) + extra),
+ ((arg_nonnegative_integer (3)) + extra));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-WINDOW-SET-POSITION", Prim_x_window_set_position, 3, 3, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ int screen_number;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ screen_number = (DefaultScreen (display));
+ XMoveWindow
+ ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (arg_fixnum (2)), (arg_fixnum (3)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
--- /dev/null
+/* -*-C-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11graph.c,v 1.1 1989/06/21 10:18:51 cph Exp $
+
+Copyright (c) 1989 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science. Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. */
+
+/* Simple graphics for X11 */
+
+#include "scheme.h"
+#include "prims.h"
+#include "string.h"
+#include "x11.h"
+
+#define RESOURCE_NAME "scheme-graphics"
+#define DEFAULT_GEOMETRY "512x384+0+0"
+\f
+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;
+};
+
+#define XW_EXTRA(xw) ((struct gw_extra *) ((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 FLONUM_ARG(argno, target) \
+{ \
+ fast Pointer argument; \
+ fast long fixnum_value; \
+ \
+ argument = (ARG_REF (argno)); \
+ switch (OBJECT_TYPE (argument)) \
+ { \
+ case TC_FIXNUM: \
+ FIXNUM_VALUE (argument, fixnum_value); \
+ target = ((float) fixnum_value); \
+ break; \
+ \
+ case TC_BIG_FLONUM: \
+ target = ((float) (Get_Float (argument))); \
+ break; \
+ \
+ default: \
+ error_wrong_type_arg (argno); \
+ } \
+}
+
+#define ROUND_FLOAT(flonum) \
+ ((int) (((flonum) >= 0.0) ? ((flonum) + 0.5) : ((flonum) - 0.5)))
+
+static int
+arg_x_coordinate (arg, xw)
+ int arg;
+ struct xwindow * xw;
+{
+ float virtual_device_x;
+ float device_x;
+
+ FLONUM_ARG (arg, virtual_device_x);
+ device_x = ((XW_X_SLOPE (xw)) * (virtual_device_x - (XW_X_LEFT (xw))));
+ return (ROUND_FLOAT (device_x));
+}
+
+static int
+arg_y_coordinate (arg, xw)
+ int arg;
+ struct xwindow * xw;
+{
+ float virtual_device_y;
+ float device_y;
+
+ FLONUM_ARG (arg, virtual_device_y);
+ device_y = ((XW_Y_SLOPE (xw)) * (virtual_device_y - (XW_Y_BOTTOM (xw))));
+ return (((XW_Y_SIZE (xw)) - 1) + (ROUND_FLOAT (device_y)));
+}
+\f
+static void
+set_clip_rectangle (xw, x_left, y_bottom, x_right, y_top)
+ struct xwindow * xw;
+ int x_left;
+ int y_bottom;
+ int x_right;
+ int y_top;
+{
+ XRectangle rectangles [1];
+ Display * display = (XW_DISPLAY (xw));
+ int internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+
+ if (x_left > x_right)
+ {
+ int x = x_left;
+ x_left = x_right;
+ x_right = x;
+ }
+ if (y_top > y_bottom)
+ {
+ int y = y_top;
+ y_top = y_bottom;
+ y_bottom = y;
+ }
+ ((rectangles [0]) . x) = x_left;
+ ((rectangles [0]) . y) = y_top;
+ ((rectangles [0]) . width) = ((x_right + 1) - x_left);
+ ((rectangles [0]) . height) = ((y_bottom + 1) - y_top);
+ 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);
+ return;
+}
+
+static void
+reset_clip_rectangle (xw)
+ struct xwindow * xw;
+{
+ set_clip_rectangle
+ (xw, 0, ((XW_Y_SIZE (xw)) - 1), ((XW_X_SIZE (xw)) - 1), 0);
+ return;
+}
+
+static void
+reset_virtual_device_coordinates (xw)
+ 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)) =
+ (((float) ((XW_X_SIZE (xw)) - 1)) /
+ ((XW_X_RIGHT (xw)) - (XW_X_LEFT (xw))));
+ (XW_Y_SLOPE (xw)) =
+ (((float) ((XW_Y_SIZE (xw)) - 1)) /
+ ((XW_Y_BOTTOM (xw)) - (XW_Y_TOP (xw))));
+ reset_clip_rectangle (xw);
+ return;
+}
+\f
+static void
+process_event (xw, event)
+ struct xwindow * xw;
+ XEvent * event;
+{
+ switch (event -> type)
+ {
+ case ConfigureNotify:
+ if (x_debug) fprintf (stderr, "\nX event: ConfigureNotify\n");
+ {
+ int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
+ int x_size = (((event -> xconfigure) . width) - extra);
+ int y_size = (((event -> xconfigure) . 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);
+ (XW_EVENT_FLAGS (xw)) |= EVENT_FLAG_RESIZED;
+ XClearWindow ((XW_DISPLAY (xw)), (XW_WINDOW (xw)));
+ }
+ }
+ break;
+
+ case MapNotify:
+ if (x_debug) fprintf (stderr, "\nX event: MapNotify\n");
+ (XW_VISIBLE_P (xw)) = 1;
+ break;
+
+ case UnmapNotify:
+ if (x_debug) fprintf (stderr, "\nX event: UnmapNotify\n");
+ (XW_VISIBLE_P (xw)) = 0;
+ break;
+
+ case CirculateNotify:
+ if (x_debug) fprintf (stderr, "\nX event: CirculateNotify\n");
+ break;
+
+ case CreateNotify:
+ if (x_debug) fprintf (stderr, "\nX event: CreateNotify\n");
+ break;
+
+ case DestroyNotify:
+ if (x_debug) fprintf (stderr, "\nX event: DestroyNotify\n");
+ break;
+
+ case GravityNotify:
+ if (x_debug) fprintf (stderr, "\nX event: GravityNotify\n");
+ break;
+
+ case ReparentNotify:
+ if (x_debug) fprintf (stderr, "\nX event: ReparentNotify\n");
+ break;
+
+ default:
+ if (x_debug) fprintf (stderr, "\nX event: %d", (event -> type));
+ break;
+ }
+ return;
+}
+
+static void
+process_events (xw)
+ struct xwindow * xw;
+{
+ XEvent event;
+ while (xw_dequeue_event (xw, (& event)))
+ process_event (xw, (& event));
+ return;
+}
+\f
+DEFINE_PRIMITIVE ("X-GRAPHICS-SET-VDC-EXTENT", Prim_x_graphics_set_vdc_extent, 5, 5,
+ "(X-GRAPHICS-SET-VDC-EXTENT WINDOW X-MIN Y-MIN X-MAX Y-MAX)
+Set the virtual device coordinates to the given values.")
+{
+ struct xwindow * xw;
+ float x_left;
+ float y_bottom;
+ float x_right;
+ float y_top;
+ PRIMITIVE_HEADER (5);
+
+ xw = (WINDOW_ARG (1));
+ FLONUM_ARG (2, x_left);
+ FLONUM_ARG (3, y_bottom);
+ FLONUM_ARG (4, x_right);
+ FLONUM_ARG (5, y_top);
+ process_events (xw);
+ (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)
+{
+ struct xwindow * xw;
+ Pointer result;
+ PRIMITIVE_HEADER (5);
+
+ xw = (WINDOW_ARG (1));
+ process_events (xw);
+ result = (allocate_marked_vector (TC_VECTOR, 4, true));
+ User_Vector_Set (result, 0, (Allocate_Float ((double) (XW_X_LEFT (xw)))));
+ User_Vector_Set (result, 1, (Allocate_Float ((double) (XW_Y_BOTTOM (xw)))));
+ User_Vector_Set (result, 2, (Allocate_Float ((double) (XW_X_RIGHT (xw)))));
+ User_Vector_Set (result, 3, (Allocate_Float ((double) (XW_Y_TOP (xw)))));
+ PRIMITIVE_RETURN (result);
+}
+
+DEFINE_PRIMITIVE ("X-GRAPHICS-RESET-CLIP-RECTANGLE", Prim_x_graphics_reset_clip_rectangle, 1, 1, 0)
+{
+ struct xwindow * xw;
+ PRIMITIVE_HEADER (1);
+
+ xw = (WINDOW_ARG (1));
+ process_events (xw);
+ reset_clip_rectangle (xw);
+ 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)
+Set the clip rectangle to the given coordinates.")
+{
+ struct xwindow * xw;
+ int x_left;
+ int y_bottom;
+ int x_right;
+ int y_top;
+ PRIMITIVE_HEADER (5);
+
+ xw = (WINDOW_ARG (1));
+ process_events (xw);
+ x_left = (arg_x_coordinate (2, xw));
+ y_bottom = (arg_y_coordinate (3, xw));
+ x_right = (arg_x_coordinate (4, xw));
+ y_top = (arg_y_coordinate (5, xw));
+ set_clip_rectangle (xw, x_left, y_bottom, x_right, y_top);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+static void
+wm_set_size_hint (xw, flags, x, y)
+ struct xwindow * xw;
+ long flags;
+ int x, y;
+{
+ int extra = (2 * (XW_INTERNAL_BORDER_WIDTH (xw)));
+ XSizeHints size_hints;
+
+ (size_hints . flags) = (PResizeInc | PMinSize | flags);
+ (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;
+ XSetNormalHints ((XW_DISPLAY (xw)), (XW_WINDOW (xw)), (& size_hints));
+ return;
+}
+
+#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))); \
+}
+\f
+DEFINE_PRIMITIVE ("X-GRAPHICS-OPEN-WINDOW", Prim_x_graphics_open_window, 3, 3,
+ "(X-GRAPHICS-OPEN-WINDOW DISPLAY GEOMETRY SUPPRESS-MAP?)
+Open a window on DISPLAY using GEOMETRY.
+If GEOMETRY is false map window interactively.
+If third argument SUPPRESS-MAP? is true, do not map the window immediately.")
+{
+ Display * display;
+ int screen_number;
+ char * name;
+ struct drawing_attributes attributes;
+ int border_width;
+ int internal_border_width;
+ int extra;
+ int x_pos;
+ int y_pos;
+ int x_size;
+ int y_size;
+ Window window;
+ long flags;
+ struct xwindow * xw;
+ PRIMITIVE_HEADER (3);
+
+ display = (DISPLAY_ARG (1));
+ screen_number = (DefaultScreen (display));
+ name = "scheme-graphics";
+ x_default_attributes (display, RESOURCE_NAME, (& attributes));
+ border_width = (attributes . border_width);
+ internal_border_width = (attributes . internal_border_width);
+ extra = (2 * internal_border_width);
+ x_pos = (-1);
+ y_pos = (-1);
+ x_size = 512;
+ y_size = 384;
+ {
+ char * geometry;
+ int result;
+
+ geometry =
+ (((ARG_REF (2)) == SHARP_F)
+ ? (XGetDefault (display, RESOURCE_NAME, "Geometry"))
+ : (STRING_ARG (2)));
+ result =
+ (XGeometry (display, screen_number, geometry,
+ DEFAULT_GEOMETRY, border_width,
+ 1, 1, extra, extra,
+ (& x_pos), (& y_pos), (& x_size), (& y_size)));
+ flags = 0;
+ flags |=
+ (((result & XValue) && (result & YValue)) ? USPosition : PPosition);
+ flags |=
+ (((result & WidthValue) && (result & HeightValue)) ? USSize : PSize);
+ }
+
+ /* Open the window with the given arguments. */
+ {
+ XSetWindowAttributes wattributes;
+
+ (wattributes . background_pixel) = (attributes . background_pixel);
+ (wattributes . border_pixel) = (attributes . border_pixel);
+ (wattributes . backing_store) = Always;
+ window =
+ (XCreateWindow
+ (display,
+ (RootWindow (display, screen_number)),
+ x_pos, y_pos, (x_size + extra), (y_size + extra), border_width,
+ CopyFromParent, CopyFromParent, CopyFromParent,
+ (CWBackPixel | CWBorderPixel | CWBackingStore),
+ (& wattributes)));
+ }
+ if (window == ((Window) 0))
+ error_external_return ();
+
+ xw =
+ (x_make_window
+ (display,
+ window,
+ x_size,
+ y_size,
+ (& attributes),
+ (sizeof (struct gw_extra)),
+ ((void (*) ()) 0)));
+ (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;
+
+ XSelectInput (display, window, StructureNotifyMask);
+ wm_set_size_hint (xw, flags, x_pos, y_pos);
+ XStoreName (display, window, name);
+ XSetIconName (display, window, name);
+
+ if ((ARG_REF (3)) == SHARP_F)
+ {
+ (XW_VISIBLE_P (xw)) = 1;
+ XMapWindow (display, window);
+ XFlush (display);
+ }
+
+ PRIMITIVE_RETURN (x_window_to_object (xw));
+}
+\f
+DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-LINE", Prim_x_graphics_draw_line, 5, 5,
+ "(X-GRAPHICS-DRAW-LINE WINDOW X-START Y-START X-END Y-END)
+Draw a line from the start coordinates to the end coordinates.
+Subsequently move the graphics cursor to the end coordinates.")
+{
+ struct xwindow * xw;
+ int new_x_cursor;
+ int new_y_cursor;
+ int internal_border_width;
+ PRIMITIVE_HEADER (5);
+
+ xw = (WINDOW_ARG (1));
+ new_x_cursor = (arg_x_coordinate (4, xw));
+ new_y_cursor = (arg_y_coordinate (5, xw));
+ 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))),
+ (internal_border_width + (arg_y_coordinate (3, 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-MOVE-CURSOR", Prim_x_graphics_move_cursor, 3, 3,
+ "(X-GRAPHICS-MOVE-CURSOR WINDOW X Y)
+Move the graphics cursor to the given coordinates.")
+{
+ struct xwindow * xw;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ (XW_X_CURSOR (xw)) = (arg_x_coordinate (2, xw));
+ (XW_Y_CURSOR (xw)) = (arg_y_coordinate (3, xw));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-GRAPHICS-DRAG-CURSOR", Prim_x_graphics_drag_cursor, 3, 3,
+ "(X-GRAPHICS-DRAG-CURSOR WINDOW X Y)
+Draw a line from the graphics cursor to the given coordinates.
+Subsequently move the graphics cursor to those coordinates.")
+{
+ struct xwindow * xw;
+ int new_x_cursor;
+ int new_y_cursor;
+ int internal_border_width;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ new_x_cursor = (arg_x_coordinate (2, xw));
+ new_y_cursor = (arg_y_coordinate (3, xw));
+ internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ XDrawLine
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (XW_X_CURSOR (xw))),
+ (internal_border_width + (XW_Y_CURSOR (xw))),
+ (internal_border_width + new_x_cursor),
+ (internal_border_width + new_y_cursor));
+ (XW_X_CURSOR (xw)) = new_x_cursor;
+ (XW_Y_CURSOR (xw)) = new_y_cursor;
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-POINT", Prim_x_graphics_draw_point, 3, 3,
+ "(X-GRAPHICS-DRAW-POINT WINDOW X Y)
+Draw one point at the given coordinates.
+Subsequently move the graphics cursor to those coordinates.")
+{
+ struct xwindow * xw;
+ int internal_border_width;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ 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))),
+ (internal_border_width + (arg_y_coordinate (3, xw))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-GRAPHICS-DRAW-STRING", Prim_x_graphics_draw_string, 4, 4,
+ "(X-GRAPHICS-DRAW-STRING WINDOW X Y STRING)
+Draw characters in the current font at the given coordinates.")
+{
+ struct xwindow * xw;
+ int internal_border_width;
+ char * s;
+ PRIMITIVE_HEADER (4);
+
+ xw = (WINDOW_ARG (1));
+ internal_border_width = (XW_INTERNAL_BORDER_WIDTH (xw));
+ s = (STRING_ARG (4));
+ XDrawString
+ ((XW_DISPLAY (xw)),
+ (XW_WINDOW (xw)),
+ (XW_NORMAL_GC (xw)),
+ (internal_border_width + (arg_x_coordinate (2, xw))),
+ (internal_border_width + (arg_y_coordinate (3, xw))),
+ s,
+ (string_length (ARG_REF (4))));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FUNCTION", Prim_x_graphics_set_function, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ int function;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ function = (arg_index_integer (2, 16));
+ XSetFunction (display, (XW_NORMAL_GC (xw)), function);
+ XSetFunction (display, (XW_REVERSE_GC (xw)), function);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+\f
+DEFINE_PRIMITIVE ("X-GRAPHICS-SET-FILL-STYLE", Prim_x_graphics_set_fill_style, 2, 2, 0)
+{
+ struct xwindow * xw;
+ Display * display;
+ int fill_style;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ fill_style = (arg_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)
+{
+ struct xwindow * xw;
+ Display * display;
+ int style;
+ PRIMITIVE_HEADER (2);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ style = (arg_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)
+{
+ struct xwindow * xw;
+ Display * display;
+ int dash_offset;
+ char * dash_list;
+ int dash_list_length;
+ PRIMITIVE_HEADER (3);
+
+ xw = (WINDOW_ARG (1));
+ display = (XW_DISPLAY (xw));
+ dash_list = (STRING_ARG (3));
+ dash_list_length = (string_length (ARG_REF (3)));
+ dash_offset = (arg_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-PROCESS-EVENTS", Prim_x_graphics_process_events, 1, 1, 0)
+{
+ PRIMITIVE_HEADER (1);
+
+ process_events (WINDOW_ARG (1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
projects / mit-scheme.git / commitdiff