From: Chris Hanson Date: Wed, 21 Jun 1989 10:22:19 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~11991 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=43defdbc4ffbe2cd3fc7d055826f1ed9cde6216a;p=mit-scheme.git Initial revision --- diff --git a/v7/src/microcode/starbase.c b/v7/src/microcode/starbase.c new file mode 100644 index 000000000..da351611e --- /dev/null +++ b/v7/src/microcode/starbase.c @@ -0,0 +1,551 @@ +/* -*-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 + +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); \ + } \ +} + +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); +} + +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); +} + +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); +} + +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); +} + +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); +} + +/* 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); +} + +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; +} diff --git a/v7/src/microcode/starbasx.c b/v7/src/microcode/starbasx.c new file mode 100644 index 000000000..d6f6165bc --- /dev/null +++ b/v7/src/microcode/starbasx.c @@ -0,0 +1,57 @@ +/* -*-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 + +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))); +} diff --git a/v7/src/microcode/x11.h b/v7/src/microcode/x11.h new file mode 100644 index 000000000..de659e0b0 --- /dev/null +++ b/v7/src/microcode/x11.h @@ -0,0 +1,164 @@ +/* -*-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 +#include +#include +#include + +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; +}; + +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 diff --git a/v7/src/microcode/x11base.c b/v7/src/microcode/x11base.c new file mode 100644 index 000000000..dc11c041d --- /dev/null +++ b/v7/src/microcode/x11base.c @@ -0,0 +1,884 @@ +/* -*-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" + +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); +} + +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; + +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)); +} + +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; +} + +#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)))); +} + +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; +} + +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)); +} + +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)); +} + +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)))); +} + +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))); +} + +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); +} + +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); +} + +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); +} + +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); +} diff --git a/v7/src/microcode/x11graph.c b/v7/src/microcode/x11graph.c new file mode 100644 index 000000000..68a0b17b4 --- /dev/null +++ b/v7/src/microcode/x11graph.c @@ -0,0 +1,658 @@ +/* -*-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" + +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))); +} + +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; +} + +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; +} + +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); +} + +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))); \ +} + +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)); +} + +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); +} + +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); +} + +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); +}