--- /dev/null
+##
+## $Id: Makefile,v 1.1 1995/08/02 21:19:38 adams Exp $
+##
+##
+##
+
+#_______________________________________________________________________
+#
+# Installation configuration
+#
+# Where the installed version of SWAT lives
+
+INSTALL_DIR=/scheme/8.0/700/lib/swat
+
+# SWAT's own copies of tcl and tk. These definitions are passed down to
+# the compilation of Tk and Tcl and become hard paths in the tcl.sl
+# and tk.sl libraries. DO NOT point these to source directories: the
+# installation cleans them out.
+
+TCL_LIBRARY = $(INSTALL_DIR)/tcl_lib
+TK_LIBRARY = $(INSTALL_DIR)/tk_lib
+
+#_______________________________________________________________________
+
+C_LIBRARIES = c/scxl.sl c/tk.sl c/tcl.sl c/uitk.sl
+
+all:
+ echo "No all target."
+ echo "Only make install"
+ exit 1
+
+install: scheme/compiled
+ (cd c; make TCL_LIBRARY=$(TCL_LIBRARY) TK_LIBRARY=$(TK_LIBRARY) all)
+ # Remove dynload separatly first: will fail if SWAT is in use.
+ rm -rf $(INSTALL_DIR)/dynload
+ rm -rf $(INSTALL_DIR) $(TCL_LIBRARY) $(TK_LIBRARY)
+ mkdir $(INSTALL_DIR) $(INSTALL_DIR)/dynload \
+ $(TCL_LIBRARY) $(TK_LIBRARY)
+ cp $(C_LIBRARIES) $(INSTALL_DIR)/dynload
+ (cd c/tk3.2/library; cp *.tcl tclIndex prolog.ps $(TK_LIBRARY))
+ (cd c/tk3.2/tcl/library; cp *.tcl tclIndex $(TCL_LIBRARY))
+ (cd scheme; cp load.scm *.com *.bci $(INSTALL_DIR))
+ echo "Installation complete"
+
+
+#$(C_LIBRARIES):
+
+
+scheme/compiled:
+ echo "Build Scheme subsystem with scheme compiler"
+ exit 1
+ (cd scheme; \
+ echo '(load "swat.sf") (load "swat.cbf")' | $(SCHEME) -compiler \
+ )
+
+clean:
\ No newline at end of file
--- /dev/null
+#include "scheme.h"
+#include "prims.h"
+
+extern char *EXFUN (dload_initialize_file, (void));
+
+char *
+ DEFUN_VOID (dload_initialize_file)
+{ return "#NoMITSchemePrimitives";
+}
--- /dev/null
+##
+## $Id: Makefile,v 1.1 1995/08/02 21:21:00 adams Exp $
+##
+## WARNING: This makefile is designed to be used only from the master
+## makefile in the parent directory.
+
+#_______________________________________________________________________
+#
+# How this makefile works.
+#
+# This makefile builds four libraries. Two are based directly on
+# Tk/Tcl. The other two are an interface between Scheme, X and
+# Tk/Tcl.
+#
+# The build process works by customizing an off-the-shelf version of tk
+# (currently version 3.2). The SWAT versions of some of the files are
+# copied over the off-the-shelf version. The customized version is
+# compiled to produce the libtk.a and libtcl.a libraries. These
+# libraries are not acutally used but they ensure that all the targets
+# that we are interested in are up to date. Then we construct our own
+# libraries (tk.sl and tcl.sl).
+#
+# The other libraries are more straight-forward.
+#_______________________________________________________________________
+
+# The location of the customized files. The directory structure matches
+# that of tk3.2 and is sparsely populated with customized files:
+
+CUSTOM = tk3.2-custom
+
+# Important: select a microcode source directory with the correct scheme
+# object representation:
+
+SCHEME_INCLUDE_DIRS = -I/scheme/8.0/src/microcode
+
+TK = tk3.2
+TCL = $(TK)/tcl
+
+#UITK_INCLUDE_DIRS = -I $(UITK) -I $(UITK_C) -I $(TK) -I $(TCL) $(SCHEME_INCLUDE_DIRS)
+UITK_INCLUDE_DIRS = -I $(TK) -I $(TCL) $(SCHEME_INCLUDE_DIRS)
+CFLAGS = -DMIT_SCHEME -O -Ae -D_HPUX -I/usr/include/X11R5 +z
+
+XLIB = -L /usr/lib/X11R5 -lX11
+
+# These library paths are overruled by the master makefile.
+
+#TK_LIBRARY = /scheme/8.0/700/swat/c/tk3.2/library
+#TCL_LIBRARY = /scheme/8.0/700/swat/c/tk3.2/tcl/library
+TK_LIBRARY = Built_incorrectly__TK_LIBRARY__not_specified
+TCL_LIBRARY = Built_incorrectly__TCL_LIBRARY__not_specified
+
+TCL_GENERIC_OBJS = \
+ $(TCL)/regexp.o $(TCL)/tclAssem.o $(TCL)/tclBasic.o \
+ $(TCL)/tclCkalloc.o $(TCL)/tclCmdAH.o $(TCL)/tclCmdIL.o \
+ $(TCL)/tclCmdMZ.o $(TCL)/tclExpr.o $(TCL)/tclGet.o \
+ $(TCL)/tclHash.o $(TCL)/tclHistory.o $(TCL)/tclParse.o \
+ $(TCL)/tclProc.o $(TCL)/tclUtil.o $(TCL)/tclVar.o
+
+TCL_UNIX_OBJS = \
+ $(TCL)/panic.o $(TCL)/tclEnv.o $(TCL)/tclGlob.o $(TCL)/tclUnixAZ.o \
+ $(TCL)/tclUnixStr.o $(TCL)/tclUnixUtil.o
+
+TCL_OBJS = $(TCL_GENERIC_OBJS) $(TCL_UNIX_OBJS) MITScheme.o
+
+TK_WIDGOBJS = \
+ $(TK)/tkButton.o $(TK)/tkEntry.o $(TK)/tkFrame.o $(TK)/tkListbox.o \
+ $(TK)/tkMenu.o $(TK)/tkMenubutton.o $(TK)/tkMessage.o $(TK)/tkScale.o \
+ $(TK)/tkScrollbar.o
+
+TK_CANVOBJS = \
+ $(TK)/tkCanvas.o $(TK)/tkCanvArc.o $(TK)/tkCanvBmap.o \
+ $(TK)/tkCanvLine.o $(TK)/tkCanvPoly.o $(TK)/tkCanvPs.o \
+ $(TK)/tkCanvText.o $(TK)/tkCanvWind.o $(TK)/tkRectOval.o $(TK)/tkTrig.o
+
+TK_TEXTOBJS = $(TK)/tkText.o $(TK)/tkTextBTree.o $(TK)/tkTextDisp.o \
+ $(TK)/tkTextIndex.o $(TK)/tkTextTag.o
+
+TK_OBJS = \
+ $(TK)/tk3d.o $(TK)/tkArgv.o $(TK)/tkAtom.o $(TK)/tkBind.o \
+ $(TK)/tkBitmap.o $(TK)/tkCmds.o $(TK)/tkColor.o $(TK)/tkConfig.o \
+ $(TK)/tkCursor.o $(TK)/tkError.o $(TK)/tkEvent.o $(TK)/tkFocus.o \
+ $(TK)/tkFont.o $(TK)/tkGet.o $(TK)/tkGC.o $(TK)/tkGeometry.o \
+ $(TK)/tkGrab.o $(TK)/tkOption.o $(TK)/tkPack.o $(TK)/tkPlace.o \
+ $(TK)/tkPreserve.o $(TK)/tkSelect.o $(TK)/tkSend.o $(TK)/tkWindow.o \
+ $(TK)/tkWm.o $(TK_WIDGOBJS) $(TK_CANVOBJS) $(TK_TEXTOBJS) MITScheme.o
+
+UITK_OBJS = tk-c.o tk-c-mit.o widget-c.o widget-c-mit.o uitk-prims.o
+SCXL_OBJS = scxl.o
+
+# Contents of custom directory structure:
+
+CUSTOM_SRC = \
+ $(CUSTOM)/Makefile $(CUSTOM)/tkCanvArc.c $(CUSTOM)/tkMenu.c \
+ $(CUSTOM)/tkEvent.c $(CUSTOM)/tkWindow.c \
+ $(CUSTOM)/tcl/Makefile $(CUSTOM)/tcl/tclUnix.h \
+ $(CUSTOM)/library/emacs.tcl
+
+all: scxl.sl tcl.sl tk.sl uitk.sl
+
+scxl.sl: $(SCXL_OBJS)
+ rm -f scxl.sl
+ ld -b -o scxl.sl $(SCXL_OBJS) $(XLIB) -lc
+
+tcl.sl: $(TCL)/libtcl.a MITScheme.o
+ rm -f tcl.sl
+ ld -b -o tcl.sl $(TCL_OBJS) -lc
+
+tk.sl: $(TK)/libtk.a MITScheme.o
+ rm -f tk.sl
+ ld -b -o tk.sl $(TK_OBJS) $(XLIB) -lm -lc
+
+uitk.sl: $(UITK_OBJS)
+ rm -f uitk.sl
+ ld -b -o uitk.sl $(UITK_OBJS) -lm -lc
+
+scxl.o MITScheme.o uitk-prims.o:
+ $(CC) $(CFLAGS) $(SCHEME_INCLUDE_DIRS) -c $*.c
+
+MITScheme.o: MITScheme.c
+scxl.o: scxl.c
+uitk-prims.o: uitk-prims.c
+
+widget-c.o widget-c-mit.o tk-c-mit.o: $(TK)/tkInt.h $(TK)/default.h
+ $(CC) $(CFLAGS) $(UITK_INCLUDE_DIRS) -c $*.c
+
+tk-c.o: tk-c.c $(TK)/tkInt.h $(TK)/default.h
+ $(CC) $(CFLAGS) $(UITK_INCLUDE_DIRS) TK_LIBRARY=$(TK_LIBRARY) \
+ TCL_LIBRARY=$(TCL_LIBRARY) -c $*.c
+widegt-c.o: widget-c.c
+widget-c-mit.o: widget-c-mit.c
+tk-c-mit.o: tk-c-mit.c
+
+#$(TCL_OBJS) $(TK_OBJS): customization
+$(TCL)/libtcl.a $(TK)/libtk.a: customization
+
+customization: $(CUSTOM_SRC)
+ (cd $(TCL); ./config)
+ # overwrite standard code with customized files
+ cp -f -R tk3.2-custom/* tk3.2
+ rm -f $(TK)/libtk.a $(TCL)/libtcl.a
+ (cd tk3.2; \
+ make -f Makefile TCL_LIBRARY=$(TCL_LIBRARY) TK_LIBRARY=$(TK_LIBRARY) \
+ libtk.a tcl/libtcl.a \
+ )
+ date > customization
+
+
--- /dev/null
+/* X11 support similar to that in Joel Bartlett's Scheme-To-C xlib (scxl) */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ux.h"
+#include "uxselect.h"
+
+/* Changed 7/95 by Nick in an attempt to fix problem Hal was having with SWAT over PPP (i.e. slow connections) */
+/* commented out 'cause x11.h includes em all
+#include <X11/Xlib.h>
+#include <X11/cursorfont.h>
+#include <X11/keysym.h>
+#include <X11/Xutil.h>
+#include <X11/Xatom.h>
+#include "ansidecl.h" */
+
+#include "x11.h"
+
+extern void EXFUN (block_signals, (void));
+extern void EXFUN (unblock_signals, (void));
+
+/* end nick's changes - but see below for more */
+
+
+/* Operations */
+
+DEFINE_PRIMITIVE ("%XAllocNamedColor", Prim_scxl_allocated_named_color,
+ 5, 5, 0)
+{ /* (%XAllocNamedColor display colormap color-string
+ return-alloc return-exact)
+ */
+ PRIMITIVE_HEADER(5);
+ CHECK_ARG(4, STRING_P);
+ CHECK_ARG(5, STRING_P);
+ if (STRING_LENGTH(ARG_REF(4)) < sizeof (XColor))
+ error_bad_range_arg(4);
+ if (STRING_LENGTH(ARG_REF(5)) < sizeof (XColor))
+ error_bad_range_arg(5);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XAllocNamedColor((Display *) arg_integer(1),
+ (Colormap) arg_integer(2),
+ STRING_ARG(3),
+ (XColor *) STRING_ARG(4),
+ (XColor *) STRING_ARG(5))));
+}
+
+DEFINE_PRIMITIVE ("%XChangeWindowAttributes", Prim_scxl_change_wind_attr,
+ 4, 4, 0)
+{ /* (%XChangeWindowAttributes display window mask attributes) */
+ /* ATTRIBUTES is a string */
+ PRIMITIVE_HEADER(4);
+ CHECK_ARG(4, STRING_P);
+ if (STRING_LENGTH(ARG_REF(4)) < sizeof (XSetWindowAttributes))
+ error_bad_range_arg(4);
+ XChangeWindowAttributes((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ (unsigned long) arg_integer(3),
+ (XSetWindowAttributes *) STRING_ARG(4));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XCheckMaskEvent", Prim_scxl_check_mask_event, 3, 3, 0)
+{ /* (%XCheckMaskEvent display event-mask return-event) */
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG(3, STRING_P);
+ if (STRING_LENGTH(ARG_REF(3)) < sizeof(XEvent))
+ error_bad_range_arg(3);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
+ (XCheckMaskEvent ((Display *) arg_integer(1),
+ (long) arg_integer(2),
+ (XEvent *) STRING_ARG(3))));
+}
+
+DEFINE_PRIMITIVE ("%XClearArea", Prim_scxl_clear_area, 7, 7, 0)
+{ /* (%XClearArea display window x y width height) */
+ PRIMITIVE_HEADER (7);
+ XClearArea ((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (int) arg_integer(3),
+ (int) arg_integer(4),
+ (unsigned int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (Bool) BOOLEAN_ARG(7));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XClearWindow", Prim_scxl_clear_window, 2, 2, 0)
+{ /* (%XClearWindow display window) */
+ PRIMITIVE_HEADER (2);
+ XClearWindow ((Display *) arg_integer(1),
+ (Drawable) arg_integer(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XCloseDisplay", Prim_scxl_close, 1, 1, 0)
+{ /* (%XCloseDisplay display) */
+ PRIMITIVE_HEADER (1);
+ XCloseDisplay((Display *) arg_integer(1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XConnectionNumber", Prim_scxl_connection_number, 1, 1, 0)
+{ /* (%XConnectionNumber display) */
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN (long_to_integer
+ (XConnectionNumber((Display *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%XCreateGC", Prim_scxl_create_gc, 4, 4, 0)
+{ /* (%XCreateGC display window mask values) */
+ PRIMITIVE_HEADER(4);
+ CHECK_ARG(4, STRING_P);
+ if (STRING_LENGTH(ARG_REF(4)) < sizeof(XGCValues))
+ error_bad_range_arg(4);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XCreateGC((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (unsigned long) arg_integer(3),
+ (XGCValues *) STRING_ARG(4))));
+}
+
+DEFINE_PRIMITIVE ("%XCreateRegion", Prim_scxl_create_region, 0, 0, 0)
+{ /* (%XCreateRegion) */
+ Region Result;
+ PRIMITIVE_HEADER(0);
+ Result = XCreateRegion();
+ PRIMITIVE_RETURN (long_to_integer ((long) Result));
+}
+
+DEFINE_PRIMITIVE ("%XCreateSimpleWindow", Prim_scxl_create_simple_window,
+ 9, 9, 0)
+{ /* (%XCreateSimpleWindow display parent-window x y width height
+ border-width border-color background-color)
+ */
+ PRIMITIVE_HEADER(9);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XCreateSimpleWindow
+ ((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ (int) arg_integer(3),
+ (int) arg_integer(4),
+ (unsigned int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (unsigned int) arg_integer(7),
+ (unsigned long) arg_integer(8),
+ (unsigned long) arg_integer(9))));
+}
+
+DEFINE_PRIMITIVE ("%XDecodeButtonEvent", prim_scxl_decode_button, 2, 2, 0)
+{ /* (%XDecodeButtonEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XButtonEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XButtonEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 15)
+ error_bad_range_arg(2);
+ Input = (XButtonEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
+ *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
+ *Next++ = long_to_integer ((long) (Input->button)); /* 13 */
+ *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeConfigureEvent",
+ prim_scxl_decode_config, 2, 2, 0)
+{ /* (%XDecodeConfigureEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XConfigureEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XConfigureEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 13)
+ error_bad_range_arg(2);
+ Input = (XConfigureEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->event)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->width)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->height)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->border_width)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->above)); /* 11 */
+ *Next = BOOLEAN_TO_OBJECT(Input->override_redirect); /* 12 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeCrossingEvent", prim_scxl_decode_crossing, 2, 2, 0)
+{ /* (%XDecodeCrossingEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XCrossingEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XCrossingEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 17)
+ error_bad_range_arg(2);
+ Input = (XCrossingEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
+ *Next++ = long_to_integer ((long) (Input->mode)); /* 12 */
+ *Next++ = long_to_integer ((long) (Input->detail)); /* 13 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->focus); /* 15 */
+ *Next = long_to_integer ((long) (Input->state)); /* 16 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeExposeEvent", prim_scxl_decode_expose, 2, 2, 0)
+{ /* (%XDecodeExposeEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XExposeEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XExposeEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 10)
+ error_bad_range_arg(2);
+ Input = (XExposeEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->width)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->height)); /* 8 */
+ *Next = long_to_integer ((long) (Input->count)); /* 9 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeKeyEvent", prim_scxl_decode_key, 2, 2, 0)
+{ /* (%XDecodeKeyEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XKeyEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XKeyEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 15)
+ error_bad_range_arg(2);
+ Input = (XKeyEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
+ *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
+ *Next++ = long_to_integer ((long) (Input->keycode)); /* 13 */
+ *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeMotionEvent", prim_scxl_decode_motion, 2, 2, 0)
+{ /* (%XDecodeMotionEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XMotionEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XMotionEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 15)
+ error_bad_range_arg(2);
+ Input = (XMotionEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->window)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->root)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->subwindow)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->time)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->x)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->x_root)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->y_root)); /* 11 */
+ *Next++ = long_to_integer ((long) (Input->state)); /* 12 */
+ *Next++ = long_to_integer ((long) (Input->is_hint)); /* 13 */
+ *Next = BOOLEAN_TO_OBJECT(Input->same_screen); /* 14 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeUnknownEvent", Prim_scxl_decode_unknown, 2, 2, 0)
+{ /* (%XDecodeUnknownEvent event vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XAnyEvent *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XAnyEvent))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 5)
+ error_bad_range_arg(2);
+ Input = (XAnyEvent *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->type)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->serial)); /* 1 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->send_event); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->display)); /* 3 */
+ *Next = long_to_integer ((long) (Input->window)); /* 4 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeWindowAttributes", Prim_scxl_decode_wind_attr, 2, 2, 0)
+{ /* (%XDecodeWindowAttributes attributes vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XWindowAttributes *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XWindowAttributes))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 23)
+ error_bad_range_arg(2);
+ Input = (XWindowAttributes *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->x)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->y)); /* 1 */
+ *Next++ = long_to_integer ((long) (Input->width)); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->height)); /* 3 */
+ *Next++ = long_to_integer ((long) (Input->border_width)); /* 4 */
+ *Next++ = long_to_integer ((long) (Input->depth)); /* 5 */
+ *Next++ = long_to_integer ((long) (Input->visual)); /* 6 */
+ *Next++ = long_to_integer ((long) (Input->root)); /* 7 */
+ *Next++ = long_to_integer ((long) (Input->class)); /* 8 */
+ *Next++ = long_to_integer ((long) (Input->bit_gravity)); /* 9 */
+ *Next++ = long_to_integer ((long) (Input->win_gravity)); /* 10 */
+ *Next++ = long_to_integer ((long) (Input->backing_store)); /* 11 */
+ *Next++ = long_to_integer ((long) (Input->backing_planes)); /* 12 */
+ *Next++ = long_to_integer ((long) (Input->backing_pixel)); /* 13 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->save_under); /* 14 */
+ *Next++ = long_to_integer ((long) (Input->colormap)); /* 15 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->map_installed); /* 16 */
+ *Next++ = long_to_integer ((long) (Input->map_state)); /* 17 */
+ *Next++ = long_to_integer ((long) (Input->all_event_masks)); /* 18 */
+ *Next++ = long_to_integer ((long) (Input->your_event_mask)); /* 19 */
+ *Next++ = long_to_integer ((long) (Input->do_not_propagate_mask)); /* 20 */
+ *Next++ = BOOLEAN_TO_OBJECT(Input->override_redirect); /* 21 */
+ *Next = long_to_integer ((long) (Input->screen)); /* 22 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDecodeXColor", Prim_scxl_decode_xcolor, 2, 2, 0)
+{ /* (%XDecodeXColor xcolor vector) */
+ SCHEME_OBJECT Result = ARG_REF(2);
+ SCHEME_OBJECT *Next;
+ XColor *Input;
+
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(1, STRING_P);
+ if (STRING_LENGTH(ARG_REF(1)) != sizeof(XColor))
+ error_bad_range_arg(1);
+ CHECK_ARG(2, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 5)
+ error_bad_range_arg(2);
+ Input = (XColor *) STRING_ARG(1);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = long_to_integer ((long) (Input->pixel)); /* 0 */
+ *Next++ = long_to_integer ((long) (Input->red)); /* 1 */
+ *Next++ = long_to_integer ((long) (Input->green)); /* 2 */
+ *Next++ = long_to_integer ((long) (Input->blue)); /* 3 */
+ *Next = long_to_integer ((long) (Input->flags)); /* 4 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDefaultColormap", Prim_scxl_default_colormap, 2, 2, 0)
+{ /* (%XDefaultColormap display screen) */
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XDefaultColormap((Display *) arg_integer(1),
+ arg_integer(2))));
+}
+
+DEFINE_PRIMITIVE ("%XDefaultRootWindow", Prim_scxl_default_root_window,
+ 1, 1, 0)
+{ /* (%XDefaultRootWindow display) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XDefaultRootWindow ((Display *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%XDefaultScreen", Prim_scxl_default_screen, 1, 1, 0)
+{ /* (%XDefaultScreen display) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) XDefaultScreen((Display *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%XDestroyRegion", Prim_scxl_destroy_region, 1, 1, 0)
+{ /* (%XDestroyRegion region) */
+ PRIMITIVE_HEADER (1);
+ XDestroyRegion ((Region) arg_integer(1));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDestroyWindow", Prim_scxl_destroy_window, 2, 2, 0)
+{ /* (%XDestroyWindow display window) */
+ PRIMITIVE_HEADER (2);
+ XDestroyWindow((Display *) arg_integer(1),
+ (Window) arg_integer(2));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDrawArc", Prim_scxl_draw_arc, 9, 9, 0)
+{ /* (%XDrawArc display window context
+ x y width height angle1 angle2) */
+ PRIMITIVE_HEADER (9);
+ XDrawArc((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (GC) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (unsigned int) arg_integer(7),
+ (unsigned int) arg_integer(8),
+ (unsigned int) arg_integer(9));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDrawLine", Prim_scxl_draw_line, 7, 7, 0)
+{ /* (%XDrawLine display window context x1 y1 x2 y2) */
+ PRIMITIVE_HEADER (7);
+ XDrawLine((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (GC) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ (int) arg_integer(6),
+ (int) arg_integer(7));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XDrawRectangle", Prim_scxl_draw_rectangle, 7, 7, 0)
+{ /* (%XDrawRectangle display window context x y width height) */
+ PRIMITIVE_HEADER (7);
+ XDrawRectangle((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (GC) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (unsigned int) arg_integer(7));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XFillArc", Prim_scxl_fill_arc, 9, 9, 0)
+{ /* (%XFillArc display window context
+ x y width height angle1 angle2) */
+ PRIMITIVE_HEADER (9);
+ XFillArc((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (GC) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (unsigned int) arg_integer(7),
+ (unsigned int) arg_integer(8),
+ (unsigned int) arg_integer(9));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XFillRectangle", Prim_scxl_fill_rectangle, 7, 7, 0)
+{ /* (%XFillRectangle display window context x y width height) */
+ PRIMITIVE_HEADER (7);
+ XFillRectangle((Display *) arg_integer(1),
+ (Drawable) arg_integer(2),
+ (GC) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ (unsigned int) arg_integer(6),
+ (unsigned int) arg_integer(7));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XFlush", Prim_scxl_flush, 1, 1, 0)
+{ /* (%XFlush display) */
+ PRIMITIVE_HEADER (1);
+ XFlush((Display *) arg_integer(1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XFreeColormap", Prim_scxl_free_colormap, 2, 2, 0)
+{ /* (%XFreeColormap display colormap) */
+ PRIMITIVE_HEADER(2);
+ XFreeColormap((Display *) arg_integer(1), (Colormap) arg_integer(2));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XFreeGC", Prim_scxl_free_gc, 2, 2, 0)
+{ /* (%XFreeGC display graphic-context) */
+ PRIMITIVE_HEADER(2);
+ XFreeGC((Display *) arg_integer(1), (GC) arg_integer(2));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XGetDefault", Prim_scxl_get_default, 3, 3, 0)
+{ /* (%XGetDefault display program option) */
+ PRIMITIVE_HEADER(3);
+ PRIMITIVE_RETURN
+ (char_pointer_to_string
+ ((unsigned char *) XGetDefault((Display *) arg_integer(1),
+ STRING_ARG(2),
+ STRING_ARG(3))));
+}
+
+DEFINE_PRIMITIVE ("%XGetWindowAttributes", Prim_scxl_get_wind_attr, 3, 3, 0)
+{ /* (%XGetWindowAttributes display window attributes-to-fill) */
+ PRIMITIVE_HEADER(3);
+ CHECK_ARG(3, STRING_P);
+ if (STRING_LENGTH(ARG_REF(3)) < sizeof(XWindowAttributes))
+ error_bad_range_arg(3);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long)
+ XGetWindowAttributes((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ (XWindowAttributes *) STRING_ARG(3))));
+}
+
+DEFINE_PRIMITIVE ("%XIntersectRegion", Prim_scxl_intersect_reg, 3, 3, 0)
+{ /* (%XIntersectRegion source1 source2 dest) */
+ PRIMITIVE_HEADER (3);
+ XIntersectRegion((Region) arg_integer(1),
+ (Region) arg_integer(2),
+ (Region) arg_integer(3));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XLoadFont", Prim_scxl_load_font, 2, 2, 0)
+{ /* (%XLoadFont display name-string) */
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN
+ (long_to_integer ((long) XLoadFont((Display *) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%XMapWindow", Prim_scxl_map_window, 2, 2, 0)
+{ /* (%XMapWindow display window) */
+ PRIMITIVE_HEADER(2);
+ XMapWindow((Display *) arg_integer(1),
+ (Window) arg_integer(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XNextEvent", Prim_scxl_next_event, 2, 2, 0)
+{ /* (%XNextEvent display returned-event) */
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(2, STRING_P);
+ if (STRING_LENGTH(ARG_REF(2)) < sizeof(XEvent))
+ error_bad_range_arg(2);
+ XNextEvent((Display *) arg_integer(1),
+ (XEvent *) STRING_ARG(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XOpenDisplay", Prim_scxl_open_display, 1, 1, 0)
+{ /* (%XOpenDisplay string) */
+ PRIMITIVE_HEADER (1);
+ {
+ /* Changed 7/95 by Nick in an attempt to fix problem Hal was having with SWAT over PPP (i.e. slow connections) */
+ Display * display;
+ block_signals ();
+ display = XOpenDisplay(STRING_ARG(1));
+ unblock_signals ();
+ PRIMITIVE_RETURN (long_to_integer((long) display));
+ }
+}
+
+DEFINE_PRIMITIVE ("%XPending", Prim_scxl_pending, 1, 1, 0)
+{ /* (%XPending display) */
+ PRIMITIVE_HEADER (1);
+ PRIMITIVE_RETURN
+ (long_to_integer(XPending ((Display *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%XPutBackEvent", Prim_scxl_put_back_event, 2, 2, 0)
+{ /* (%XPutBackEvent display event) */
+ PRIMITIVE_HEADER (2);
+ CHECK_ARG(2, STRING_P);
+ if (STRING_LENGTH(ARG_REF(2)) < sizeof(XEvent))
+ error_bad_range_arg(2);
+ XPutBackEvent ((Display *) arg_integer(1),
+ (XEvent *) STRING_ARG(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XQueryPointer", Prim_scxl_query_pointer, 3, 3, 0)
+{ /* (%XQueryPointer display window result-vector) */
+ SCHEME_OBJECT Result = ARG_REF(3);
+ SCHEME_OBJECT *Next;
+ Window Root=0, Child=0;
+ int Root_X=0, Root_Y=0, Win_X=0, Win_Y=0;
+ unsigned int Keys_Buttons=0;
+ Bool result_status;
+
+ PRIMITIVE_HEADER (3);
+ CHECK_ARG(3, VECTOR_P);
+ if (VECTOR_LENGTH(Result) < 8) error_bad_range_arg(3);
+ result_status = XQueryPointer((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ &Root, &Child, &Root_X, &Root_Y,
+ &Win_X, &Win_Y, &Keys_Buttons);
+ Next = VECTOR_LOC(Result, 0);
+ *Next++ = BOOLEAN_TO_OBJECT(result_status); /* 0 */
+ *Next++ = long_to_integer ((long) Root); /* 1 */
+ *Next++ = long_to_integer ((long) Child); /* 2 */
+ *Next++ = long_to_integer ((long) Root_X); /* 3 */
+ *Next++ = long_to_integer ((long) Root_Y); /* 4 */
+ *Next++ = long_to_integer ((long) Win_X); /* 5 */
+ *Next++ = long_to_integer ((long) Win_Y); /* 6 */
+ *Next++ = long_to_integer ((long) Keys_Buttons); /* 7 */
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XQueryTree", Prim_query_tree, 2, 2, 0)
+{ /* (%XQueryTree display window)
+ returns a vector of #(root parent . kids)
+ */
+ SCHEME_OBJECT Kid_Return;
+ Window Root, Parent, *Kids;
+ unsigned int NKids, i;
+
+ PRIMITIVE_HEADER (2);
+ if (XQueryTree((Display *) arg_integer(1), (Window) arg_integer(2),
+ &Root, &Parent, &Kids, &NKids)==0)
+ { error_external_return();
+ }
+ Kid_Return = allocate_marked_vector(TC_VECTOR, NKids+2, true);
+ VECTOR_SET(Kid_Return, 0, long_to_integer((long) Root));
+ VECTOR_SET(Kid_Return, 1, long_to_integer((long) Parent));
+ for (i=0; i < NKids; i++)
+ VECTOR_SET(Kid_Return, i+2, long_to_integer((long) Kids[i]));
+ XFree(Kids);
+ PRIMITIVE_RETURN (Kid_Return);
+}
+
+DEFINE_PRIMITIVE ("%XScreenCount", Prim_scxl_screencount, 1, 1, 0)
+{ /* (%XScreenCount display) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ (XScreenCount((Display *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%XSetForeground", Prim_scxl_set_foreground, 3, 3, 0)
+{ /* (%XSetForeground display context pixel) */
+ PRIMITIVE_HEADER(3);
+ XSetForeground((Display *) arg_integer(1),
+ (GC) arg_integer(2),
+ arg_integer(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+
+DEFINE_PRIMITIVE ("%XSetFunction", Prim_scxl_set_function, 3, 3, 0)
+{ /* (%XSetFunction display context function_number) */
+ PRIMITIVE_HEADER(3);
+ XSetFunction((Display *) arg_integer(1),
+ (GC) arg_integer(2),
+ arg_integer(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+
+DEFINE_PRIMITIVE ("%XSetRegion", Prim_scxl_set_region, 3, 3, 0)
+{ /* (%XSetForeground display gc region) */
+ PRIMITIVE_HEADER(3);
+ XSetRegion((Display *) arg_integer(1),
+ (GC) arg_integer(2),
+ (Region) arg_integer(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XStoreName", Prim_scxl_store_name, 3, 3, 0)
+{ /* (%XStoreName display window title-string */
+ PRIMITIVE_HEADER (3);
+ XStoreName((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ STRING_ARG(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XSubtractRegion", Prim_scxl_subtract_reg, 3, 3, 0)
+{ /* (%XSubtractRegion source1 source2 dest) */
+ PRIMITIVE_HEADER (3);
+ XSubtractRegion((Region) arg_integer(1),
+ (Region) arg_integer(2),
+ (Region) arg_integer(3));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XTranslateCoordinates", Prim_scxl_translate_coords,
+ 6, 6, 0)
+{ /* (%XTranslateCoordinates display old-window new-window x y vector)
+ */
+ int X, Y;
+ Window W;
+ SCHEME_OBJECT Vect;
+ Boolean status;
+ PRIMITIVE_HEADER (6);
+ Vect = VECTOR_ARG(6);
+ if (VECTOR_LENGTH(Vect) < 4) error_bad_range_arg(6);
+ status = XTranslateCoordinates((Display *) arg_integer(1),
+ (Window) arg_integer(2),
+ (Window) arg_integer(3),
+ (int) arg_integer(4),
+ (int) arg_integer(5),
+ &X, &Y, &W);
+ VECTOR_SET(Vect, 0, BOOLEAN_TO_OBJECT(status));
+ VECTOR_SET(Vect, 1, long_to_integer((long) X));
+ VECTOR_SET(Vect, 2, long_to_integer((long) Y));
+ VECTOR_SET(Vect, 3, long_to_integer((long) W));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XUnionRegion", Prim_scxl_union_reg, 3, 3, 0)
+{ /* (%XUnionRegion source1 source2 dest) */
+ PRIMITIVE_HEADER (3);
+ XUnionRegion((Region) arg_integer(1),
+ (Region) arg_integer(2),
+ (Region) arg_integer(3));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XUnionRectSpecsWithRegion!", Prim_scxl_union_rectspecs, 6, 6, 0)
+{ /* (%XUnionRectSpecsWithRegion! x y width height inregion outregion) */
+ XRectangle Rect;
+ PRIMITIVE_HEADER (6);
+ Rect.x = arg_integer(1);
+ Rect.y = arg_integer(2);
+ Rect.width = arg_integer(3);
+ Rect.height = arg_integer(4);
+ XUnionRectWithRegion(&Rect,
+ (Region) (arg_integer (5)),
+ (Region) (arg_integer (6)));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%XUnloadFont", Prim_scxl_unload_font, 2, 2, 0)
+{ /* (%XUnloadFont display font) */
+ PRIMITIVE_HEADER(2);
+ XUnloadFont((Display *) arg_integer(1), (Font) arg_integer(2));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+/* Data structure constructors. These are represented as strings to */
+/* circumvent garbage collection */
+
+DEFINE_PRIMITIVE ("%XMake-Color", Prim_scxl_make_color, 0, 0, 0)
+{ /* (%XMake-Color) */
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN(allocate_string(sizeof(XColor)));
+}
+
+DEFINE_PRIMITIVE ("%XMake-Event", Prim_scxl_make_event, 0, 0, 0)
+{ /* (%XMake-Event) */
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN(allocate_string(sizeof(XEvent)));
+}
+
+DEFINE_PRIMITIVE ("%XMake-GCValues", Prim_scxl_make_gc_values, 0, 0, 0)
+{ /* (%XMake-GCValues) */
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN(allocate_string(sizeof(XGCValues)));
+}
+
+DEFINE_PRIMITIVE ("%XMake-GetWindowAttributes", Prim_scxl_make_get_wind_attr,
+ 0, 0, 0)
+{ /* (%XMake-GetWindowAttributes) */
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN(allocate_string(sizeof(XWindowAttributes)));
+}
+
+DEFINE_PRIMITIVE ("%XMake-SetWindowAttributes", Prim_scxl_make_set_wind_attr,
+ 0, 0, 0)
+{ /* (%XMake-SetWindowAttributes) */
+ PRIMITIVE_HEADER (0);
+ PRIMITIVE_RETURN(allocate_string(sizeof(XSetWindowAttributes)));
+}
+
+/* Mutators */
+
+#define Mutator(StructType, Field, FieldType, Converter) \
+{ \
+ PRIMITIVE_HEADER(2); \
+ CHECK_ARG(1, STRING_P); \
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(StructType)) \
+ error_bad_range_arg(1); \
+ ((StructType *) (STRING_ARG(1)))->Field = \
+ ((FieldType) Converter(2)); \
+ PRIMITIVE_RETURN (UNSPECIFIC); \
+}
+
+DEFINE_PRIMITIVE ("%XSetWindowAttributes-Event_Mask!",
+ Prim_scxl_XSetWindowAttributes_Event_Mask_bang,
+ 2, 2, 0)
+ Mutator(XSetWindowAttributes, event_mask, long, arg_integer)
+
+static int
+DEFUN (x_io_error_handler, (display),
+ Display * display)
+{
+ fprintf (stderr, "\nX IO Error on display 0x%x\n", display);
+ error_external_return ();
+}
+
+void DEFUN (Scheme_x_error_handler, (display, error_event),
+ Display * display AND
+ 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: 0x%x\n",
+ (error_event -> serial));
+ fprintf (stderr, " Display: %d (0x%x)\n",
+ error_event->display, error_event->display);
+ fprintf (stderr, " Resource ID: %d (0x%x)\n",
+ error_event->resourceid, error_event->resourceid);
+ fprintf (stderr, " Minor code: %d (0x%x)\n",
+ error_event->minor_code, error_event->minor_code);
+ fflush (stderr);
+}
+
+static int
+DEFUN (Scheme_low_x_error_handler, (display, error_event),
+ Display * display AND
+ XErrorEvent * error_event)
+{ Scheme_x_error_handler(display, error_event);
+ error_external_return ();
+}
+
+DEFINE_PRIMITIVE("%XInitSCXL!", Prim_scxl_init, 0, 0, 0)
+{ extern int _XDefaultError();
+ PRIMITIVE_HEADER (0);
+ XSetErrorHandler (Scheme_low_x_error_handler);
+ XSetIOErrorHandler (x_io_error_handler);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE("%XSync", Prim_scxl_sync, 2, 2, 0)
+{ PRIMITIVE_HEADER (2);
+ XSync((Display *) arg_integer(1), BOOLEAN_ARG(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE("%XSynchronize", Prim_scxl_synchronize, 2, 2, 0)
+{ PRIMITIVE_HEADER (2);
+ XSynchronize((Display *) arg_integer(1), BOOLEAN_ARG(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+SCHEME_OBJECT Debug_State_Flag;
+
+DEFINE_PRIMITIVE("%SetDebugState!", Prim_scxl_state, 1, 1, 0)
+{ PRIMITIVE_HEADER(1);
+ Debug_State_Flag = ARG_REF(1);
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+extern char *EXFUN (dload_initialize_file, (void));
+
+char *
+ DEFUN_VOID (dload_initialize_file)
+{ declare_primitive("%XAllocNamedColor", Prim_scxl_allocated_named_color,
+ 5, 5, 0);
+ declare_primitive("%XChangeWindowAttributes", Prim_scxl_change_wind_attr,
+ 4, 4, 0);
+ declare_primitive("%XCheckMaskEvent", Prim_scxl_check_mask_event, 3, 3, 0);
+ declare_primitive("%XClearArea", Prim_scxl_clear_area, 7, 7, 0);
+ declare_primitive("%XClearWindow", Prim_scxl_clear_window, 2, 2, 0);
+ declare_primitive("%XCloseDisplay", Prim_scxl_close, 1, 1, 0);
+ declare_primitive("%XConnectionNumber", Prim_scxl_connection_number, 1, 1, 0);
+ declare_primitive("%XCreateGC", Prim_scxl_create_gc, 4, 4, 0);
+ declare_primitive("%XCreateRegion", Prim_scxl_create_region, 0, 0, 0);
+ declare_primitive("%XCreateSimpleWindow", Prim_scxl_create_simple_window,
+ 9, 9, 0);
+ declare_primitive("%XDecodeButtonEvent", prim_scxl_decode_button, 2, 2, 0);
+ declare_primitive("%XDecodeConfigureEvent",
+ prim_scxl_decode_config, 2, 2, 0);
+ declare_primitive("%XDecodeCrossingEvent", prim_scxl_decode_crossing, 2, 2, 0);
+ declare_primitive("%XDecodeExposeEvent", prim_scxl_decode_expose, 2, 2, 0);
+ declare_primitive("%XDecodeKeyEvent", prim_scxl_decode_key, 2, 2, 0);
+ declare_primitive("%XDecodeMotionEvent", prim_scxl_decode_motion, 2, 2, 0);
+ declare_primitive("%XDecodeUnknownEvent", Prim_scxl_decode_unknown, 2, 2, 0);
+ declare_primitive("%XDecodeWindowAttributes", Prim_scxl_decode_wind_attr, 2, 2, 0);
+ declare_primitive("%XDecodeXColor", Prim_scxl_decode_xcolor, 2, 2, 0);
+ declare_primitive("%XDefaultColormap", Prim_scxl_default_colormap, 2, 2, 0);
+ declare_primitive("%XDefaultRootWindow", Prim_scxl_default_root_window,
+ 1, 1, 0);
+ declare_primitive("%XDefaultScreen", Prim_scxl_default_screen, 1, 1, 0);
+ declare_primitive("%XDestroyRegion", Prim_scxl_destroy_region, 1, 1, 0);
+ declare_primitive("%XDestroyWindow", Prim_scxl_destroy_window, 2, 2, 0);
+ declare_primitive("%XDrawArc", Prim_scxl_draw_arc, 9, 9, 0);
+ declare_primitive("%XDrawLine", Prim_scxl_draw_line, 7, 7, 0);
+ declare_primitive("%XDrawRectangle", Prim_scxl_draw_rectangle, 7, 7, 0);
+ declare_primitive("%XFillArc", Prim_scxl_fill_arc, 9, 9, 0);
+ declare_primitive("%XFillRectangle", Prim_scxl_fill_rectangle, 7, 7, 0);
+ declare_primitive("%XFlush", Prim_scxl_flush, 1, 1, 0);
+ declare_primitive("%XFreeColormap", Prim_scxl_free_colormap, 2, 2, 0);
+ declare_primitive("%XFreeGC", Prim_scxl_free_gc, 2, 2, 0);
+ declare_primitive("%XGetDefault", Prim_scxl_get_default, 3, 3, 0);
+ declare_primitive("%XGetWindowAttributes", Prim_scxl_get_wind_attr, 3, 3, 0);
+ declare_primitive("%XIntersectRegion", Prim_scxl_intersect_reg, 3, 3, 0);
+ declare_primitive("%XLoadFont", Prim_scxl_load_font, 2, 2, 0);
+ declare_primitive("%XMapWindow", Prim_scxl_map_window, 2, 2, 0);
+ declare_primitive("%XNextEvent", Prim_scxl_next_event, 2, 2, 0);
+ declare_primitive("%XOpenDisplay", Prim_scxl_open_display, 1, 1, 0);
+ declare_primitive("%XPending", Prim_scxl_pending, 1, 1, 0);
+ declare_primitive("%XPutBackEvent", Prim_scxl_put_back_event, 2, 2, 0);
+ declare_primitive("%XQueryPointer", Prim_scxl_query_pointer, 3, 3, 0);
+ declare_primitive("%XQueryTree", Prim_query_tree, 2, 2, 0);
+ declare_primitive("%XScreenCount", Prim_scxl_screencount, 1, 1, 0);
+ declare_primitive("%XSetForeground", Prim_scxl_set_foreground, 3, 3, 0);
+ declare_primitive("%XSetFunction", Prim_scxl_set_function, 3, 3, 0);
+ declare_primitive("%XSetRegion", Prim_scxl_set_region, 3, 3, 0);
+ declare_primitive("%XStoreName", Prim_scxl_store_name, 3, 3, 0);
+ declare_primitive("%XSubtractRegion", Prim_scxl_subtract_reg, 3, 3, 0);
+ declare_primitive("%XTranslateCoordinates", Prim_scxl_translate_coords,
+ 6, 6, 0);
+ declare_primitive("%XUnionRegion", Prim_scxl_union_reg, 3, 3, 0);
+ declare_primitive("%XUnionRectSpecsWithRegion!", Prim_scxl_union_rectspecs, 6, 6, 0);
+ declare_primitive("%XUnloadFont", Prim_scxl_unload_font, 2, 2, 0);
+ declare_primitive("%XMake-Color", Prim_scxl_make_color, 0, 0, 0);
+ declare_primitive("%XMake-Event", Prim_scxl_make_event, 0, 0, 0);
+ declare_primitive("%XMake-GCValues", Prim_scxl_make_gc_values, 0, 0, 0);
+ declare_primitive("%XMake-GetWindowAttributes", Prim_scxl_make_get_wind_attr,
+ 0, 0, 0);
+ declare_primitive("%XMake-SetWindowAttributes", Prim_scxl_make_set_wind_attr,
+ 0, 0, 0);
+ declare_primitive("%XSetWindowAttributes-Event_Mask!",
+ Prim_scxl_XSetWindowAttributes_Event_Mask_bang,
+ 2, 2, 0);
+ declare_primitive("%XInitSCXL!", Prim_scxl_init, 0, 0, 0);
+ declare_primitive("%XSync", Prim_scxl_sync, 2, 2, 0);
+ declare_primitive("%XSynchronize", Prim_scxl_synchronize, 2, 2, 0);
+ declare_primitive("%SetDebugState!", Prim_scxl_state, 1, 1, 0);
+ return "#SCXL";
+}
--- /dev/null
+/* -*- C -*-
+/* Uses tk-c.c - Support routines for Tk Widgets called from Scheme */
+/* $Id: tk-c-mit.c,v 1.1 1995/08/02 21:21:00 adams Exp $ */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ansidecl.h"
+#include "X11/Xlib.h"
+#include "tk.h"
+#include "tkInt.h" /* For TkWindow */
+
+DEFINE_PRIMITIVE ("%tclGlobalEval", Prim_tcl_eval, 2, 2, 0)
+{ /* (%tclGlobalEval TK-main-window string) */
+ Tcl_Interp *tclInterp;
+
+ PRIMITIVE_HEADER(2);
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tcl_GlobalEval(tclInterp, STRING_ARG(2)) != TCL_OK)
+ { fprintf(stderr, "%tclGlobalEval: error '%s'\n",
+ tclInterp->result);
+ error_external_return();
+ }
+ PRIMITIVE_RETURN (char_pointer_to_string
+ ((unsigned char *) tclInterp->result));
+}
+
+long TKEvent = true;
+DEFINE_PRIMITIVE ("%tkCompletelyHandlesEvent?",
+ Prim_tk_completely_handles_event, 1, 1, 0)
+{ /* (%tkCompletelyHandlesEvent? event) */
+ XEvent *Event;
+
+ PRIMITIVE_HEADER (1);
+
+ /* We return 0 if there is a bad argument rather than generating */
+ /* and error. This avoids the need to put a */
+ /* dynamic wind around calls to this primitive. */
+ /* Error checking is */
+ /* done at the next level up, in tk-completely-handles-event? */
+
+ if (!STRING_P(ARG_REF(1))) PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
+ if (STRING_LENGTH(ARG_REF(1)) < sizeof(XEvent))
+ PRIMITIVE_RETURN(LONG_TO_UNSIGNED_FIXNUM(0));
+
+
+ Event = (XEvent *) STRING_ARG(1);
+ TKEvent = true;
+ Tk_HandleEvent(Event);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT(TKEvent));
+}
+
+void OurTopLevelGeometryProc(ClientData CallBackHash, XEvent *Event)
+{ /* Based on the code for PackStructureProc in tkPack.c. That code */
+ /* handles four kinds of events: ConfigureNotify, DestroyNotify, */
+ /* MapNotify, and UnmapNotify. Here, we consider only the */
+ /* ConfigureNotify case and reflect it back into Scheme. */
+
+ if (Event->type == ConfigureNotify)
+ {
+#include <string.h>
+ extern void
+ AddSchemeCallBack(int argc, char **argv, long *countv);
+ char *argv[2], CallBackNumber[50],
+ EventChars[1+sizeof(XConfigureEvent)];
+ long Counts[2];
+
+ XConfigureEvent *E = (XConfigureEvent *) Event;
+ Counts[0] = sprintf(CallBackNumber, "%d", (long) CallBackHash);
+ argv[0] = CallBackNumber;
+ Counts[1] = sizeof(XConfigureEvent);
+ argv[1] = (char *) E;
+ AddSchemeCallBack(2, argv, Counts);
+ }
+}
+
+DEFINE_PRIMITIVE ("%tkCreateTopLevelWindow", Prim_tk_create_tl_window,
+ 3, 3, 0)
+{ /* (%tkCreateTopLevelWindow MainWindow Name CallBackHash) */
+ Tk_Window Result;
+ Tcl_Interp *tclInterp;
+
+ PRIMITIVE_HEADER (3);
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ Result =
+ Tk_CreateWindow(tclInterp, (Tk_Window) arg_integer(1),
+ STRING_ARG(2), "");
+ if (Result == NULL)
+ { fprintf(stderr, "%tkCreateTopLevelWindow: error '%s'\n",
+ tclInterp->result);
+ error_external_return();
+ }
+ Tk_SetWindowBackground(Result,
+ BlackPixelOfScreen(Tk_Screen(Result)));
+ Tk_CreateEventHandler(Result,
+ StructureNotifyMask,
+ OurTopLevelGeometryProc,
+ (ClientData) arg_integer(3));
+ PRIMITIVE_RETURN (long_to_integer((long) Result));
+}
+\f
+char *TK_CallBack_List;
+long NChars_In_TK_Callbacks = 0;
+
+DEFINE_PRIMITIVE ("%tkDoEvents", Prim_tk_do_events, 0, 0, 0)
+{ /* (%tkDoEvents) */
+ extern void DoTkEvents ();
+ PRIMITIVE_HEADER (0);
+ DoTkEvents();
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkDrainCallBacks", Prim_tk_drain, 2, 2, 0)
+{ /* (%tkDrainCallBacks nchar string) */
+ /* Returns the number of characters available in the call back */
+ /* string if there is NOT enough room in the string to hold all of */
+ /* the characters. Otherwise, the characters are written into */
+ /* STRING, C variable is cleared, space freed and the primitive */
+ /* returns #F. */
+
+ long NCharsInString;
+ unsigned char *StringSpace;
+
+ PRIMITIVE_HEADER (2);
+ NCharsInString = arg_integer(1);
+ StringSpace = (unsigned char *) STRING_ARG(2);
+ if ((NChars_In_TK_Callbacks != 0) &&
+ (NCharsInString >= NChars_In_TK_Callbacks))
+ { fast unsigned char * scan_result = StringSpace;
+ fast unsigned char * end_result = (scan_result + NChars_In_TK_Callbacks);
+ fast unsigned char * data = (unsigned char *) TK_CallBack_List;
+ while (scan_result < end_result)
+ (*scan_result++) = (*data++);
+ SET_STRING_LENGTH (ARG_REF(2), NChars_In_TK_Callbacks);
+ /* free(TK_CallBack_List); */
+ /* TK_CallBack_List = NULL; */
+ NChars_In_TK_Callbacks = 0;
+ PRIMITIVE_RETURN (SHARP_F);
+ }
+ else
+ { PRIMITIVE_RETURN(long_to_integer(NChars_In_TK_Callbacks));
+ }
+}
+
+void OurEventHandler(ClientData ignored_data, XEvent *ignored_event)
+{ TKEvent = false;
+}
+
+DEFINE_PRIMITIVE ("%tkGenerateSchemeEvent",
+ Prim_tk_generate_scheme_event, 2, 2, 0)
+{ /* (%tkGenerateSchemeEvent mask TkWindow) */
+ PRIMITIVE_HEADER (2);
+ if (arg_integer(1) == 0)
+ Tk_DeleteEventHandler((Tk_Window) arg_integer(2),
+ arg_integer(1),
+ OurEventHandler,
+ (ClientData) 0);
+ else Tk_CreateEventHandler((Tk_Window) arg_integer(2),
+ arg_integer(1),
+ OurEventHandler,
+ (ClientData) 0);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkInit", Prim_tk_init, 2, 2, 0)
+{ /* (%tkInit display name) */
+ extern long /*Tk_Window*/ InitTkApplication (long /*Display*/ *display,
+ char *Name);
+ PRIMITIVE_HEADER (2);
+ PRIMITIVE_RETURN((long_to_integer
+ ((long) InitTkApplication
+ ((long /*Display*/ *) arg_integer(1),
+ STRING_ARG(2)))));
+}
+
+typedef int (*cmdProc) (ClientData clientData, Tcl_Interp *interp,
+ int argc, char **argv);
+
+#define NTKCommands 14
+cmdProc TkCommandTable[] =
+{ Tk_AfterCmd, Tk_BindCmd, Tk_DestroyCmd, Tk_FocusCmd, Tk_GrabCmd,
+ Tk_OptionCmd, Tk_PackCmd, Tk_PlaceCmd, Tk_SelectionCmd,
+ Tk_TkCmd, Tk_TkwaitCmd, Tk_UpdateCmd, Tk_WinfoCmd, Tk_WmCmd
+};
+
+DEFINE_PRIMITIVE ("%tkInvokeCommand", Prim_tk_invoke, 2, LEXPR, 0)
+{ /* (%tkInvokeCommand commandnumber tkmainwindow . argstrings) */
+#include "tkInt.h"
+ long WhichCommand, NArgsToPass, i, Result;
+ char **Argv;
+ SCHEME_OBJECT SchemeResult;
+ Tcl_Interp *tclInterp;
+
+ PRIMITIVE_HEADER(LEXPR);
+ WhichCommand = arg_integer(1);
+ tclInterp = (((TkWindow *) arg_integer(2))->mainPtr)->interp;
+ if (WhichCommand > NTKCommands) error_bad_range_arg(1);
+ NArgsToPass = LEXPR_N_ARGUMENTS() - 1;
+ Argv = (char **) malloc((sizeof (char *)) * NArgsToPass);
+ Argv[0] = "<InvokedFromScheme>";
+ for (i=1; i < NArgsToPass; i++) Argv[i] = STRING_ARG(i+2);
+ Result = (TkCommandTable[WhichCommand])((ClientData) arg_integer(2),
+ tclInterp,
+ NArgsToPass,
+ Argv);
+ free(Argv);
+ if (Result != TCL_OK)
+ { fprintf(stderr, "tkInvokeCommand error: %s\n", tclInterp->result);
+ error_external_return();
+ }
+
+ SchemeResult = (char_pointer_to_string
+ ((unsigned char *) tclInterp->result));
+ Tcl_ResetResult(tclInterp);
+ PRIMITIVE_RETURN(SchemeResult);
+}
+
+DEFINE_PRIMITIVE ("%tkKillApplication", Prim_tk_kill_app, 1, 1, 0)
+{ /* (%tkKillApplication TKMainWindow) */
+ Tk_Window TKWin;
+ Tcl_Interp *Interp;
+
+ PRIMITIVE_HEADER (1);
+ TKWin = (Tk_Window) arg_integer(1);
+ Interp = (((TkWindow *) TKWin)->mainPtr)->interp;
+ Tk_DestroyWindow(TKWin);
+ Tcl_DeleteInterp(Interp);
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+void Our_Geometry_Manager(ClientData clientData, Tk_Window tkwin)
+{ extern void AddSchemeCallBack(int argc, char **argv, long *countv);
+ char *argv[1], CallBackNumber[50];
+ long counts[1];
+
+ counts[0] = sprintf(CallBackNumber, "%d", (long) clientData);
+ argv[0] = CallBackNumber;
+ AddSchemeCallBack(1, argv, counts);
+}
+
+DEFINE_PRIMITIVE ("%tkManageGeometry", Prim_tk_manage_geom, 2, 2, 0)
+{ /* (%tkManageGeometry tkwin object-hash) */
+ PRIMITIVE_HEADER (2);
+ if (ARG_REF(2) == SHARP_F)
+ Tk_ManageGeometry((Tk_Window) arg_integer(1), NULL, 0);
+ else Tk_ManageGeometry((Tk_Window) arg_integer(1),
+ Our_Geometry_Manager,
+ (ClientData) arg_integer(2));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkMapWidget", Prim_tk_map_widget, 6, 6, 0)
+{ extern char * tk_map_widget (long /*Button*/ *button,
+ long /*Tk_Window*/ tkMainWindow,
+ char *name,
+ long /*Window*/ xwindow,
+ int x, int y);
+ PRIMITIVE_HEADER(6);
+ PRIMITIVE_RETURN(char_pointer_to_string
+ ((unsigned char *)
+ tk_map_widget((long /*Button*/ *) arg_integer(1),
+ (long /*Tk_Window*/) arg_integer(2),
+ STRING_ARG(3),
+ (long /*Window*/) arg_integer(4),
+ arg_integer(5),
+ arg_integer(6))));
+
+}
+
+DEFINE_PRIMITIVE ("%tkMapWindow", Prim_tk_map_window, 1, 1, 0)
+{ /* (%tkMapWindow TkWindow) returns X Window ID */
+ Tk_Window tkwin;
+
+ PRIMITIVE_HEADER(1);
+ tkwin = (Tk_Window) arg_integer(1);
+ Tk_MapWindow(tkwin);
+ PRIMITIVE_RETURN(long_to_integer((long) Tk_WindowId(tkwin)));
+}
+
+DEFINE_PRIMITIVE ("%tkMoveWindow", Prim_tk_move, 3, 3, 0)
+{ /* (%tkMoveWindow tkwin x y) */
+ PRIMITIVE_HEADER (3);
+ Tk_MoveWindow((Tk_Window) arg_integer(1),
+ (int) arg_integer(2),
+ (int) arg_integer(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkMoveResizeWindow", Prim_tk_move_resize, 5, 5, 0)
+{ /* (%tkMoveResizeWindow tkwin x y width height) */
+ PRIMITIVE_HEADER (5);
+ Tk_MoveResizeWindow((Tk_Window) arg_integer(1),
+ (int) arg_integer(2), (int) arg_integer(3),
+ (unsigned int) arg_integer(4),
+ (unsigned int) arg_integer(5));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkNextWakeup", Prim_tk_next_wakeup, 0, 0, 0)
+{ /* (%tkNextWakeup) */
+ /* If the call back list isn't empty, wake up right away. */
+ extern long tk_GetIntervalToNextEvent();
+ long Result =
+ (NChars_In_TK_Callbacks != 0) ? 0 : tk_GetIntervalToNextEvent();
+
+ if (Result == -1)
+ PRIMITIVE_RETURN(SHARP_F);
+ else PRIMITIVE_RETURN(long_to_integer(Result));
+}
+
+DEFINE_PRIMITIVE ("%tkResizeWindow", Prim_tk_resize, 3, 3, 0)
+{ /* (%tkResizeWindow tkwin width height) */
+ PRIMITIVE_HEADER (3);
+ Tk_ResizeWindow((Tk_Window) arg_integer(1),
+ (int) arg_integer(2),
+ (int) arg_integer(3));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkUnmapWindow", Prim_tk_unmap_window, 1, 1, 0)
+{ /* (%tkUnmapWindow tk-win) */
+ PRIMITIVE_HEADER (1);
+ Tk_UnmapWindow((Tk_Window) arg_integer(1));
+ PRIMITIVE_RETURN (UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkWinReqHeight", Prim_tk_win_req_height, 1, 1, 0)
+{ /* (%tkwinReqHeight tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_ReqHeight (arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinReqWidth", Prim_tk_win_req_width, 1, 1, 0)
+{ /* (%tkwinReqWidth tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_ReqWidth (arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWidget.tkwin", Prim_tk_widget_get_tkwin, 1, 1, 0)
+{ extern long /*Tk_Window*/ tk_tkwin_widget (long /*button*/ *button);
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN(long_to_integer
+ ((long) tk_tkwin_widget
+ ((long /*Button*/ *) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinDisplay", Prim_tk_win_display, 1, 1, 0)
+{ /* (%tkwinDisplay tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_Display ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinIsMapped?", Prim_tk_win_is_mapped, 1, 1, 0)
+{ /* (%tkwinismapped? tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT
+ (Tk_IsMapped ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinHeight", Prim_tk_win_height, 1, 1, 0)
+{ /* (%tkwinHeight tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_Height ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinWidth", Prim_tk_win_width, 1, 1, 0)
+{ /* (%tkwinWidth tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_Width ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinWindow", Prim_tk_win_window, 1, 1, 0)
+{ /* (%tkwinWindow tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_WindowId ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinX", Prim_tk_win_x, 1, 1, 0)
+{ /* (%tkwinx tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_X ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinY", Prim_tk_win_y, 1, 1, 0)
+{ /* (%tkwiny tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (long_to_integer
+ ((long) Tk_Y ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinName", Prim_tk_win_name, 1, 1, 0)
+{ /* (%tkwinname tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (char_pointer_to_string
+ ((unsigned char *) Tk_Name ((Tk_Window) arg_integer(1))));
+}
+
+DEFINE_PRIMITIVE ("%tkWinPathName", Prim_tk_win_pathname, 1, 1, 0)
+{ /* (%tkwinpathname tk-win) */
+ PRIMITIVE_HEADER(1);
+ PRIMITIVE_RETURN (char_pointer_to_string
+ ((unsigned char *) Tk_PathName ((Tk_Window) arg_integer(1))));
+}
+
--- /dev/null
+/* -*- C -*-
+/* tk-c.c - Support routines for Tk Widgets called from Scheme */
+/* $Id: tk-c.c,v 1.1 1995/08/02 21:21:00 adams Exp $ */
+
+/**********************************************************************
+ This file contains the C code shared between MIT CScheme and DEC
+ Scheme-To-C for interfacing to general TK things. There are similar
+ files for particular widgets, named things like "button-c.c". The
+ Scheme implementation specific interface files for this are tk-sc.sc,
+ tk-c-mit.c, and tk-mit.scm.
+**********************************************************************/
+
+#include "tk.h"
+#include <tcl/tclInt.h>
+#include <tclHash.h>
+
+/* structure for passing callbacks to the TK Shell */
+
+typedef struct {
+ char *name; /* Name of command */
+ Tcl_CmdProc *proc; /* Pointer to procedure */
+ ClientData data; /* Client data */
+} TKCallbacks, *TKCallbackPtr;
+
+/* shell procedure declaration */
+
+static void TKShell
+(
+ Tk_Window, /* Application main window */
+ char *, /* Name of shell window */
+ char *, /* Class name */
+ TKCallbackPtr /* Array of callbacks */
+);
+\f
+/* This procedure is registered with TCL under the name
+ "SchemeCallBack". TK widgets are given command lines of the form
+ "-command SchemeCallBack n" where "n" is the object ID of the
+ Scheme call back procedure. Thus, when TK actually calls this
+ procedure, it will pass as argv[1] the Scheme object ID (as a
+ string), followed by any TK-supplied arguments.
+
+ This procedure side-effects the C global variable TK_CallBack_List
+ (in file tk-c-mit.c). The value of this variable is tested in
+ %tkOwnsEvent? to generate callbacks int Scheme.
+
+ Tk_SchemeCallBack COPIES all of the arguments passed in, since I
+ haven't the vaguest idea how TK handles garbage collection.
+*/
+
+static int NDigits(unsigned long N)
+{ register Ans = 1;
+ while (N > 9)
+ { Ans += 1;
+ N = N/10;
+ }
+ return Ans;
+}
+
+#define TK_CALLBACK_CHUNK_SIZE 256
+static long Size_Of_TK_Callbacks = 0;
+
+void Allocate_TK_Callback(long NChars)
+{ /* Size_Of_TK_Callbacks will always be a multiple of */
+ /* TK_CALLBACK_CHUNK_SIZE. It is the total number of bytes */
+ /* available, and includes space for the terminating null. */
+ /* NChars_In_TK_Callbacks, however, is the number of useful bytes */
+ /* and does NOT include the terminating null byte. NChars is the */
+ /* number of bytes to be added to the current contents. */
+
+ extern char *TK_CallBack_List;
+ extern long NChars_In_TK_Callbacks;
+
+ Size_Of_TK_Callbacks =
+ (((NChars_In_TK_Callbacks+NChars)/TK_CALLBACK_CHUNK_SIZE)+1) *
+ TK_CALLBACK_CHUNK_SIZE;
+ if (NChars_In_TK_Callbacks == 0)
+ TK_CallBack_List = malloc(Size_Of_TK_Callbacks);
+ else
+ TK_CallBack_List =
+ (char *) realloc(TK_CallBack_List, Size_Of_TK_Callbacks);
+ return;
+}
+
+extern void AddSchemeCallBack(int argc, char **argv, long *countv)
+{ /* argc is the number of arguments to be transmitted. They start at */
+ /* argv[0]. This isn't the usual C convention, but it is more */
+ /* sensible. */
+ extern char *TK_CallBack_List;
+ extern long NChars_In_TK_Callbacks;
+ register long ThisEntryLength = 0;
+ register long i;
+ register char **This;
+ register long *Count;
+ char *NextEntry;
+ long NChars_To_Add;
+
+ /* First, calculate how much space we need */
+ for (i=0, Count=countv; i < argc; i++)
+ { register long N = *Count++;
+ ThisEntryLength += N + 2 + NDigits(N); /* 2 for < > */
+ }
+ NChars_To_Add =
+ ThisEntryLength + 2 + NDigits(ThisEntryLength); /* 2 more for < > */
+ if ((NChars_In_TK_Callbacks+NChars_To_Add+1) > Size_Of_TK_Callbacks)
+ Allocate_TK_Callback(NChars_To_Add);
+ NextEntry = &(TK_CallBack_List[NChars_In_TK_Callbacks]);
+ NChars_In_TK_Callbacks += NChars_To_Add;
+ /* And start putting in the information */
+ NextEntry += sprintf(NextEntry, "<%d>", ThisEntryLength);
+ for (i=0, This=argv, Count=countv; i < argc; i++, This++, Count++)
+ { NextEntry += sprintf(NextEntry, "<%d>", *Count);
+ memcpy(NextEntry, *This, *Count);
+ NextEntry += *Count;
+ }
+ if (NextEntry != TK_CallBack_List+(NChars_In_TK_Callbacks))
+ fprintf(stderr, "Tk_SchemeCallback %d %s\n",
+ NChars_In_TK_Callbacks, TK_CallBack_List);
+ *NextEntry = '\0'; /* Null terminate the string */
+ return;
+}
+
+int
+Tk_TkError(ClientData clientData,
+ Tcl_Interp *interp,
+ int argc,
+ char **argv)
+{ if (argc==2)
+ { fprintf(stderr, "TCL Error: %s\n", argv[1]);
+ fputs(Tcl_GetVar(interp, "errorInfo", 0), stderr);
+ }
+ else
+ fprintf(stderr, "TCL Error with argc=%d!\n", argc);
+ error_external_return();
+}
+
+int
+Tk_SchemeCallBack(clientData, interp, argc, argv)
+ ClientData clientData; /* Main window associated with
+ * interpreter. NOT USED. */
+ Tcl_Interp *interp; /* Current interpreter. NOT USED. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{ /* As usual, argv[0] is *NOT* used for anything! */
+ long *Counts = (long *) malloc(argc*sizeof(long));
+ register long i, *Count;
+ register char **This;
+
+ if (Counts == NULL)
+ { fprintf(stderr, "Out of space in Tk_SchemeCallBack\n");
+ exit (1);
+ }
+ for (i=1, This=argv+1, Count=Counts+1; i < argc; i++)
+ *Count++ = strlen(*This++);
+ AddSchemeCallBack(argc-1, argv+1, Counts+1);
+ /* Deliberately not changing interp->result, 'cause the TCL manual */
+ /* says we don't have to if we don't want to. */
+ return TCL_OK;
+}
+\f
+/*
+ * External Interface Routines
+ */
+
+int Scheme_TK_X_error_handler(ClientData D, XErrorEvent *E)
+{ extern void Scheme_x_error_handler(Display *Disp, XErrorEvent *Event);
+
+ fprintf(stderr, "Our Handler for %d 0x%x\n", D, E);
+ Scheme_x_error_handler((Display *) D, E);
+ return 0;
+}
+
+extern Tk_Window
+InitTkApplication(Display *Disp, char *Name)
+{ Tk_Window Result;
+ extern Tk_Window
+ Tk_CreateMainWindow_from_display(Tcl_Interp *interp,
+ Display *display,
+ char *baseName);
+ Tcl_Interp *tclInterp = Tcl_CreateInterp();
+/*
+ static char initTCLCmd[] =
+ "source /scheme/users/jmiller/uitk/tk/tcl/library/init.tcl;";
+ static char initTKCmd[] =
+ "source /scheme/users/jmiller/uitk/tk/library/tk.tcl";
+ static char initEmacsCmd[] =
+ "source /scheme/users/jmiller/uitk/tk/library/emacs.tcl";
+*/
+
+ static char initTCLCmd[] = "source [info library]/init.tcl;";
+ static char initTKCmd[] = "source $tk_library/tk.tcl";
+ static char initEmacsCmd[] = "source $tk_library/emacs.tcl";
+
+ Result = Tk_CreateMainWindow_from_display(tclInterp, Disp, Name);
+ if (Result == (Tk_Window) NULL)
+ fprintf(stderr,
+ "Error from Tk_CreateMainWindow: %s\n"
+ , tclInterp->result);
+ if (Tcl_Eval(tclInterp, initTCLCmd, 0, (char **) NULL) != TCL_OK)
+ { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
+ if (msg == NULL) msg = tclInterp->result;
+ fprintf(stderr, "%s\n", msg);
+ return (Tk_Window) NULL;
+ }
+ /* This must be read for EVERY new main window, since it */
+ /* establishes bindings and so forth that use "." implicitly */
+ if (Tcl_Eval(tclInterp, initTKCmd, 0, (char **) NULL) != TCL_OK)
+ { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
+ if (msg == NULL) msg = tclInterp->result;
+ fprintf(stderr, "%s\n", msg);
+ return (Tk_Window) NULL;
+ }
+ if (Tcl_Eval(tclInterp, initEmacsCmd, 0, (char **) NULL) != TCL_OK)
+ { char * msg = Tcl_GetVar(tclInterp, "errorInfo", TCL_GLOBAL_ONLY);
+ if (msg == NULL) msg = tclInterp->result;
+ fprintf(stderr, "%s\n", msg);
+ return (Tk_Window) NULL;
+ }
+ Tcl_CreateCommand(tclInterp,
+ "SchemeCallBack",
+ Tk_SchemeCallBack,
+ (ClientData) 0 /* not used */,
+ (void (*)()) NULL); /* Delete Procedure */
+ Tcl_CreateCommand(tclInterp,
+ "tkerror",
+ Tk_TkError,
+ (ClientData) 0 /* not used */,
+ (void (*) ()) NULL); /* Delete Procedure */
+ Tk_CreateErrorHandler(Disp, -1, -1, -1,
+ Scheme_TK_X_error_handler, (ClientData) Disp);
+ return Result;
+}
+\f
+/*
+ * Process all pending Tk events, then return
+ */
+
+void
+DoTkEvents ()
+{ while (Tk_DoOneEvent (TK_DONT_WAIT|TK_TIMER_EVENTS|TK_IDLE_EVENTS) > 0)
+ { /* fprintf(stderr, "Did TK Event"); */ }
+}
+
+/* Access the Client Data for a command. For widget commands,
+ * this is a pointer to the widget data structure.
+ */
+
+ClientData
+GetCmdClientData (Tcl_Interp *interp, char *cmd)
+
+{
+ Tcl_HashEntry *hPtr;
+
+ hPtr = Tcl_FindHashEntry (&((Interp *)interp)->commandTable, cmd);
+ return ((Command *) Tcl_GetHashValue (hPtr))->clientData;
+}
+
+/* Window structure routines.
+ * These are Macros, so need a functional interface for Scheme
+ */
+
+Display *
+tk_display (Tk_Window tkwin)
+
+{
+ return Tk_Display (tkwin);
+}
+
+Window
+tk_windowid (Tk_Window tkwin)
+
+{
+ return Tk_WindowId (tkwin);
+}
+
+int
+tk_width (Tk_Window tkwin)
+
+{
+ return Tk_Width (tkwin);
+}
+
+int
+tk_height (Tk_Window tkwin)
+
+{
+ return Tk_Height (tkwin);
+}
+
+void
+tk_set_width (Tk_Window tkwin, long W)
+{ Tk_Width(tkwin) = W;
+}
+
+void
+tk_set_height (Tk_Window tkwin, long H)
+{ Tk_Height(tkwin) = H;
+}
+
+/*****************************************************************/
+/* The following procedures OUGHT to be here, but they require */
+/* internal data structure from tkButton.c to work */
+/* */
+/* void */
+/* tk_map_widget (Button *button, Tk_Window tkMainWindow, */
+/* char *name, Window xwindow, int x, int y) */
+/* Tk_Window */
+/* tk_tkwin_widget (Button *button) */
+/*****************************************************************/
--- /dev/null
+#
+# This is a simplified Makefile for use in Tk distributions. Before using
+# it to compile Tk, you may wish to reset some of the following variables:
+#
+# TCL_DIR - Name of directory holding tcl.h and tcl.a.
+# XLIB - If your Xlib library isn't in the standard place,
+# you can replace "-lX11" with the name of the file
+# containing your library archive.
+# INSTALL_DIR - Full path name of top-level directory where
+# information is installed.
+# TK_LIBRARY - Full path name of directory to contain scripts
+# and other library files used by Tk. This value
+# is available to applications as the variable
+# $tk_library. If the environment variable
+# TK_LIBRARY is defined by a user, it will override
+# the value specified in this Makefile.
+# LIB_DIR - Directory in which to install the archive libtcl.a
+# BIN_DIR - Directory in which to install executables such as wish.
+# INCLUDE_DIR - Directory in which to install header files.
+# MANx_DIR - Directories in which to install manual entries.
+# RANLIB - If you're using a System-V-based UNIX that doesn't
+# have ranlib, change this definition to "echo" or
+# something else harmless.
+# SHELL - Some versions of make (e.g. SGI's) use this variable
+# to determine which shell to use for executing
+# commands.
+#
+
+TCL_DIR = tcl
+XLIB = -lX11
+INSTALL_DIR = /usr/local
+LIB_DIR = $(INSTALL_DIR)/lib
+TK_LIBRARY = $(INSTALL_DIR)/lib/tk
+BIN_DIR = $(INSTALL_DIR)/bin
+INCLUDE_DIR = $(INSTALL_DIR)/include
+MAN1_DIR = $(INSTALL_DIR)/man/man1
+MAN3_DIR = $(INSTALL_DIR)/man/man3
+MANN_DIR = $(INSTALL_DIR)/man/mann
+RANLIB = ranlib
+SHELL = /bin/sh
+
+# ANSI-C procedure prototypes are turned on by default if supported
+# by the compiler. To turn them off, uncomment the following line:
+
+# NP = -DNO_PROTOTYPE
+
+# To compile under OpenWindows, uncomment the following line:
+
+# OW = -I/usr/openwin/include -L/usr/openwin/lib
+CC = cc
+CFLAGS = -I. -I$(TCL_DIR) -O -DTK_LIBRARY=\"${TK_LIBRARY}\" +z \
+ ${NP} ${OW}
+
+LIBS = libtk.a $(TCL_DIR)/libtcl.a
+
+WIDGOBJS = tkButton.o tkEntry.o tkFrame.o tkListbox.o \
+ tkMenu.o tkMenubutton.o tkMessage.o tkScale.o \
+ tkScrollbar.o
+
+CANVOBJS = tkCanvas.o tkCanvArc.o tkCanvBmap.o tkCanvLine.o \
+ tkCanvPoly.o tkCanvPs.o tkCanvText.o tkCanvWind.o \
+ tkRectOval.o tkTrig.o
+
+TEXTOBJS = tkText.o tkTextBTree.o tkTextDisp.o tkTextIndex.o tkTextTag.o
+
+OBJS = tk3d.o tkArgv.o tkAtom.o tkBind.o tkBitmap.o tkCmds.o \
+ tkColor.o tkConfig.o tkCursor.o tkError.o tkEvent.o \
+ tkFocus.o tkFont.o tkGet.o tkGC.o tkGeometry.o tkGrab.o \
+ tkOption.o tkPack.o tkPlace.o tkPreserve.o tkSelect.o \
+ tkSend.o tkWindow.o tkWm.o $(WIDGOBJS) \
+ $(CANVOBJS) $(TEXTOBJS)
+
+WIDGSRCS = tkButton.c tkEntry.c tkFrame.c tkListbox.c \
+ tkMenu.c tkMenubutton.c tkMessage.c tkScale.c \
+ tkScrollbar.c tkText.c tkTextBTree.c tkTextDisp.c \
+ tkTextIndex.c
+
+CANVSRCS = tkCanvas.c tkCanvArc.c tkCanvBmap.c tkCanvLine.c \
+ tkCanvPoly.c tkCanvPs.c tkCanvText.c tkCanvWind.c \
+ tkRectOval.c tkTrig.c
+
+TEXTSRCS = tkText.c tkTextBTree.c tkTextDisp.c tkTextIndex.c tkTextTag.c
+
+SRCS = tk3d.c tkArgv.c tkAtom.c tkBind.c tkBitmap.c tkCmds.c \
+ tkColor.c tkConfig.c tkCursor.c tkError.c tkEvent.c \
+ tkFocus.c tkFont.c tkGet.c tkGC.c tkGeometry.c tkGrab.c \
+ tkOption.c tkPack.c tkPlace.c tkPreserve.c tkSelect.c \
+ tkSend.c tkWindow.c tkWm.c $(WIDGSRCS) \
+ $(CANVSRCS) $(TEXTSRCS)
+
+all: libtk.a wish
+
+wish: main.o $(LIBS)
+ $(CC) $(CFLAGS) main.o $(LIBS) $(XLIB) -lm -o wish
+
+libtk.a: $(OBJS)
+ rm -f libtk.a
+ ar cr libtk.a $(OBJS)
+ $(RANLIB) libtk.a
+
+$(TCL_DIR)/libtcl.a:
+ cd $(TCL_DIR); $(MAKE) $(MFLAGS) TCL_LIBRARY=$(TCL_LIBRARY) libtcl.a
+
+install: libtk.a wish $(TCL_DIR)/libtcl.a
+ -if [ ! -d $(LIB_DIR) ] ; then mkdir -p $(LIB_DIR); fi
+ -if [ ! -d $(INCLUDE_DIR) ] ; then mkdir -p $(INCLUDE_DIR); fi
+ -if [ ! -d $(TK_LIBRARY) ] ; then mkdir -p $(TK_LIBRARY); fi
+ -if [ ! -d $(BIN_DIR) ] ; then mkdir -p $(BIN_DIR); fi
+ -if [ ! -d $(MAN1_DIR) ] ; then mkdir -p $(MAN1_DIR); fi
+ -if [ ! -d $(MAN3_DIR) ] ; then mkdir -p $(MAN3_DIR); fi
+ -if [ ! -d $(MANN_DIR) ] ; then mkdir -p $(MANN_DIR); fi
+ rm -rf $(TK_LIBRARY)/*
+ cp -r library/*.tcl library/tclIndex library/demos $(TK_LIBRARY)
+ cp library/prolog.ps $(TK_LIBRARY)
+ rm -f $(LIB_DIR)/libtk.a
+ cp libtk.a $(LIB_DIR)
+ $(RANLIB) $(LIB_DIR)/libtk.a
+ rm -f $(BIN_DIR)/wish
+ cp wish $(BIN_DIR)
+ rm -f $(INCLUDE_DIR)/tk.h
+ cp tk.h $(INCLUDE_DIR)
+ cd doc; for i in *.1; \
+ do \
+ rm -f $(MAN1_DIR)/$$i; \
+ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
+ $$i > $(MAN1_DIR)/$$i; \
+ done; cd ..
+ cd doc; for i in *.3; \
+ do \
+ rm -f $(MAN3_DIR)/$$i; \
+ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
+ $$i > $(MAN3_DIR)/$$i; \
+ done; cd ..
+ cd doc; for i in *.n; \
+ do \
+ rm -f $(MANN_DIR)/$$i; \
+ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
+ $$i > $(MANN_DIR)/$$i; \
+ done; cd ..
+ cd $(TCL_DIR); $(MAKE) $(MFLAGS) INSTALL_DIR=$(INSTALL_DIR) install
+
+clean:
+ rm -f $(OBJS) main.o libtk.a wish
+ cd $(TCL_DIR); $(MAKE) $(MFLAGS) clean
+
+$(OBJS): tk.h tkInt.h tkConfig.h
+$(WIDGOBJS): default.h
+$(CANVOBJS): default.h tkCanvas.h
+$(TEXTOBJS): default.h tkText.h
+main.o: tk.h tkInt.h
--- /dev/null
+#-----------------------------------------------------------------------------
+# Emacs-like bindings for Tk text widgets
+#
+# Andrew C. Payne
+# payne@crl.dec.com
+#
+#-----------------------------------------------------------------------------
+
+set tk_priv(cutbuffer) ""
+
+#-----------------------------------------------------------------------------
+# Keyboard bindings, model after emacs
+#-----------------------------------------------------------------------------
+
+proc emacs-text-move {w where} {
+ global tk_priv
+
+ $w mark set insert $where
+ $w yview -pickplace insert
+ if {$tk_priv(selectMode) == "select"} {
+ $w tag remove sel 0.0 end
+ $w tag add sel anchor insert
+ }
+}
+
+proc emacs-twiddle {w} {
+ set c [$w get insert-1c]
+ $w delete insert-1c
+ $w insert insert-1c $c
+}
+
+proc emacs-move-page {w dir} {
+ global tk_priv
+
+ set height [lindex [$w configure -height] 4]
+ $w mark set insert "insert $dir $height lines"
+ $w yview -pickplace insert
+ if {$tk_priv(selectMode) == "select"} {
+ $w tag remove sel 0.0 end
+ $w tag add sel anchor insert
+ }
+}
+
+#
+# If there is a current selection, delete it. Else, backspace one character
+#
+proc emacs-backspace {w} {
+ if {[catch {$w delete sel.first sel.last}]} {
+ tk_textBackspace $w
+ }
+ $w yview -pickplace insert
+}
+
+bind Text <Any-KeyPress> {
+ if {%k == 140} {
+ set tk_priv(selectMode) {}
+ catch {set tk_priv(cutbuffer) [%W get sel.first sel.last]}
+ catch {%W delete sel.first sel.last}
+ }
+ if {"%A" != ""} {
+ %W insert insert %A
+ }
+ %W yview -pickplace insert
+}
+
+# By default, all the control and meta keys are disabled
+bind Text <Control-Key> {
+ %W yview -pickplace insert
+}
+bind Text <Meta-Key> {
+ %W yview -pickplace insert
+}
+bind Text <Control-Meta-Key> {
+ %W yview -pickplace insert
+}
+bind Text <Escape> {
+ %W yview -pickplace insert
+}
+
+set tk_last_deleted ""
+bind Text <Control-k> {
+ global tk_last_deleted
+ set tk_last_deleted [%W get insert {insert lineend}]
+ %W delete insert {insert lineend}
+}
+bind Text <Control-y> {
+ global tk_last_deleted
+ %W insert insert $tk_last_deleted
+ %W yview -pickplace insert
+}
+
+bind Text <Up> {emacs-text-move %W insert-1l}
+bind Text <Down> {emacs-text-move %W insert+1l}
+bind Text <Left> {emacs-text-move %W insert-1c}
+bind Text <Right> {emacs-text-move %W insert+1c}
+
+bind Text <Control-a> {emacs-text-move %W {insert linestart}}
+bind Text <Control-b> {emacs-text-move %W insert-1c}
+bind Text <Control-d> {%W delete insert insert+1c}
+bind Text <Control-e> {emacs-text-move %W {insert lineend}}
+bind Text <Control-f> {emacs-text-move %W insert+1c}
+bind Text <Control-h> {emacs-backspace %W}
+bind Text <Control-n> {emacs-text-move %W insert+1l}
+bind Text <Control-o> {%W insert insert "\n"; emacs-text-move %W insert-1c}
+bind Text <Control-p> {emacs-text-move %W insert-1l}
+bind Text <Control-t> {emacs-twiddle %W}
+bind Text <Control-v> {emacs-move-page %W +}
+
+bind Text <Prior> {emacs-move-page %W -}
+bind Text <Next> {emacs-move-page %W +}
+bind Text <Delete> {emacs-backspace %W}
+
+bind Text <Insert> {
+ %W insert insert $tk_priv(cutbuffer)
+ %W yview -pickplace insert
+}
+
+bind Text <Select> {
+ %W tag remove sel 0.0 end
+ if {$tk_priv(selectMode) == "select"} {
+ set tk_priv(selectMode) {}
+ } {
+ %W mark set anchor insert
+ set tk_priv(selectMode) select
+ }
+}
+
+
+#-----------------------------------------------------------------------------
+# Mouse bindings
+#-----------------------------------------------------------------------------
+
+bind Text <1> {
+ set tk_priv(selectMode) char
+ %W mark set insert @%x,%y
+ %W mark set anchor insert
+ if {[lindex [%W config -state] 4] == "normal"} {focus %W}
+ %W tag remove sel 0.0 end
+}
+
+#
+# Button 2 is used to paste the current X selection, just like many X
+# applications. This is the default Motif binding.
+#
+bind Text <2> {
+ catch {
+ %W insert insert [selection get]
+ %W yview -pickplace insert
+ }
+}
+
+bind Text <B2-Motion> {}
+
+#
+# Use button 3 as a drag for window text (just like the old Tk button 2
+# binding.
+#
+bind Text <3> {%W scan mark %y}
+bind Text <B3-Motion> {%W scan dragto %y}
+
+
+#-----------------------------------------------------------------------------
+# Emacs-like bindings for Tk entry widgets
+#-----------------------------------------------------------------------------
+
+# By default, all the control and meta keys are disabled
+bind Entry <Control-Key> {
+ tk_entrySeeCaret %W
+}
+bind Entry <Meta-Key> {
+ tk_entrySeeCaret %W
+}
+bind Entry <Control-Meta-Key> {
+ tk_entrySeeCaret %W
+}
+bind Entry <Escape> {
+ tk_entrySeeCaret %W
+}
+
+# need to repeat these because they've just been overwritten
+bind Entry <Control-h> {tk_entryBackspace %W; tk_entrySeeCaret %W}
+bind Entry <Control-u> {%W delete 0 end}
+bind Entry <Control-v> {%W insert insert [selection get]; tk_entrySeeCaret %W}
+bind Entry <Control-w> {tk_entryBackword %W; tk_entrySeeCaret %W}
+
+# Some Emacs bindings
+bind Entry <Control-a> {%W icursor 0; tk_entrySeeCaret %W}
+bind Entry <Control-e> {%W icursor end; tk_entrySeeCaret %W}
+bind Entry <Control-k> {%W delete insert end}
+bind Entry <Control-d> {%W delete insert}
+
+set entry_cursor_index ""
+bind Entry <Control-f> {
+ global entry_cursor_index
+ set entry_cursor_index [expr {[%W index insert] + 1}]
+ %W icursor $entry_cursor_index
+}
+bind Entry <Control-b> {
+ global entry_cursor_index
+ set entry_cursor_index [expr {[%W index insert] - 1}]
+ %W icursor $entry_cursor_index
+}
+
--- /dev/null
+#
+# This Makefile is for use when distributing Tcl to the outside world.
+# It is normally set up by running the "config" script. Before modifying
+# this file by hand, you should read through the "config" script to see
+# what it does.
+#
+# Some changes you may wish to make here:
+#
+# 1. To compile for non-UNIX systems (so that only the non-UNIX-specific
+# commands are available), change the OBJS line below so it doesn't
+# include ${UNIX_OBJS}. Also, add the switch "-DTCL_GENERIC_ONLY" to
+# CFLAGS. Lastly, you'll have to provide your own replacement for the
+# "panic" procedure (see panic.c for what the current one does).
+
+# 2. ANSI-C procedure prototypes are turned on by default if supported
+# by the compiler. To turn them off, uncomment the following line:
+
+# NP = -DNO_PROTOTYPE
+
+# 3. If you want to put Tcl-related information in non-standard places,
+# change the following definitions below to reflect where you want
+# things (all must be specified as full rooted path names):
+#
+# INSTALL_DIR Top-level directory in which to install; contains
+# each of the other directories below.
+# TCL_LIBRARY Directory in which to install the library of Tcl
+# scripts. Note: if the TCL_LIBRARY environment
+# variable is specified at run-time then Tcl looks
+# there rather than in the place specified here.
+# LIB_DIR Directory in which to install the archive libtcl.a
+# INCLUDE_DIR Directory in which to install include files.
+# MAN3_DIR Directory in which to install manual entries for
+# library procedures such as Tcl_Eval.
+# MANN_DIR Directory in which to install manual entries for
+# miscellaneous things such as the Tcl overview
+# manual entry.
+# RANLIB If you're using a System-V-based UNIX that doesn't
+# have ranlib, change this definition to "echo" or
+# something else harmless.
+# SHELL Some versions of make (e.g. SGI's) use this variable
+# to determine which shell to use for executing
+# commands.
+
+INSTALL_DIR = /usr/local
+TCL_LIBRARY = $(INSTALL_DIR)/lib/tcl
+LIB_DIR = $(INSTALL_DIR)/lib
+INCLUDE_DIR = $(INSTALL_DIR)/include
+MAN3_DIR = $(INSTALL_DIR)/man/man3
+MANN_DIR = $(INSTALL_DIR)/man/mann
+RANLIB = ranlib
+SHELL = /bin/sh
+
+CC = cc
+CFLAGS = -O -I. -DTCL_LIBRARY=\"${TCL_LIBRARY}\" ${NP} +z
+
+GENERIC_OBJS = regexp.o tclAssem.o tclBasic.o tclCkalloc.o \
+ tclCmdAH.o tclCmdIL.o tclCmdMZ.o tclExpr.o tclGet.o \
+ tclHash.o tclHistory.o tclParse.o tclProc.o tclUtil.o \
+ tclVar.o
+
+UNIX_OBJS = panic.o tclEnv.o tclGlob.o tclUnixAZ.o tclUnixStr.o \
+ tclUnixUtil.o
+
+COMPAT_OBJS =
+
+OBJS = ${GENERIC_OBJS} ${UNIX_OBJS} ${COMPAT_OBJS}
+
+all: libtcl.a
+
+libtcl.a: ${OBJS}
+ rm -f libtcl.a
+ ar cr libtcl.a ${OBJS}
+ $(RANLIB) libtcl.a
+
+install: libtcl.a
+ -if [ ! -d $(LIB_DIR) ] ; then mkdir -p $(LIB_DIR); fi
+ -if [ ! -d $(TCL_LIBRARY) ] ; then mkdir -p $(TCL_LIBRARY); fi
+ -if [ ! -d $(INCLUDE_DIR) ] ; then mkdir -p $(INCLUDE_DIR); fi
+ -if [ ! -d $(MAN3_DIR) ] ; then mkdir -p $(MAN3_DIR); fi
+ -if [ ! -d $(MANN_DIR) ] ; then mkdir -p $(MANN_DIR); fi
+ rm -rf $(TCL_LIBRARY)/*
+ for i in library/*.tcl library/tclIndex; \
+ do \
+ cp $$i $(TCL_LIBRARY); \
+ done
+ rm -f $(LIB_DIR)/libtcl.a
+ cp libtcl.a $(LIB_DIR)
+ $(RANLIB) $(LIB_DIR)/libtcl.a
+ rm -f $(INCLUDE_DIR)/tcl.h $(INCLUDE_DIR)/tclHash.h
+ cp tcl.h $(INCLUDE_DIR)
+ cp tclHash.h $(INCLUDE_DIR)
+ cd doc; for i in *.3; \
+ do \
+ rm -f $(MAN3_DIR)/$$i; \
+ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
+ $$i > $(MAN3_DIR)/$$i; \
+ done; cd ..
+ cd doc; for i in *.n; \
+ do \
+ rm -f $(MANN_DIR)/$$i; \
+ sed -e '/man\.macros/r man.macros' -e '/man\.macros/d' \
+ $$i > $(MANN_DIR)/$$i; \
+ done; cd ..
+
+tclTest: tclTest.o libtcl.a
+ ${CC} ${CFLAGS} tclTest.o libtcl.a -o tclTest
+
+test: tclTest
+ ( echo cd tests ; echo source all ) | ./tclTest
+
+configured:
+ @echo "The configuration script \"./config\" hasn't been run"
+ @echo "successfully yet. Please run it as described in the "
+ @echo "README file, then run make again."
+ exit 1
+
+clean:
+ rm -f ${OBJS} libtcl.a tclTest.o tclTest
+
+# The following target is used during configuration to compile
+# a test program to see if certain facilities are available on
+# the system.
+
+configtest:
+ ${CC} ${CFLAGS} test.c
+
+${OBJS}: tcl.h tclHash.h tclInt.h configured
+${UNIX_OBJS}: tclUnix.h
--- /dev/null
+/*
+ * tclUnix.h --
+ *
+ * This file reads in UNIX-related header files and sets up
+ * UNIX-related macros for Tcl's UNIX core. It should be the
+ * only file that contains #ifdefs to handle different flavors
+ * of UNIX. This file sets up the union of all UNIX-related
+ * things needed by any of the Tcl core files. This file
+ * depends on configuration #defines in tclConfig.h
+ *
+ * The material in this file was originally contributed by
+ * Karl Lehenbauer, Mark Diekhans and Peter da Silva.
+ *
+ * Copyright 1991 Regents of the University of California
+ * Permission to use, copy, modify, and distribute this
+ * software and its documentation for any purpose and without
+ * fee is hereby granted, provided that this copyright
+ * notice appears in all copies. The University of California
+ * makes no representations about the suitability of this
+ * software for any purpose. It is provided "as is" without
+ * express or implied warranty.
+ *
+ * $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/swat/c/tk3.2-custom/tcl/tclUnix.h,v 1.1 1995/08/02 21:24:59 adams Exp $ SPRITE (Berkeley)
+ */
+
+#ifndef _TCLUNIX
+#define _TCLUNIX
+
+/*
+ * The following #defines are used to distinguish between different
+ * UNIX systems. These #defines are normally set by the "config" script
+ * based on information it gets by looking in the include and library
+ * areas. The defaults below are for BSD-based systems like SunOS
+ * or Ultrix.
+ *
+ * TCL_GETTOD - 1 means there exists a library procedure
+ * "gettimeofday" (e.g. BSD systems). 0 means
+ * have to use "times" instead.
+ * TCL_GETWD - 1 means there exists a library procedure
+ * "getwd" (e.g. BSD systems). 0 means
+ * have to use "getcwd" instead.
+ * TCL_SYS_ERRLIST - 1 means that the array sys_errlist is
+ * defined as part of the C library.
+ * TCL_SYS_TIME_H - 1 means there exists an include file
+ * <sys/time.h> (e.g. BSD derivatives).
+ * TCL_SYS_WAIT_H - 1 means there exists an include file
+ * <sys/wait.h> that defines constants related
+ * to the results of "wait".
+ * TCL_UNION_WAIT - 1 means that the "wait" system call returns
+ * a structure of type "union wait" (e.g. BSD
+ * systems). 0 means "wait" returns an int
+ * (e.g. System V and POSIX).
+ * TCL_PID_T - 1 means that <sys/types> defines the type
+ * pid_t. 0 means that it doesn't.
+ * TCL_UID_T - 1 means that <sys/types> defines the type
+ * uid_t. 0 means that it doesn't.
+ */
+
+#define TCL_GETTOD 1
+#define TCL_GETWD 1
+#define TCL_SYS_ERRLIST 1
+#define TCL_SYS_TIME_H 1
+#define TCL_SYS_WAIT_H 1
+#define TCL_UNION_WAIT 0
+#define TCL_PID_T 1
+#define TCL_UID_T 1
+
+#include <errno.h>
+#include <fcntl.h>
+#include <limits.h>
+#include <pwd.h>
+#include <signal.h>
+#include <sys/param.h>
+#include <sys/types.h>
+#include <dirent.h>
+#include <sys/file.h>
+#include <sys/stat.h>
+#if TCL_SYS_TIME_H
+# include <sys/time.h>
+#else
+# include <time.h>
+#endif
+#if TCL_SYS_WAIT_H
+# include <sys/wait.h>
+#endif
+
+/*
+ * Not all systems declare the errno variable in errno.h. so this
+ * file does it explicitly. The list of system error messages also
+ * isn't generally declared in a header file anywhere.
+ */
+
+extern int errno;
+extern int sys_nerr;
+extern char *sys_errlist[];
+
+/*
+ * The type of the status returned by wait varies from UNIX system
+ * to UNIX system. The macro below defines it:
+ */
+
+#if TCL_UNION_WAIT
+# define WAIT_STATUS_TYPE union wait
+#else
+# define WAIT_STATUS_TYPE int
+#endif
+
+/*
+ * Supply definitions for macros to query wait status, if not already
+ * defined in header files above.
+ */
+
+#ifndef WIFEXITED
+# define WIFEXITED(stat) (((*((int *) &(stat))) & 0xff) == 0)
+#endif
+
+#ifndef WEXITSTATUS
+# define WEXITSTATUS(stat) (((*((int *) &(stat))) >> 8) & 0xff)
+#endif
+
+#ifndef WIFSIGNALED
+# define WIFSIGNALED(stat) (((*((int *) &(stat)))) && ((*((int *) &(stat))) == ((*((int *) &(stat))) & 0x00ff)))
+#endif
+
+#ifndef WTERMSIG
+# define WTERMSIG(stat) ((*((int *) &(stat))) & 0x7f)
+#endif
+
+#ifndef WIFSTOPPED
+# define WIFSTOPPED(stat) (((*((int *) &(stat))) & 0xff) == 0177)
+#endif
+
+#ifndef WSTOPSIG
+# define WSTOPSIG(stat) (((*((int *) &(stat))) >> 8) & 0xff)
+#endif
+
+/*
+ * Supply macros for seek offsets, if they're not already provided by
+ * an include file.
+ */
+
+#ifndef SEEK_SET
+# define SEEK_SET 0
+#endif
+
+#ifndef SEEK_CUR
+# define SEEK_CUR 1
+#endif
+
+#ifndef SEEK_END
+# define SEEK_END 2
+#endif
+
+/*
+ * The stuff below is needed by the "time" command. If this
+ * system has no gettimeofday call, then must use times and the
+ * CLK_TCK #define (from sys/param.h) to compute elapsed time.
+ * Unfortunately, some systems only have HZ and no CLK_TCK, and
+ * some might not even have HZ.
+ */
+
+#if ! TCL_GETTOD
+# include <sys/times.h>
+# include <sys/param.h>
+# ifndef CLK_TCK
+# ifdef HZ
+# define CLK_TCK HZ
+# else
+# define CLK_TCK 60
+# endif
+# endif
+#endif
+
+/*
+ * Define access mode constants if they aren't already defined.
+ */
+
+#ifndef F_OK
+# define F_OK 00
+#endif
+#ifndef X_OK
+# define X_OK 01
+#endif
+#ifndef W_OK
+# define W_OK 02
+#endif
+#ifndef R_OK
+# define R_OK 04
+#endif
+
+/*
+ * On systems without symbolic links (i.e. S_IFLNK isn't defined)
+ * define "lstat" to use "stat" instead.
+ */
+
+#ifndef S_IFLNK
+# define lstat stat
+#endif
+
+/*
+ * Define macros to query file type bits, if they're not already
+ * defined.
+ */
+
+#ifndef S_ISREG
+# ifdef S_IFREG
+# define S_ISREG(m) (((m) & S_IFMT) == S_IFREG)
+# else
+# define S_ISREG(m) 0
+# endif
+# endif
+#ifndef S_ISDIR
+# ifdef S_IFDIR
+# define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR)
+# else
+# define S_ISDIR(m) 0
+# endif
+# endif
+#ifndef S_ISCHR
+# ifdef S_IFCHR
+# define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR)
+# else
+# define S_ISCHR(m) 0
+# endif
+# endif
+#ifndef S_ISBLK
+# ifdef S_IFBLK
+# define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK)
+# else
+# define S_ISBLK(m) 0
+# endif
+# endif
+#ifndef S_ISFIFO
+# ifdef S_IFIFO
+# define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO)
+# else
+# define S_ISFIFO(m) 0
+# endif
+# endif
+#ifndef S_ISLNK
+# ifdef S_IFLNK
+# define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK)
+# else
+# define S_ISLNK(m) 0
+# endif
+# endif
+#ifndef S_ISSOCK
+# ifdef S_IFSOCK
+# define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK)
+# else
+# define S_ISSOCK(m) 0
+# endif
+# endif
+
+/*
+ * Make sure that MAXPATHLEN is defined.
+ */
+
+#ifndef MAXPATHLEN
+# ifdef PATH_MAX
+# define MAXPATHLEN PATH_MAX
+# else
+# define MAXPATHLEN 2048
+# endif
+#endif
+
+/*
+ * Define pid_t and uid_t if they're not already defined.
+ */
+
+#if ! TCL_PID_T
+# define pid_t int
+#endif
+#if ! TCL_UID_T
+# define uid_t int
+#endif
+
+/*
+ * Variables provided by the C library:
+ */
+
+#if defined(_sgi) || defined(__sgi)
+#define environ _environ
+#endif
+extern char **environ;
+
+/*
+ * Library procedures used by Tcl but not declared in a header file:
+ */
+
+#ifndef _CRAY
+extern int access _ANSI_ARGS_((CONST char *path, int mode));
+extern int chdir _ANSI_ARGS_((CONST char *path));
+extern int close _ANSI_ARGS_((int fd));
+extern int dup2 _ANSI_ARGS_((int src, int dst));
+extern void endpwent _ANSI_ARGS_((void));
+extern int execvp _ANSI_ARGS_((CONST char *name, char **argv));
+extern void _exit _ANSI_ARGS_((int status));
+extern pid_t fork _ANSI_ARGS_((void));
+extern uid_t geteuid _ANSI_ARGS_((void));
+extern pid_t getpid _ANSI_ARGS_((void));
+extern char * getcwd _ANSI_ARGS_((char *buffer, int size));
+extern char * getwd _ANSI_ARGS_((char *buffer));
+extern int kill _ANSI_ARGS_((pid_t pid, int sig));
+extern long lseek _ANSI_ARGS_((int fd, int offset, int whence));
+extern char * mktemp _ANSI_ARGS_((char *template));
+#if !(defined(sparc) || defined(_IBMR2))
+extern int open _ANSI_ARGS_((CONST char *path, int flags, ...));
+#endif
+extern int pipe _ANSI_ARGS_((int *fdPtr));
+extern int read _ANSI_ARGS_((int fd, char *buf, int numBytes));
+extern int readlink _ANSI_ARGS_((CONST char *path, char *buf, int size));
+extern int unlink _ANSI_ARGS_((CONST char *path));
+extern int write _ANSI_ARGS_((int fd, char *buf, int numBytes));
+#endif /* _CRAY */
+
+#endif /* _TCLUNIX */
--- /dev/null
+/*
+ * tkEvent.c --
+ *
+ * This file provides basic event-managing facilities,
+ * whereby procedure callbacks may be attached to
+ * certain events.
+ *
+ * Copyright 1990-1992 Regents of the University of California.
+ * Permission to use, copy, modify, and distribute this
+ * software and its documentation for any purpose and without
+ * fee is hereby granted, provided that the above copyright
+ * notice appear in all copies. The University of California
+ * makes no representations about the suitability of this
+ * software for any purpose. It is provided "as is" without
+ * express or implied warranty.
+ */
+
+/* ADDED tk_GetIntervalToNextEvent */
+
+#ifndef lint
+static char rcsid[] = "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/swat/c/tk3.2-custom/tkEvent.c,v 1.1 1995/08/02 21:23:26 adams Exp $ SPRITE (Berkeley)";
+#endif
+
+#include "tkConfig.h"
+#include "tkInt.h"
+#include <errno.h>
+#include <signal.h>
+
+/*
+ * For each timer callback that's pending, there is one record
+ * of the following type, chained together in a list sorted by
+ * time (earliest event first).
+ */
+
+typedef struct TimerEvent {
+ struct timeval time; /* When timer is to fire. */
+ void (*proc) _ANSI_ARGS_((ClientData clientData));
+ /* Procedure to call. */
+ ClientData clientData; /* Argument to pass to proc. */
+ Tk_TimerToken token; /* Identifies event so it can be
+ * deleted. */
+ struct TimerEvent *nextPtr; /* Next event in queue, or NULL for
+ * end of queue. */
+} TimerEvent;
+
+static TimerEvent *timerQueue; /* First event in queue. */
+
+/*
+ * The information below is used to provide read, write, and
+ * exception masks to select during calls to Tk_DoOneEvent.
+ */
+
+static int readCount; /* Number of files for which we */
+static int writeCount; /* care about each event type. */
+static int exceptCount;
+#define MASK_SIZE ((OPEN_MAX+(8*sizeof(int))-1)/(8*sizeof(int)))
+static int masks[3*MASK_SIZE]; /* Integer array containing official
+ * copies of the three sets of
+ * masks. */
+static int ready[3*MASK_SIZE]; /* Temporary copy of masks, passed
+ * to select and modified by kernel
+ * to indicate which files are
+ * actually ready. */
+static int *readPtr; /* Pointers to the portions of */
+static int *writePtr; /* *readyPtr for reading, writing, */
+static int *exceptPtr; /* and excepting. Will be NULL if
+ * corresponding count (e.g. readCount
+ * is zero. */
+static int numFds = 0; /* Number of valid bits in mask
+ * arrays (this value is passed
+ * to select). */
+
+/*
+ * For each file registered in a call to Tk_CreateFileHandler,
+ * and for each display that's currently active, there is one
+ * record of the following type. All of these records are
+ * chained together into a single list.
+ */
+
+typedef struct FileEvent {
+ int fd; /* Descriptor number for this file. */
+ int *readPtr; /* Pointer to word in ready array
+ * for this file's read mask bit. */
+ int *writePtr; /* Same for write mask bit. */
+ int *exceptPtr; /* Same for except mask bit. */
+ int mask; /* Value to AND with mask word to
+ * select just this file's bit. */
+ void (*proc) _ANSI_ARGS_((ClientData clientData, int mask));
+ /* Procedure to call. NULL means
+ * this is a display. */
+ ClientData clientData; /* Argument to pass to proc. For
+ * displays, this is a (Display *). */
+ struct FileEvent *nextPtr; /* Next in list of all files we
+ * care about (NULL for end of
+ * list). */
+} FileEvent;
+
+static FileEvent *fileList; /* List of all file events. */
+
+/*
+ * There is one of the following structures for each of the
+ * handlers declared in a call to Tk_DoWhenIdle. All of the
+ * currently-active handlers are linked together into a list.
+ */
+
+typedef struct IdleHandler {
+ void (*proc) _ANSI_ARGS_((ClientData clientData));
+ /* Procedure to call. */
+ ClientData clientData; /* Value to pass to proc. */
+ int generation; /* Used to distinguish older handlers from
+ * recently-created ones. */
+ struct IdleHandler *nextPtr;/* Next in list of active handlers. */
+} IdleHandler;
+
+static IdleHandler *idleList = NULL;
+ /* First in list of all idle handlers. */
+static IdleHandler *lastIdlePtr = NULL;
+ /* Last in list (or NULL for empty list). */
+static int idleGeneration = 0; /* Used to fill in the "generation" fields
+ * of IdleHandler structures. Increments
+ * each time Tk_DoOneEvent starts calling
+ * idle handlers, so that all old handlers
+ * can be called without calling any of the
+ * new ones created by old ones. */
+
+/*
+ * There's a potential problem if a handler is deleted while it's
+ * current (i.e. its procedure is executing), since Tk_HandleEvent
+ * will need to read the handler's "nextPtr" field when the procedure
+ * returns. To handle this problem, structures of the type below
+ * indicate the next handler to be processed for any (recursively
+ * nested) dispatches in progress. The nextHandler fields get
+ * updated if the handlers pointed to are deleted. Tk_HandleEvent
+ * also needs to know if the entire window gets deleted; the winPtr
+ * field is set to zero if that particular window gets deleted.
+ */
+
+typedef struct InProgress {
+ XEvent *eventPtr; /* Event currently being handled. */
+ TkWindow *winPtr; /* Window for event. Gets set to None if
+ * window is deleted while event is being
+ * handled. */
+ TkEventHandler *nextHandler; /* Next handler in search. */
+ struct InProgress *nextPtr; /* Next higher nested search. */
+} InProgress;
+
+static InProgress *pendingPtr = NULL;
+ /* Topmost search in progress, or
+ * NULL if none. */
+
+/*
+ * For each call to Tk_CreateGenericHandler, an instance of the following
+ * structure will be created. All of the active handlers are linked into a
+ * list.
+ */
+
+typedef struct GenericHandler {
+ Tk_GenericProc *proc; /* Procedure to dispatch on all X events. */
+ ClientData clientData; /* Client data to pass to procedure. */
+ int deleteFlag; /* Flag to set when this handler is deleted. */
+ struct GenericHandler *nextPtr;
+ /* Next handler in list of all generic
+ * handlers, or NULL for end of list. */
+} GenericHandler;
+
+static GenericHandler *genericList = NULL;
+ /* First handler in the list, or NULL. */
+static GenericHandler *lastGenericPtr = NULL;
+ /* Last handler in list. */
+
+/*
+ * There's a potential problem if Tk_HandleEvent is entered recursively.
+ * A handler cannot be deleted physically until we have returned from
+ * calling it. Otherwise, we're looking at unallocated memory in advancing to
+ * its `next' entry. We deal with the problem by using the `delete flag' and
+ * deleting handlers only when it's known that there's no handler active.
+ *
+ * The following variable has a non-zero value when a handler is active.
+ */
+
+static int genericHandlersActive = 0;
+
+/*
+ * Array of event masks corresponding to each X event:
+ */
+
+static unsigned long eventMasks[] = {
+ 0,
+ 0,
+ KeyPressMask, /* KeyPress */
+ KeyReleaseMask, /* KeyRelease */
+ ButtonPressMask, /* ButtonPress */
+ ButtonReleaseMask, /* ButtonRelease */
+ PointerMotionMask|PointerMotionHintMask|ButtonMotionMask
+ |Button1MotionMask|Button2MotionMask|Button3MotionMask
+ |Button4MotionMask|Button5MotionMask,
+ /* MotionNotify */
+ EnterWindowMask, /* EnterNotify */
+ LeaveWindowMask, /* LeaveNotify */
+ FocusChangeMask, /* FocusIn */
+ FocusChangeMask, /* FocusOut */
+ KeymapStateMask, /* KeymapNotify */
+ ExposureMask, /* Expose */
+ ExposureMask, /* GraphicsExpose */
+ ExposureMask, /* NoExpose */
+ VisibilityChangeMask, /* VisibilityNotify */
+ SubstructureNotifyMask, /* CreateNotify */
+ StructureNotifyMask, /* DestroyNotify */
+ StructureNotifyMask, /* UnmapNotify */
+ StructureNotifyMask, /* MapNotify */
+ SubstructureRedirectMask, /* MapRequest */
+ StructureNotifyMask, /* ReparentNotify */
+ StructureNotifyMask, /* ConfigureNotify */
+ SubstructureRedirectMask, /* ConfigureRequest */
+ StructureNotifyMask, /* GravityNotify */
+ ResizeRedirectMask, /* ResizeRequest */
+ StructureNotifyMask, /* CirculateNotify */
+ SubstructureRedirectMask, /* CirculateRequest */
+ PropertyChangeMask, /* PropertyNotify */
+ 0, /* SelectionClear */
+ 0, /* SelectionRequest */
+ 0, /* SelectionNotify */
+ ColormapChangeMask, /* ColormapNotify */
+ 0, /* ClientMessage */
+ 0, /* Mapping Notify */
+};
+
+/*
+ * If someone has called Tk_RestrictEvents, the information below
+ * keeps track of it.
+ */
+
+static Bool (*restrictProc) _ANSI_ARGS_((Display *display, XEvent *eventPtr,
+ char *arg)); /* Procedure to call. NULL means no
+ * restrictProc is currently in effect. */
+static char *restrictArg; /* Argument to pass to restrictProc. */
+
+/*
+ * The following array keeps track of the last TK_NEVENTS X events, for
+ * memory dump analysis. The tracing is only done if tkEventDebug is set
+ * to 1.
+ */
+
+#define TK_NEVENTS 32
+static XEvent eventTrace[TK_NEVENTS];
+static int traceIndex = 0;
+int tkEventDebug = 0;
+\f
+long tk_GetIntervalToNextEvent()
+/* Returns next time event in milliseconds (from now) */
+{ struct timeval curTime, timeout, *timeoutPtr;
+
+ if (idleList != NULL) return 0; /* Ready NOW */
+ if (timerQueue == NULL) return -1;
+ (void) gettimeofday(&curTime, (struct timezone *) NULL);
+ if ((timerQueue->time.tv_sec < curTime.tv_sec)
+ || ((timerQueue->time.tv_sec == curTime.tv_sec)
+ && (timerQueue->time.tv_usec < curTime.tv_usec)))
+ return 0; /* Already expired, so do it NOW */
+ return (((curTime.tv_sec - timerQueue->time.tv_sec) * 1000) +
+ (((curTime.tv_usec - timerQueue->time.tv_usec) + 500) /
+ 1000));
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CreateEventHandler --
+ *
+ * Arrange for a given procedure to be invoked whenever
+ * events from a given class occur in a given window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * From now on, whenever an event of the type given by
+ * mask occurs for token and is processed by Tk_HandleEvent,
+ * proc will be called. See the manual entry for details
+ * of the calling sequence and return value for proc.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_CreateEventHandler(token, mask, proc, clientData)
+ Tk_Window token; /* Token for window in which to
+ * create handler. */
+ unsigned long mask; /* Events for which proc should
+ * be called. */
+ Tk_EventProc *proc; /* Procedure to call for each
+ * selected event */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ register TkEventHandler *handlerPtr;
+ register TkWindow *winPtr = (TkWindow *) token;
+ int found;
+
+ /*
+ * Skim through the list of existing handlers to (a) compute the
+ * overall event mask for the window (so we can pass this new
+ * value to the X system) and (b) see if there's already a handler
+ * declared with the same callback and clientData (if so, just
+ * change the mask). If no existing handler matches, then create
+ * a new handler.
+ */
+
+ found = 0;
+ if (winPtr->handlerList == NULL) {
+ handlerPtr = (TkEventHandler *) ckalloc(
+ (unsigned) sizeof(TkEventHandler));
+ winPtr->handlerList = handlerPtr;
+ goto initHandler;
+ } else {
+ for (handlerPtr = winPtr->handlerList; ;
+ handlerPtr = handlerPtr->nextPtr) {
+ if ((handlerPtr->proc == proc)
+ && (handlerPtr->clientData == clientData)) {
+ handlerPtr->mask = mask;
+ found = 1;
+ }
+ if (handlerPtr->nextPtr == NULL) {
+ break;
+ }
+ }
+ }
+
+ /*
+ * Create a new handler if no matching old handler was found.
+ */
+
+ if (!found) {
+ handlerPtr->nextPtr = (TkEventHandler *)
+ ckalloc(sizeof(TkEventHandler));
+ handlerPtr = handlerPtr->nextPtr;
+ initHandler:
+ handlerPtr->mask = mask;
+ handlerPtr->proc = proc;
+ handlerPtr->clientData = clientData;
+ handlerPtr->nextPtr = NULL;
+ }
+
+ /*
+ * No need to call XSelectInput: Tk always selects on all events
+ * for all windows (needed to support bindings on classes and "all").
+ */
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DeleteEventHandler --
+ *
+ * Delete a previously-created handler.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If there existed a handler as described by the
+ * parameters, the handler is deleted so that proc
+ * will not be invoked again.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DeleteEventHandler(token, mask, proc, clientData)
+ Tk_Window token; /* Same as corresponding arguments passed */
+ unsigned long mask; /* previously to Tk_CreateEventHandler. */
+ Tk_EventProc *proc;
+ ClientData clientData;
+{
+ register TkEventHandler *handlerPtr;
+ register InProgress *ipPtr;
+ TkEventHandler *prevPtr;
+ register TkWindow *winPtr = (TkWindow *) token;
+
+ /*
+ * Find the event handler to be deleted, or return
+ * immediately if it doesn't exist.
+ */
+
+ for (handlerPtr = winPtr->handlerList, prevPtr = NULL; ;
+ prevPtr = handlerPtr, handlerPtr = handlerPtr->nextPtr) {
+ if (handlerPtr == NULL) {
+ return;
+ }
+ if ((handlerPtr->mask == mask) && (handlerPtr->proc == proc)
+ && (handlerPtr->clientData == clientData)) {
+ break;
+ }
+ }
+
+ /*
+ * If Tk_HandleEvent is about to process this handler, tell it to
+ * process the next one instead.
+ */
+
+ for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->nextHandler == handlerPtr) {
+ ipPtr->nextHandler = handlerPtr->nextPtr;
+ }
+ }
+
+ /*
+ * Free resources associated with the handler.
+ */
+
+ if (prevPtr == NULL) {
+ winPtr->handlerList = handlerPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = handlerPtr->nextPtr;
+ }
+ ckfree((char *) handlerPtr);
+
+
+ /*
+ * No need to call XSelectInput: Tk always selects on all events
+ * for all windows (needed to support bindings on classes and "all").
+ */
+}
+\f
+/*--------------------------------------------------------------
+ *
+ * Tk_CreateGenericHandler --
+ *
+ * Register a procedure to be called on each X event, regardless
+ * of display or window. Generic handlers are useful for capturing
+ * events that aren't associated with windows, or events for windows
+ * not managed by Tk.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * From now on, whenever an X event is given to Tk_HandleEvent,
+ * invoke proc, giving it clientData and the event as arguments.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_CreateGenericHandler(proc, clientData)
+ Tk_GenericProc *proc; /* Procedure to call on every event. */
+ ClientData clientData; /* One-word value to pass to proc. */
+{
+ GenericHandler *handlerPtr;
+
+ handlerPtr = (GenericHandler *) ckalloc (sizeof (GenericHandler));
+
+ handlerPtr->proc = proc;
+ handlerPtr->clientData = clientData;
+ handlerPtr->deleteFlag = 0;
+ handlerPtr->nextPtr = NULL;
+ if (genericList == NULL) {
+ genericList = handlerPtr;
+ } else {
+ lastGenericPtr->nextPtr = handlerPtr;
+ }
+ lastGenericPtr = handlerPtr;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DeleteGenericHandler --
+ *
+ * Delete a previously-created generic handler.
+ *
+ * Results:
+ * None.
+ *
+ * Side Effects:
+ * If there existed a handler as described by the parameters,
+ * that handler is logically deleted so that proc will not be
+ * invoked again. The physical deletion happens in the event
+ * loop in Tk_HandleEvent.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DeleteGenericHandler(proc, clientData)
+ Tk_GenericProc *proc;
+ ClientData clientData;
+{
+ GenericHandler * handler;
+
+ for (handler = genericList; handler; handler = handler->nextPtr) {
+ if ((handler->proc == proc) && (handler->clientData == clientData)) {
+ handler->deleteFlag = 1;
+ }
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_HandleEvent --
+ *
+ * Given an event, invoke all the handlers that have
+ * been registered for the event.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Depends on the handlers.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_HandleEvent(eventPtr)
+ XEvent *eventPtr; /* Event to dispatch. */
+{
+ register TkEventHandler *handlerPtr;
+ register GenericHandler *genericPtr;
+ register GenericHandler *genPrevPtr;
+ TkWindow *winPtr;
+ register unsigned long mask;
+ InProgress ip;
+ Window handlerWindow;
+
+ /*
+ * First off, look for a special trigger event left around by the
+ * grab module. If it's found, call the grab module and discard
+ * the event.
+ */
+
+ if ((eventPtr->xany.type == -1) && (eventPtr->xany.window == None)) {
+ TkGrabTriggerProc(eventPtr);
+ return;
+ }
+
+ /*
+ * Next, invoke all the generic event handlers (those that are
+ * invoked for all events). If a generic event handler reports that
+ * an event is fully processed, go no further.
+ */
+
+ for (genPrevPtr = NULL, genericPtr = genericList; genericPtr != NULL; ) {
+ if (genericPtr->deleteFlag) {
+ if (!genericHandlersActive) {
+ GenericHandler *tmpPtr;
+
+ /*
+ * This handler needs to be deleted and there are no
+ * calls pending through the handler, so now is a safe
+ * time to delete it.
+ */
+
+ tmpPtr = genericPtr->nextPtr;
+ if (genPrevPtr == NULL) {
+ genericList = tmpPtr;
+ } else {
+ genPrevPtr->nextPtr = tmpPtr;
+ }
+ (void) ckfree((char *) genericPtr);
+ genericPtr = tmpPtr;
+ continue;
+ }
+ } else {
+ int done;
+
+ genericHandlersActive++;
+ done = (*genericPtr->proc)(genericPtr->clientData, eventPtr);
+ genericHandlersActive--;
+ if (done) {
+ return;
+ }
+ }
+ genPrevPtr = genericPtr;
+ genericPtr = genPrevPtr->nextPtr;
+ }
+
+ /*
+ * If the event is a MappingNotify event, find its display and
+ * refresh the keyboard mapping information for the display.
+ * After that there's nothing else to do with the event, so just
+ * quit.
+ */
+
+ if (eventPtr->type == MappingNotify) {
+ TkDisplay *dispPtr;
+
+ for (dispPtr = tkDisplayList; dispPtr != NULL;
+ dispPtr = dispPtr->nextPtr) {
+ if (dispPtr->display != eventPtr->xmapping.display) {
+ continue;
+ }
+ XRefreshKeyboardMapping(&eventPtr->xmapping);
+ dispPtr->bindInfoStale = 1;
+ break;
+ }
+ return;
+ }
+
+ /*
+ * Events selected by StructureNotify look the same as those
+ * selected by SubstructureNotify; the only difference is
+ * whether the "event" and "window" fields are the same.
+ * Check it out and convert StructureNotify to
+ * SubstructureNotify if necessary.
+ */
+
+ handlerWindow = eventPtr->xany.window;
+ mask = eventMasks[eventPtr->xany.type];
+ if (mask == StructureNotifyMask) {
+ if (eventPtr->xmap.event != eventPtr->xmap.window) {
+ mask = SubstructureNotifyMask;
+ handlerWindow = eventPtr->xmap.event;
+ }
+ }
+ if (XFindContext(eventPtr->xany.display, handlerWindow,
+ tkWindowContext, (caddr_t *) &winPtr) != 0) {
+
+ /*
+ * There isn't a TkWindow structure for this window.
+ * However, if the event is a PropertyNotify event then call
+ * the selection manager (it deals beneath-the-table with
+ * certain properties).
+ */
+
+ if (eventPtr->type == PropertyNotify) {
+ TkSelPropProc(eventPtr);
+ }
+ return;
+ }
+
+ /*
+ * Call focus-related code to look at FocusIn, FocusOut, Enter,
+ * and Leave events; depending on its return value, ignore the
+ * event.
+ */
+
+ if ((mask & (FocusChangeMask|EnterWindowMask|LeaveWindowMask))
+ && !TkFocusFilterEvent(winPtr, eventPtr)) {
+ return;
+ }
+
+ /*
+ * Redirect KeyPress and KeyRelease events to the focus window,
+ * or ignore them entirely if there is no focus window. Map the
+ * x and y coordinates to make sense in the context of the focus
+ * window, if possible (make both -1 if the map-from and map-to
+ * windows don't share the same screen).
+ */
+
+ if (mask & (KeyPressMask|KeyReleaseMask)) {
+ TkWindow *focusPtr;
+ int winX, winY, focusX, focusY;
+
+ winPtr->dispPtr->lastEventTime = eventPtr->xkey.time;
+ if (winPtr->mainPtr->focusPtr == NULL) {
+ return;
+ }
+ focusPtr = winPtr->mainPtr->focusPtr;
+ if ((focusPtr->display != winPtr->display)
+ || (focusPtr->screenNum != winPtr->screenNum)) {
+ eventPtr->xkey.x = -1;
+ eventPtr->xkey.y = -1;
+ } else {
+ Tk_GetRootCoords((Tk_Window) winPtr, &winX, &winY);
+ Tk_GetRootCoords((Tk_Window) focusPtr, &focusX, &focusY);
+ eventPtr->xkey.x -= focusX - winX;
+ eventPtr->xkey.y -= focusY - winY;
+ }
+ eventPtr->xkey.window = focusPtr->window;
+ winPtr = focusPtr;
+ }
+
+ /*
+ * Call a grab-related procedure to do special processing on
+ * pointer events.
+ */
+
+ if (mask & (ButtonPressMask|ButtonReleaseMask|PointerMotionMask
+ |EnterWindowMask|LeaveWindowMask)) {
+ if (mask & (ButtonPressMask|ButtonReleaseMask)) {
+ winPtr->dispPtr->lastEventTime = eventPtr->xbutton.time;
+ } else if (mask & PointerMotionMask) {
+ winPtr->dispPtr->lastEventTime = eventPtr->xmotion.time;
+ } else {
+ winPtr->dispPtr->lastEventTime = eventPtr->xcrossing.time;
+ }
+ if (TkPointerEvent(eventPtr, winPtr) == 0) {
+ return;
+ }
+ }
+
+ /*
+ * For events where it hasn't already been done, update the current
+ * time in the display.
+ */
+
+ if (eventPtr->type == PropertyNotify) {
+ winPtr->dispPtr->lastEventTime = eventPtr->xproperty.time;
+ }
+
+ /*
+ * There's a potential interaction here with Tk_DeleteEventHandler.
+ * Read the documentation for pendingPtr.
+ */
+
+ ip.eventPtr = eventPtr;
+ ip.winPtr = winPtr;
+ ip.nextHandler = NULL;
+ ip.nextPtr = pendingPtr;
+ pendingPtr = &ip;
+ if (mask == 0) {
+ if ((eventPtr->type == SelectionClear)
+ || (eventPtr->type == SelectionRequest)
+ || (eventPtr->type == SelectionNotify)) {
+ TkSelEventProc((Tk_Window) winPtr, eventPtr);
+ } else if ((eventPtr->type == ClientMessage)
+ && (eventPtr->xclient.message_type ==
+ Tk_InternAtom((Tk_Window) winPtr, "WM_PROTOCOLS"))) {
+ TkWmProtocolEventProc(winPtr, eventPtr);
+ }
+ } else {
+ for (handlerPtr = winPtr->handlerList; handlerPtr != NULL; ) {
+ if ((handlerPtr->mask & mask) != 0) {
+ ip.nextHandler = handlerPtr->nextPtr;
+ (*(handlerPtr->proc))(handlerPtr->clientData, eventPtr);
+ handlerPtr = ip.nextHandler;
+ } else {
+ handlerPtr = handlerPtr->nextPtr;
+ }
+ }
+
+ /*
+ * Pass the event to the "bind" command mechanism. But, don't
+ * do this for SubstructureNotify events. The "bind" command
+ * doesn't support them anyway, and it's easier to filter out
+ * these events here than in the lower-level procedures.
+ */
+
+ if ((ip.winPtr != None) && (mask != SubstructureNotifyMask)) {
+ TkBindEventProc(winPtr, eventPtr);
+ }
+ }
+ pendingPtr = ip.nextPtr;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CreateFileHandler --
+ *
+ * Arrange for a given procedure to be invoked whenever
+ * a given file becomes readable or writable.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * From now on, whenever the I/O channel given by fd becomes
+ * ready in the way indicated by mask, proc will be invoked.
+ * See the manual entry for details on the calling sequence
+ * to proc. If fd is already registered then the old mask
+ * and proc and clientData values will be replaced with
+ * new ones.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_CreateFileHandler(fd, mask, proc, clientData)
+ int fd; /* Integer identifier for stream. */
+ int mask; /* OR'ed combination of TK_READABLE,
+ * TK_WRITABLE, and TK_EXCEPTION:
+ * indicates conditions under which
+ * proc should be called. */
+ Tk_FileProc *proc; /* Procedure to call for each
+ * selected event. NULL means that
+ * this is a display, and that
+ * clientData is the (Display *)
+ * for it, and that events should
+ * be handled automatically. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ register FileEvent *filePtr;
+ int index;
+
+ if (fd >= OPEN_MAX) {
+ panic("Tk_CreatefileHandler can't handle file id %d", fd);
+ }
+
+ /*
+ * Make sure the file isn't already registered. Create a
+ * new record in the normal case where there's no existing
+ * record.
+ */
+
+ for (filePtr = fileList; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (filePtr->fd == fd) {
+ break;
+ }
+ }
+ index = fd/(8*sizeof(int));
+ if (filePtr == NULL) {
+ filePtr = (FileEvent *) ckalloc(sizeof(FileEvent));
+ filePtr->fd = fd;
+ filePtr->readPtr = &ready[index];
+ filePtr->writePtr = &ready[index+MASK_SIZE];
+ filePtr->exceptPtr = &ready[index+2*MASK_SIZE];
+ filePtr->mask = 1 << (fd%(8*sizeof(int)));
+ filePtr->nextPtr = fileList;
+ fileList = filePtr;
+ } else {
+ if (masks[index] & filePtr->mask) {
+ readCount--;
+ *filePtr->readPtr &= ~filePtr->mask;
+ masks[index] &= ~filePtr->mask;
+ }
+ if (masks[index+MASK_SIZE] & filePtr->mask) {
+ writeCount--;
+ *filePtr->writePtr &= ~filePtr->mask;
+ masks[index+MASK_SIZE] &= ~filePtr->mask;
+ }
+ if (masks[index+2*MASK_SIZE] & filePtr->mask) {
+ exceptCount--;
+ *filePtr->exceptPtr &= ~filePtr->mask;
+ masks[index+2*MASK_SIZE] &= ~filePtr->mask;
+ }
+ }
+
+ /*
+ * The remainder of the initialization below is done
+ * regardless of whether or not this is a new record
+ * or a modification of an old one.
+ */
+
+ if (mask & TK_READABLE) {
+ masks[index] |= filePtr->mask;
+ readCount++;
+ }
+ readPtr = (readCount == 0) ? (int *) NULL : &ready[0];
+
+ if (mask & TK_WRITABLE) {
+ masks[index+MASK_SIZE] |= filePtr->mask;
+ writeCount++;
+ }
+ writePtr = (writeCount == 0) ? (int *) NULL : &ready[MASK_SIZE];
+
+ if (mask & TK_EXCEPTION) {
+ masks[index+2*MASK_SIZE] |= filePtr->mask;
+ exceptCount++;
+ }
+ exceptPtr = (exceptCount == 0) ? (int *) NULL : &ready[2*MASK_SIZE];
+
+ filePtr->proc = proc;
+ filePtr->clientData = clientData;
+
+ if (numFds <= fd) {
+ numFds = fd+1;
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DeleteFileHandler --
+ *
+ * Cancel a previously-arranged callback arrangement for
+ * a file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If a callback was previously registered on fd, remove it.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DeleteFileHandler(fd)
+ int fd; /* Stream id for which to remove
+ * callback procedure. */
+{
+ register FileEvent *filePtr;
+ FileEvent *prevPtr;
+ int index;
+
+ /*
+ * Find the entry for the given file (and return if there
+ * isn't one).
+ */
+
+ for (prevPtr = NULL, filePtr = fileList; ;
+ prevPtr = filePtr, filePtr = filePtr->nextPtr) {
+ if (filePtr == NULL) {
+ return;
+ }
+ if (filePtr->fd == fd) {
+ break;
+ }
+ }
+
+ /*
+ * Clean up information in the callback record.
+ */
+
+ index = filePtr->fd/(8*sizeof(int));
+ if (masks[index] & filePtr->mask) {
+ readCount--;
+ *filePtr->readPtr &= ~filePtr->mask;
+ masks[index] &= ~filePtr->mask;
+ }
+ if (masks[index+MASK_SIZE] & filePtr->mask) {
+ writeCount--;
+ *filePtr->writePtr &= ~filePtr->mask;
+ masks[index+MASK_SIZE] &= ~filePtr->mask;
+ }
+ if (masks[index+2*MASK_SIZE] & filePtr->mask) {
+ exceptCount--;
+ *filePtr->exceptPtr &= ~filePtr->mask;
+ masks[index+2*MASK_SIZE] &= ~filePtr->mask;
+ }
+ if (prevPtr == NULL) {
+ fileList = filePtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = filePtr->nextPtr;
+ }
+ ckfree((char *) filePtr);
+
+ /*
+ * Recompute numFds.
+ */
+
+ numFds = 0;
+ for (filePtr = fileList; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ if (numFds <= filePtr->fd) {
+ numFds = filePtr->fd+1;
+ }
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CreateTimerHandler --
+ *
+ * Arrange for a given procedure to be invoked at a particular
+ * time in the future.
+ *
+ * Results:
+ * The return value is a token for the timer event, which
+ * may be used to delete the event before it fires.
+ *
+ * Side effects:
+ * When milliseconds have elapsed, proc will be invoked
+ * exactly once.
+ *
+ *--------------------------------------------------------------
+ */
+
+Tk_TimerToken
+Tk_CreateTimerHandler(milliseconds, proc, clientData)
+ int milliseconds; /* How many milliseconds to wait
+ * before invoking proc. */
+ Tk_TimerProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary data to pass to proc. */
+{
+ register TimerEvent *timerPtr, *tPtr2, *prevPtr;
+ static int id = 0;
+
+ timerPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent));
+
+ /*
+ * Compute when the event should fire.
+ */
+
+ (void) gettimeofday(&timerPtr->time, (struct timezone *) NULL);
+ timerPtr->time.tv_sec += milliseconds/1000;
+ timerPtr->time.tv_usec += (milliseconds%1000)*1000;
+ if (timerPtr->time.tv_usec > 1000000) {
+ timerPtr->time.tv_usec -= 1000000;
+ timerPtr->time.tv_sec += 1;
+ }
+
+ /*
+ * Fill in other fields for the event.
+ */
+
+ timerPtr->proc = proc;
+ timerPtr->clientData = clientData;
+ id++;
+ timerPtr->token = (Tk_TimerToken) id;
+
+ /*
+ * Add the event to the queue in the correct position
+ * (ordered by event firing time).
+ */
+
+ for (tPtr2 = timerQueue, prevPtr = NULL; tPtr2 != NULL;
+ prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
+ if ((tPtr2->time.tv_sec > timerPtr->time.tv_sec)
+ || ((tPtr2->time.tv_sec == timerPtr->time.tv_sec)
+ && (tPtr2->time.tv_usec > timerPtr->time.tv_usec))) {
+ break;
+ }
+ }
+ if (prevPtr == NULL) {
+ timerPtr->nextPtr = timerQueue;
+ timerQueue = timerPtr;
+ } else {
+ timerPtr->nextPtr = prevPtr->nextPtr;
+ prevPtr->nextPtr = timerPtr;
+ }
+ return timerPtr->token;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DeleteTimerHandler --
+ *
+ * Delete a previously-registered timer handler.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Destroy the timer callback identified by TimerToken,
+ * so that its associated procedure will not be called.
+ * If the callback has already fired, or if the given
+ * token doesn't exist, then nothing happens.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DeleteTimerHandler(token)
+ Tk_TimerToken token; /* Result previously returned by
+ * Tk_DeleteTimerHandler. */
+{
+ register TimerEvent *timerPtr, *prevPtr;
+
+ for (timerPtr = timerQueue, prevPtr = NULL; timerPtr != NULL;
+ prevPtr = timerPtr, timerPtr = timerPtr->nextPtr) {
+ if (timerPtr->token != token) {
+ continue;
+ }
+ if (prevPtr == NULL) {
+ timerQueue = timerPtr->nextPtr;
+ } else {
+ prevPtr->nextPtr = timerPtr->nextPtr;
+ }
+ ckfree((char *) timerPtr);
+ return;
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DoWhenIdle --
+ *
+ * Arrange for proc to be invoked the next time the
+ * system is idle (i.e., just before the next time
+ * that Tk_DoOneEvent would have to wait for something
+ * to happen).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Proc will eventually be called, with clientData
+ * as argument. See the manual entry for details.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DoWhenIdle(proc, clientData)
+ Tk_IdleProc *proc; /* Procedure to invoke. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ register IdleHandler *idlePtr;
+
+ idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
+ idlePtr->proc = proc;
+ idlePtr->clientData = clientData;
+ idlePtr->generation = idleGeneration;
+ idlePtr->nextPtr = NULL;
+ if (lastIdlePtr == NULL) {
+ idleList = idlePtr;
+ } else {
+ lastIdlePtr->nextPtr = idlePtr;
+ }
+ lastIdlePtr = idlePtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_CancelIdleCall --
+ *
+ * If there are any when-idle calls requested to a given procedure
+ * with given clientData, cancel all of them.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * If the proc/clientData combination were on the when-idle list,
+ * they are removed so that they will never be called.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tk_CancelIdleCall(proc, clientData)
+ Tk_IdleProc *proc; /* Procedure that was previously registered. */
+ ClientData clientData; /* Arbitrary value to pass to proc. */
+{
+ register IdleHandler *idlePtr, *prevPtr;
+ IdleHandler *nextPtr;
+
+ for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
+ prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
+ while ((idlePtr->proc == proc)
+ && (idlePtr->clientData == clientData)) {
+ nextPtr = idlePtr->nextPtr;
+ ckfree((char *) idlePtr);
+ idlePtr = nextPtr;
+ if (prevPtr == NULL) {
+ idleList = idlePtr;
+ } else {
+ prevPtr->nextPtr = idlePtr;
+ }
+ if (idlePtr == NULL) {
+ lastIdlePtr = prevPtr;
+ return;
+ }
+ }
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DoOneEvent --
+ *
+ * Process a single event of some sort. If there's no
+ * work to do, wait for an event to occur, then process
+ * it.
+ *
+ * Results:
+ * The return value is 1 if the procedure actually found
+ * an event to process. If no event was found then 0 is
+ * returned.
+ *
+ * Side effects:
+ * May delay execution of process while waiting for an
+ * X event, X error, file-ready event, or timer event.
+ * The handling of the event could cause additional
+ * side effects. Collapses sequences of mouse-motion
+ * events for the same window into a single event by
+ * delaying motion event processing.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_DoOneEvent(flags)
+ int flags; /* Miscellaneous flag values: may be any
+ * combination of TK_DONT_WAIT, TK_X_EVENTS,
+ * TK_FILE_EVENTS, TK_TIMER_EVENTS, and
+ * TK_IDLE_EVENTS. */
+{
+ register FileEvent *filePtr;
+ struct timeval curTime, timeout, *timeoutPtr;
+ int numFound;
+ static XEvent delayedMotionEvent; /* Used to hold motion events that
+ * are being saved until later. */
+ static int eventDelayed = 0; /* Non-zero means there is an event
+ * in delayedMotionEvent. */
+
+ if ((flags & TK_ALL_EVENTS) == 0) {
+ flags |= TK_ALL_EVENTS;
+ }
+
+ /*
+ * Phase One: see if there's already something ready
+ * (either a file or a display) that was left over
+ * from before (i.e don't do a select, just check the
+ * bits from the last select).
+ */
+
+ checkFiles:
+ for (filePtr = fileList; filePtr != NULL;
+ filePtr = filePtr->nextPtr) {
+ int mask;
+
+ /*
+ * Displays: flush output, check for queued events,
+ * and read events from the server if display is ready.
+ * If there are any events, process one and then
+ * return.
+ */
+
+ if ((filePtr->proc == NULL) && (flags & TK_X_EVENTS)) {
+ Display *display = (Display *) filePtr->clientData;
+ XEvent event;
+
+ XFlush(display);
+ if ((*filePtr->readPtr) & filePtr->mask) {
+ *filePtr->readPtr &= ~filePtr->mask;
+ if (XEventsQueued(display, QueuedAfterReading) == 0) {
+
+ /*
+ * Things are very tricky if there aren't any events
+ * readable at this point (after all, there was
+ * supposedly data available on the connection).
+ * A couple of things could have occurred:
+ *
+ * One possibility is that there were only error events
+ * in the input from the server. If this happens,
+ * we should return (we don't want to go to sleep
+ * in XNextEvent below, since this would block out
+ * other sources of input to the process).
+ *
+ * Another possibility is that our connection to the
+ * server has been closed. This will not necessarily
+ * be detected in XEventsQueued (!!), so if we just
+ * return then there will be an infinite loop. To
+ * detect such an error, generate a NoOp protocol
+ * request to exercise the connection to the server,
+ * then return. However, must disable SIGPIPE while
+ * sending the event, or else the process will die
+ * from the signal and won't invoke the X error
+ * function to print a nice message.
+ */
+
+ void (*oldHandler)();
+
+ oldHandler = (void (*)()) signal(SIGPIPE, SIG_IGN);
+ XNoOp(display);
+ XFlush(display);
+ (void) signal(SIGPIPE, oldHandler);
+ return 1;
+ }
+ if (restrictProc != NULL) {
+ if (!XCheckIfEvent(display, &event, restrictProc,
+ restrictArg)) {
+ return 1;
+ }
+ } else {
+ XNextEvent(display, &event);
+ }
+ } else {
+ if (QLength(display) == 0) {
+ continue;
+ }
+ if (restrictProc != NULL) {
+ if (!XCheckIfEvent(display, &event, restrictProc,
+ restrictArg)) {
+ continue;
+ }
+ } else {
+ XNextEvent(display, &event);
+ }
+ }
+
+ /*
+ * Got an event. Deal with mouse-motion-collapsing and
+ * event-delaying here. If there's already an event delayed,
+ * then process that event if it's incompatible with the new
+ * event (new event not mouse motion, or window changed, or
+ * state changed). If the new event is mouse motion, then
+ * don't process it now; delay it until later in the hopes
+ * that it can be merged with other mouse motion events
+ * immediately following.
+ */
+
+ if (tkEventDebug) {
+ eventTrace[traceIndex] = event;
+ traceIndex = (traceIndex+1) % TK_NEVENTS;
+ }
+
+ if (eventDelayed) {
+ if (((event.type != MotionNotify)
+ && (event.type != GraphicsExpose)
+ && (event.type != NoExpose)
+ && (event.type != Expose))
+ || (event.xmotion.display
+ != delayedMotionEvent.xmotion.display)
+ || (event.xmotion.window
+ != delayedMotionEvent.xmotion.window)) {
+ XEvent copy;
+
+ /*
+ * Must copy the event out of delayedMotionEvent before
+ * processing it, in order to allow recursive calls to
+ * Tk_DoOneEvent as part of the handler.
+ */
+
+ copy = delayedMotionEvent;
+ eventDelayed = 0;
+ Tk_HandleEvent(©);
+ }
+ }
+ if (event.type == MotionNotify) {
+ delayedMotionEvent = event;
+ eventDelayed = 1;
+ } else {
+ Tk_HandleEvent(&event);
+ }
+ return 1;
+ }
+
+ /*
+ * Not a display: if the file is ready, call the
+ * appropriate handler.
+ */
+
+ if (((*filePtr->readPtr | *filePtr->writePtr
+ | *filePtr->exceptPtr) & filePtr->mask) == 0) {
+ continue;
+ }
+ if (!(flags & TK_FILE_EVENTS)) {
+ continue;
+ }
+ mask = 0;
+ if (*filePtr->readPtr & filePtr->mask) {
+ mask |= TK_READABLE;
+ *filePtr->readPtr &= ~filePtr->mask;
+ }
+ if (*filePtr->writePtr & filePtr->mask) {
+ mask |= TK_WRITABLE;
+ *filePtr->writePtr &= ~filePtr->mask;
+ }
+ if (*filePtr->exceptPtr & filePtr->mask) {
+ mask |= TK_EXCEPTION;
+ *filePtr->exceptPtr &= ~filePtr->mask;
+ }
+ (*filePtr->proc)(filePtr->clientData, mask);
+ return 1;
+ }
+
+ /*
+ * Phase Two: get the current time and see if any timer
+ * events are ready to fire. If so, fire one and return.
+ */
+
+ checkTime:
+ if ((timerQueue != NULL) && (flags & TK_TIMER_EVENTS)) {
+ register TimerEvent *timerPtr = timerQueue;
+
+ (void) gettimeofday(&curTime, (struct timezone *) NULL);
+ if ((timerPtr->time.tv_sec < curTime.tv_sec)
+ || ((timerPtr->time.tv_sec == curTime.tv_sec)
+ && (timerPtr->time.tv_usec < curTime.tv_usec))) {
+ timerQueue = timerPtr->nextPtr;
+ (*timerPtr->proc)(timerPtr->clientData);
+ ckfree((char *) timerPtr);
+ return 1;
+ }
+ }
+
+
+ /*
+ * Phase Three: if there is a delayed motion event, process it
+ * now, before any DoWhenIdle handlers. Better to process before
+ * idle handlers than after, because the goal of idle handlers is
+ * to delay until after all pending events have been processed.
+ * Must free up delayedMotionEvent *before* calling Tk_HandleEvent,
+ * so that the event handler can call Tk_DoOneEvent recursively
+ * without infinite looping.
+ */
+
+ if ((eventDelayed) && (flags & TK_X_EVENTS)) {
+ XEvent copy;
+
+ copy = delayedMotionEvent;
+ eventDelayed = 0;
+ Tk_HandleEvent(©);
+ return 1;
+ }
+
+ /*
+ * Phase Four: if there are DoWhenIdle requests pending (or
+ * if we're not allowed to block), then do a select with an
+ * instantaneous timeout. If a ready file is found, then go
+ * back to process it.
+ */
+
+ if (((idleList != NULL) && (flags & TK_IDLE_EVENTS))
+ || (flags & TK_DONT_WAIT)) {
+ if (flags & (TK_X_EVENTS|TK_FILE_EVENTS)) {
+ memcpy((VOID *) ready, (VOID *) masks, 3*MASK_SIZE*sizeof(int));
+ timeout.tv_sec = timeout.tv_usec = 0;
+ do {
+ numFound = select(numFds, (SELECT_MASK *) readPtr,
+ (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr,
+ &timeout);
+ } while ((numFound == -1) && (errno == EINTR));
+ if (numFound > 0) {
+ goto checkFiles;
+ }
+ }
+ }
+
+ /*
+ * Phase Five: process all pending DoWhenIdle requests.
+ */
+
+ if ((idleList != NULL) && (flags & TK_IDLE_EVENTS)) {
+ register IdleHandler *idlePtr;
+ int oldGeneration;
+
+ oldGeneration = idleList->generation;
+ idleGeneration++;
+
+ /*
+ * The code below is trickier than it may look, for the following
+ * reasons:
+ *
+ * 1. New handlers can get added to the list while the current
+ * one is being processed. If new ones get added, we don't
+ * want to process them during this pass through the list (want
+ * to check for other work to do first). This is implemented
+ * using the generation number in the handler: new handlers
+ * will have a different generation than any of the ones currently
+ * on the list.
+ * 2. The handler can call Tk_DoOneEvent, so we have to remove
+ * the hander from the list before calling it. Otherwise an
+ * infinite loop could result.
+ * 3. Tk_CancelIdleCall can be called to remove an element from
+ * the list while a handler is executing, so the list could
+ * change structure during the call.
+ */
+
+ for (idlePtr = idleList;
+ ((idlePtr != NULL) && (idlePtr->generation == oldGeneration));
+ idlePtr = idleList) {
+ /* fprintf(stderr, "Phase5A"); Here is where it is looping */
+ idleList = idlePtr->nextPtr;
+ if (idleList == NULL) {
+ lastIdlePtr = NULL;
+ }
+ (*idlePtr->proc)(idlePtr->clientData);
+ ckfree((char *) idlePtr);
+ }
+ return 1;
+ }
+
+ /*
+ * Phase Six: do a select to wait for either one of the
+ * files to become ready or for the first timer event to
+ * fire. Then go back to process the event.
+ */
+
+ if ((flags & TK_DONT_WAIT)
+ || !(flags & (TK_TIMER_EVENTS|TK_FILE_EVENTS|TK_X_EVENTS))) {
+ return 0;
+ }
+ if ((timerQueue == NULL) || !(flags & TK_TIMER_EVENTS)) {
+ timeoutPtr = NULL;
+ } else {
+ timeoutPtr = &timeout;
+ timeout.tv_sec = timerQueue->time.tv_sec - curTime.tv_sec;
+ timeout.tv_usec = timerQueue->time.tv_usec - curTime.tv_usec;
+ if (timeout.tv_usec < 0) {
+ timeout.tv_sec -= 1;
+ timeout.tv_usec += 1000000;
+ }
+ }
+ memcpy((VOID *) ready, (VOID *) masks, 3*MASK_SIZE*sizeof(int));
+ do {
+ numFound = select(numFds, (SELECT_MASK *) readPtr,
+ (SELECT_MASK *) writePtr, (SELECT_MASK *) exceptPtr,
+ timeoutPtr);
+ } while ((numFound == -1) && (errno == EINTR));
+ if (numFound == 0) {
+ goto checkTime;
+ }
+ goto checkFiles;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_MainLoop --
+ *
+ * Call Tk_DoOneEvent over and over again in an infinite
+ * loop as long as there exist any main windows.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Arbitrary; depends on handlers for events.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_MainLoop()
+{
+ while (tk_NumMainWindows > 0) {
+ Tk_DoOneEvent(0);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_Sleep --
+ *
+ * Delay execution for the specified number of milliseconds.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Time passes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tk_Sleep(ms)
+ int ms; /* Number of milliseconds to sleep. */
+{
+ static struct timeval delay;
+
+ delay.tv_sec = ms/1000;
+ delay.tv_usec = (ms%1000)*1000;
+ (void) select(0, (SELECT_MASK *) 0, (SELECT_MASK *) 0,
+ (SELECT_MASK *) 0, &delay);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_RestrictEvents --
+ *
+ * This procedure is used to globally restrict the set of events
+ * that will be dispatched. The restriction is done by filtering
+ * all incoming X events through a procedure that determines
+ * whether they are to be processed immediately or deferred.
+ *
+ * Results:
+ * The return value is the previous restriction procedure in effect,
+ * if there was one, or NULL if there wasn't.
+ *
+ * Side effects:
+ * From now on, proc will be called to determine whether to process
+ * or defer each incoming X event.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_RestrictProc *
+Tk_RestrictEvents(proc, arg, prevArgPtr)
+ Tk_RestrictProc *proc; /* X "if" procedure to call for each
+ * incoming event. See "XIfEvent" doc.
+ * for details. */
+ char *arg; /* Arbitrary argument to pass to proc. */
+ char **prevArgPtr; /* Place to store information about previous
+ * argument. */
+{
+ Bool (*prev) _ANSI_ARGS_((Display *display, XEvent *eventPtr, char *arg));
+
+ prev = restrictProc;
+ *prevArgPtr = restrictArg;
+ restrictProc = proc;
+ restrictArg = arg;
+ return prev;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * TkEventDeadWindow --
+ *
+ * This procedure is invoked when it is determined that
+ * a window is dead. It cleans up event-related information
+ * about the window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Various things get cleaned up and recycled.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+TkEventDeadWindow(winPtr)
+ TkWindow *winPtr; /* Information about the window
+ * that is being deleted. */
+{
+ register TkEventHandler *handlerPtr;
+ register InProgress *ipPtr;
+
+ /*
+ * While deleting all the handlers, be careful to check for
+ * Tk_HandleEvent being about to process one of the deleted
+ * handlers. If it is, tell it to quit (all of the handlers
+ * are being deleted).
+ */
+
+ while (winPtr->handlerList != NULL) {
+ handlerPtr = winPtr->handlerList;
+ winPtr->handlerList = handlerPtr->nextPtr;
+ for (ipPtr = pendingPtr; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ if (ipPtr->nextHandler == handlerPtr) {
+ ipPtr->nextHandler = NULL;
+ }
+ if (ipPtr->winPtr == winPtr) {
+ ipPtr->winPtr = None;
+ }
+ }
+ ckfree((char *) handlerPtr);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * TkCurrentTime --
+ *
+ * Try to deduce the current time. "Current time" means the time
+ * of the event that led to the current code being executed, which
+ * means the time in the most recently-nested invocation of
+ * Tk_HandleEvent.
+ *
+ * Results:
+ * The return value is the time from the current event, or
+ * CurrentTime if there is no current event or if the current
+ * event contains no time.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Time
+TkCurrentTime(dispPtr)
+ TkDisplay *dispPtr; /* Display for which the time is desired. */
+{
+ register XEvent *eventPtr;
+
+ if (pendingPtr == NULL) {
+ return dispPtr->lastEventTime;
+ }
+ eventPtr = pendingPtr->eventPtr;
+ switch (eventPtr->type) {
+ case ButtonPress:
+ case ButtonRelease:
+ return eventPtr->xbutton.time;
+ case KeyPress:
+ case KeyRelease:
+ return eventPtr->xkey.time;
+ case MotionNotify:
+ return eventPtr->xmotion.time;
+ case EnterNotify:
+ case LeaveNotify:
+ return eventPtr->xcrossing.time;
+ case PropertyNotify:
+ return eventPtr->xproperty.time;
+ }
+ return dispPtr->lastEventTime;
+}
--- /dev/null
+/**************************
+ Changes on April 1, 1993 to support Scheme UITK:
+ 1) Added Tk_CreateMainWindow_from_display.
+ 2) Renamed GetScreen to GetScreenByName. Added GetScreenByDisplay.
+ 3) Rewrote Tk_CreateMainWindow into Tk_CreateMainWindow_from_data,
+ which takes both a lookup procedure for finding a Screen and the
+ data necessary for the lookup. Rewrite Tk_CreateMainWindow in
+ terms of this.
+ 4) Changed the signature of CreateTopLevelWindow to accept a lookup
+ procedure and data.
+ 5) Made NameWindow public for reparenting widgets when mapped by UITK
+ 6) Added external entry point Tk_DestroyDisplayByNumber.
+**************************/
+
+/*
+ * tkWindow.c --
+ *
+ * This file provides basic window-manipulation procedures,
+ * which are equivalent to procedures in Xlib (and even
+ * invoke them) but also maintain the local Tk_Window
+ * structure.
+ *
+ * Copyright 1989-1992 Regents of the University of California.
+ * Permission to use, copy, modify, and distribute this
+ * software and its documentation for any purpose and without
+ * fee is hereby granted, provided that the above copyright
+ * notice appear in all copies. The University of California
+ * makes no representations about the suitability of this
+ * software for any purpose. It is provided "as is" without
+ * express or implied warranty.
+ */
+
+#ifndef lint
+static char rcsid[] = "$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/swat/c/tk3.2-custom/tkWindow.c,v 1.1 1995/08/02 21:23:26 adams Exp $ SPRITE (Berkeley)";
+#endif
+
+#include "tkConfig.h"
+#include "tkInt.h"
+
+/*
+ * Count of number of main windows currently open in this process.
+ */
+
+int tk_NumMainWindows;
+
+/*
+ * List of all displays currently in use.
+ */
+
+TkDisplay *tkDisplayList = NULL;
+
+/*
+ * Have statics in this module been initialized?
+ */
+
+static initialized = 0;
+
+/*
+ * Context information used to map from X window id's to
+ * TkWindow structures (during event handling, for example):
+ */
+
+XContext tkWindowContext;
+
+/*
+ * The variables below hold several uid's that are used in many places
+ * in the toolkit.
+ */
+
+Tk_Uid tkDisabledUid = NULL;
+Tk_Uid tkActiveUid = NULL;
+Tk_Uid tkNormalUid = NULL;
+
+/*
+ * Default values for "changes" and "atts" fields of TkWindows. Note
+ * that Tk always requests all events for all windows, except StructureNotify
+ * events on internal windows: these events are generated internally.
+ */
+
+static XWindowChanges defChanges = {
+ 0, 0, 1, 1, 0, 0, Above
+};
+#define ALL_EVENTS_MASK \
+ KeyPressMask|KeyReleaseMask|ButtonPressMask|ButtonReleaseMask| \
+ EnterWindowMask|LeaveWindowMask|PointerMotionMask|ExposureMask| \
+ VisibilityChangeMask|SubstructureNotifyMask| \
+ FocusChangeMask|PropertyChangeMask|ColormapChangeMask
+static XSetWindowAttributes defAtts= {
+ None, /* background_pixmap */
+ 0, /* background_pixel */
+ CopyFromParent, /* border_pixmap */
+ 0, /* border_pixel */
+ ForgetGravity, /* bit_gravity */
+ NorthWestGravity, /* win_gravity */
+ NotUseful, /* backing_store */
+ ~0, /* backing_planes */
+ 0, /* backing_pixel */
+ False, /* save_under */
+ ALL_EVENTS_MASK, /* event_mask */
+ 0, /* do_not_propagate_mask */
+ False, /* override_redirect */
+ CopyFromParent, /* colormap */
+ None /* cursor */
+};
+
+/*
+ * The following structure defines all of the commands supported by
+ * Tk, and the C procedures that execute them.
+ */
+
+typedef struct {
+ char *name; /* Name of command. */
+ int (*cmdProc) _ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp,
+ int argc, char **argv));
+ /* Command procedure. */
+} TkCmd;
+
+TkCmd commands[] = {
+ /*
+ * Commands that are part of the intrinsics:
+ */
+
+ {"after", Tk_AfterCmd},
+ {"bind", Tk_BindCmd},
+ {"destroy", Tk_DestroyCmd},
+ {"focus", Tk_FocusCmd},
+ {"grab", Tk_GrabCmd},
+ {"option", Tk_OptionCmd},
+ {"pack", Tk_PackCmd},
+ {"place", Tk_PlaceCmd},
+ {"selection", Tk_SelectionCmd},
+ {"tk", Tk_TkCmd},
+ {"tkwait", Tk_TkwaitCmd},
+ {"update", Tk_UpdateCmd},
+ {"winfo", Tk_WinfoCmd},
+ {"wm", Tk_WmCmd},
+
+ /*
+ * Widget-creation commands.
+ */
+ {"button", Tk_ButtonCmd},
+ {"canvas", Tk_CanvasCmd},
+ {"checkbutton", Tk_ButtonCmd},
+ {"entry", Tk_EntryCmd},
+ {"frame", Tk_FrameCmd},
+ {"label", Tk_ButtonCmd},
+ {"listbox", Tk_ListboxCmd},
+ {"menu", Tk_MenuCmd},
+ {"menubutton", Tk_MenubuttonCmd},
+ {"message", Tk_MessageCmd},
+ {"radiobutton", Tk_ButtonCmd},
+ {"scale", Tk_ScaleCmd},
+ {"scrollbar", Tk_ScrollbarCmd},
+ {"text", Tk_TextCmd},
+ {"toplevel", Tk_FrameCmd},
+ {(char *) NULL, (int (*)()) NULL}
+};
+
+/*
+ * Forward declarations to procedures defined later in this file:
+ */
+
+static Tk_Window CreateTopLevelWindow
+ _ANSI_ARGS_((Tcl_Interp *interp,
+ Tk_Window parent,
+ char *name,
+ TkDisplay *LookupProcedure(Tcl_Interp *interp,
+ char *data,
+ int *screenPtr),
+ char *data));
+static void DoConfigureNotify _ANSI_ARGS_((TkWindow *winPtr));
+static TkDisplay * GetScreenByName _ANSI_ARGS_((Tcl_Interp *interp,
+ char *screenName,
+ int *screenPtr));
+static TkDisplay * GetScreenByDisplay _ANSI_ARGS_((Tcl_Interp *interp,
+ char /*Display*/ *disp,
+ int *screenPtr));
+extern int NameWindow _ANSI_ARGS_((Tcl_Interp *interp,
+ TkWindow *winPtr, TkWindow *parentPtr,
+ char *name));
+static TkWindow * NewWindow _ANSI_ARGS_((TkDisplay *dispPtr,
+ int screenNum, TkWindow *parentPtr));
+
+extern void Tk_DestroyDisplayByNumber _ANSI_ARGS_ ((Display *disp));
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * CreateTopLevelWindow --
+ *
+ * Make a new window that will be at top-level (its parent will
+ * be the root window of a screen).
+ *
+ * Results:
+ * The return value is a token for the new window, or NULL if
+ * an error prevented the new window from being created. If
+ * NULL is returned, an error message will be left in
+ * interp->result.
+ *
+ * Side effects:
+ * A new window structure is allocated locally. An X
+ * window is NOT initially created, but will be created
+ * the first time the window is mapped.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tk_Window
+CreateTopLevelWindow(interp, parent, name, LookupProcedure, data)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ Tk_Window parent; /* Token for logical parent of new window
+ * (used for naming, options, etc.). May
+ * be NULL. */
+ char *name; /* Name for new window; if parent is
+ * non-NULL, must be unique among parent's
+ * children. */
+ TkDisplay *(*LookupProcedure) _ANSI_ARGS_ ((Tcl_Interp *interp, char *data, int *screenPtr));
+ /* Lookup a display structure, either */
+ /* by name or by display connection */
+ char *data; /* Data supplied to LookupProcedure: */
+ /* either a screen name or a display */
+ /* connection */
+{
+ register TkWindow *winPtr;
+ register TkDisplay *dispPtr;
+ int screenId;
+
+ if (!initialized) {
+ initialized = 1;
+ tkWindowContext = XUniqueContext();
+ tkActiveUid = Tk_GetUid("active");
+ tkDisabledUid = Tk_GetUid("disabled");
+ tkNormalUid = Tk_GetUid("normal");
+ }
+
+ if ((LookupProcedure==GetScreenByName) && (parent != NULL) &&
+ (data != NULL) && (data[0] == '\0'))
+ { dispPtr = ((TkWindow *) parent)->dispPtr;
+ screenId = Tk_ScreenNumber(parent);
+ }
+ else
+ { dispPtr = LookupProcedure(interp, data, &screenId);
+ if (dispPtr == NULL) return (Tk_Window) NULL;
+ }
+
+ winPtr = NewWindow(dispPtr, screenId, (TkWindow *) parent);
+
+ /*
+ * Internal windows don't normally ask for StructureNotify events,
+ * since we can generate them internally. However, for top-level
+ * windows we need to as for the events because the window could
+ * be manipulated externally.
+ */
+
+ winPtr->atts.event_mask |= StructureNotifyMask;
+
+ /*
+ * (Need to set the TK_TOP_LEVEL flag immediately here; otherwise
+ * Tk_DestroyWindow will core dump if it is called before the flag
+ * has been set.)
+ */
+
+ winPtr->flags |= TK_TOP_LEVEL;
+ if (parent != NULL) {
+ if (NameWindow(interp, winPtr, (TkWindow *) parent, name) != TCL_OK) {
+ Tk_DestroyWindow((Tk_Window) winPtr);
+ return (Tk_Window) NULL;
+ }
+ }
+ TkWmNewWindow(winPtr);
+ return (Tk_Window) winPtr;
+}
+\f
+TkDisplay * MakeTkDisplay(display, NameLength, screenName)
+ Display *display;
+ int NameLength;
+ char* screenName;
+{
+ register TkDisplay *dispPtr = (TkDisplay *) ckalloc(sizeof(TkDisplay));
+ register long i;
+
+ dispPtr->display = display;
+ dispPtr->nextPtr = tkDisplayList;
+ dispPtr->name = (char *) ckalloc((unsigned) (NameLength+1));
+ dispPtr->lastEventTime = CurrentTime;
+ strncpy(dispPtr->name, screenName, NameLength);
+ dispPtr->focusTopLevelPtr = NULL;
+ dispPtr->focussedOnEnter = 0;
+ dispPtr->name[NameLength] = '\0';
+ dispPtr->bindInfoStale = 1;
+ dispPtr->errorPtr = NULL;
+ dispPtr->deleteCount = 0;
+ dispPtr->commWindow = NULL;
+ dispPtr->selectionOwner = NULL;
+ dispPtr->selectionSerial = 0;
+ dispPtr->multipleAtom = None;
+ dispPtr->atomInit = 0;
+ dispPtr->cursorFont = None;
+ dispPtr->grabWinPtr = NULL;
+ dispPtr->eventualGrabWinPtr = NULL;
+ dispPtr->buttonWinPtr = NULL;
+ dispPtr->serverWinPtr = NULL;
+ dispPtr->firstGrabEventPtr = NULL;
+ dispPtr->lastGrabEventPtr = NULL;
+ dispPtr->grabFlags = 0;
+ dispPtr->colorModels =
+ (Tk_ColorModel *) ckalloc((unsigned)
+ (ScreenCount(display)*
+ sizeof(Tk_ColorModel)));
+ for (i = ScreenCount(display)-1; i >= 0; i--) {
+ if (DisplayPlanes(display, i) <= 4) {
+ dispPtr->colorModels[i] = TK_MONO;
+ } else {
+ dispPtr->colorModels[i] = TK_COLOR;
+ }
+ }
+ tkDisplayList = dispPtr;
+ Tk_CreateFileHandler(ConnectionNumber(display),
+ TK_READABLE, (void (*)()) NULL,
+ (ClientData) display);
+ return dispPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetScreenByName --
+ *
+ * Given a string name for a display-plus-screen, find the
+ * TkDisplay structure for the display and return the screen
+ * number too.
+ *
+ * Results:
+ * The return value is a pointer to information about the display,
+ * or NULL if the display couldn't be opened. In this case, an
+ * error message is left in interp->result. The location at
+ * *screenPtr is overwritten with the screen number parsed from
+ * screenName.
+ *
+ * Side effects:
+ * A new connection is opened to the display if there is no
+ * connection already. A new TkDisplay data structure is also
+ * setup, if necessary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static TkDisplay *
+GetScreenByName(interp, screenName, screenPtr)
+ Tcl_Interp *interp; /* Place to leave error message. */
+ char *screenName; /* Name for screen. NULL or empty means
+ * use DISPLAY envariable. */
+ int *screenPtr; /* Where to store screen number. */
+{
+ register TkDisplay *dispPtr;
+ char *p;
+ int length, screenId, i;
+
+ /*
+ * Separate the screen number from the rest of the display
+ * name. ScreenName is assumed to have the syntax
+ * <display>.<screen> with the dot and the screen being
+ * optional.
+ */
+
+ if ((screenName == NULL) || (screenName[0] == '\0')) {
+ screenName = getenv("DISPLAY");
+ if (screenName == NULL) {
+ interp->result =
+ "no display name and no $DISPLAY environment variable";
+ return (TkDisplay *) NULL;
+ }
+ }
+ length = strlen(screenName);
+ screenId = 0;
+ p = screenName+length-1;
+ while (isdigit(*p) && (p != screenName)) {
+ p--;
+ }
+ if ((*p == '.') && (p[1] != '\0')) {
+ length = p - screenName;
+ screenId = strtoul(p+1, (char **) NULL, 10);
+ }
+
+ /*
+ * See if we already have a connection to this display. If not,
+ * then open a new connection.
+ */
+
+ for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr)
+ { if (dispPtr == NULL)
+ { Display *display;
+ /* block and unblock added by Hal -- 7/22/95 in an attempt to fix a problem
+ with making this work over PPP (i.e. slow) connections */
+ block_signals ();
+ display = XOpenDisplay(screenName);
+ unblock_signals ();
+ if (display == NULL)
+ { Tcl_AppendResult(interp, "couldn't connect to display \"",
+ screenName, "\"", (char *) NULL);
+ return (TkDisplay *) NULL;
+ }
+ dispPtr = MakeTkDisplay(display, length, screenName);
+ break;
+ }
+ if ((strncmp(dispPtr->name, screenName, length) == 0)
+ && (dispPtr->name[length] == '\0'))
+ {
+ break;
+ }
+ }
+ if (screenId >= ScreenCount(dispPtr->display)) {
+ sprintf(interp->result, "bad screen number \"%d\"", screenId);
+ return (TkDisplay *) NULL;
+ }
+ *screenPtr = screenId;
+ return dispPtr;
+}
+
+static TkDisplay *GetScreenByDisplay(interp, disp, screenPtr)
+ Tcl_Interp *interp;
+ char *disp;
+ int *screenPtr;
+/* GetScreenByDisplay assumes screen 0! */
+{ Display *Disp = (Display *) disp;
+ register TkDisplay *dispPtr;
+
+ for (dispPtr = tkDisplayList; ; dispPtr = dispPtr->nextPtr)
+ { if (dispPtr == NULL)
+ { dispPtr = MakeTkDisplay(Disp, 0, "");
+ break;
+ }
+ if (Disp==(dispPtr->display)) break;
+ }
+ *screenPtr = 0;
+ return dispPtr;
+}
+
+void Tk_DestroyDisplayByNumber(Disp)
+ Display *Disp;
+/* Tk_DestroyDisplayByNumber assumes screen 0! */
+{ register TkDisplay *dispPtr, *Prev=(TkDisplay *) NULL;
+
+ for (dispPtr = tkDisplayList; dispPtr != NULL;
+ Prev=dispPtr, dispPtr = dispPtr->nextPtr)
+ { if (Disp==(dispPtr->display))
+ { if (Prev==(TkDisplay *) NULL)
+ tkDisplayList = dispPtr->nextPtr;
+ else Prev->nextPtr = dispPtr->nextPtr;
+ ckfree(dispPtr->name);
+ ckfree(dispPtr->colorModels);
+ ckfree(dispPtr);
+ Tk_DeleteFileHandler(ConnectionNumber(Disp));
+ return;
+ }
+ }
+ return;
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * NewWindow --
+ *
+ * This procedure creates and initializes a TkWindow structure.
+ *
+ * Results:
+ * The return value is a pointer to the new window.
+ *
+ * Side effects:
+ * A new window structure is allocated and all its fields are
+ * initialized.
+ *
+ *--------------------------------------------------------------
+ */
+
+static TkWindow *
+NewWindow(dispPtr, screenNum, parentPtr)
+ TkDisplay *dispPtr; /* Display associated with new window. */
+ int screenNum; /* Index of screen for new window. */
+ TkWindow *parentPtr; /* Parent from which this window should
+ * inherit visual inforamtion. NULL means
+ * use screen defaults instead of
+ * inheriting. */
+{
+ register TkWindow *winPtr;
+
+ winPtr = (TkWindow *) ckalloc(sizeof(TkWindow));
+ winPtr->display = dispPtr->display;
+ winPtr->dispPtr = dispPtr;
+ winPtr->screenNum = screenNum;
+ if (parentPtr != NULL) {
+ winPtr->visual = parentPtr->visual;
+ winPtr->depth = parentPtr->depth;
+ } else {
+ winPtr->visual = DefaultVisual(dispPtr->display, screenNum);
+ winPtr->depth = DefaultDepth(dispPtr->display, screenNum);
+ }
+ winPtr->window = None;
+ winPtr->childList = NULL;
+ winPtr->parentPtr = NULL;
+ winPtr->nextPtr = NULL;
+ winPtr->mainPtr = NULL;
+ winPtr->pathName = NULL;
+ winPtr->nameUid = NULL;
+ winPtr->classUid = NULL;
+ winPtr->changes = defChanges;
+ winPtr->dirtyChanges = CWX|CWY|CWWidth|CWHeight|CWBorderWidth;
+ winPtr->atts = defAtts;
+ if (parentPtr != NULL) {
+ winPtr->atts.colormap = parentPtr->atts.colormap;
+ } else {
+ winPtr->atts.colormap = DefaultColormap(dispPtr->display, screenNum);
+ }
+ winPtr->dirtyAtts = CWEventMask|CWColormap;
+ winPtr->flags = 0;
+ winPtr->handlerList = NULL;
+ winPtr->focusProc = NULL;
+ winPtr->focusData = NULL;
+ winPtr->optionLevel = -1;
+ winPtr->selHandlerList = NULL;
+ winPtr->selClearProc = NULL;
+ winPtr->selClearData = NULL;
+ winPtr->geomProc = NULL;
+ winPtr->geomData = NULL;
+ winPtr->reqWidth = winPtr->reqHeight = 0;
+ winPtr->internalBorderWidth = 0;
+ winPtr->wmInfoPtr = NULL;
+
+ return winPtr;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * NameWindow --
+ *
+ * This procedure is invoked to give a window a name and insert
+ * the window into the hierarchy associated with a particular
+ * application.
+ *
+ * Results:
+ * A standard Tcl return value.
+ *
+ * Side effects:
+ * See above.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+NameWindow(interp, winPtr, parentPtr, name)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ register TkWindow *winPtr; /* Window that is to be named and inserted. */
+ TkWindow *parentPtr; /* Pointer to logical parent for winPtr
+ * (used for naming, options, etc.). */
+ char *name; /* Name for winPtr; must be unique among
+ * parentPtr's children. */
+{
+#define FIXED_SIZE 200
+ char staticSpace[FIXED_SIZE];
+ char *pathName;
+ int new;
+ Tcl_HashEntry *hPtr;
+ int length1, length2;
+
+ /*
+ * Setup all the stuff except name right away, then do the name stuff
+ * last. This is so that if the name stuff fails, everything else
+ * will be properly initialized (needed to destroy the window cleanly
+ * after the naming failure).
+ */
+ winPtr->parentPtr = parentPtr;
+ winPtr->nextPtr = parentPtr->childList;
+ parentPtr->childList = winPtr;
+ winPtr->mainPtr = parentPtr->mainPtr;
+ winPtr->nameUid = Tk_GetUid(name);
+
+ /*
+ * Don't permit names that start with an upper-case letter: this
+ * will just cause confusion with class names in the option database.
+ */
+
+ if (isupper(name[0])) {
+ Tcl_AppendResult(interp,
+ "window name starts with an upper-case letter: \"",
+ name, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * To permit names of arbitrary length, must be prepared to malloc
+ * a buffer to hold the new path name. To run fast in the common
+ * case where names are short, use a fixed-size buffer on the
+ * stack.
+ */
+
+ length1 = strlen(parentPtr->pathName);
+ length2 = strlen(name);
+ if ((length1+length2+2) <= FIXED_SIZE) {
+ pathName = staticSpace;
+ } else {
+ pathName = (char *) ckalloc((unsigned) (length1+length2+2));
+ }
+ if (length1 == 1) {
+ pathName[0] = '.';
+ strcpy(pathName+1, name);
+ } else {
+ strcpy(pathName, parentPtr->pathName);
+ pathName[length1] = '.';
+ strcpy(pathName+length1+1, name);
+ }
+ hPtr = Tcl_CreateHashEntry(&parentPtr->mainPtr->nameTable, pathName, &new);
+ if (pathName != staticSpace) {
+ ckfree(pathName);
+ }
+ if (!new) {
+ Tcl_AppendResult(interp, "window name \"", name,
+ "\" already exists in parent", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetHashValue(hPtr, winPtr);
+ winPtr->pathName = Tcl_GetHashKey(&parentPtr->mainPtr->nameTable, hPtr);
+ return TCL_OK;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_CreateMainWindow --
+ *
+ * Make a new main window. A main window is a special kind of
+ * top-level window used as the outermost window in an
+ * application.
+ *
+ * Results:
+ * The return value is a token for the new window, or NULL if
+ * an error prevented the new window from being created. If
+ * NULL is returned, an error message will be left in
+ * interp->result.
+ *
+ * Side effects:
+ * A new window structure is allocated locally; "interp" is
+ * associated with the window and registered for "send" commands
+ * under "baseName". BaseName may be extended with an instance
+ * number in the form "#2" if necessary to make it globally
+ * unique. Tk-related commands are bound into interp. An X
+ * window is NOT initially created, but will be created the
+ * first time the window is mapped.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_Window
+Tk_CreateMainWindow_from_data(interp, baseName, LookupProcedure, data)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ char *baseName; /* Base name for application; usually of the
+ * form "prog instance". */
+ TkDisplay *(*LookupProcedure) _ANSI_ARGS_ ((Tcl_Interp *interp, char *data, int *screenPtr));
+ /* Lookup a display structure, either */
+ /* by name or by display connection */
+ char *data; /* Data supplied to LookupProcedure */
+{
+ Tk_Window tkwin;
+ int result, dummy;
+ Tcl_HashEntry *hPtr;
+ register TkMainInfo *mainPtr;
+ register TkWindow *winPtr;
+ register TkCmd *cmdPtr;
+ char *libDir;
+
+ /*
+ * Create the basic TkWindow structure.
+ */
+
+ tkwin = CreateTopLevelWindow(interp, (Tk_Window) NULL, baseName,
+ LookupProcedure, data);
+ if (tkwin == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Create the TkMainInfo structure for this application, and set
+ * up name-related information for the new window.
+ */
+
+ winPtr = (TkWindow *) tkwin;
+ mainPtr = (TkMainInfo *) ckalloc(sizeof(TkMainInfo));
+ mainPtr->winPtr = winPtr;
+ mainPtr->interp = interp;
+ Tcl_InitHashTable(&mainPtr->nameTable, TCL_STRING_KEYS);
+ mainPtr->bindingTable = Tk_CreateBindingTable(interp);
+ mainPtr->focusPtr = winPtr;
+ mainPtr->focusDefaultPtr = NULL;
+ mainPtr->optionRootPtr = NULL;
+ winPtr->mainPtr = mainPtr;
+ hPtr = Tcl_CreateHashEntry(&mainPtr->nameTable, ".", &dummy);
+ Tcl_SetHashValue(hPtr, winPtr);
+ winPtr->pathName = Tcl_GetHashKey(&mainPtr->nameTable, hPtr);
+
+ /*
+ * Register the interpreter for "send" purposes. If baseName isn't
+ * already unique, find a unique suffix to add to it to make it
+ * unique. Change the window's name to contain the suffix.
+ */
+
+ result = Tk_RegisterInterp(interp, baseName, tkwin);
+ if (result == TCL_OK) {
+ winPtr->nameUid = Tk_GetUid(baseName);
+ } else {
+ char newName[110];
+ int i;
+
+ for (i = 2; ; i++) {
+ sprintf(newName, "%.100s #%d", baseName, i);
+ Tcl_SetResult(interp, (char *) NULL, TCL_STATIC);
+ result = Tk_RegisterInterp(interp, newName, tkwin);
+ if (result == TCL_OK) {
+ break;
+ }
+ if (i >= 100) {
+ Tcl_SetResult(interp,
+ "couldn't generate unique name to register application",
+ TCL_STATIC);
+ Tk_DestroyWindow(tkwin);
+ }
+ }
+ winPtr->nameUid = Tk_GetUid(newName);
+ }
+
+ /*
+ * Bind in Tk's commands.
+ */
+
+ for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
+ Tcl_CreateCommand(interp, cmdPtr->name, cmdPtr->cmdProc,
+ (ClientData) tkwin, (void (*)()) NULL);
+ }
+
+ /*
+ * Set variables for the intepreter.
+ */
+
+ libDir = getenv("TK_LIBRARY");
+ if (libDir == NULL) {
+ libDir = TK_LIBRARY;
+ }
+ Tcl_SetVar(interp, "tk_library", libDir, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tk_version", TK_VERSION, TCL_GLOBAL_ONLY);
+ Tcl_SetVar(interp, "tkVersion", TK_VERSION, TCL_GLOBAL_ONLY);
+
+ tk_NumMainWindows++;
+ return tkwin;
+}
+
+Tk_Window
+ Tk_CreateMainWindow(interp, screenName, baseName)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ char *screenName; /* Name of screen on which to create
+ * window. Empty or NULL string means
+ * use DISPLAY environment variable. */
+ char *baseName; /* Base name for application; usually of the
+ * form "prog instance". */
+{ return Tk_CreateMainWindow_from_data(interp, baseName,
+ GetScreenByName, screenName);
+}
+
+Tk_Window
+Tk_CreateMainWindow_from_display(interp, display, baseName)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting. */
+ Display *display; /* X Display connection */
+ char *baseName; /* Base name for application; usually of the
+ * form "prog instance". */
+{ return Tk_CreateMainWindow_from_data(interp, baseName,
+ GetScreenByDisplay,
+ (char *) display);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_CreateWindow --
+ *
+ * Create a new internal or top-level window as a child of an
+ * existing window.
+ *
+ * Results:
+ * The return value is a token for the new window. This
+ * is not the same as X's token for the window. If an error
+ * occurred in creating the window (e.g. no such display or
+ * screen), then an error message is left in interp->result and
+ * NULL is returned.
+ *
+ * Side effects:
+ * A new window structure is allocated locally. An X
+ * window is not initially created, but will be created
+ * the first time the window is mapped.
+ *
+ *--------------------------------------------------------------
+ */
+
+Tk_Window
+Tk_CreateWindow(interp, parent, name, screenName)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting.
+ * Interp->result is assumed to be
+ * initialized by the caller. */
+ Tk_Window parent; /* Token for parent of new window. */
+ char *name; /* Name for new window. Must be unique
+ * among parent's children. */
+ char *screenName; /* If NULL, new window will be internal on
+ * same screen as its parent. If non-NULL,
+ * gives name of screen on which to create
+ * new window; window will be a top-level
+ * window. */
+{
+ TkWindow *parentPtr = (TkWindow *) parent;
+ TkWindow *winPtr;
+
+ if (screenName == NULL)
+ { winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum,
+ parentPtr);
+ if (NameWindow(interp, winPtr, parentPtr, name) != TCL_OK)
+ { Tk_DestroyWindow((Tk_Window) winPtr);
+ return NULL;
+ }
+ else
+ { return (Tk_Window) winPtr;
+ }
+ }
+ else
+ { return CreateTopLevelWindow(interp, parent, name,
+ GetScreenByName, screenName);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_CreateWindowFromPath --
+ *
+ * This procedure is similar to Tk_CreateInternalWindow except
+ * that it uses a path name to create the window, rather than
+ * a parent and a child name.
+ *
+ * Results:
+ * The return value is a token for the new window. This
+ * is not the same as X's token for the window. If an error
+ * occurred in creating the window (e.g. no such display or
+ * screen), then an error message is left in interp->result and
+ * NULL is returned.
+ *
+ * Side effects:
+ * A new window structure is allocated locally. An X
+ * window is not initially created, but will be created
+ * the first time the window is mapped.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_Window
+Tk_CreateWindowFromPath(interp, tkwin, pathName, screenName)
+ Tcl_Interp *interp; /* Interpreter to use for error reporting.
+ * Interp->result is assumed to be
+ * initialized by the caller. */
+ Tk_Window tkwin; /* Token for any window in application
+ * that is to contain new window. */
+ char *pathName; /* Path name for new window within the
+ * application of tkwin. The parent of
+ * this window must already exist, but
+ * the window itself must not exist. */
+ char *screenName; /* If NULL, new window will be on same
+ * screen as its parent. If non-NULL,
+ * gives name of screen on which to create
+ * new window; window will be a top-level
+ * window. */
+{
+#define FIXED_SPACE 5
+ char fixedSpace[FIXED_SPACE+1];
+ char *p;
+ Tk_Window parent;
+ int numChars;
+
+ /*
+ * Strip the parent's name out of pathName (it's everything up
+ * to the last dot). There are two tricky parts: (a) must
+ * copy the parent's name somewhere else to avoid modifying
+ * the pathName string (for large names, space for the copy
+ * will have to be malloc'ed); (b) must special-case the
+ * situation where the parent is ".".
+ */
+
+ p = strrchr(pathName, '.');
+ if (p == NULL) {
+ Tcl_AppendResult(interp, "bad window path name \"", pathName,
+ "\"", (char *) NULL);
+ return NULL;
+ }
+ numChars = p-pathName;
+ if (numChars > FIXED_SPACE) {
+ p = (char *) ckalloc((unsigned) (numChars+1));
+ } else {
+ p = fixedSpace;
+ }
+ if (numChars == 0) {
+ *p = '.';
+ p[1] = '\0';
+ } else {
+ strncpy(p, pathName, numChars);
+ p[numChars] = '\0';
+ }
+
+ /*
+ * Find the parent window.
+ */
+
+ parent = Tk_NameToWindow(interp, p, tkwin);
+ if (p != fixedSpace) {
+ ckfree(p);
+ }
+ if (parent == NULL) {
+ return NULL;
+ }
+
+ /*
+ * Create the window.
+ */
+
+ if (screenName == NULL) {
+ TkWindow *parentPtr = (TkWindow *) parent;
+ TkWindow *winPtr;
+
+ winPtr = NewWindow(parentPtr->dispPtr, parentPtr->screenNum,
+ parentPtr);
+ if (NameWindow(interp, winPtr, parentPtr, pathName+numChars+1)
+ != TCL_OK) {
+ Tk_DestroyWindow((Tk_Window) winPtr);
+ return NULL;
+ } else
+ { return (Tk_Window) winPtr;
+ }
+ } else {
+ return CreateTopLevelWindow(interp, parent, pathName+numChars+1,
+ GetScreenByName, screenName);
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_DestroyWindow --
+ *
+ * Destroy an existing window. After this call, the caller
+ * should never again use the token.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The window is deleted, along with all of its children.
+ * Relevant callback procedures are invoked.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_DestroyWindow(tkwin)
+ Tk_Window tkwin; /* Window to destroy. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+ XEvent event;
+
+ if (winPtr->flags & TK_ALREADY_DEAD) {
+ /*
+ * An destroy event binding caused the window to be destroyed
+ * again. Ignore the request.
+ */
+
+ return;
+ }
+
+ /*
+ * Recursively destroy children. The TK_RECURSIVE_DESTROY
+ * flags means that the child's window needn't be explicitly
+ * destroyed (the destroy of the parent already did it), nor
+ * does it need to be removed from its parent's child list,
+ * since the parent is being destroyed too.
+ */
+
+ while (winPtr->childList != NULL) {
+ winPtr->childList->flags |= TK_RECURSIVE_DESTROY;
+ Tk_DestroyWindow((Tk_Window) winPtr->childList);
+ }
+
+ /*
+ * Generate a DestroyNotify event. In order for the DestroyNotify
+ * event to be processed correctly, need to make sure the window
+ * exists. This is a bit of a kludge, and may be unnecessarily
+ * expensive, but without it no event handlers will get called for
+ * windows that don't exist yet.
+ */
+
+ if (winPtr->window == None) {
+ Tk_MakeWindowExist(tkwin);
+ }
+ winPtr->flags |= TK_ALREADY_DEAD;
+ event.type = DestroyNotify;
+ event.xdestroywindow.serial =
+ LastKnownRequestProcessed(winPtr->display);
+ event.xdestroywindow.send_event = False;
+ event.xdestroywindow.display = winPtr->display;
+ event.xdestroywindow.event = winPtr->window;
+ event.xdestroywindow.window = winPtr->window;
+ Tk_HandleEvent(&event);
+
+ /*
+ * Cleanup the data structures associated with this window.
+ * No need to destroy windows during recursive destroys, since
+ * that will happen automatically when the parent window is
+ * destroyed (not true for top-level windows: must destroy
+ * them explicitly).
+ */
+
+ if (winPtr->window != None) {
+ if (!(winPtr->flags & TK_RECURSIVE_DESTROY)
+ || (winPtr->flags & TK_TOP_LEVEL)) {
+ XDestroyWindow(winPtr->display, winPtr->window);
+ }
+ XDeleteContext(winPtr->display, winPtr->window, tkWindowContext);
+ winPtr->window = None;
+ }
+ if (winPtr->parentPtr != NULL) {
+ if (winPtr->parentPtr->childList == winPtr) {
+ winPtr->parentPtr->childList = winPtr->nextPtr;
+ } else {
+ register TkWindow *winPtr2;
+
+ for (winPtr2 = winPtr->parentPtr->childList; ;
+ winPtr2 = winPtr2->nextPtr) {
+ if (winPtr2 == NULL) {
+ panic("Tk_DestroyWindow couldn't find child in parent (deleted twice?)");
+ break;
+ }
+ if (winPtr2->nextPtr == winPtr) {
+ winPtr2->nextPtr = winPtr->nextPtr;
+ break;
+ }
+ }
+ }
+ }
+ TkEventDeadWindow(winPtr);
+ TkFocusDeadWindow(winPtr);
+ TkOptionDeadWindow(winPtr);
+ TkSelDeadWindow(winPtr);
+ if (winPtr->flags & TK_TOP_LEVEL) {
+ TkWmDeadWindow(winPtr);
+ }
+ TkGrabDeadWindow(winPtr);
+ if (winPtr->mainPtr != NULL) {
+ Tk_DeleteAllBindings(winPtr->mainPtr->bindingTable,
+ (ClientData) winPtr->pathName);
+ if (winPtr->pathName != NULL) {
+ Tcl_DeleteHashEntry(Tcl_FindHashEntry(&winPtr->mainPtr->nameTable,
+ winPtr->pathName));
+ }
+ if (winPtr->mainPtr->winPtr == winPtr) {
+ register TkCmd *cmdPtr;
+
+ /*
+ * Deleting a main window. Delete the TkMainInfo structure too
+ * and replace all of Tk's commands with dummy commands that
+ * return errors. Also delete the "send" command to unregister
+ * the interpreter.
+ */
+
+ for (cmdPtr = commands; cmdPtr->name != NULL; cmdPtr++) {
+ Tcl_CreateCommand(winPtr->mainPtr->interp, cmdPtr->name,
+ TkDeadAppCmd, (ClientData) NULL, (void (*)()) NULL);
+ }
+ Tcl_CreateCommand(winPtr->mainPtr->interp, "send",
+ TkDeadAppCmd, (ClientData) NULL, (void (*)()) NULL);
+ Tcl_DeleteHashTable(&winPtr->mainPtr->nameTable);
+ Tk_DeleteBindingTable(winPtr->mainPtr->bindingTable);
+ ckfree((char *) winPtr->mainPtr);
+ tk_NumMainWindows--;
+ }
+ }
+ ckfree((char *) winPtr);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_MapWindow --
+ *
+ * Map a window within its parent. This may require the
+ * window and/or its parents to actually be created.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The given window will be mapped. Windows may also
+ * be created.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_MapWindow(tkwin)
+ Tk_Window tkwin; /* Token for window to map. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+ XEvent event;
+
+ if (winPtr->flags & TK_MAPPED) {
+ return;
+ }
+ if (winPtr->window == None) {
+ Tk_MakeWindowExist(tkwin);
+ }
+ if (winPtr->flags & TK_TOP_LEVEL) {
+ /*
+ * Lots of special processing has to be done for top-level
+ * windows. Let tkWm.c handle everything itself.
+ */
+
+ TkWmMapWindow(winPtr);
+ return;
+ }
+ winPtr->flags |= TK_MAPPED;
+ XMapWindow(winPtr->display, winPtr->window);
+ event.type = MapNotify;
+ event.xmap.serial = LastKnownRequestProcessed(winPtr->display);
+ event.xmap.send_event = False;
+ event.xmap.display = winPtr->display;
+ event.xmap.event = winPtr->window;
+ event.xmap.window = winPtr->window;
+ event.xmap.override_redirect = winPtr->atts.override_redirect;
+ Tk_HandleEvent(&event);
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_MakeWindowExist --
+ *
+ * Ensure that a particular window actually exists. This
+ * procedure shouldn't normally need to be invoked from
+ * outside the Tk package, but may be needed if someone
+ * wants to manipulate a window before mapping it.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * When the procedure returns, the X window associated with
+ * tkwin is guaranteed to exist. This may require the
+ * window's ancestors to be created also.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_MakeWindowExist(tkwin)
+ Tk_Window tkwin; /* Token for window. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+ Window parent;
+
+ if (winPtr->window != None) {
+ return;
+ }
+
+ if (winPtr->flags & TK_TOP_LEVEL) {
+ parent = XRootWindow(winPtr->display, winPtr->screenNum);
+ } else {
+ if (winPtr->parentPtr->window == None) {
+ Tk_MakeWindowExist((Tk_Window) winPtr->parentPtr);
+ }
+ parent = winPtr->parentPtr->window;
+ }
+
+ winPtr->window = XCreateWindow(winPtr->display, parent,
+ winPtr->changes.x, winPtr->changes.y,
+ winPtr->changes.width, winPtr->changes.height,
+ winPtr->changes.border_width, winPtr->depth,
+ InputOutput, winPtr->visual, winPtr->dirtyAtts,
+ &winPtr->atts);
+ XSaveContext(winPtr->display, winPtr->window, tkWindowContext,
+ (caddr_t) winPtr);
+ winPtr->dirtyAtts = 0;
+ winPtr->dirtyChanges &= ~(CWX|CWY|CWWidth|CWHeight|CWBorderWidth);
+ if (winPtr->dirtyChanges != 0) {
+ XConfigureWindow(winPtr->display, winPtr->window,
+ winPtr->dirtyChanges, &winPtr->changes);
+ winPtr->dirtyChanges = 0;
+ }
+
+ /*
+ * Issue a ConfigureNotify event if there were deferred configuration
+ * changes.
+ */
+
+ if (winPtr->flags & TK_NEED_CONFIG_NOTIFY) {
+ winPtr->flags &= ~TK_NEED_CONFIG_NOTIFY;
+ DoConfigureNotify(winPtr);
+ }
+}
+\f
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_UnmapWindow, etc. --
+ *
+ * There are several procedures under here, each of which
+ * mirrors an existing X procedure. In addition to performing
+ * the functions of the corresponding procedure, each
+ * procedure also updates the local window structure and
+ * synthesizes an X event (if the window's structure is being
+ * managed internally).
+ *
+ * Results:
+ * See the manual entries.
+ *
+ * Side effects:
+ * See the manual entries.
+ *
+ *--------------------------------------------------------------
+ */
+
+void
+Tk_UnmapWindow(tkwin)
+ Tk_Window tkwin; /* Token for window to unmap. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ if (!(winPtr->flags & TK_MAPPED)) {
+ return;
+ }
+ winPtr->flags &= ~TK_MAPPED;
+ XUnmapWindow(winPtr->display, winPtr->window);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ XEvent event;
+
+ event.type = UnmapNotify;
+ event.xunmap.serial = LastKnownRequestProcessed(winPtr->display);
+ event.xunmap.send_event = False;
+ event.xunmap.display = winPtr->display;
+ event.xunmap.event = winPtr->window;
+ event.xunmap.window = winPtr->window;
+ event.xunmap.from_configure = False;
+ Tk_HandleEvent(&event);
+ }
+}
+
+void
+Tk_ConfigureWindow(tkwin, valueMask, valuePtr)
+ Tk_Window tkwin; /* Window to re-configure. */
+ unsigned int valueMask; /* Mask indicating which parts of
+ * *valuePtr are to be used. */
+ XWindowChanges *valuePtr; /* New values. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ if (valueMask & CWX) {
+ winPtr->changes.x = valuePtr->x;
+ }
+ if (valueMask & CWY) {
+ winPtr->changes.y = valuePtr->y;
+ }
+ if (valueMask & CWWidth) {
+ winPtr->changes.width = valuePtr->width;
+ }
+ if (valueMask & CWHeight) {
+ winPtr->changes.height = valuePtr->height;
+ }
+ if (valueMask & CWBorderWidth) {
+ winPtr->changes.border_width = valuePtr->border_width;
+ }
+ if (valueMask & CWSibling) {
+ winPtr->changes.sibling = valuePtr->sibling;
+ }
+ if (valueMask & CWStackMode) {
+ winPtr->changes.stack_mode = valuePtr->stack_mode;
+ }
+
+ if (winPtr->window != None) {
+ XConfigureWindow(winPtr->display, winPtr->window,
+ valueMask, valuePtr);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ DoConfigureNotify(winPtr);
+ }
+ } else {
+ winPtr->dirtyChanges |= valueMask;
+ winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
+ }
+}
+
+void
+Tk_MoveWindow(tkwin, x, y)
+ Tk_Window tkwin; /* Window to move. */
+ int x, y; /* New location for window (within
+ * parent). */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->changes.x = x;
+ winPtr->changes.y = y;
+ if (winPtr->window != None) {
+ XMoveWindow(winPtr->display, winPtr->window, x, y);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ DoConfigureNotify(winPtr);
+ }
+ } else {
+ winPtr->dirtyChanges |= CWX|CWY;
+ winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
+ }
+}
+
+void
+Tk_ResizeWindow(tkwin, width, height)
+ Tk_Window tkwin; /* Window to resize. */
+ unsigned int width, height; /* New dimensions for window. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->changes.width = width;
+ winPtr->changes.height = height;
+ if (winPtr->window != None) {
+ XResizeWindow(winPtr->display, winPtr->window, width, height);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ DoConfigureNotify(winPtr);
+ }
+ } else {
+ winPtr->dirtyChanges |= CWWidth|CWHeight;
+ winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
+ }
+}
+
+void
+Tk_MoveResizeWindow(tkwin, x, y, width, height)
+ Tk_Window tkwin; /* Window to move and resize. */
+ int x, y; /* New location for window (within
+ * parent). */
+ unsigned int width, height; /* New dimensions for window. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->changes.x = x;
+ winPtr->changes.y = y;
+ winPtr->changes.width = width;
+ winPtr->changes.height = height;
+ if (winPtr->window != None) {
+ XMoveResizeWindow(winPtr->display, winPtr->window,
+ x, y, width, height);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ DoConfigureNotify(winPtr);
+ }
+ } else {
+ winPtr->dirtyChanges |= CWX|CWY|CWWidth|CWHeight;
+ winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
+ }
+}
+
+void
+Tk_SetWindowBorderWidth(tkwin, width)
+ Tk_Window tkwin; /* Window to modify. */
+ int width; /* New border width for window. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->changes.border_width = width;
+ if (winPtr->window != None) {
+ XSetWindowBorderWidth(winPtr->display, winPtr->window, width);
+ if (!(winPtr->flags & TK_TOP_LEVEL)) {
+ DoConfigureNotify(winPtr);
+ }
+ } else {
+ winPtr->dirtyChanges |= CWBorderWidth;
+ winPtr->flags |= TK_NEED_CONFIG_NOTIFY;
+ }
+}
+
+void
+Tk_ChangeWindowAttributes(tkwin, valueMask, attsPtr)
+ Tk_Window tkwin; /* Window to manipulate. */
+ unsigned long valueMask; /* OR'ed combination of bits,
+ * indicating which fields of
+ * *attsPtr are to be used. */
+ register XSetWindowAttributes *attsPtr;
+ /* New values for some attributes. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ if (valueMask & CWBackPixmap) {
+ winPtr->atts.background_pixmap = attsPtr->background_pixmap;
+ }
+ if (valueMask & CWBackPixel) {
+ winPtr->atts.background_pixel = attsPtr->background_pixel;
+ }
+ if (valueMask & CWBorderPixmap) {
+ winPtr->atts.border_pixmap = attsPtr->border_pixmap;
+ }
+ if (valueMask & CWBorderPixel) {
+ winPtr->atts.border_pixel = attsPtr->border_pixel;
+ }
+ if (valueMask & CWBitGravity) {
+ winPtr->atts.bit_gravity = attsPtr->bit_gravity;
+ }
+ if (valueMask & CWWinGravity) {
+ winPtr->atts.win_gravity = attsPtr->win_gravity;
+ }
+ if (valueMask & CWBackingStore) {
+ winPtr->atts.backing_store = attsPtr->backing_store;
+ }
+ if (valueMask & CWBackingPlanes) {
+ winPtr->atts.backing_planes = attsPtr->backing_planes;
+ }
+ if (valueMask & CWBackingPixel) {
+ winPtr->atts.backing_pixel = attsPtr->backing_pixel;
+ }
+ if (valueMask & CWOverrideRedirect) {
+ winPtr->atts.override_redirect = attsPtr->override_redirect;
+ }
+ if (valueMask & CWSaveUnder) {
+ winPtr->atts.save_under = attsPtr->save_under;
+ }
+ if (valueMask & CWEventMask) {
+ winPtr->atts.event_mask = attsPtr->event_mask;
+ }
+ if (valueMask & CWDontPropagate) {
+ winPtr->atts.do_not_propagate_mask
+ = attsPtr->do_not_propagate_mask;
+ }
+ if (valueMask & CWColormap) {
+ winPtr->atts.colormap = attsPtr->colormap;
+ }
+ if (valueMask & CWCursor) {
+ winPtr->atts.cursor = attsPtr->cursor;
+ }
+
+ if (winPtr->window != None) {
+ XChangeWindowAttributes(winPtr->display, winPtr->window,
+ valueMask, attsPtr);
+ } else {
+ winPtr->dirtyAtts |= valueMask;
+ }
+}
+
+void
+Tk_SetWindowBackground(tkwin, pixel)
+ Tk_Window tkwin; /* Window to manipulate. */
+ unsigned long pixel; /* Pixel value to use for
+ * window's background. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.background_pixel = pixel;
+
+ if (winPtr->window != None) {
+ XSetWindowBackground(winPtr->display, winPtr->window, pixel);
+ } else {
+ winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixmap)
+ | CWBackPixel;
+ }
+}
+
+void
+Tk_SetWindowBackgroundPixmap(tkwin, pixmap)
+ Tk_Window tkwin; /* Window to manipulate. */
+ Pixmap pixmap; /* Pixmap to use for window's
+ * background. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.background_pixmap = pixmap;
+
+ if (winPtr->window != None) {
+ XSetWindowBackgroundPixmap(winPtr->display,
+ winPtr->window, pixmap);
+ } else {
+ winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBackPixel)
+ | CWBackPixmap;
+ }
+}
+
+void
+Tk_SetWindowBorder(tkwin, pixel)
+ Tk_Window tkwin; /* Window to manipulate. */
+ unsigned long pixel; /* Pixel value to use for
+ * window's border. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.border_pixel = pixel;
+
+ if (winPtr->window != None) {
+ XSetWindowBorder(winPtr->display, winPtr->window, pixel);
+ } else {
+ winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixmap)
+ | CWBorderPixel;
+ }
+}
+
+void
+Tk_SetWindowBorderPixmap(tkwin, pixmap)
+ Tk_Window tkwin; /* Window to manipulate. */
+ Pixmap pixmap; /* Pixmap to use for window's
+ * border. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.border_pixmap = pixmap;
+
+ if (winPtr->window != None) {
+ XSetWindowBorderPixmap(winPtr->display,
+ winPtr->window, pixmap);
+ } else {
+ winPtr->dirtyAtts = (winPtr->dirtyAtts & ~CWBorderPixel)
+ | CWBorderPixmap;
+ }
+}
+
+void
+Tk_DefineCursor(tkwin, cursor)
+ Tk_Window tkwin; /* Window to manipulate. */
+ Cursor cursor; /* Cursor to use for window (may be None). */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.cursor = cursor;
+
+ if (winPtr->window != None) {
+ XDefineCursor(winPtr->display, winPtr->window, cursor);
+ } else {
+ winPtr->dirtyAtts = winPtr->dirtyAtts | CWCursor;
+ }
+}
+
+void
+Tk_UndefineCursor(tkwin)
+ Tk_Window tkwin; /* Window to manipulate. */
+{
+ Tk_DefineCursor(tkwin, None);
+}
+
+void
+Tk_SetWindowColormap(tkwin, colormap)
+ Tk_Window tkwin; /* Window to manipulate. */
+ Colormap colormap; /* Colormap to use for window. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->atts.colormap = colormap;
+
+ if (winPtr->window != None) {
+ XSetWindowColormap(winPtr->display, winPtr->window, colormap);
+ } else {
+ winPtr->dirtyAtts |= CWColormap;
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_SetWindowVisual --
+ *
+ * This procedure is called to specify a visual to be used
+ * for a Tk window when it is created. This procedure, if
+ * called at all, must be called before the X window is created
+ * (i.e. before Tk_MakeWindowExist is called).
+ *
+ * Results:
+ * The return value is 1 if successful, or 0 if the X window has
+ * been already created.
+ *
+ * Side effects:
+ * The information given is stored for when the window is created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tk_SetWindowVisual(tkwin, visual, depth, colormap)
+ Tk_Window tkwin; /* Window to manipulate. */
+ Visual *visual; /* New visual for window. */
+ unsigned int depth; /* New depth for window. */
+ Colormap colormap; /* An appropriate colormap for the visual. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ if( winPtr->window != None ){
+ /* Too late! */
+ return 0;
+ }
+
+ winPtr->visual = visual;
+ winPtr->depth = depth;
+ winPtr->atts.colormap = colormap;
+
+ /*
+ * The following code is needed to make sure that the window doesn't
+ * inherit the parent's border pixmap, which would result in a BadMatch
+ * error.
+ */
+
+ if (!(winPtr->dirtyAtts & CWBorderPixmap)) {
+ winPtr->dirtyAtts |= CWBorderPixel;
+ }
+ return 1;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * DoConfigureNotify --
+ *
+ * Generate a ConfigureNotify event describing the current
+ * configuration of a window.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * An event is generated and processed by Tk_HandleEvent.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DoConfigureNotify(winPtr)
+ register TkWindow *winPtr; /* Window whose configuration
+ * was just changed. */
+{
+ XEvent event;
+
+ event.type = ConfigureNotify;
+ event.xconfigure.serial = LastKnownRequestProcessed(winPtr->display);
+ event.xconfigure.send_event = False;
+ event.xconfigure.display = winPtr->display;
+ event.xconfigure.event = winPtr->window;
+ event.xconfigure.window = winPtr->window;
+ event.xconfigure.x = winPtr->changes.x;
+ event.xconfigure.y = winPtr->changes.y;
+ event.xconfigure.width = winPtr->changes.width;
+ event.xconfigure.height = winPtr->changes.height;
+ event.xconfigure.border_width = winPtr->changes.border_width;
+ if (winPtr->changes.stack_mode == Above) {
+ event.xconfigure.above = winPtr->changes.sibling;
+ } else {
+ event.xconfigure.above = None;
+ }
+ event.xconfigure.override_redirect = winPtr->atts.override_redirect;
+ Tk_HandleEvent(&event);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_SetClass --
+ *
+ * This procedure is used to give a window a class.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * A new class is stored for tkwin, replacing any existing
+ * class for it.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tk_SetClass(tkwin, className)
+ Tk_Window tkwin; /* Token for window to assign class. */
+ char *className; /* New class for tkwin. */
+{
+ register TkWindow *winPtr = (TkWindow *) tkwin;
+
+ winPtr->classUid = Tk_GetUid(className);
+ if (winPtr->flags & TK_TOP_LEVEL) {
+ TkWmSetClass(winPtr);
+ }
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_NameToWindow --
+ *
+ * Given a string name for a window, this procedure
+ * returns the token for the window, if there exists a
+ * window corresponding to the given name.
+ *
+ * Results:
+ * The return result is either a token for the window corresponding
+ * to "name", or else NULL to indicate that there is no such
+ * window. In this case, an error message is left in interp->result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_Window
+Tk_NameToWindow(interp, pathName, tkwin)
+ Tcl_Interp *interp; /* Where to report errors. */
+ char *pathName; /* Path name of window. */
+ Tk_Window tkwin; /* Token for window: name is assumed to
+ * belong to the same main window as tkwin. */
+{
+ Tcl_HashEntry *hPtr;
+
+ hPtr = Tcl_FindHashEntry(&((TkWindow *) tkwin)->mainPtr->nameTable,
+ pathName);
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "bad window path name \"",
+ pathName, "\"", (char *) NULL);
+ return NULL;
+ }
+ return (Tk_Window) Tcl_GetHashValue(hPtr);
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_DisplayName --
+ *
+ * Return the textual name of a window's display.
+ *
+ * Results:
+ * The return value is the string name of the display associated
+ * with tkwin.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Tk_DisplayName(tkwin)
+ Tk_Window tkwin; /* Window whose display name is desired. */
+{
+ return ((TkWindow *) tkwin)->dispPtr->name;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_SetColorModel --
+ *
+ * This procedure changes the current color model for a window
+ * (actually, for the window's screen).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The color model for tkwin's screen is set to "model".
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tk_SetColorModel(tkwin, model)
+ Tk_Window tkwin; /* Token for window; this selects a screen
+ * whose color model is to be modified. */
+ Tk_ColorModel model; /* New model for tkwin's screen. */
+{
+ TkWindow *winPtr = (TkWindow *) tkwin;
+ winPtr->dispPtr->colorModels[winPtr->screenNum] = model;
+}
+\f
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tk_GetColorModel --
+ *
+ * This procedure returns the current color model for a window
+ * (actually, for the window's screen).
+ *
+ * Results:
+ * A color model.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tk_ColorModel
+Tk_GetColorModel(tkwin)
+ Tk_Window tkwin; /* Token for window; this selects a screen
+ * whose color model is returned. */
+{
+ TkWindow *winPtr = (TkWindow *) tkwin;
+ return winPtr->dispPtr->colorModels[winPtr->screenNum];
+
+}
--- /dev/null
+#include "scheme.h"
+#include "prims.h"
+
+#define External_Primitive(fn_name) \
+ extern SCHEME_OBJECT EXFUN (fn_name, (void))
+
+External_Primitive(Prim_tcl_eval);
+External_Primitive(Prim_tk_completely_handles_event);
+External_Primitive(Prim_tk_create_tl_window);
+External_Primitive(Prim_tk_do_events);
+External_Primitive(Prim_tk_drain);
+External_Primitive(Prim_tk_generate_scheme_event);
+External_Primitive(Prim_tk_init);
+External_Primitive(Prim_tk_invoke);
+External_Primitive(Prim_tk_kill_app);
+External_Primitive(Prim_tk_manage_geom);
+External_Primitive(Prim_tk_map_widget);
+External_Primitive(Prim_tk_map_window);
+External_Primitive(Prim_tk_move);
+External_Primitive(Prim_tk_move_resize);
+External_Primitive(Prim_tk_next_wakeup);
+External_Primitive(Prim_tk_resize);
+External_Primitive(Prim_tk_unmap_window);
+External_Primitive(Prim_tk_win_req_height);
+External_Primitive(Prim_tk_win_req_width);
+External_Primitive(Prim_tk_widget_get_tkwin);
+External_Primitive(Prim_tk_win_display);
+External_Primitive(Prim_tk_win_is_mapped);
+External_Primitive(Prim_tk_win_height);
+External_Primitive(Prim_tk_win_width);
+External_Primitive(Prim_tk_win_window);
+External_Primitive(Prim_tk_win_x);
+External_Primitive(Prim_tk_win_y);
+External_Primitive(Prim_tk_win_name);
+External_Primitive(Prim_tk_win_pathname);
+External_Primitive(Prim_tk_delete_display);
+External_Primitive(Prim_tk_destroy_widget);
+External_Primitive(Prim_tk_make_button);
+External_Primitive(Prim_tk_make_canvas);
+External_Primitive(Prim_tk_make_check_button);
+External_Primitive(Prim_tk_make_entry);
+External_Primitive(Prim_tk_make_label);
+External_Primitive(Prim_tk_make_listbox);
+External_Primitive(Prim_tk_make_menu);
+External_Primitive(Prim_tk_make_menu_button);
+External_Primitive(Prim_tk_make_message);
+External_Primitive(Prim_tk_make_radio_button);
+External_Primitive(Prim_tk_make_scale);
+External_Primitive(Prim_tk_make_scrollbar);
+External_Primitive(Prim_tk_make_text);
+
+extern char *EXFUN (dload_initialize_file, (void));
+
+char *
+ DEFUN_VOID (dload_initialize_file)
+{ /* Primitives in tk-c-mit.c */
+ declare_primitive ("%tclGlobalEval", Prim_tcl_eval, 2, 2, 0);
+ declare_primitive ("%tkCompletelyHandlesEvent?",
+ Prim_tk_completely_handles_event, 1, 1, 0);
+ declare_primitive ("%tkCreateTopLevelWindow",
+ Prim_tk_create_tl_window, 3, 3, 0);
+ declare_primitive ("%tkDoEvents", Prim_tk_do_events, 0, 0, 0);
+ declare_primitive ("%tkDrainCallBacks", Prim_tk_drain, 2, 2, 0);
+ declare_primitive ("%tkGenerateSchemeEvent",
+ Prim_tk_generate_scheme_event, 2, 2, 0);
+ declare_primitive ("%tkInit", Prim_tk_init, 2, 2, 0);
+ declare_primitive ("%tkInvokeCommand", Prim_tk_invoke, 2, LEXPR, 0);
+ declare_primitive ("%tkKillApplication", Prim_tk_kill_app, 1, 1, 0);
+ declare_primitive ("%tkManageGeometry", Prim_tk_manage_geom, 2, 2, 0);
+ declare_primitive ("%tkMapWidget", Prim_tk_map_widget, 6, 6, 0);
+ declare_primitive ("%tkMapWindow", Prim_tk_map_window, 1, 1, 0);
+ declare_primitive ("%tkMoveWindow", Prim_tk_move, 3, 3, 0);
+ declare_primitive ("%tkMoveResizeWindow", Prim_tk_move_resize, 5, 5, 0);
+ declare_primitive ("%tkNextWakeup", Prim_tk_next_wakeup, 0, 0, 0);
+ declare_primitive ("%tkResizeWindow", Prim_tk_resize, 3, 3, 0);
+ declare_primitive ("%tkUnmapWindow", Prim_tk_unmap_window, 1, 1, 0);
+ declare_primitive ("%tkWinReqHeight", Prim_tk_win_req_height, 1, 1, 0);
+ declare_primitive ("%tkWinReqWidth", Prim_tk_win_req_width, 1, 1, 0);
+ declare_primitive ("%tkWidget.tkwin", Prim_tk_widget_get_tkwin, 1, 1, 0);
+ declare_primitive ("%tkWinDisplay", Prim_tk_win_display, 1, 1, 0);
+ declare_primitive ("%tkWinIsMapped?", Prim_tk_win_is_mapped, 1, 1, 0);
+ declare_primitive ("%tkWinHeight", Prim_tk_win_height, 1, 1, 0);
+ declare_primitive ("%tkWinWidth", Prim_tk_win_width, 1, 1, 0);
+ declare_primitive ("%tkWinWindow", Prim_tk_win_window, 1, 1, 0);
+ declare_primitive ("%tkWinX", Prim_tk_win_x, 1, 1, 0);
+ declare_primitive ("%tkWinY", Prim_tk_win_y, 1, 1, 0);
+ declare_primitive ("%tkWinName", Prim_tk_win_name, 1, 1, 0);
+ declare_primitive ("%tkWinPathName", Prim_tk_win_pathname, 1, 1, 0);
+ /* Primitive in widget-c-mit.c */
+ declare_primitive ("%tkDeleteDisplay", Prim_tk_delete_display, 1, 1, 0);
+ declare_primitive ("%tkDestroyWidget", Prim_tk_destroy_widget, 1, 1, 0);
+ declare_primitive ("%tkMakeButton", Prim_tk_make_button, 2, 2, 0);
+ declare_primitive ("%tkMakeCanvas", Prim_tk_make_canvas, 2, 2, 0);
+ declare_primitive ("%tkMakeCheckButton", Prim_tk_make_check_button, 2, 2, 0);
+ declare_primitive ("%tkMakeEntry", Prim_tk_make_entry, 2, 2, 0);
+ declare_primitive ("%tkMakeLabel", Prim_tk_make_label, 2, 2, 0);
+ declare_primitive ("%tkMakeListbox", Prim_tk_make_listbox, 2, 2, 0);
+ declare_primitive ("%tkMakeMenu", Prim_tk_make_menu, 2, 2, 0);
+ declare_primitive ("%tkMakeMenuButton", Prim_tk_make_menu_button, 2, 2, 0);
+ declare_primitive ("%tkMakeMessage", Prim_tk_make_message, 2, 2, 0);
+ declare_primitive ("%tkMakeRadioButton", Prim_tk_make_radio_button, 2, 2, 0);
+ declare_primitive ("%tkMakeScale", Prim_tk_make_scale, 2, 2, 0);
+ declare_primitive ("%tkMakeScrollBar", Prim_tk_make_scrollbar, 2, 2, 0);
+ declare_primitive ("%tkMakeText", Prim_tk_make_text, 2, 2, 0);
+ return "#UITK";
+}
--- /dev/null
+/* Cover routines to make MIT Scheme primitives out of the procedures */
+/* in button-c.c. */
+
+#include "scheme.h"
+#include "prims.h"
+#include "ansidecl.h"
+#include "X11/Xlib.h"
+
+DEFINE_PRIMITIVE ("%tkDeleteDisplay", Prim_tk_delete_display, 1, 1, 0)
+{ /* (%tkDeleteDisplay XDisplayNumber) */
+ extern void tk_delete_display (Display *disp);
+ PRIMITIVE_HEADER(1);
+ tk_delete_display((Display *) arg_integer(1));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkDestroyWidget", Prim_tk_destroy_widget, 1, 1, 0)
+{ /* (%tkDestroyWidget tk-handle ) */
+ extern void tk_destroy_widget(long /*Button **/ button);
+ PRIMITIVE_HEADER(1);
+ tk_destroy_widget((long /*Button **/) arg_integer(1));
+ PRIMITIVE_RETURN(UNSPECIFIC);
+}
+
+DEFINE_PRIMITIVE ("%tkMakeButton", Prim_tk_make_button, 2, 2, 0)
+{ /* (%tkMakeButton ParentTKWindow name-string)
+ */
+ extern int *MakeButton(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeButton((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeCanvas", Prim_tk_make_canvas, 2, 2, 0)
+{ /* (%tkMakeCanvas ParentTKWindow name-string)
+ */
+ extern int *MakeCanvas(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeCanvas((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeCheckButton", Prim_tk_make_check_button, 2, 2, 0)
+{ /* (%tkMakeCheckButton ParentTKWindow name-string)
+ */
+ extern int *MakeCheckButton(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeCheckButton((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+
+}
+
+DEFINE_PRIMITIVE ("%tkMakeEntry", Prim_tk_make_entry, 2, 2, 0)
+{ /* (%tkMakeEntry ParentTKWindow name-string)
+ */
+ extern int *MakeEntry(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeEntry((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeLabel", Prim_tk_make_label, 2, 2, 0)
+{ /* (%tkMakeLabel ParentTKWindow name-string)
+ */
+ extern int *MakeLabel(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeLabel((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeListbox", Prim_tk_make_listbox, 2, 2, 0)
+{ /* (%tkMakeListbox ParentTKWindow name-string)
+ */
+ extern int *MakeListbox(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeListbox((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeMenu", Prim_tk_make_menu, 2, 2, 0)
+{ /* (%tkMakeMenu ParentTKWindow name-string)
+ */
+ extern int *MakeMenu(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeMenu((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+
+}
+
+DEFINE_PRIMITIVE ("%tkMakeMenuButton", Prim_tk_make_menu_button, 2, 2, 0)
+{ /* (%tkMakeMenuButton ParentTKWindow name-string)
+ */
+ extern int *MakeMenuButton(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeMenuButton((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+
+}
+
+DEFINE_PRIMITIVE ("%tkMakeMessage", Prim_tk_make_message, 2, 2, 0)
+{ /* (%tkMakeMessage ParentTKWindow name-string)
+ */
+ extern int *MakeMessage(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeMessage((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeRadioButton", Prim_tk_make_radio_button, 2, 2, 0)
+{ /* (%tkMakeRadioButton ParentTKWindow name-string)
+ */
+ extern int *MakeRadioButton(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeRadioButton((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+
+}
+
+DEFINE_PRIMITIVE ("%tkMakeScale", Prim_tk_make_scale, 2, 2, 0)
+{ /* (%tkMakeScale ParentTKWindow name-string)
+ */
+ extern int *MakeScale(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeScale((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeScrollBar", Prim_tk_make_scrollbar, 2, 2, 0)
+{ /* (%tkMakeScrollBar ParentTKWindow name-string)
+ */
+ extern int *MakeScrollBar(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeScrollBar((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+}
+
+DEFINE_PRIMITIVE ("%tkMakeText", Prim_tk_make_text, 2, 2, 0)
+{ /* (%tkMakeText ParentTKWindow name-string)
+ */
+ extern int *MakeText(long /*Tk_Window*/ parent_window, char *name);
+ PRIMITIVE_HEADER(2);
+ PRIMITIVE_RETURN
+ (long_to_integer
+ ((long) MakeText((long /*Tk_Window*/) arg_integer(1),
+ STRING_ARG(2))));
+
+}
--- /dev/null
+#include <stdio.h>
+#include "tk.h"
+#include "default.h"
+#include "tkInt.h"
+
+typedef struct
+{ Tk_Window tkwin;
+ Display *display;
+ Tcl_Interp *interp;
+} All_Widgets;
+
+
+int *
+MakeButton(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "button";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ButtonCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeCanvas(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "canvas";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_CanvasCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeCheckButton(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "checkbutton";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ButtonCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeEntry(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "entry";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_EntryCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeLabel(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "label";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ButtonCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeListbox(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "listbox";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ListboxCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeMenu(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "menu";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_MenuCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeMenuButton(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "menubutton";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_MenubuttonCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeMessage(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "message";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_MessageCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeRadioButton(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "radiobutton";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ButtonCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeScale(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "scale";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ScaleCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeScrollBar(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "scrollbar";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_ScrollbarCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+int *
+MakeText(Tk_Window tkMainWindow, char *name)
+{ char *argv [2];
+ Tcl_Interp *tclInterp;
+
+ argv [0] = "text";
+ argv [1] = name;
+ tclInterp = (((TkWindow *) arg_integer(1))->mainPtr)->interp;
+ if (Tk_TextCmd ((ClientData) tkMainWindow,
+ tclInterp, 2, argv) != TCL_OK)
+ { fprintf (stderr, tclInterp->result);
+ exit (1);
+ }
+ return (int *) GetCmdClientData (tclInterp, name);
+}
+
+/* These ought to be in tk-c.c but need internal data structures to work */
+
+char *
+tk_map_widget (All_Widgets *Widget, Tk_Window tkMainWindow, char *name,
+ Window xwindow, int x, int y)
+/* This better work for all TK widgets or there's trouble */
+/* "name" is the name originally given to this widget. */
+{ TkWindow *win;
+
+ win = ((TkWindow *) (Widget->tkwin));
+ if ((xwindow != (Window) NULL) &&
+ (((win->parentPtr)->window) != xwindow))
+ { extern int NameWindow _ANSI_ARGS_((Tcl_Interp *interp,
+ TkWindow *winPtr,
+ TkWindow *parentPtr,
+ char *name));
+ char *argv [3];
+ Tcl_Interp *tclInterp = (((TkWindow *) tkMainWindow)->mainPtr)->interp;
+ Tk_Window InternalWindow =
+ Tk_CreateWindow(tclInterp, tkMainWindow, name, (char *) NULL);
+
+ ((TkWindow *) InternalWindow)->window = xwindow;
+ if (((win->parentPtr)->window) != (Window) NULL)
+ fprintf(stderr, "tk_map_widget: changing parent window!\n");
+ NameWindow(tclInterp, (TkWindow *) win,
+ (TkWindow *) InternalWindow, name);
+ argv[0] = "rename";
+ argv[1] = name;
+ argv[2] = Tk_PathName((Tk_Window) win);
+ if (Tcl_RenameCmd((ClientData) 0, tclInterp, 3, argv) != TCL_OK)
+ { fprintf(stderr, "Failed. %s\n", tclInterp->result);
+ }
+ }
+ Tk_MoveWindow ((Tk_Window) win, x, y);
+ if (xwindow == (Window) NULL) Tk_UnmapWindow((Tk_Window) win);
+ else Tk_MapWindow ((Tk_Window) win);
+ return Tk_PathName((Tk_Window) win);
+}
+
+Tk_Window
+tk_tkwin_widget (All_Widgets *Widget)
+/* This better work for all TK widgets or there's trouble */
+{
+ return Widget->tkwin;
+}
+
+void
+tk_destroy_widget (All_Widgets *Widget)
+{ /* This better work for all TK widgets or there's trouble */
+ Tk_DestroyWindow(Widget->tkwin);
+ return;
+}
+
+void
+ tk_delete_display (Display *disp)
+{ Tk_DestroyDisplayByNumber(disp);
+ return;
+}
--- /dev/null
+;;;;; -*- Scheme -*-
+;;;;; Basic objects for the Scheme User Interface Tool Kit
+;;;; MIT Scheme Version derived from Scheme-To-C version 1.2
+
+;;;; $Id: baseobj.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+
+;;;; Application objects
+
+(define (application->TKMainWindow obj) (Application%.TKMainWindow obj))
+(define (application->Display obj) (Application%.Xdisplay obj))
+
+(define (valid-color-for-application? app color-string)
+ ((string->color (application->display app)) color-string))
+
+(define (valid-color? color-string)
+ ;; For default application
+ ((string->color (application->display *the-default-application*))
+ color-string))
+
+(define (make-top-level-geometry-callback kid)
+ ;; Is the TK-TOP-LEVEL-WINDOW required any more? --Jim
+ (let ((my-screen-area #f))
+ (lambda (configure-event)
+ (Decode-Configure-Event
+ Configure-Event
+ (lambda (type serial send_event display event window x y width
+ height border-width above override-redirect)
+ type serial send_event display event window x y
+ border-width above override-redirect ; Not used
+ (let ((new-area (make-UITKRectangle
+ ; (make-point x y)
+ (make-point 0 0)
+ (make-size width height))))
+ (if (not (screen-area= new-area my-screen-area))
+ (begin
+ (%XClearWindow display window)
+ (assign-screen-area! kid #F)
+ (assign-screen-area! kid new-area)))
+ (set! my-screen-area new-area))
+ 'DONE)))))
+
+(define (valid-child? object)
+ (or (interactor%? object)
+ (box%? object)
+ (arraybox%? object)
+ (shape%? object)
+ (tkwidget%? object)))
+
+(define (application-add-child! application to-be-managed . child-name)
+ ;; Name is an optional string that overrides the application's
+ ;; name for providing a title to the child window
+ (if (not (valid-child? to-be-managed))
+ (error "APPLICATION-ADD-CHILD!: Bad UIObj" to-be-managed))
+ (one-parent-only! to-be-managed application)
+ (let ((really-adding? #F)
+ (new-entry (cons to-be-managed 'TK-Top-Level-Window)))
+ (update-locked-list!
+ (Application%.%child-windows application)
+ (lambda (kids)
+ (if (assq to-be-managed kids)
+ kids
+ (begin
+ (set! really-adding? #T)
+ (cons new-entry kids)))))
+ (if really-adding?
+ (let ((Xdisplay (Application%.Xdisplay application))
+ (context (Application%.context application))
+ (top-level-geometry-callback
+ (make-top-level-geometry-callback to-be-managed))
+ (TKMainW
+ (application->TKMainWindow application))
+ (TKW (make-ToolKitWindow application #F #F)))
+ (let* ((drawing-surface (make-DrawingSurface TKW #F))
+ (tlwindow
+ (tk-create-top-level-window
+ TKMainW
+ (hash top-level-geometry-callback *our-hash-table*))))
+ (set-cdr! new-entry tlwindow)
+ (set-ToolKitWindow.TK-Window! TKW tlwindow)
+ (set-ToolKitWindow.Top-Level-Geometry-Callback!
+ TKW top-level-geometry-callback)
+ (set-context! to-be-managed context)
+ (assign-drawing-surface! to-be-managed drawing-surface)
+ (let ((desired-size (get-desired-size to-be-managed))
+ (window-name (tkwin.pathname tlwindow)))
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "title" window-name
+ (if (and (pair? child-name)
+ (string? (car child-name)))
+ (car child-name)
+ (Application%.application-name application))))
+ (let ((tlwindow-width
+ (number->string (or (size.width desired-size) 0)))
+ (tlwindow-height
+ (number->string (or (size.height desired-size) 0))))
+
+ #|
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "minsize" window-name "1" "1"))
+ |#
+
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "minsize" window-name tlwindow-width tlwindow-height))
+ ;;X signals errors if we don't do this, but I'm damned if I know why
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "geometry" window-name
+ (string-append tlwindow-width "x" tlwindow-height)))
+ )
+ (let ((kill-me
+ (lambda ()
+ (application-remove-destroyed-child! application to-be-managed)
+ )))
+ (tk-invoke-command
+ 'BIND TKMainW
+ (list window-name "<Destroy>"
+ (string-append
+ "SchemeCallBack "
+ (number->string (hash kill-me *our-hash-table*)))))
+ (UIObj-protect-from-gc! to-be-managed kill-me))
+ ;; Events start being generated and handled in
+ ;; the other thread as soon as we map this
+ ;; window! We must map the window before doing
+ ;; the MAKE-UITKWINDOW below, because TK
+ ;; doesn't create the X window until the widget
+ ;; is mapped.
+ (our-with-thread-mutex-locked
+ 'add-child-locks-out-others
+ *event-processing-mutex*
+ (lambda ()
+ (tk-map-window tlwindow)
+ (let ((UITKWindow
+ (make-uitkwindow
+ Xdisplay
+ (wrap-window Xdisplay
+ (tkwin.window tlwindow)))))
+ (set-DrawingSurface.UITKWindow!
+ drawing-surface UITKWindow)
+ (assign-drawing-surface!
+ to-be-managed drawing-surface))
+ ;; UITKWindow changed and some objects will
+ ;; need that rather than just the TK top
+ ;; level window.
+ (assign-screen-area!
+ to-be-managed
+ (make-UITKRectangle (make-point 0 0)
+ (tkwin->size tlwindow)))
+ ))))
+ #|
+ ;;let window resize when kid requests resize
+ ;;but this means that size is determined by kid -- not WM
+ ;;do we want both kinds of windows??
+ (on-geometry-change!
+ to-be-managed 'APPLICATION
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area ;not used
+ (if (eq? new-screen-area #T) ;instigated by child
+ (let* ((desired-size (get-desired-size to-be-managed))
+ (tlwindow-width
+ (number->string (or (size.width desired-size) 0)))
+ (tlwindow-height
+ (number->string (or (size.height desired-size) 0)))
+ (window-name
+ (tkwin.pathname
+ (ToolkitWindow.TK-window
+ (DrawingSurface.ToolkitWindow
+ (drawing-surface to-be-managed))))))
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "minsize" window-name tlwindow-width tlwindow-height))
+ (tk-invoke-command
+ 'WM TKMainW
+ (list "geometry" window-name
+ (string-append tlwindow-width "x" tlwindow-height)))))))
+
+ |#
+
+ (on-death! to-be-managed 'APPLICATION
+ (lambda ()
+ (application-remove-child! application to-be-managed)))))
+ 'ADDED))
+;;; More methods for Applications below
+ \f
+;;; More methods for Applications objects
+
+(define (application-remove-child! Application to-be-unmanaged)
+ ;; This is called by the generic REMOVE-CHILD! procedure.
+ (let ((entry (with-locked-list
+ (application%.%child-windows application)
+ (lambda (kids) (assq to-be-unmanaged kids)))))
+ (if (not entry)
+ 'NOT-A-CHILD
+ (let ((tlwindow (cdr entry)))
+ ;; Just kill the TK Top Level window. This will cause us to get a
+ ;; <Destroy> back from TK, which we process with
+ ;; Application-Remove-Destroyed-Child!, below.
+ (tk-invoke-command 'DESTROY
+ (Application->TKMainWindow Application)
+ (list (tkwin.pathname tlwindow)))
+ 'REMOVED))))
+
+(define (application-remove-destroyed-child! Application to-be-unmanaged)
+ (if (not (valid-child? to-be-unmanaged))
+ (error "APPLICATION-REMOVE-DESTROYED-CHILD!: Bad UIObj" to-be-unmanaged))
+ (if (let ((OK? #T))
+ (update-locked-list! (Application%.%child-windows Application)
+ (lambda (kids)
+ (if (assq to-be-unmanaged kids)
+ (del-assq! to-be-unmanaged kids)
+ (begin (set! OK? #F)
+ kids))))
+ OK?)
+ (begin
+ (assign-drawing-surface! to-be-unmanaged 'RETRACTED)
+ (forget! Application to-be-unmanaged)
+ 'REMOVED)
+ 'NOT-A-CHILD))
+
+(define (make-destroy-<application>-related-objects disp registration mainwindow)
+ ;; This code should not have lexical reference to the
+ ;; Application, since it will run only after the Application
+ ;; has vanished.
+ (lambda ()
+ (destroy-registration registration)
+ (destroy-associated-tk-widgets (->xdisplay disp))
+ (destroy-all-sensitive-surfaces-from-display disp)
+ (tk-kill-application mainwindow)
+ 'done))
+
+(define (application-maker application-name dsp TKmain context children code)
+ ;; Can't be nested in MAKE-APPLICATION because it would lexically
+ ;; capture the list of kids!
+ (make-application%
+ (make-UIObjInternals application-add-child!
+ application-remove-child!
+ UIObj-set-context!
+ 'invalid-application-1 ; UIObj-assign-screen-area!
+ 'invalid-application-2 ; UIObj-assign-drawing-surface!
+ 'invalid-application-3 ; UIObj-point-within?
+ 'invalid-application-4 ; UIObj-rectangle-overlaps?
+ 'invalid-application-5 ; UIObj-handle-event
+ 'invalid-application-6 ; UIObj-get-desired-size
+ 'invalid-application-7 ; UIObj-assigned-screen-area
+ 'invalid-application-8 ; UIObj-used-screen-area
+ 'invalid-application-9 ; UIObj-set-assigned-screen-area!
+ 'invalid-application-10 ; UIObj-set-used-screen-area!
+ 'invalid-application-11); UIObj-assign-glue!
+ children
+ code
+ application-name
+ dsp
+ TKMain
+ context))
+
+(define (make-application application-name . kids)
+ (let* ((dsp (open-display))
+ (context (create-default-context application-name dsp))
+ (me 'later)
+ (event-string (%XMake-Event)))
+ (define (service-display-connection)
+ ;; This code is run asynchronously when data arrives from
+ ;; the display connection
+ (define (process-event event)
+ (for-each
+ (lambda (kid) (handle-event kid event))
+ (with-locked-list (Application%.%child-windows me)
+ (lambda (kids)
+ (let loop ((rest kids)
+ (handled-by '()))
+ (cond ((null? rest) (reverse handled-by))
+ ((event-within? (caar rest) event)
+ (loop (cdr rest)
+ (cons (caar rest) handled-by)))
+ (else (loop (cdr rest) handled-by))))))))
+ (let loop ((nextevent (get-x-event dsp event-string)))
+ (if nextevent
+ (begin
+ (set! EVENT-COUNTER (+ 1 EVENT-COUNTER))
+
+ (our-with-thread-mutex-locked
+ 'process-event *event-processing-mutex*
+ (lambda ()
+ (if (not (tk-completely-handles-event? nextevent))
+ (process-event (XEvent-><Event> nextevent)))))
+
+ (do-tk-callbacks)
+
+ (loop (get-x-event dsp event-string)))
+ 'done))
+ )
+ (define (idle-work)
+ ; Not actually used by MIT version
+ (debug-print 'idle-work 'never called!!!!)
+ (flush-queued-output dsp)
+ (tk-doevents))
+ (let ((TKMainWindow (tk-init dsp)))
+ (set! me (application-maker application-name dsp TKMainWindow
+ context (make-locked-list)
+ service-display-connection))
+ (add-widget-list-for-display-number! (->xdisplay dsp))
+ (for-each (lambda (kid) (add-child! me kid)) kids)
+ (when-unreferenced
+ me
+ (make-destroy-<application>-related-objects
+ dsp
+ (fork-to-wait-on dsp service-display-connection idle-work)
+ TKMainWindow))
+ me))
+ )
+\f
+;;;; Interactive Geometry handlers ... low level version
+
+(define (interactor-add-child! interact to-be-managed)
+ (define (find-handler event-type handlers)
+ ;; Returns a list of all handlers for this event-type
+ (let loop ((rest handlers))
+ (cond ((null? rest) '())
+ ((eq? event-type (caar rest))
+ (cons (cadr (car rest)) (loop (cdr rest))))
+ (else (loop (cdr rest))))))
+
+ (if (not (valid-child? to-be-managed))
+ (error "INTERACTOR-ADD-CHILD!: Bad UIObj" to-be-managed))
+ (let ((sensitive-surfaces (Interactor%.sensitive-surface-map interact)))
+ (if (not (assq to-be-managed sensitive-surfaces))
+ (let* ((ss (create-sensitive-surface to-be-managed
+ (Interactor%.handlers interact)))
+ (entry `(,to-be-managed ,ss)))
+ (set-Interactor%.sensitive-surface-map! interact
+ (cons entry sensitive-surfaces))
+ (on-event! to-be-managed interact
+ (lambda (event)
+ (let* ((handlers (Interactor%.handlers interact))
+ (applicable-handlers
+ (find-handler (event.type event) handlers)))
+ (cond ((not (null? applicable-handlers))
+ (for-each (lambda (handler) (handler event))
+ applicable-handlers))
+ ((assq #T handlers)
+ => (lambda (entry) ((cadr entry) event)))
+ (else #F)))
+ (event! interact event)))
+ (on-geometry-change! to-be-managed interact
+ (lambda (old-screen-area new-screen-area)
+ (if (and (not old-screen-area)
+ (not new-screen-area))
+ ;; When a drawing surface is set.
+ (set! ss
+ (change-sensitive-surface!
+ ss
+ to-be-managed))
+ (set-car! (cdr entry) ss))))))))
+
+(define (interactor-remove-child! interact was-managed)
+ (if (not (valid-child? was-managed))
+ (error "INTERACTOR-REMOVE-CHILD!: Bad UIObj" to-be-managed))
+ (forget! was-managed interact)
+ (let ((ss (assq was-managed (Interactor%.sensitive-surface-map interact))))
+ (if ss (destroy-sensitive-surface was-managed (cadr ss)))))
+
+;; Interactor Maker
+(define (interactor-maker alist-of-handlers)
+ (make-Interactor%
+ (make-UIObjInternals interactor-add-child!
+ interactor-remove-child!
+ UIObj-set-context! ; Defaults
+ UIObj-assign-screen-area!
+ UIObj-assign-drawing-surface!
+ UIObj-point-within?
+ UIObj-rectangle-overlaps?
+ UIObj-handle-event
+ UIObj-get-desired-size
+ UIObj-assigned-screen-area
+ UIObj-used-screen-area
+ UIObj-set-assigned-screen-area!
+ UIObj-set-used-screen-area!
+ 'invalid)
+ alist-of-handlers))
+
+(define (make-interactor objects alist-of-handlers)
+ ;; Constructor for interactors
+ (let ((me (interactor-maker alist-of-handlers)))
+ (for-each (lambda (object) (add-child! me object)) objects)
+ me)
+ )
+\f
+;;;; Higher level interactors
+
+(define (handle-exposure object receiver)
+ ;; Receiver will be called with the exposed rectangle
+ (make-interactor
+ (list object)
+ `((EXPOSURE
+ ,(lambda (event)
+ (receiver
+ (Make-UITKRectangle (Event.Offset Event)
+ (Make-Size (Event.Width Event)
+ (Event.Height Event))))))))
+ 'OK)
+
+(define (handle-button-grab object which-buttons receiver)
+ ;; Receiver is called with the buttons that were actually down and a
+ ;; "while-grabbed" procedure which is expected to be tail-called by
+ ;; receiver, specifying how to handle subsequent motion events and
+ ;; motion termination.
+ (make-interactor
+ (list object)
+ `((BUTTON-PRESS
+ ,(lambda (event)
+ (decode-button-event
+ (Event.OS-Event event)
+ (lambda (type serial sent? display window root
+ subwindow time x y RootX RootY state
+ button SameScreen?)
+ type serial sent? display window root
+ subwindow time x y RootX RootY state
+ button SameScreen?
+ (if (or (= which-buttons ANYBUTTON)
+ (memv button which-buttons))
+ (let* ((should-be-result (list 'foo))
+ (result
+ (receiver event
+ (lambda (on-motion at-end)
+ (mouse-drag (drawing-surface object)
+ on-motion)
+ (at-end)
+ should-be-result))))
+ (if (eq? result should-be-result)
+ 'OK
+ (error "HANDLE-BUTTON-GRAB: Must tail call"))))))))
+ (POINTER-MOTION ,(lambda (e) e 'IGNORE))
+ (BUTTON-RELEASE ,(lambda (e) e 'IGNORE)))))
+\f
+;;;; Support code for interaction managers:
+;;;; Maps from DrawingSurface to Interactor to event masks
+
+;; The global map ds->(<interactor>->eventmasks)
+(define *all-sensitive-surfaces* '())
+
+;; A Surface-Sensitivity specifies for a given drawing surface the
+;; total event-generation mask for that surface and a list of
+;; Sensitivity data structures. The mask here is the inclusive-OR of
+;; all the masks in the Sensitivity data structures.
+
+;; A Sensitivity maps a single handler to the list of event types it
+;; is intended to handle. For GC reasons, it only weakly holds the
+;; handler itself, since these are included in the global
+;; *all-sensitive-surfaces* list.
+
+(define find-sensitivity
+ ;; (find-sensitivity <interactor> list-of-sensitivities) =>
+ ;; sensitivity or #F
+ ;; Or, in layman's terms, given a list of handler/description pairs
+ ;; and a specific handler, find the description of that handler.
+ (make-lookup
+ (lambda (obj) (weak-car (Sensitivity.%weak-<interactor> obj)))))
+
+(define find-ss
+ ;; (find-ss drawing-surface list-of-Surface-Sensitivity)
+ ;; returns a specific Surface-Sensitivity or #F
+ (make-lookup
+ (lambda (x) (weak-car (Surface-Sensitivity.Weak-Surface x)))))
+
+(define (record-surface-sensitivity! surface interactor mask)
+ (define (record-<interactor>-sensitivity! ss)
+ (let* ((sensitivities (surface-sensitivity.sensitivities ss))
+ (entry (find-sensitivity interactor sensitivities)))
+ (if entry
+ (set-sensitivity.masks! entry (cons mask (sensitivity.masks entry)))
+ (set-surface-sensitivity.sensitivities! ss
+ `(,(make-sensitivity (weak-cons interactor '()) (list mask))
+ ,@sensitivities))))
+ ;; Now tell the window system to set the event generation for this
+ ;; particular drawing surface
+ (reset-sensitivity! ss))
+ (let ((sensitivity-of-surface
+ (or (find-ss surface *all-sensitive-surfaces*)
+ (let ((new-entry
+ (make-surface-sensitivity (weak-cons surface 'ignore)
+ NoEventMask '())))
+ (set! *all-sensitive-surfaces*
+ (cons new-entry *all-sensitive-surfaces*))
+ new-entry))))
+ (record-<interactor>-sensitivity! sensitivity-of-surface)))
+
+(define delete-<interactor>!
+ (let ((del-sensitivity!
+ (del-op! (lambda (obj)
+ (weak-car (sensitivity.%weak-<interactor> obj)))))
+ (del-ss! (del-op! surface-sensitivity.sensitivities)))
+ (lambda (surface interactor)
+ (let ((ss (find-ss surface *all-sensitive-surfaces*)))
+ (if ss
+ (let ((new (del-sensitivity!
+ interactor
+ (surface-sensitivity.sensitivities ss))))
+ (if (null? new)
+ (set! *all-sensitive-surfaces*
+ (del-ss! surface *all-sensitive-surfaces*))
+ (begin
+ (set-surface-sensitivity.sensitivities! ss new)
+ ;; Now tell the window system to set the event
+ ;; generation for this particular drawing surface
+ (reset-sensitivity! ss)))))))))
+
+;;;; Continued ...
+\f
+;;;; Support code for interactive geometry managers, continued
+
+;;; When a surface is asked to generate events, we ask the toolkit to
+;;; generate events if it is a toolkit window. Otherwise, we ask the
+;;; window system directly. WE DO NOT DO BOTH.
+;;;
+;;; This lets people create windows from Scheme which don't have
+;;; related toolkit windows, even though we haven't done that yet.
+
+(define (reset-sensitivity! surface-sensitivity)
+ ;; This tells the window system to actually update the event
+ ;; generation mask for a given drawing surface.
+ ;; NOTE: Whoever calls this is responsible for guaranteeing that the
+ ;; surface (which is weakly held) still exists.
+ (let ((original (surface-sensitivity.mask surface-sensitivity)))
+ (let loop ((s 0)
+ (rest (surface-sensitivity.sensitivities
+ surface-sensitivity)))
+ (if (null? rest)
+ (begin
+ (set-surface-sensitivity.mask! surface-sensitivity s)
+ (if (not (= s original))
+ (let ((Surface
+ (weak-car
+ (surface-sensitivity.Weak-Surface
+ surface-sensitivity))))
+ (if Surface
+ (let ((TKWindow (DrawingSurface.ToolKitWindow Surface))
+ (UITKWindow (DrawingSurface.UITKWindow Surface)))
+ (if TKWindow
+ (tk-generate-Scheme-event
+ s
+ (ToolKitWindow.TK-Window TKWindow))
+ (Generate-Events! UITKWindow s)))))))
+ (loop (apply bit-or s (sensitivity.masks (car rest)))
+ (cdr rest))))))
+
+(define (create-sensitive-surface UIObject handlers)
+ ;; Given an object, return the Sensitive-Surface that will generate
+ ;; these events.
+ (let ((surface (Drawing-Surface UIObject)))
+ (if (DrawingSurface? surface)
+ (begin
+ (record-surface-sensitivity! surface UIObject
+ (if (null? handlers)
+ 0
+ (apply bit-or (map handler->sensitivity handlers))))
+ (make-sensitive-surface surface handlers))
+ (make-sensitive-surface #F handlers))))
+
+(define (change-sensitive-surface! sensitive-surface UIObject)
+ ;; If the drawing surface for an object changes, remove the old
+ ;; record of handlers for that object (recorded on the old drawing
+ ;; surface) and enter a new record on the current drawing surface.
+ (let ((surface (Drawing-Surface UIObject))
+ (old-surface
+ (sensitive-surface.DrawingSurface sensitive-surface)))
+ (if (eq? surface old-surface)
+ sensitive-surface
+ (begin
+ (if (DrawingSurface? old-surface)
+ (destroy-sensitive-surface UIObject sensitive-surface))
+ (create-sensitive-surface
+ UIObject (sensitive-surface.handlers sensitive-surface))))))
+
+(define (destroy-sensitive-surface interactor sensitive-surface)
+ (let ((surface
+ (sensitive-surface.DrawingSurface sensitive-surface)))
+ (delete-<interactor>! surface interactor)))
+
+(define (destroy-all-sensitive-surfaces-from-display display)
+ (set! *all-sensitive-surfaces*
+ ((list-deletor!
+ (lambda (surface-sensitivity)
+ (let ((surface
+ (weak-car (surface-sensitivity.Weak-Surface
+ surface-sensitivity))))
+ (or (not surface)
+ (eq? display
+ (Application->display
+ (ToolKitWindow.Application
+ (drawingsurface.ToolKitWindow surface))))))))
+ *all-sensitive-surfaces*)))
+\f
+;;;; Support for simplified user interface building. We provide a
+;;;; default application, and a procedure for adding new children to
+;;;; it.
+
+(define *the-default-application*
+ (make-application "SWAT"))
+
+;;; (Swat-Open obj1 ['-title "title1"] obj2 ['-title "title2"] ...)
+;;; adds obj1, obj2, ... to the default application with the window
+;;; titled by the string specified with the -title option.
+;;; If no title option is specified, the window title will be the
+;;; title of the application
+
+(define (swat-open . objects-and-title-options)
+ (apply swat-open-in-application
+ *the-default-application*
+ objects-and-title-options))
+
+;;; (SWAT-OPEN-IN-APPLICATION app obj1 ['-title "title1"] obj2 ['-title "title2"] ...)
+;;; is like swat-open, except for the speficifed application.
+
+(define (swat-open-in-application app . objects-and-title-options)
+ (let loop ((more-to-show objects-and-title-options))
+ (if (null? more-to-show)
+ 'OK
+ (let ((next-obj (car more-to-show))
+ (after-next (if (null? (cdr more-to-show))
+ #F
+ (cadr more-to-show))))
+ ;;look for -title following the object to show
+ (if (eq? after-next '-title)
+ (let ((specified-title
+ (if (null? (cddr more-to-show))
+ (error
+ "-title option given and no title specified -- SWAT-OPEN"
+ objects-and-title-options)
+ (caddr more-to-show))))
+ ;;if -title is there, next thing must be a string
+ (if (string? specified-title)
+ (add-child! app
+ next-obj
+ specified-title)
+ (error "specified title is not a string -- SWAT-OPEN"
+ specified-title))
+ (loop (cdddr more-to-show)))
+ ;;no -title specified -- use default naming
+ (begin (add-child! app next-obj)
+ (loop (cdr more-to-show))))))))
+
+(define (swat-close . objs)
+ (for-each (lambda (obj) (remove-child! *the-default-application* obj))
+ objs)
+ 'closed)
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+;;; Canvases can be scrollable: we can create them with two scrollbars,
+;;; one on the right and one on the bottom.
+
+(define (make-scrollable-canvas . options)
+ (let ((canvas (apply make-canvas options))
+ (vscroll (make-scrollbar '(-orient vert)))
+ (hscroll (make-scrollbar '(-orient horiz))))
+ (let ((v-command
+ (lambda ()
+ (ask-widget
+ vscroll
+ `(configure -command
+ ,(string-append (tk-widget->pathname canvas) " yview")))))
+ (h-command
+ (lambda ()
+ (ask-widget
+ hscroll
+ `(configure -command
+ ,(string-append (tk-widget->pathname canvas) " xview")))))
+ (c-command
+ (lambda ()
+ (maybe-defer
+ vscroll
+ (lambda ()
+ (ask-widget
+ canvas
+ `(configure
+ -xscroll
+ ,(string-append (tk-widget->pathname hscroll) " set")
+ -yscroll
+ ,(string-append (tk-widget->pathname vscroll) " set"))))))))
+ (defer canvas v-command)
+ (defer canvas h-command)
+ (defer hscroll c-command)
+ (make-vbox (make-hbox canvas vscroll) hscroll))))
+
+(define (scrollable-canvas-canvas scrollable-canvas)
+ (let ((top-row (car (box-children scrollable-canvas))))
+ (car (box-children top-row))))
+
+(define (scrollable-canvas-vscroll scrollable-canvas)
+ (let ((top-row (car (box-children scrollable-canvas))))
+ (cadr (box-children top-row))))
+
+(define (scrollable-canvas-hscroll scrollable-canvas)
+ (cadr (box-children scrollable-canvas)))
+
+
+;;; Canvas has special protect-from-gc! procedures
+
+(define (canvas-protect-from-gc! canvas stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
+ (set-cdr! crud (cons stuff (cdr crud))))
+ 'done)
+
+(define (canvas-unprotect-from-gc! canvas stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
+ (set-cdr! crud (delq! stuff (cdr crud))))
+ 'done)
+
+(define (canvas-flush-protect-list! canvas)
+ (let ((crud (crud-that-I-dont-want-to-gc-away canvas)))
+ (set-cdr! crud '()))
+ 'done)
+
+
+;;; CanvasItem structure
+
+(define (make-canvas-item name canvas)
+ (if (not (TKWidget%.handle canvas))
+ (error "You must OPEN the canvas before you can make an item on it"))
+ (let ((item (make-canvasitem canvasitem-ask-widget
+ canvasitem-add-event-handler!
+ 'invalid
+ name
+ canvas
+ '())))
+ (canvas-protect-from-gc! canvas item)
+ item))
+
+(define (canvasitem-add-event-handler! item event handler substitutions)
+ (let ((canvas (CanvasItem.canvas item))
+ (handler (proc-with-transformed-args handler substitutions)))
+ (set-canvasitem.%binding-callbacks!
+ item
+ (cons handler (canvasitem.%binding-callbacks item)))
+ (ask-widget canvas
+ `(bind
+ ,(CanvasItem.name item)
+ ,event
+ ("SchemeCallBack" ,(hash handler *our-hash-table*)
+ ,@substitutions)))))
+
+;;; The following assumes that the commands which explicitly mention
+;;; canvas items mention them only as their second argument. This is
+;;; true for most of the commands (e.g., itemconfigure, move, raise);
+;;; but select, for example, is an exception. Do we care about those,
+;;; anyway? Same is true for the <CanvasItemGroup> version.
+
+(define (canvasitem-ask-widget me arg-list)
+ (let* ((name (CanvasItem.name me))
+ (canvas (CanvasItem.canvas me))
+ (command (car arg-list))
+ (new-arg-list (cons (if (eq? command 'configure)
+ 'itemconfigure
+ command)
+ (cons name (cdr arg-list)))))
+ (let ((result (ask-widget canvas new-arg-list)))
+ (if (eq? command 'delete)
+ (canvas-unprotect-from-gc! canvas me))
+ result)))
+
+
+;;; CanvasItemGroup structure, for grouping (tagging) canvas items together.
+
+(define (make-canvas-item-group canvas list-of-canvas-items)
+ (let ((tag (tk-gen-name "CanvasItemGroup")))
+ (for-each (lambda (item)
+ (if (eq? canvas (CanvasItem.canvas item))
+ (ask-widget item `(configure -tags ,tag))
+ (error "MAKE-CANVAS-ITEM-GROUP: not a canvas item on canvas"
+ canvas item)))
+ list-of-canvas-items)
+ (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
+ CanvasItemGroup-add-event-handler!
+ 'invalid
+ tag
+ canvas
+ '())))
+ (canvas-protect-from-gc! canvas CanvasItemGroup)
+ CanvasItemGroup)))
+
+
+(define (add-to-canvas-item-group tag new-item)
+ (if (eq? (CanvasItem.canvas new-item)
+ (CanvasItemGroup.canvas tag))
+ (ask-widget new-item `(configure -tags ,(CanvasItemGroup.tag tag)))
+ (error "ADD-TO-CANVAS-ITEM-GROUP: not a canvas item on canvas"
+ canvas new-item)))
+
+(define (merge-canvas-item-groups canvas destructive? . tags)
+ (let ((new-tag (tk-gen-name "CanvasItemGroup")))
+ (for-each
+ (lambda (tag)
+ (cond ((eq? (CanvasItemGroup.canvas tag) canvas)
+ (let ((tk-tag (CanvasItemGroup.tag tag)))
+ (ask-widget canvas `(addtag ,new-tag withtag ,tk-tag))
+ ;; If destructive? is true, the old tags are
+ ;; destroyed. Otherwise, they are kept. The old tags
+ ;; take precedence in case of conflicting event handlers.
+ (if destructive?
+ (begin
+ (ask-widget canvas `(dtag ,tk-tag))
+ (canvas-unprotect-from-gc! canvas tag)))))
+ (else
+ (error "MERGE-CANVAS-ITEM-GROUPS: not a canvas tag on canvas"
+ canvas tag))))
+ tags)
+ (let ((CanvasItemGroup (make-CanvasItemGroup CanvasItemGroup-ask-widget
+ CanvasItemGroup-add-event-handler!
+ 'invalid
+ new-tag
+ canvas
+ '())))
+ (canvas-protect-from-gc! canvas CanvasItemGroup)
+ CanvasItemGroup)))
+
+(define (CanvasItemGroup-add-event-handler! tag event handler substitutions)
+ ;; to handle tagged canvas items
+ (let ((canvas (CanvasItemGroup.canvas tag))
+ (handler (proc-with-transformed-args handler substitutions)))
+ (set-CanvasItemGroup.%binding-callbacks!
+ tag
+ (cons handler (CanvasItemGroup.%binding-callbacks tag)))
+ (ask-widget canvas
+ `(bind
+ ,(CanvasItemGroup.tag tag)
+ ,event
+ ("SchemeCallBack" ,(hash handler *our-hash-table*)
+ ,@substitutions)))))
+
+(define (CanvasItemGroup-ask-widget tag arg-list)
+ ;; to handle tagged canvas items
+ (let* ((tag-name (CanvasItemGroup.tag tag))
+ (canvas (CanvasItemGroup.canvas tag))
+ (command (car arg-list))
+ (new-arg-list (cons (if (eq? command 'configure)
+ 'itemconfigure
+ command)
+ (cons tag-name (cdr arg-list)))))
+ (let ((result (ask-widget canvas new-arg-list)))
+ (if (eq? command 'delete)
+ (canvas-unprotect-from-gc! canvas tag))
+ result)))
+
+
+;;; This is how the user creates canvas items, e.g.
+;;; (define george (make-arc-on-canvas c 200 200 250 250))
+
+(define (make-arc-on-canvas canvas x1 y1 x2 y2 . options)
+ (let ((configure-options (if (null? options) '() (car options))))
+ (make-canvas-item
+ (ask-widget canvas `(create arc ,x1 ,y1 ,x2 ,y2 ,@configure-options))
+ canvas)))
+
+(define (make-bitmap-on-canvas canvas bitmap-filename-string x y . options)
+ (if (not (file-exists? bitmap-filename-string))
+ (error "MAKE-BITMAP-ON-CANVAS: Bad file name" bitmap-filename-string))
+ (let ((configure-options (if (null? options) '() (car options))))
+ (make-canvas-item
+ (ask-widget canvas
+ `(create bitmap ,x ,y
+ -bitmap ,(string-append "@" bitmap-filename-string)
+ ,@configure-options))
+ canvas)))
+
+(define (make-line-on-canvas canvas x1 y1 x2 y2 . opt-args)
+ (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
+ (if (null? opt-args)
+ (if (odd? (length xy-list))
+ (error "MAKE-LINE: Missing a y coordinate"
+ (append (list x1 y1 x2 y2) xy-list))
+ (make-canvas-item
+ (ask-widget canvas `(create line ,x1 ,y1 ,x2 ,y2 ,@xy-list
+ ,@configure-options))
+ canvas))
+ (let ((next-arg (car opt-args)))
+ (if (list? next-arg)
+ (loop (cdr opt-args) xy-list next-arg)
+ (loop (cdr opt-args)
+ (append xy-list (list next-arg))
+ configure-options))))))
+
+(define (make-oval-on-canvas canvas x1 y1 x2 y2 . options)
+ (let ((configure-options (if (null? options) '() (car options))))
+ (make-canvas-item
+ (ask-widget canvas `(create oval ,x1 ,y1 ,x2 ,y2 ,@configure-options))
+ canvas)))
+
+(define (make-polygon-on-canvas canvas x1 y1 x2 y2 x3 y3 . opt-args)
+ (let loop ((opt-args opt-args) (xy-list '()) (configure-options '()))
+ (if (null? opt-args)
+ (if (odd? (length xy-list))
+ (error "MAKE-POLYGON: Missing a y coordinate"
+ (append (list x1 y1 x2 y2 x3 y3) xy-list))
+ (make-canvas-item
+ (ask-widget canvas `(create polygon ,x1 ,y1 ,x2 ,y2 ,x3 ,y3
+ ,@xy-list ,@configure-options))
+ canvas))
+ (let ((next-arg (car opt-args)))
+ (if (list? next-arg)
+ (loop (cdr opt-args) xy-list next-arg)
+ (loop (cdr opt-args)
+ (append xy-list (list next-arg))
+ configure-options))))))
+
+(define (make-rectangle-on-canvas canvas x1 y1 x2 y2 . options)
+ (let ((configure-options (if (null? options) '() (car options))))
+ (make-canvas-item
+ (ask-widget canvas `(create rectangle ,x1 ,y1 ,x2 ,y2 ,@configure-options))
+ canvas)))
+
+(define (make-text-on-canvas canvas x y . options)
+ (let ((configure-options (if (null? options) '() (car options))))
+ (make-canvas-item
+ (ask-widget canvas `(create text ,x ,y ,@configure-options))
+ canvas)))
+
+(define (make-widget-on-canvas canvas widget x y . options)
+ (let ((configure-options (if (null? options) '() (car options))))
+ (add-child! canvas widget)
+ (make-canvas-item
+ (ask-widget
+ canvas
+ `(create window ,x ,y
+ -window ,(lambda () (tk-widget->pathname widget))
+ ,@configure-options))
+ canvas)))
+
--- /dev/null
+;;; -*-Scheme-*-
+
+#|
+ (set-floating-error-mask! <fixnum>)
+
+ sets the floating-point enables to the bottom 5 bits of fixnum.
+ returns a fixnum with the old floating-point enables in the bottom 5 bits.
+
+ Warning: This does not check the argument type.
+
+ Flags: V valid operation 16
+ Z zero divide 8
+ O overflow 4
+ U underflow 2
+ I inexact 1
+
+ This version is long because it compiles under both 7.4 and 8.0
+|#
+
+(declare (usual-integrations))
+
+(define-macro (deflap name . lap)
+ `(define ,name
+ (scode-eval
+ ',((access lap->code (->environment '(compiler top-level)))
+ name
+ lap)
+ system-global-environment)))
+
+(define set-floating-error-mask!
+ (let ()
+ (deflap set-floating-error-mask/8.0!
+ (entry-point set-floating-error-mask/8.0!)
+ (scheme-object CONSTANT-0 #F)
+ (scheme-object CONSTANT-1 0)
+ (external-label () #x202 (@pcr set-floating-error-mask/8.0!))
+
+ (LABEL set-floating-error-mask/8.0!)
+ ; arg = 2, cont = 19
+ (fstws () 0 (offset 0 0 21)) ; flags to free
+ (ldw () (offset 0 0 21) 6) ; flags to reg 6
+ (copy () 6 7) ; copy flags to 7
+ (dep () 2 31 5 7) ; arg merged with flags in 7
+ (stw () 7 (offset 0 0 21)) ; new flags to free
+ (dep () 6 31 5 2) ; flags merged with arg in 2
+ (fldws () (offset 0 0 21) 0) ; store flags
+ (bv (n) 0 19) ; return
+ )
+
+ (deflap set-floating-error-mask/7.4!
+ (entry-point set-floating-error-mask/7.4!)
+ (scheme-object CONSTANT-0 #F)
+ (scheme-object CONSTANT-1 0)
+ (external-label () #x202 (@pcr set-floating-error-mask/7.4!))
+
+ (LABEL set-floating-error-mask/7.4!)
+
+ (fstws () 0 (offset 0 0 21)) ; flags to free
+ (ldw () (offset 0 0 #x16) 2) ; arg to reg 2
+ (ldw () (offset 0 0 21) 6) ; flags to reg 6
+ (copy () 6 7) ; copy flags to 7
+ (dep () 2 31 5 7) ; arg merged with flags in 7
+ (stw () 7 (offset 0 0 21)) ; new flags to free
+ (dep () 6 31 5 2) ; flags merged with arg in 2
+ (fldws () (offset 0 0 21) 0) ; store flags
+ (ldo () (offset 4 0 #x16) #x16) ; pop arg
+ (ldwm () (offset 4 0 #x16) 6) ; pop ret add
+ (dep () 5 5 6 6) ; remove tag
+ (bv (n) 0 6) ; return
+ )
+
+ (if (object-type? 0 0) ; untagged fixnums?
+ set-floating-error-mask/8.0!
+ set-floating-error-mask/7.4!)))
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(define-integrable (uiobjinternals uiobj)
+ (vector-ref uiobj uiobjinternals-index))
+
+;;; Generic operations:
+;;; ADD-CHILD!, REMOVE-CHILD!, SET-CONTEXT!, ASSIGN-SCREEN-AREA!,
+;;; ASSIGN-DRAWING-SURFACE!, HANDLE-EVENT,
+;;; GET-DESIRED-SIZE, GET-DESIRED-SIZE, EVENT-WITHIN?
+
+(define (add-child! object child . others)
+ (if (null? others)
+ ((UIObjInternals.Add-Child!-Procedure (uiobjinternals object))
+ object
+ child)
+ (apply
+ (UIObjInternals.Add-Child!-Procedure (uiobjinternals object))
+ object child others)))
+
+(define (REMOVE-CHILD! Object Child)
+ ((UIObjInternals.Remove-Child!-Procedure (uiobjinternals object))
+ Object
+ child))
+
+(define (SET-CONTEXT! Object Context)
+ ((UIObjInternals.Set-Context!-Procedure (uiobjinternals object))
+ Object Context))
+
+(define (ASSIGN-SCREEN-AREA! Object Screen-area)
+ ((UIObjInternals.Assign-Screen-Area!-Procedure (uiobjinternals object))
+ Object Screen-Area))
+
+(define (weak-delq! item items)
+ ;; Cleans out #F entries in the list as it goes
+ (let loop ((previous #F)
+ (items* items))
+ (cond ((weak-pair? items*)
+ (if (or (null? (weak-car items*))
+ (eq? (weak-car items*) item))
+ (begin
+ (if previous
+ (weak-set-cdr! previous (weak-cdr items*))
+ (set! items (weak-cdr items*)))
+ (loop previous (weak-cdr items*)))
+ (loop items* (weak-cdr items*))))
+ ((null? items*) items)
+ (else
+ (error:wrong-type-argument items "weak pair" 'weak-delq!)))))
+
+(define (ASSIGN-DRAWING-SURFACE! Object Surface)
+ (let ((old (drawing-surface object)))
+ ((UIObjInternals.Assign-Drawing-Surface!-Procedure (uiobjinternals object))
+ Object Surface)
+ (if (eq? Surface 'RETRACTED)
+ (begin
+ (set-assigned-screen-area! Object #F)
+ (set-used-screen-area! Object #F)))
+ (if (not (eq? old Surface))
+ (begin
+ (if (DrawingSurface? old)
+ (set-DrawingSurface.Weak-List-of-Widgets!
+ old
+ (weak-delq! object (DrawingSurface.Weak-List-of-Widgets old))))
+ (if (DrawingSurface? Surface)
+ (set-DrawingSurface.Weak-List-of-Widgets!
+ Surface (weak-cons object
+ (DrawingSurface.Weak-List-of-Widgets
+ Surface))))))
+ 'OK))
+
+(define (POINT-WITHIN? Object Point)
+ ((UIObjInternals.Point-Within?-Procedure (uiobjinternals object))
+ Object Point))
+
+(define (RECTANGLE-OVERLAPS? Object Point Width Height)
+ ((UIObjInternals.Rectangle-Overlaps?-Procedure (uiobjinternals object))
+ Object Point Width Height))
+
+(define (HANDLE-EVENT Object Event)
+ ((UIObjInternals.Handle-Event-Procedure (uiobjinternals object))
+ Object Event))
+
+(define (GET-DESIRED-SIZE Object)
+ ((UIObjInternals.Get-Desired-Size-Procedure (uiobjinternals object))
+ Object))
+
+(define (ASSIGNED-SCREEN-AREA Object)
+ ((UIObjInternals.ASSIGNED-SCREEN-AREA-Procedure (uiobjinternals object))
+ Object))
+
+(define (USED-SCREEN-AREA Object)
+ ((UIObjInternals.Used-SCREEN-AREA-Procedure (uiobjinternals object))
+ Object))
+
+(define (SET-ASSIGNED-SCREEN-AREA! Object Screen-area)
+ ((UIObjInternals.Set-ASSIGNED-SCREEN-AREA!-Procedure (uiobjinternals object))
+ Object Screen-area))
+
+(define (SET-USED-SCREEN-AREA! Object Screen-area)
+ ((UIObjInternals.Set-Used-SCREEN-AREA!-Procedure (uiobjinternals object))
+ Object Screen-Area))
+
+(define (ASSIGN-GLUE! Object)
+ ((UIObjInternals.Assign-Glue!-Procedure (uiobjinternals object))
+ Object))
+
+
+(define (%geometry-alerts UIObj)
+ (UIObjInternals.%geometry-alerts (UIObjInternals UIObj)))
+
+(define (set-%geometry-alerts! UIObj new-value)
+ (set-UIObjInternals.%geometry-alerts! (UIObjInternals UIObj)
+ new-value))
+
+(define (%event-alerts UIObj)
+ (UIObjInternals.%event-alerts (UIObjInternals UIObj)))
+
+(define (set-%event-alerts! UIObj new-value)
+ (set-UIObjInternals.%event-alerts! (UIObjInternals UIObj)
+ new-value))
+
+(define (%context-alerts UIObj)
+ (UIObjInternals.%context-alerts (UIObjInternals UIObj)))
+
+(define (set-%context-alerts! UIObj new-value)
+ (set-UIObjInternals.%context-alerts! (UIObjInternals UIObj)
+ new-value))
+
+(define (%death-alerts UIObj)
+ (UIObjInternals.%death-alerts (UIObjInternals UIObj)))
+
+(define (set-%death-alerts! UIObj new-value)
+ (set-UIObjInternals.%death-alerts! (UIObjInternals UIObj)
+ new-value))
+
+(define (clip-region UIObj)
+ (UIObjInternals.clip-region (UIObjInternals UIObj)))
+
+(define (set-clip-region! UIObj new-value)
+ (set-UIObjInternals.clip-region! (UIObjInternals UIObj)
+ new-value))
+
+(define (drawing-surface UIObj)
+ (UIObjInternals.drawing-surface (UIObjInternals UIObj)))
+
+(define (set-drawing-surface! UIObj new-value)
+ (set-UIObjInternals.drawing-surface! (UIObjInternals UIObj)
+ new-value))
+
+(define (%desired-size UIObj)
+ (UIObjInternals.%desired-size (UIObjInternals UIObj)))
+
+(define (set-%desired-size! UIObj new-value)
+ (set-UIObjInternals.%desired-size! (UIObjInternals UIObj)
+ new-value))
+
+(define (%vglue UIObj)
+ (UIObjInternals.%vglue (UIObjInternals UIObj)))
+
+(define (set-%vglue! UIObj new-value)
+ (set-UIObjInternals.%vglue! (UIObjInternals UIObj) new-value))
+
+(define (%hglue UIObj)
+ (UIObjInternals.%hglue (UIObjInternals UIObj)))
+
+(define (set-%hglue! UIObj new-value)
+ (set-UIObjInternals.%hglue! (UIObjInternals UIObj) new-value))
+
+(define (crud-that-I-dont-want-to-gc-away UIObj)
+ (UIObjInternals.crud-that-I-dont-want-to-gc-away (UIObjInternals UIObj)))
+
+(define (set-crud-that-I-dont-want-to-gc-away! UIObj new-value)
+ (set-UIObjInternals.crud-that-I-dont-want-to-gc-away!
+ (UIObjInternals UIObj) new-value))
+
+
+;;; procedures that are generic over CanvasItem, CanvasItemGroup, MenuItem,
+;;; TextTag, and TKWidget
+
+(define (valid-non-widget? obj)
+ (or (CanvasItem? obj)
+ (CanvasItemGroup? obj)
+ (MenuItem? obj)
+ (TextTag? obj)))
+
+(define (ASK-WIDGET Object Command)
+ (cond ((TkWidget%? Object)
+ ((TKwidget%.ask-widget-procedure Object) Object Command))
+ ((valid-non-widget? Object)
+ ((vector-ref object ask-widget-procedure-index) object command))
+ (else (error "ASK-WIDGET: Not a valid Tk widget" Object))))
+
+(define (ADD-EVENT-HANDLER! Object Event-type Handler . Substitutions)
+ (cond ((TkWidget%? Object)
+ ((TKwidget%.add-event-handler!-procedure Object)
+ Object Event-type Handler substitutions))
+ ((valid-non-widget? Object)
+ ((vector-ref object add-event-handler!-procedure-index)
+ Object Event-type Handler substitutions))
+ (else (error "ADD-EVENT-HANDLER!: Can't add an event handler to" Object))))
+
+;;; set-callback! is also generic over active variables
+
+(define (SET-CALLBACK! Object Callback)
+ (cond ((TkWidget%? Object)
+ ((TKWidget%.set-callback!-procedure Object) Object Callback))
+ ((TK-variable? Object)
+ (set-active-variable-callback! Object Callback))
+ ((valid-non-widget? Object)
+ ((vector-ref object set-callback!-procedure-index) Object Callback))
+ (else (error "SET-CALLBACK!: Can't set a callback for" Object))))
+
+
+
--- /dev/null
+;;;;; -*- Scheme -*-
+;;;;;
+;;;;; $Id: geometry.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+;;;;; derived from geometry.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
+
+;; The box makers - one for horizontal, one for vertical
+
+(define (make-hbox . kids)
+ (make-box h-size h-arrange h-get-hglue h-get-vglue kids))
+
+(define (make-vbox . kids)
+ (make-box v-size v-arrange v-get-hglue v-get-vglue kids))
+
+;; user-level accessor
+(define (box-children box)
+ (cond ((box%? box)
+ (box%.kids box))
+ ((arraybox%? box)
+ (arraybox%.kids-lists box))
+ (else (error "not a box -- BOX-CHILDREN" box))))
+
+;; Vertical sizer
+
+(define (v-size kids)
+ (make-size
+ (apply max (cons 0
+ (map (lambda (kid)
+ (Size.Width (get-desired-size kid)))
+ kids)))
+ (apply + (map (lambda (kid)
+ (Size.Height (get-desired-size kid)))
+ kids))))
+
+;; Horizontal sizer
+
+(define (h-size kids)
+ (make-size
+ (apply + (map (lambda (kid)
+ (Size.Width (get-desired-size kid)))
+ kids))
+ (apply max (cons 0
+ (map (lambda (kid)
+ (Size.Height (get-desired-size kid)))
+ kids)))))
+
+;; Vertical arranger
+
+(define (v-arrange kids my-screen-area)
+ (let* ((my-height (UITKRectangle.Height my-screen-area))
+ (full-width (UITKRectangle.Width my-screen-area))
+ (my-offset (UITKRectangle.Offset my-screen-area))
+ (Y (point.Y my-offset))
+ (vglues (map %vglue kids)))
+ (conquer-space
+ my-height
+ vglues
+ (lambda (positions-vector)
+ (let loop ((n 0) (rest kids))
+ (if (null? rest)
+ #F
+ (let* ((kid (car rest))
+ (kid-y-offset (vector-ref positions-vector n))
+ (height (- (vector-ref positions-vector (+ n 1))
+ kid-y-offset))
+ (desired-size (get-desired-size kid))
+ (desired-width (Size.Width Desired-Size))
+ (hglue (%hglue kid))
+ (width (cond ((or (fil-glue? hglue)
+ (fill-glue? hglue))
+ full-width)
+ ((rigid-glue? hglue) desired-width)
+ ;;((percent-glue? hglue)
+ ;;(max desired-width
+ ;;(inexact->exact
+ ;;(ceiling (* .01 (glue.value hglue) height)))))
+ (else (error "Unknown glue class"
+ (glue.class hglue)))))
+ (X (+ (Point.X my-offset)
+ (ceiling
+ (/ (- (UITKRectangle.Width my-screen-area) width)
+ 2)))))
+ (assign-screen-area!
+ kid
+ (make-UITKRectangle (make-point X (+ Y kid-y-offset))
+ (make-size width height)))
+ (loop (+ n 1) (cdr rest)))))))))
+
+
+;; Horizontal arranger
+
+(define (h-arrange kids my-screen-area)
+ (let* ((my-width (UITKRectangle.Width my-screen-area))
+ (full-height (UITKRectangle.Height my-screen-area))
+ (my-offset (UITKRectangle.Offset my-screen-area))
+ (X (point.X my-offset))
+ (hglues (map %hglue kids)))
+ (conquer-space
+ my-width
+ hglues
+ (lambda (positions-vector)
+ (let loop ((n 0) (rest kids))
+ (if (null? rest)
+ #F
+ (let* ((kid (car rest))
+ (kid-x-offset (vector-ref positions-vector n))
+ (width (- (vector-ref positions-vector (+ n 1))
+ kid-x-offset))
+ (desired-size (get-desired-size kid))
+ (desired-height (Size.Height Desired-Size))
+ (vglue (%vglue kid))
+ (height (cond ((or (fil-glue? vglue)
+ (fill-glue? vglue))
+ full-height)
+ ((rigid-glue? vglue) desired-height)
+ ;;((percent-glue? vglue)
+ ;;(max desired-height
+ ;;(inexact->exact
+ ;;(ceiling (* .01 (glue.value vglue) width)))))
+ (else (error "Unknown glue class"
+ (glue.class vglue)))))
+ (Y (+ (Point.Y my-offset)
+ (ceiling
+ (/ (- (UITKRectangle.Height my-screen-area) height)
+ 2)))))
+ (assign-screen-area!
+ kid
+ (make-UITKRectangle (make-point (+ X kid-x-offset) Y)
+ (make-size width height)))
+ (loop (+ n 1) (cdr rest)))))))))
+
+
+;;; Calculate hglue and vglue for hboxes...
+
+(define (h-get-hglue kids)
+ (series-compose-glues (map %hglue kids)))
+
+(define (h-get-vglue kids)
+ (parallel-compose-glues (map %vglue kids)))
+
+;;; ... and vboxes.
+
+(define (v-get-hglue kids)
+ (parallel-compose-glues (map %hglue kids)))
+
+(define (v-get-vglue kids)
+ (series-compose-glues (map %vglue kids)))
+
+
+;; Generic arranger
+
+(define (retract-area objects)
+ (for-each (lambda (obj) (assign-screen-area! obj #F))
+ objects))
+
+(define (box-add-child! me kid)
+ (if (not (valid-child? kid))
+ (error "BOX-ADD-CHILD!: Bad UIObj" kid))
+ (one-parent-only! kid me)
+ (set-Box%.kids! me (append (Box%.kids me) (list kid)))
+ (on-geometry-change!
+ kid 'BOX
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area ; Not used
+ (if (eq? new-screen-area #T) ; Instigated by child, not manager
+ (box:rearrange me))))
+ (on-death! kid 'BOX (lambda () (box-remove-child! me kid)))
+ (assign-drawing-surface! kid (drawing-surface me))
+ (box:rearrange me))
+
+(define (box-remove-child! me kid)
+ (if (not (valid-child? kid))
+ (error "BOX-REMOVE-CHILD!: Bad UIObj" kid))
+ (set-Box%.kids! me (delq! kid (Box%.kids me)))
+ (forget! kid 'BOX)
+ (assign-drawing-surface! kid 'RETRACTED)
+ (box:rearrange me))
+
+(define (box-assign-drawing-surface! me surface)
+ (check-drawing-surface! me surface)
+ (for-each (lambda (kid)
+ (if (eq? surface 'RETRACTED)
+ (forget! kid 'BOX))
+ (assign-drawing-surface! kid surface))
+ (Box%.kids me))
+ (if (DrawingSurface? surface)
+ (set-%desired-size! me ((Box%.sizer me) (Box%.kids me))))
+ (if (eq? Surface 'RETRACTED)
+ (death! me)
+ (geometry-change! me #F #F))
+ 'OK)
+
+(define (box-assign-screen-area! me screen-area)
+ (cond ((vector? screen-area)
+ (set-assigned-screen-area! me screen-area)
+ (let ((old (used-screen-area me)))
+ (if (not (screen-area= old screen-area))
+ (begin
+ (set-used-screen-area! me screen-area)
+ (box:rearrange me)
+ (geometry-change! me old screen-area))))
+ screen-area)
+ ((not screen-area)
+ (set-assigned-screen-area! me screen-area)
+ (let ((old (used-screen-area me)))
+ (if (not (screen-area= old screen-area))
+ (begin
+ (set-used-screen-area! me screen-area)
+ (retract-area (Box%.kids me))
+ (geometry-change! me old screen-area))))
+ screen-area)
+ (else
+ (error "BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
+
+(define (box-assign-glue! me)
+ (let ((kids (Box%.kids me)))
+ (for-each assign-glue! kids)
+ (set-%hglue! me ((Box%.get-hglue me) kids))
+ (set-%vglue! me ((Box%.get-vglue me) kids))))
+
+;; Box Maker
+(define (box-maker size-proc screen-area-proc get-hglue get-vglue)
+ (make-Box%
+ (make-UIObjInternals box-add-child!
+ 'invalid
+ UIObj-set-context!
+ box-assign-screen-area!
+ box-assign-drawing-surface!
+ UIObj-point-within?
+ UIObj-rectangle-overlaps?
+ UIObj-handle-event
+ UIObj-get-desired-size
+ UIObj-assigned-screen-area
+ UIObj-used-screen-area
+ UIObj-set-assigned-screen-area!
+ UIObj-set-used-screen-area!
+ box-assign-glue!)
+ size-proc
+ screen-area-proc
+ get-hglue
+ get-vglue))
+
+(define (box:rearrange me)
+ (let ((screen-area (used-screen-area me))
+ (arrange (Box%.arranger me))
+ (size (Box%.sizer me))
+ (kids (Box%.kids me)))
+ (if screen-area
+ (let ((new-size (size kids)))
+ (set-%desired-size! me new-size)
+ (if (size= new-size (UITKRectangle.Size screen-area))
+ (begin (assign-glue! me)
+ (arrange kids screen-area))
+ (begin
+ (set-%desired-size! me new-size)
+ (geometry-change! me screen-area #T)
+ (if (eq? screen-area (used-screen-area me))
+ (begin (assign-glue! me)
+ (arrange kids screen-area)))))))))
+
+(define (box:event-propagator box)
+ (lambda (event)
+ (for-each (lambda (kid)
+ (if (event-within? kid event)
+ (handle-event kid event)))
+ (Box%.kids box))))
+
+
+(define (make-box size-proc screen-area-proc get-hglue get-vglue children)
+ (let ((me (box-maker size-proc screen-area-proc get-hglue get-vglue)))
+ (on-event! me 'BOX
+ (box:event-propagator me))
+ (for-each (lambda (kid) (add-child! me kid)) children)
+ me))
+
+;;; Glue Mechanism snarfed from Halstead
+
+;;; Glue abstraction, captures a minimum size (horizontal or vertical,
+;;; depending on usage) below which the object really ought not to shrink.
+;;; Also specifies a stretchability value (glue-value) and a stretchability
+;;; class (glue-class). Space is divided between two series-composed
+;;; glues as follows:
+;;;
+;;; 1. If the total is less than the sum of the glues' minimum sizes
+;;; then divide the space in proportion to the minimum sizes (everybody
+;;; has to give up the same percentage of their minimum size).
+;;;
+;;; 2. Else, if both glues have the same glue-class, then divide the excess
+;;; of available space (over the sum of their minimum sizes)
+;;; in proportion to their glue-values.
+;;;
+;;; 3. If the glue-classes differ, then the glue with the smaller glue-class
+;;; gets its minimum size, and the glue with the larger glue-class gets
+;;; all the rest (thus glue of a given glue-class is "infinitely" more
+;;; stretchable than any glue from a lower glue-class -- this is useful
+;;; for filling out to a boundary without stretching the item before the
+;;; fill).
+
+;;; Conventional glue classes:
+
+(define *rigid-glue-class* -1) ; for things that really don't want to stretch
+(define *percent-glue-class* 0) ; for proportionally allocating space
+(define *fill-glue-class* 1) ; for things intended to be infinitely stretchable
+(define *fil-glue-class* 2) ; even stretchier!
+
+(define (make-rigid-glue minsize value)
+ (make-glue minsize *rigid-glue-class* value))
+
+(define (make-percent-glue minsize percent)
+ (make-glue minsize *percent-glue-class* percent))
+
+(define (make-fill-glue minsize value)
+ (make-glue minsize *fill-glue-class* value))
+
+(define (make-fil-glue minsize value)
+ (make-glue minsize *fil-glue-class* value))
+
+(define (rigid-glue? glue)
+ (= (glue.class glue) *rigid-glue-class*))
+
+(define (percent-glue? glue)
+ (= (glue.class glue) *percent-glue-class*))
+
+(define (fill-glue? glue)
+ (= (glue.class glue) *fill-glue-class*))
+
+(define (fil-glue? glue)
+ (= (glue.class glue) *fil-glue-class*))
+
+(define *fil-glue* (make-fil-glue 0 1))
+(define *rigid-glue* (make-rigid-glue 0 1))
+
+
+;;; Compose two glues laid end-to-end -- sum their minimum sizes
+;;; and their glue values (which implies that if the glue-classes
+;;; differ, then the resulting glue-class and glue-value are those
+;;; of the input glue with the larger glue-class).
+
+(define (series-compose-glue g1 g2)
+ (let ((c1 (glue.class g1))
+ (c2 (glue.class g2)))
+ (if (< c2 c1)
+ (series-compose-glue g2 g1)
+ (make-glue (+ (glue.minsize g1) (glue.minsize g2))
+ c2
+ (if (= c1 c2)
+ (+ (glue.value g1) (glue.value g2))
+ (glue.value g2))))))
+
+;;; Compose two glues laid in parallel -- use the max of their
+;;; minimum sizes and the min of their stretchabilities (which
+;;; implies using the stretchability of the glue with the smaller
+;;; glue-class, or the smaller glue-value if the glue-classes are
+;;; equal).
+
+(define (parallel-compose-glue g1 g2)
+ (let ((c1 (glue.class g1))
+ (c2 (glue.class g2)))
+ (if (< c2 c1)
+ (parallel-compose-glue g2 g1)
+ (make-glue (max (glue.minsize g1) (glue.minsize g2))
+ c1
+ (if (= c1 c2)
+ (min (glue.value g1) (glue.value g2))
+ (glue.value g1))))))
+
+;;; Support > 2 glues as arguments
+
+(define (compose-glues fcn list-of-glues)
+ ;; If there's no glue at all, make it be fil glue.
+ (if (null? list-of-glues)
+ *fil-glue*
+ (let loop ((cumulative-glue (car list-of-glues))
+ (rest (cdr list-of-glues)))
+ (if (null? rest)
+ cumulative-glue
+ (let ((next-glue (car rest)))
+ (loop (fcn cumulative-glue next-glue)
+ (cdr rest)))))))
+
+(define (series-compose-glues list-of-glues)
+ (compose-glues series-compose-glue list-of-glues))
+
+(define (parallel-compose-glues list-of-glues)
+ (compose-glues parallel-compose-glue list-of-glues))
+
+
+;;; Choose the less restrictive (in terms of minimum size) of two
+;;; glues. This procedure is used for implementing the "orbox" combiner:
+
+(define (choose-minimum-glue list-of-glues)
+ (define (min-glue g1 g2)
+ (let ((min1 (glue.minsize g1))
+ (min2 (glue.minsize g2)))
+ (cond ((< min1 min2) g1)
+ ((> min1 min2) g2)
+ (else g1)))) ; arbitrary choice
+ (let ((g1 (car list-of-glues)))
+ (let loop ((list-of-glues list-of-glues) (g g1))
+ (if (null? (cdr list-of-glues))
+ (min-glue g (car list-of-glues))
+ (let* ((next-glue (car list-of-glues)))
+ (loop (cdr list-of-glues) (min-glue g next-glue)))))))
+
+(define (choose-maximum-glue list-of-glues)
+ (define (max-glue g1 g2)
+ (let ((max1 (glue.minsize g1))
+ (max2 (glue.minsize g2)))
+ (cond ((< max1 max2) g2)
+ ((> max1 max2) g1)
+ (else g1)))) ; arbitrary choice
+ (let ((g1 (car list-of-glues)))
+ (let loop ((list-of-glues list-of-glues) (g g1))
+ (if (null? list-of-glues)
+ g
+ (let* ((next-glue (car list-of-glues)))
+ (loop (cdr list-of-glues) (max-glue g next-glue)))))))
+
+#|
+;;; Magnify the minsize and stretchability of a glue by a factor:
+
+(define (magnify-glue g factor)
+ (make-glue (* factor (glue.minsize g))
+ (glue.class g)
+ (* factor (glue.value g))))
+
+;;; Decide whether the given glue fits happily into the given space:
+
+(define (glue-fits-space? g space)
+ (<= (glue.minsize g) space))
+|#
+
+;;; Divide a given amount of space between two glues, according to the
+;;; rules given above. Returns the amounts of space allocated to the
+;;; two glues to the continuation k.
+
+(define (divide-space space g1 g2 k)
+ (let ((m1 (glue.minsize g1))
+ (m2 (glue.minsize g2)))
+ (let ((msum (+ m1 m2)))
+ (if (and (<= space msum) (> msum 0))
+ (let ((x1 (inexact->exact
+ (floor
+ (quotient (+ (* 2 m1 space) msum)
+ (* 2 msum)))))) ; round off space allocation
+ (k x1 (- space x1)))
+ (let ((c1 (glue.class g1))
+ (c2 (glue.class g2)))
+ (cond ((< c1 c2) (k m1 (- space m1)))
+ ((> c1 c2) (k (- space m2) m2))
+ (else (let ((v1 (glue.value g1))
+ (v2 (glue.value g2)))
+ (let ((vsum (+ v1 v2)))
+ (let ((x1 (+ m1
+ (inexact->exact
+ (floor
+ (quotient
+ (+ (* 2 v1 (- space msum))
+ vsum)
+ (* 2 vsum)))))))
+ (k x1 (- space x1))))))))))))
+
+
+;;; Given a space (width or height), a list of glues (assuming the
+;;; order of glues provided is left to right), and a receiver, divides
+;;; the space between the glues according to their properties.
+;;; Receiver is applied to the resulting vector of positions which are
+;;; offsets into the space.
+
+(define (conquer-space space list-of-glues receiver)
+ (let* ((num-glues (length list-of-glues))
+ (glues (list->vector list-of-glues))
+ (cum-glues (compute-cumulative-glues list-of-glues))
+ (positions-vector (make-vector (+ num-glues 1))))
+ (let loop ((s space) (n (- num-glues 1)))
+ (vector-set! positions-vector (+ n 1) s)
+ (if (> n 0)
+ (divide-space
+ s (vector-ref cum-glues (- n 1)) (vector-ref glues n)
+ (lambda (s1 s2)
+ s2 ; ignore
+ (loop s1 (- n 1))))))
+ (vector-set! positions-vector 0 0)
+ (receiver positions-vector)))
+
+
+;;; Given a list of glues, returns a vector of cumulative glues --
+;;; glues obtained by series composition of g1, g1&g2, (g1&g2)&g3, and
+;;; so on. For example,
+;;;
+;;; (compute-cumulative-glues (list g1 g2 g3)) is equivalent to:
+;;;
+;;; (let* ((g12 (series-compose-glue g1 g2))
+;;; (g123 (series-compose-glue g12 g3)))
+;;; `#(,g1 ,g12 ,g123))
+
+(define (compute-cumulative-glues list-of-glues)
+ ;; If there's no glue at all, make it be fil glue.
+ (if (null? list-of-glues)
+ *fil-glue*
+ (let* ((num-glues (length list-of-glues))
+ (cum-glues (make-vector num-glues))
+ (g1 (car list-of-glues)))
+ (vector-set! cum-glues 0 g1)
+ (let loop ((n 1) (old-glue g1) (glues (cdr list-of-glues)))
+ (if (= n num-glues)
+ cum-glues
+ (let* ((g (car glues))
+ (new-glue (series-compose-glue old-glue g)))
+ (vector-set! cum-glues n new-glue)
+ (loop (+ n 1) new-glue (cdr glues))))))))
+
+
+;;; A space is basically a "piece of glue." It is of class fil, so it
+;;; is very stretchable (more so than anything else). It can be used
+;;; to fill in spaces between widgets in a box.
+;;; This would probably be better off if implemented as a shape
+;;; instead of a canvas, but for now (till shapes are working
+;;; right)...
+
+(define (make-space . options)
+ (let* ((configure-options (if options (car options) '()))
+ (space (make-canvas `(-width 0 -height 0 ,@configure-options))))
+ (set-%hglue! space *fil-glue*)
+ (set-%vglue! space *fil-glue*)
+ space))
+
+
+
+;;; Build a tabular array of boxes. Each argument is a list of kids that
+;;; are to be arranged left-to-right, in hbox fashion. These rows of boxes
+;;; are in turn stacked vertically, in vbox fashion; however, the sizes of
+;;; the boxes in different rows interact so that columns, as well as rows,
+;;; of boxes are kept aligned. Thus (array-box '(A B C) '(D E F) '(G H J))
+;;; will generate the following arrangement of kids A-J:
+;;;
+;;; A B C
+;;;
+;;; D E F
+;;;
+;;; G H J
+;;;
+;;; regardless of the individual sizes of the component boxes. Instead of
+;;; boxes, the following symbols may also appear as elements of an argument:
+;;;
+;;; skip -- indicates the corresponding cell is to be left empty.
+;;; left -- indicates the box to the left spans into this cell as well.
+;;; up -- indicates the box above spans into this cell as well.
+;;;
+;;; If the argument lists are not all of the same length, they are considered
+;;; to be padded out at the end with as many occurrences of the symbol "left"
+;;; as needed to make their lengths all equal.
+
+(define (kids-lists->complete-kids-lists kids-lists)
+ (let ((num-cols (apply max (map length kids-lists))))
+ (define (kids-list->complete-kids-list kids-list)
+ (let loop ((col 0) (complete-kids-list '()) (rest-kids kids-list))
+ (if (= col num-cols)
+ complete-kids-list
+ (let* ((next-kid
+ (if (null? rest-kids)
+ 'left
+ (car rest-kids)))
+ (rest-kids
+ (if (null? rest-kids)
+ '()
+ (cdr rest-kids)))
+ (next-complete-list
+ (append complete-kids-list (list next-kid))))
+ (loop (+ col 1) next-complete-list rest-kids)))))
+
+ (let loop ((complete-kids-lists '()) (rest-kids-lists kids-lists))
+ (if (null? rest-kids-lists)
+ complete-kids-lists
+ (let ((next-list (car rest-kids-lists)))
+ (loop (append complete-kids-lists
+ (list (kids-list->complete-kids-list next-list)))
+ (cdr rest-kids-lists)))))))
+
+
+(define (row-lists->col-lists kids-lists)
+ (let ((kids-lists (kids-lists->complete-kids-lists kids-lists)))
+ (let loop ((col 0) (col-lists '()))
+ (if (= col (apply max (map length kids-lists)))
+ col-lists
+ (let ((col-list
+ (let loop ((row 0) (col-list '()))
+ (if (= row (length kids-lists))
+ col-list
+ (loop (+ row 1)
+ (cons (list-ref (list-ref kids-lists row) col)
+ col-list))))))
+ (loop (+ col 1) (cons col-list col-lists)))))))
+
+(define (array-size kids-lists)
+ (let ((col-lists (row-lists->col-lists kids-lists)))
+ (make-size
+ (apply +
+ (map (lambda (col-list)
+ (apply max
+ (map (lambda (kid)
+ (if (symbol? kid)
+ 0
+ (size.width (get-desired-size kid))))
+ col-list)))
+ col-lists))
+ (apply +
+ (map (lambda (row-list)
+ (apply max
+ (map (lambda (kid)
+ (if (symbol? kid)
+ 0
+ (size.height (get-desired-size kid))))
+ row-list)))
+ kids-lists)))))
+
+(define (array-arrange kids-lists my-screen-area)
+ (let* ((my-width (UITKRectangle.Width my-screen-area))
+ (my-height (UITKRectangle.Height my-screen-area))
+ (my-offset (UITKRectangle.Offset my-screen-area))
+ (X (point.X my-offset))
+ (Y (point.Y my-offset))
+ (kids-lists (kids-lists->complete-kids-lists kids-lists))
+ )
+
+ (define (kids-lists->kids-array kids-lists)
+ (let loop ((kids-lists kids-lists) (kids-array-list '()))
+ (if (null? kids-lists)
+ (list->vector kids-array-list)
+ (loop (cdr kids-lists)
+ (append kids-array-list
+ (list (list->vector (car kids-lists))))))))
+
+ (let* ((kids-array (kids-lists->kids-array kids-lists))
+ (num-rows (vector-length kids-array))
+ (num-cols (vector-length (vector-ref kids-array 0))))
+
+ (define (aref array row col)
+ (vector-ref (vector-ref array row) col))
+
+ (define (aset! array row col value)
+ (vector-set! (vector-ref array row) col value))
+
+ (define (kids-column-hglue col)
+ (define (get-hglue kid)
+ (if (symbol? kid)
+ *fil-glue*
+ (%hglue kid)))
+ (let* ((kid1 (aref kids-array 0 col))
+ (g1 (get-hglue kid1)))
+ (let loop ((row 1) (g g1))
+ (if (< row num-rows)
+ (let* ((next-kid (aref kids-array row col))
+ (next-glue (get-hglue next-kid)))
+ (loop (+ row 1) (parallel-compose-glue g next-glue)))
+ g))))
+
+ (define (kids-row-vglue row)
+ (define (get-vglue kid)
+ (if (symbol? kid)
+ *fil-glue*
+ (%vglue kid)))
+ (let* ((kid1 (aref kids-array row 0))
+ (g1 (get-vglue kid1)))
+ (let loop ((col 1) (g g1))
+ (if (< col num-cols)
+ (let* ((next-kid (aref kids-array row col))
+ (next-glue (get-vglue next-kid)))
+ (loop (+ col 1) (parallel-compose-glue g next-glue)))
+ g))))
+
+ (define (enumerate-interval from to)
+ (if (> from to)
+ '()
+ (cons from (enumerate-interval (+ from 1) to))))
+
+ (define (instantiate-kids h-positions-vector v-positions-vector)
+ (let loop-rows ((row 0))
+ (if (= row num-rows)
+ 'done
+ (let loop-cols ((col 0))
+ (if (= col num-cols)
+ (loop-rows (+ row 1))
+ (let ((kid (aref kids-array row col)))
+ (if (symbol? kid)
+ (cond ((eq? kid 'skip)
+ (loop-cols (+ col 1)))
+ ((or (eq? kid 'left) (eq? kid 'up))
+ ;; wasn't to the right or below a
+ ;; valid child, so it's either been
+ ;; taken care of already, or needs to
+ ;; be 'skip.
+ (aset! kids-array row col 'skip)
+ (loop-cols (+ col 1)))
+ (else
+ (error
+ "Illegal symbol in array box:"
+ "Must be 'skip, 'left, or 'up." kid)))
+ (let* ((kid-x-offset
+ (vector-ref h-positions-vector col))
+ (kid-y-offset
+ (vector-ref v-positions-vector row))
+ (width (- (vector-ref h-positions-vector
+ (+ col 1))
+ kid-x-offset))
+ (height (- (vector-ref v-positions-vector
+ (+ row 1))
+ kid-y-offset)))
+
+ (let expand-h-loop ((col+ 1) (wid width))
+ (let ((new-col (+ col+ col)))
+ (if (= new-col num-cols)
+ (set! width wid)
+ (let ((next-h-kid (aref kids-array row new-col)))
+ (if (symbol? next-h-kid)
+ (cond
+ ((eq? next-h-kid 'left)
+ (let* ((x-offset
+ (vector-ref h-positions-vector
+ new-col))
+ (new-wid
+ (+ wid
+ (- (vector-ref
+ h-positions-vector
+ (+ new-col 1))
+ x-offset))))
+ (aset! kids-array row new-col 'skip)
+ (expand-h-loop (+ col+ 1) new-wid)))
+ ((eq? next-h-kid 'skip)
+ (set! width wid))
+ ((eq? next-h-kid 'up)
+ (set! width wid))
+ (else
+ (error "Illegal symbol in array box:"
+ "Must be 'skip, 'left, or 'up."
+ next-h-kid)))
+ (set! width wid))))))
+
+ (let expand-v-loop ((row+ 1) (ht height))
+ (let ((new-row (+ row+ row)))
+ (if (= new-row num-rows)
+ (set! height ht)
+ (let ((next-v-kid (aref kids-array new-row col)))
+ (if (symbol? next-v-kid)
+ (cond
+ ((eq? next-v-kid 'up)
+ (let* ((y-offset
+ (vector-ref v-positions-vector
+ new-row))
+ (new-ht
+ (+ ht (- (vector-ref
+ v-positions-vector
+ (+ new-row 1))
+ y-offset))))
+ (aset! kids-array new-row col 'skip)
+ (expand-v-loop (+ row+ 1) new-ht)))
+ ((eq? next-v-kid 'skip)
+ (set! height ht))
+ ((eq? next-v-kid 'left)
+ (set! height ht))
+ (else
+ (error "Illegal symbol in array box:"
+ "Must be 'skip, 'left, or 'up."
+ next-v-kid)))
+ (set! height ht))))))
+
+ (assign-screen-area!
+ kid
+ (make-UITKRectangle (make-point (+ X kid-x-offset)
+ (+ Y kid-y-offset))
+ (make-size width height)))
+ (loop-cols (+ col 1))))))))))
+
+ (let ((cols-hglues (map kids-column-hglue (enumerate-interval 0 (- num-cols 1))))
+ (rows-vglues (map kids-row-vglue (enumerate-interval 0 (- num-rows 1)))))
+ (conquer-space
+ my-width
+ cols-hglues
+ (lambda (h-positions-vector)
+ (conquer-space
+ my-height
+ rows-vglues
+ (lambda (v-positions-vector)
+ (instantiate-kids h-positions-vector v-positions-vector))))))
+ )))
+
+(define (array-get-hglue kids-lists)
+ ;; or minimum?
+ (choose-maximum-glue
+ (map (lambda (kids-list)
+ (series-compose-glues
+ (map (lambda (kid)
+ (if (symbol? kid)
+ *rigid-glue*
+ (%hglue kid)))
+ kids-list)))
+ kids-lists)))
+
+(define (array-get-vglue kids-lists)
+ (choose-maximum-glue
+ (map (lambda (kids-list)
+ (series-compose-glues
+ (map (lambda (kid)
+ (if (symbol? kid)
+ *rigid-glue*
+ (%vglue kid)))
+ kids-list)))
+ (row-lists->col-lists kids-lists))))
+
+
+(define (find-real-array-box-children kids-lists)
+ (let loop-lists ((kids-lists kids-lists)
+ (valid-kids-list '()))
+ (if (null? kids-lists)
+ valid-kids-list
+ (let loop-list ((kids-list (car kids-lists))
+ (valid-kids '()))
+ (if (null? kids-list)
+ (loop-lists (cdr kids-lists)
+ (append valid-kids-list valid-kids))
+ (let ((kid (car kids-list)))
+ (if (symbol? kid)
+ (loop-list (cdr kids-list) valid-kids)
+ (loop-list (cdr kids-list)
+ (append valid-kids (list kid))))))))))
+
+(define (array:rearrange me)
+ (let ((screen-area (used-screen-area me))
+ (kids-lists (ArrayBox%.kids-lists me)))
+ (if screen-area
+ (let ((new-size (array-size kids-lists)))
+ (set-%desired-size! me new-size)
+ (if (size= new-size (UITKRectangle.Size screen-area))
+ (begin (assign-glue! me)
+ (array-arrange kids-lists screen-area))
+ (begin
+ (set-%desired-size! me new-size)
+ (geometry-change! me screen-area #T)
+ (if (eq? screen-area (used-screen-area me))
+ (begin (assign-glue! me)
+ (array-arrange kids-lists screen-area)))))))))
+
+(define (array-box-add-child! me kid)
+ (if (not (valid-child? kid))
+ (error "ARRAY-BOX-ADD-CHILD!: Bad UIObj" kid))
+ (one-parent-only! kid me)
+ (set-ArrayBox%.kids! me (append (ArrayBox%.kids me) (list kid)))
+ (on-geometry-change!
+ kid 'ARRAY-BOX
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area ; Not used
+ (if (eq? new-screen-area #T) ; Instigated by child, not manager
+ (array:rearrange me))))
+ (on-death! kid 'ARRAY-BOX ; Die horribly ....
+ (lambda ()
+ (assign-drawing-surface! me 'RETRACTED)))
+ (assign-drawing-surface! kid (drawing-surface me))
+ (array:rearrange me))
+
+(define (array-box-assign-drawing-surface! me surface)
+ (check-drawing-surface! me surface)
+ (for-each (lambda (kid)
+ (if (eq? surface 'RETRACTED)
+ (forget! kid 'ARRAY-BOX))
+ (assign-drawing-surface! kid surface))
+ (ArrayBox%.kids me))
+ (if (DrawingSurface? surface)
+ (set-%desired-size! me (array-size (ArrayBox%.kids-lists me))))
+ (if (eq? surface 'RETRACTED)
+ (death! me)
+ (geometry-change! me #F #F))
+ 'OK)
+
+(define (array-box-assign-screen-area! me screen-area)
+ (cond ((vector? screen-area)
+ (set-assigned-screen-area! me screen-area)
+ (let ((old (used-screen-area me)))
+ (if (not (screen-area= old screen-area))
+ (begin
+ (set-used-screen-area! me screen-area)
+ (array:rearrange me)
+ (geometry-change! me old screen-area))))
+ screen-area)
+ ((not screen-area)
+ (set-assigned-screen-area! me screen-area)
+ (let ((old (used-screen-area me)))
+ (if (not (screen-area= old screen-area))
+ (begin
+ (set-used-screen-area! me screen-area)
+ (retract-area (ArrayBox%.kids me))
+ (geometry-change! me old screen-area))))
+ screen-area)
+ (else
+ (error "ARRAY-BOX-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
+
+(define (array-box-assign-glue! me)
+ (let ((kids-lists (ArrayBox%.kids-lists me)))
+ (for-each assign-glue! (ArrayBox%.kids me))
+ (set-%hglue! me (array-get-hglue kids-lists))
+ (set-%vglue! me (array-get-vglue kids-lists))))
+
+;; Box Maker
+(define (array-box-maker kids-lists)
+ (make-ArrayBox%
+ (make-UIObjInternals 'invalid-arraybox-1 ; array-box-add-child!
+ 'invalid-arraybox-2 ; array-box-remove-child!
+ UIObj-set-context!
+ array-box-assign-screen-area!
+ array-box-assign-drawing-surface!
+ UIObj-point-within?
+ UIObj-rectangle-overlaps?
+ UIObj-handle-event
+ UIObj-get-desired-size
+ UIObj-assigned-screen-area
+ UIObj-used-screen-area
+ UIObj-set-assigned-screen-area!
+ UIObj-set-used-screen-area!
+ array-box-assign-glue!)
+ kids-lists))
+
+(define (array-box-propagator box)
+ (lambda (event)
+ (for-each (lambda (kid)
+ (if (event-within? kid event)
+ (handle-event kid event)))
+ (array-box%.kids box))))
+
+(define (make-array-box . kids-lists)
+ (let ((kids (find-real-array-box-children kids-lists)))
+ (let ((me (array-box-maker kids-lists)))
+ (on-event! me 'ARRAY-BOX
+ (array-box-propagator me))
+ (for-each (lambda (kid) (array-box-add-child! me kid))
+ kids)
+ me)))
--- /dev/null
+#|
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+ ;; Dynamically load the microcode. Order important.
+ (load "dynload/scxl")
+ (load "dynload/tcl")
+ (load "dynload/tk")
+ (load "dynload/uitk")
+
+ ((access with-directory-rewriting-rule
+ (->environment '(RUNTIME COMPILER-INFO)))
+ (working-directory-pathname)
+ (pathname-as-directory "lib/swat")
+ (lambda ()
+ (package/system-loader "swat" '() 'QUERY)))
+ (add-system! (make-system "SWAT" 1 0 '()))))
+|#
+
+
+
+(let ((swat-env
+ (in-package system-global-environment
+ (let ()
+ (the-environment)))))
+
+ (package/add-child! (find-package '()) 'SWAT swat-env)
+
+ (for-each (lambda (export)
+ (local-assignment swat-env export 'UNASSIGNED)
+ (environment-link-name
+ (package/environment (find-package '()))
+ swat-env
+ export))
+ ;; All of SWAT's exported names. This list need pruning
+ '(*-alert-structure-size-*
+ *-alert.function-*
+ *-alert.reason-*
+ *-canvasitem-structure-size-*
+ *-canvasitem.add-event-handler!-procedure-*
+ *-canvasitem.ask-widget-procedure-*
+ *-canvasitem.canvas-*
+ *-canvasitem.name-*
+ *-canvasitem.set-callback!-procedure-*
+ *-canvasitemgroup-structure-size-*
+ *-canvasitemgroup.add-event-handler!-procedure-*
+ *-canvasitemgroup.ask-widget-procedure-*
+ *-canvasitemgroup.canvas-*
+ *-canvasitemgroup.set-callback!-procedure-*
+ *-canvasitemgroup.tag-*
+ *-context-structure-size-*
+ *-context.activebackground-*
+ *-context.activeforeground-*
+ *-context.anchor-*
+ *-context.background-*
+ *-context.border-*
+ *-context.borderwidth-*
+ *-context.foreground-*
+ *-context.relief-*
+ *-drawingsurface-structure-size-*
+ *-drawingsurface.toolkitwindow-*
+ *-drawingsurface.uitkwindow-*
+ *-drawingsurface.weak-list-of-widgets-*
+ *-event-structure-size-*
+ *-event.height-*
+ *-event.offset-*
+ *-event.os-event-*
+ *-event.point-or-rectangle?-*
+ *-event.type-*
+ *-event.width-*
+ *-event.window-*
+ *-glue-structure-size-*
+ *-glue.class-*
+ *-glue.minsize-*
+ *-glue.value-*
+ *-locked-list-structure-size-*
+ *-menuitem-structure-size-*
+ *-menuitem.add-event-handler!-procedure-*
+ *-menuitem.ask-widget-procedure-*
+ *-menuitem.index-*
+ *-menuitem.menurecord-*
+ *-menuitem.set-callback!-procedure-*
+ *-menurecord-structure-size-*
+ *-menurecord.items-*
+ *-menurecord.menu-*
+ *-point-structure-size-*
+ *-point.x-*
+ *-point.y-*
+ *-queue-structure-size-*
+ *-scxl-wrapper-structure-size-*
+ *-scxl-wrapper.other-stuff-*
+ *-scxl-wrapper.strong-dependents-*
+ *-scxl-wrapper.type-*
+ *-scxl-wrapper.wrapped-object-*
+ *-sensitive-surface-structure-size-*
+ *-sensitive-surface.drawingsurface-*
+ *-sensitive-surface.handlers-*
+ *-sensitivity-structure-size-*
+ *-sensitivity.masks-*
+ *-size-structure-size-*
+ *-size.height-*
+ *-size.width-*
+ *-surface-sensitivity-structure-size-*
+ *-surface-sensitivity.mask-*
+ *-surface-sensitivity.sensitivities-*
+ *-surface-sensitivity.weak-surface-*
+ *-texttag-structure-size-*
+ *-texttag.add-event-handler!-procedure-*
+ *-texttag.ask-widget-procedure-*
+ *-texttag.callbacks-*
+ *-texttag.name-*
+ *-texttag.set-callback!-procedure-*
+ *-texttag.text-*
+ *-tk-variable-structure-size-*
+ *-tk-variable.application-*
+ *-tk-variable.callback-*
+ *-tk-variable.tk-name-*
+ *-toolkitwindow-structure-size-*
+ *-toolkitwindow.application-*
+ *-toolkitwindow.tk-window-*
+ *-toolkitwindow.top-level-geometry-callback-*
+ *-uiobjinternals-structure-size-*
+ *-uiobjinternals.add-child!-procedure-*
+ *-uiobjinternals.already-have-a-parent?-*
+ *-uiobjinternals.assign-drawing-surface!-procedure-*
+ *-uiobjinternals.assign-glue!-procedure-*
+ *-uiobjinternals.assign-screen-area!-procedure-*
+ *-uiobjinternals.assigned-screen-area-*
+ *-uiobjinternals.assigned-screen-area-procedure-*
+ *-uiobjinternals.clip-region-*
+ *-uiobjinternals.crud-that-i-dont-want-to-gc-away-*
+ *-uiobjinternals.drawing-surface-*
+ *-uiobjinternals.get-desired-size-procedure-*
+ *-uiobjinternals.handle-event-procedure-*
+ *-uiobjinternals.point-within?-procedure-*
+ *-uiobjinternals.rectangle-overlaps?-procedure-*
+ *-uiobjinternals.remove-child!-procedure-*
+ *-uiobjinternals.set-assigned-screen-area!-procedure-*
+ *-uiobjinternals.set-context!-procedure-*
+ *-uiobjinternals.set-used-screen-area!-procedure-*
+ *-uiobjinternals.used-screen-area-*
+ *-uiobjinternals.used-screen-area-procedure-*
+ *-uitkrectangle-structure-size-*
+ *-uitkrectangle.offset-*
+ *-uitkrectangle.size-*
+ *-uitkwindow-structure-size-*
+ *-uitkwindow.xdisplay-*
+ *-uitkwindow.xwindow-*
+ *all-menus*
+ *all-sensitive-surfaces*
+ *event-processing-mutex*
+ *fil-glue*
+ *fil-glue-class*
+ *fill-glue-class*
+ *our-hash-table*
+ *percent-glue-class*
+ *rigid-glue*
+ *rigid-glue-class*
+ *synchronizing?*
+ *the-default-application*
+ *uitk-interval*
+ *uitk:gc-has-occurred?*
+ *xclosedisplaycallbacks*
+ ->widget
+ ->xcolormap
+ ->xdisplay
+ ->xgc
+ ->xpixel
+ ->xregion
+ ->xwindow
+ active-variable-value
+ add-child!
+ add-event-handler!
+ add-event-handler!-procedure-index
+ add-sub-menu
+ add-to-agenda!
+ add-to-canvas-item-group
+ add-to-menu
+ add-to-protection-list!
+ add-vectors
+ add-widget-list-for-display-number!
+ after-delay
+ after-last-space
+ alert.function
+ alert.reason
+ alert/pp
+ alert?
+ allow-free-trace?
+ application->display
+ application->tkmainwindow
+ application-add-child!
+ application-maker
+ application-remove-child!
+ application-remove-destroyed-child!
+ array-arrange
+ array-box-add-child!
+ array-box-assign-drawing-surface!
+ array-box-assign-glue!
+ array-box-assign-screen-area!
+ array-box-maker
+ array-box-propagator
+ array-get-hglue
+ array-get-vglue
+ array-size
+ array:rearrange
+ ask-widget
+ ask-widget-procedure-index
+ assign-drawing-surface!
+ assign-geometry!
+ assign-glue!
+ assign-location!
+ assign-screen-area!
+ assigned-screen-area
+ atomic-read-and-clear-cell!
+ bit-or
+ box-add-child!
+ box-assign-drawing-surface!
+ box-assign-glue!
+ box-assign-screen-area!
+ box-children
+ box-maker
+ box-remove-child!
+ box:event-propagator
+ box:rearrange
+ button-stretch
+ canvas-flush-protect-list!
+ canvas-protect-from-gc!
+ canvas-stretch
+ canvas-unprotect-from-gc!
+ canvasitem-add-event-handler!
+ canvasitem-ask-widget
+ canvasitem.add-event-handler!-procedure
+ canvasitem.ask-widget-procedure
+ canvasitem.canvas
+ canvasitem.name
+ canvasitem.set-callback!-procedure
+ canvasitem/pp
+ canvasitem?
+ canvasitemgroup-add-event-handler!
+ canvasitemgroup-ask-widget
+ canvasitemgroup.add-event-handler!-procedure
+ canvasitemgroup.ask-widget-procedure
+ canvasitemgroup.canvas
+ canvasitemgroup.set-callback!-procedure
+ canvasitemgroup.tag
+ canvasitemgroup/pp
+ canvasitemgroup?
+ change-sensitive-surface!
+ check-drawing-surface!
+ checkbutton-variable-on?
+ choose-maximum-glue
+ choose-minimum-glue
+ clean-lost-celled-objects
+ clean-lost-protected-objects
+ cleanup-vanished-objects-for-display
+ clear-counters!
+ cleararea
+ clip-region
+ close-lost-displays-daemon
+ color?
+ colormap/colormap
+ colormap/pixel-list
+ compose-glues
+ compute-cumulative-glues
+ conquer-space
+ context-change!
+ context.activebackground
+ context.activeforeground
+ context.anchor
+ context.background
+ context.border
+ context.borderwidth
+ context.foreground
+ context.relief
+ context/pp
+ context?
+ copy-free-traces
+ copy-rectangle
+ copyxregion
+ create-default-context
+ create-sensitive-surface
+ crud-that-i-dont-want-to-gc-away
+ current-size
+ current-time
+ death!
+ debug-print
+ debug-surface
+ debugging-port
+ decode-button-event
+ decode-configure-event
+ decode-crossing-event
+ decode-expose-event
+ decode-key-event
+ decode-motion-event
+ decode-unknown-event
+ decode-window-attributes
+ defer
+ ;;del-assq!
+ ;;del-assv!
+ ;;del-op!
+ delete-<interactor>!
+ delete-menuitem!
+ ;;dequeue!
+ destroy-all-sensitive-surfaces-from-display
+ destroy-associated-tk-widgets
+ destroy-registration
+ destroy-sensitive-surface
+ display->tk-widgets
+ display-protection-list
+ display/colormap-list
+ display/default-root-window
+ display/display
+ display/font-list
+ display/gc-list
+ display/screen/default-color-map
+ display/window-list
+ divide-space
+ do-tk-callbacks
+ do-tk-callbacks-from-string
+ drawarc
+ drawing-surface
+ drawingsurface.application
+ drawingsurface.toolkitwindow
+ drawingsurface.uitkwindow
+ drawingsurface.weak-list-of-widgets
+ drawingsurface/pp
+ drawingsurface?
+ drawline
+ drawrectangle
+ empty-agenda?
+ empty-queue?
+ empty-segments?
+ ;;enqueue!
+ ensure-graphics-context
+ entry-height-stretch
+ event!
+ event-counter
+ event-within?
+ event.height
+ event.offset
+ event.os-event
+ event.point-or-rectangle?
+ event.type
+ event.width
+ event.window
+ event/pp
+ event?
+ fil-glue?
+ fill-glue?
+ fillarc
+ fillrectangle
+ finalize-uitk-objects
+ finalize-uitk-objects-later
+ find-in-protection-list
+ find-menu-record
+ find-real-array-box-children
+ find-sensitivity
+ find-ss
+ find-tk-protection-list
+ find-tk-protection-list-from-number
+ first-segment
+ flush-display-hook
+ flush-queued-output
+ forget!
+ forget-context-change!
+ forget-death-notification!
+ forget-event!
+ forget-geometry-change!
+ fork-to-wait-on
+ gc/gc
+ gc/region
+ generate-events!
+ generate-graphics-context!
+ geometry-change!
+ get-desired-size
+ get-interval-to-next-delayed-event
+ get-interval-to-tk-wakeup
+ get-tk-widget-orientation
+ get-uitkwindow
+ get-window-attributes
+ get-x-event
+ getdefaultvalue
+ glue.class
+ glue.minsize
+ glue.value
+ glue/pp
+ glue?
+ h-arrange
+ h-get-hglue
+ h-get-vglue
+ h-size
+ handle-button-grab
+ handle-event
+ handle-exposure
+ handler->sensitivity
+ idle-queue
+ ignore-repl
+ init-alert
+ init-canvasitem
+ init-canvasitemgroup
+ init-context
+ init-drawingsurface
+ init-event
+ init-glue
+ init-locked-list
+ init-menuitem
+ init-menurecord
+ init-point
+ init-queue
+ init-scxl-wrapper
+ init-sensitive-surface
+ init-sensitivity
+ init-size
+ init-surface-sensitivity
+ init-texttag
+ init-tk-variable
+ init-toolkitwindow
+ init-uiobjinternals
+ init-uitkrectangle
+ init-uitkwindow
+ initial-thread-state
+ initialize-mit-widgets!
+ initialize-scxl!
+ initialize-uitk!
+ initialize-widgets!
+ insert-new-time!
+ interactor-add-child!
+ interactor-maker
+ interactor-remove-child!
+ intersectxregions
+ is-type-wrapped-object
+ kick-uitk-thread
+ kids-lists->complete-kids-lists
+ locked-list/pp
+ locked-list?
+ loop-counter
+ loop-trace
+ make-active-variable
+ make-add-alert!
+ make-agenda
+ make-alert
+ make-alert!
+ make-application
+ make-arc-on-canvas
+ make-arg-transformers
+ make-array-box
+ make-bitmap-on-canvas
+ make-box
+ make-button
+ make-canvas
+ make-canvas-item
+ make-canvas-item-group
+ make-canvasitem
+ make-canvasitemgroup
+ make-checkbutton
+ make-colored-graphics-context
+ make-context
+ make-del-op!
+ make-destroy-<application>-related-objects
+ make-drawingsurface
+ make-drop-rubber-rectangle-surface
+ make-enqueueable-thunk
+ make-entry
+ make-event
+ make-fil-glue
+ make-fill-glue
+ make-filled-circle
+ make-filled-oval
+ make-filled-rectangle
+ make-free-trace
+ make-glue
+ make-hbox
+ make-interactor
+ make-label
+ make-line
+ make-line-on-canvas
+ make-listbox
+ make-locked-list
+ make-lookup
+ make-menu
+ make-menubutton
+ make-menuitem
+ make-menurecord
+ make-message
+ make-oval
+ make-oval-on-canvas
+ make-percent-glue
+ make-point
+ make-point-event
+ make-polygon-on-canvas
+ make-protection-list
+ ;;make-queue
+ make-radiobutton
+ make-rect
+ make-rectangle-event
+ make-rectangle-on-canvas
+ make-remove-alert!
+ make-rigid-glue
+ make-scale
+ make-scaling-line
+ make-scaling-oval
+ make-scaling-rect
+ make-scrollable-canvas
+ make-scrollable-text
+ make-scrollbar
+ make-scxl-wrapper
+ make-self-painting-circle
+ make-self-painting-rectangle
+ make-self-painting-unfilled-rectangle
+ make-sensitive-surface
+ make-sensitivity
+ make-shape
+ make-shape-surface
+ make-simple-graphics-context
+ make-size
+ make-space
+ make-surface-sensitivity
+ make-text
+ make-text-on-canvas
+ make-text-tag
+ make-texttag
+ make-time-segment
+ make-tk-variable
+ make-tk-widget
+ make-toolkitwindow
+ make-top-level-geometry-callback
+ make-uiobjinternals
+ make-uitk-thread
+ make-uitkrectangle
+ make-uitkwindow
+ make-unfilled-circle
+ make-unfilled-oval
+ make-unfilled-rectangle
+ make-unknown-event
+ make-vbox
+ ;;make-weak-del-op!
+ ;;make-weak-lookup
+ make-widget-on-canvas
+ makexregion
+ maybe-defer
+ menuitem-ask-widget
+ menuitem-set-callback!
+ menuitem.add-event-handler!-procedure
+ menuitem.ask-widget-procedure
+ menuitem.index
+ menuitem.menu
+ menuitem.menurecord
+ menuitem.set-callback!-procedure
+ menuitem/pp
+ menuitem?
+ menurecord.items
+ menurecord.menu
+ menurecord/pp
+ menurecord?
+ merge-canvas-item-groups
+ more-counter
+ more-work-to-do
+ mouse-drag
+ on-context-change!
+ on-death!
+ on-event!
+ on-geometry-change!
+ one-parent-only!
+ open-display
+ our-with-thread-mutex-locked
+ parallel-compose-glue
+ parallel-compose-glues
+ percent-glue?
+ pixel/pixel
+ point-event-within?
+ point-event?
+ point-in-rectangle?
+ point-within?
+ point.x
+ point.y
+ point/pp
+ point=
+ point?
+ proc-with-transformed-args
+ protection-list-all-elements
+ protection-list-referenced-elements
+ queue/pp
+ ;;queue?
+ read-and-empty-agenda!
+ read-and-empty-queue!
+ read-queue-trace
+ record-free-pointer
+ record-surface-sensitivity!
+ rectangle->xregion
+ rectangle-event-within?
+ rectangle-event?
+ rectangle-overlaps-rectangle?
+ rectangle-overlaps?
+ rectangle=
+ region-protection-list
+ region/region
+ remember-on-canvas!
+ remove-child!
+ remove-from-protection-list!
+ remove-from-registry
+ reset-sensitivity!
+ rest-segments
+ restart-uitk
+ retract-area
+ rigid-glue?
+ row-lists->col-lists
+ run-queue-trace
+ screen-area=
+ scrollable-canvas-canvas
+ scrollable-canvas-hscroll
+ scrollable-canvas-vscroll
+ scrollable-text-text
+ scrollable-text-vscroll
+ scxl-destroy!
+ scxl-destroyed?
+ scxl-display?
+ scxl-install-xclosedisplay-callback
+ scxl-unwrap
+ scxl-wrap
+ scxl-wrapped?
+ scxl-wrapper.other-stuff
+ scxl-wrapper.strong-dependents
+ scxl-wrapper.type
+ scxl-wrapper.wrapped-object
+ scxl-wrapper/pp
+ scxl-wrapper?
+ search-protection-list
+ segment-queue
+ segment-time
+ segments
+ self-paint!
+ sensitive-surface.drawingsurface
+ sensitive-surface.handlers
+ sensitive-surface/pp
+ sensitive-surface?
+ sensitivity.masks
+ sensitivity/pp
+ sensitivity?
+ series-compose-glue
+ series-compose-glues
+ set-active-variable!
+ set-active-variable-callback!
+ set-alert.function!
+ set-alert.reason!
+ set-assigned-screen-area!
+ set-callback!
+ set-callback!-procedure-index
+ set-canvasitem.add-event-handler!-procedure!
+ set-canvasitem.ask-widget-procedure!
+ set-canvasitem.canvas!
+ set-canvasitem.name!
+ set-canvasitem.set-callback!-procedure!
+ set-canvasitemgroup.add-event-handler!-procedure!
+ set-canvasitemgroup.ask-widget-procedure!
+ set-canvasitemgroup.canvas!
+ set-canvasitemgroup.set-callback!-procedure!
+ set-canvasitemgroup.tag!
+ set-clip-region!
+ set-context!
+ set-context.activebackground!
+ set-context.activeforeground!
+ set-context.anchor!
+ set-context.background!
+ set-context.border!
+ set-context.borderwidth!
+ set-context.foreground!
+ set-context.relief!
+ set-crud-that-i-dont-want-to-gc-away!
+ set-drawing-surface!
+ set-drawingsurface.toolkitwindow!
+ set-drawingsurface.uitkwindow!
+ set-drawingsurface.weak-list-of-widgets!
+ set-event.height!
+ set-event.offset!
+ set-event.os-event!
+ set-event.point-or-rectangle?!
+ set-event.type!
+ set-event.width!
+ set-event.window!
+ set-floating-error-mask!
+ set-gc/region!
+ set-glue.class!
+ set-glue.minsize!
+ set-glue.value!
+ set-menuitem.add-event-handler!-procedure!
+ set-menuitem.ask-widget-procedure!
+ set-menuitem.index!
+ set-menuitem.menurecord!
+ set-menuitem.set-callback!-procedure!
+ set-menurecord.items!
+ set-menurecord.menu!
+ set-point.x!
+ set-point.y!
+ set-scxl-wrapper.other-stuff!
+ set-scxl-wrapper.strong-dependents!
+ set-scxl-wrapper.type!
+ set-scxl-wrapper.wrapped-object!
+ set-segments!
+ set-sensitive-surface.drawingsurface!
+ set-sensitive-surface.handlers!
+ set-sensitivity.masks!
+ set-size.height!
+ set-size.width!
+ set-surface-sensitivity.mask!
+ set-surface-sensitivity.sensitivities!
+ set-surface-sensitivity.weak-surface!
+ set-texttag.add-event-handler!-procedure!
+ set-texttag.ask-widget-procedure!
+ set-texttag.callbacks!
+ set-texttag.name!
+ set-texttag.set-callback!-procedure!
+ set-texttag.text!
+ set-tk-variable.application!
+ set-tk-variable.callback!
+ set-tk-variable.tk-name!
+ set-toolkitwindow.application!
+ set-toolkitwindow.tk-window!
+ set-toolkitwindow.top-level-geometry-callback!
+ set-uiobjinternals.add-child!-procedure!
+ set-uiobjinternals.already-have-a-parent?!
+ set-uiobjinternals.assign-drawing-surface!-procedure!
+ set-uiobjinternals.assign-glue!-procedure!
+ set-uiobjinternals.assign-screen-area!-procedure!
+ set-uiobjinternals.assigned-screen-area!
+ set-uiobjinternals.assigned-screen-area-procedure!
+ set-uiobjinternals.clip-region!
+ set-uiobjinternals.crud-that-i-dont-want-to-gc-away!
+ set-uiobjinternals.drawing-surface!
+ set-uiobjinternals.get-desired-size-procedure!
+ set-uiobjinternals.handle-event-procedure!
+ set-uiobjinternals.point-within?-procedure!
+ set-uiobjinternals.rectangle-overlaps?-procedure!
+ set-uiobjinternals.remove-child!-procedure!
+ set-uiobjinternals.set-assigned-screen-area!-procedure!
+ set-uiobjinternals.set-context!-procedure!
+ set-uiobjinternals.set-used-screen-area!-procedure!
+ set-uiobjinternals.used-screen-area!
+ set-uiobjinternals.used-screen-area-procedure!
+ set-uitkrectangle.offset!
+ set-uitkrectangle.size!
+ set-uitkwindow.xdisplay!
+ set-uitkwindow.xwindow!
+ set-used-screen-area!
+ setclipxregion
+ shape-assign-glue!
+ shape-assign-screen-area!
+ shape-copy
+ shape-draw
+ shape-draw-function
+ shape-erase-maybe
+ shape-maker
+ shape-point-within?
+ shape-rectangle-overlaps?
+ shape-set-color!
+ shape-set-erase-function!
+ shape-set-gc-function!
+ show-counters
+ shut-down-event-server
+ size.height
+ size.width
+ size/pp
+ size=
+ size?
+ string->color
+ stringify-for-tk
+ sub-vectors
+ subtractxregions
+ surface-sensitivity.mask
+ surface-sensitivity.sensitivities
+ surface-sensitivity.weak-surface
+ surface-sensitivity/pp
+ surface-sensitivity?
+ suspend-counter
+ swat-close
+ swat-open
+ swat-open-in-application
+ swat:number->string
+ tcl-global-eval
+ text-flush-protect-list!
+ text-protect-from-gc!
+ text-unprotect-from-gc!
+ texttag-add-event-handler!
+ texttag-ask-widget
+ texttag.add-event-handler!-procedure
+ texttag.ask-widget-procedure
+ texttag.callbacks
+ texttag.name
+ texttag.set-callback!-procedure
+ texttag.text
+ texttag/pp
+ texttag?
+ the-agenda
+ thread-start
+ tk-completely-handles-event?
+ tk-create-top-level-window
+ tk-delete-display
+ tk-doevents
+ tk-gen-name
+ tk-generate-scheme-event
+ tk-has-requested-new-size
+ tk-init
+ tk-invoke-command
+ tk-kill-application
+ tk-make-button
+ tk-make-canvas
+ tk-make-checkbutton
+ tk-make-entry
+ tk-make-label
+ tk-make-listbox
+ tk-make-menu
+ tk-make-menubutton
+ tk-make-message
+ tk-make-radiobutton
+ tk-make-scale
+ tk-make-scrollbar
+ tk-make-text
+ tk-manage-geometry
+ tk-map-window
+ tk-move-resize-widget
+ tk-op
+ tk-unmap-window
+ tk-variable.application
+ tk-variable.callback
+ tk-variable.tk-name
+ tk-variable/pp
+ tk-variable?
+ tk-widget->pathname
+ tk-widget-destroy
+ tk-widget.tkwin
+ tkwidget-add-child!
+ tkwidget-add-event-handler!
+ tkwidget-ask-widget
+ tkwidget-assign-drawing-surface!
+ tkwidget-assign-glue!
+ tkwidget-assign-screen-area!
+ tkwidget-assigned-screen-area
+ tkwidget-get-desired-size
+ tkwidget-maker
+ tkwidget-set-assigned-screen-area!
+ tkwidget-set-callback!
+ tkwidget-set-used-screen-area!
+ tkwidget-used-screen-area
+ tkwin->requested-size
+ tkwin->size
+ tkwin.display
+ tkwin.height
+ tkwin.ismapped?
+ tkwin.name
+ tkwin.pathname
+ tkwin.req-height
+ tkwin.req-width
+ tkwin.width
+ tkwin.window
+ tkwin.x
+ tkwin.y
+ toolkitwindow.application
+ toolkitwindow.tk-window
+ toolkitwindow.top-level-geometry-callback
+ toolkitwindow/pp
+ toolkitwindow?
+ translate-rectangle
+ type-check-wrapped-object
+ uiobj-assign-drawing-surface!
+ uiobj-assign-screen-area!
+ uiobj-assigned-screen-area
+ uiobj-get-desired-size
+ uiobj-handle-event
+ uiobj-point-within?
+ uiobj-protect-from-gc!
+ uiobj-rectangle-overlaps?
+ uiobj-set-assigned-screen-area!
+ uiobj-set-context!
+ uiobj-set-used-screen-area!
+ uiobj-unprotect-from-gc!
+ uiobj-used-screen-area
+ uiobjinternals
+ uiobjinternals-index
+ uiobjinternals.add-child!-procedure
+ uiobjinternals.already-have-a-parent?
+ uiobjinternals.assign-drawing-surface!-procedure
+ uiobjinternals.assign-glue!-procedure
+ uiobjinternals.assign-screen-area!-procedure
+ uiobjinternals.assigned-screen-area
+ uiobjinternals.assigned-screen-area-procedure
+ uiobjinternals.clip-region
+ uiobjinternals.crud-that-i-dont-want-to-gc-away
+ uiobjinternals.drawing-surface
+ uiobjinternals.get-desired-size-procedure
+ uiobjinternals.handle-event-procedure
+ uiobjinternals.point-within?-procedure
+ uiobjinternals.rectangle-overlaps?-procedure
+ uiobjinternals.remove-child!-procedure
+ uiobjinternals.set-assigned-screen-area!-procedure
+ uiobjinternals.set-context!-procedure
+ uiobjinternals.set-used-screen-area!-procedure
+ uiobjinternals.used-screen-area
+ uiobjinternals.used-screen-area-procedure
+ uiobjinternals/pp
+ uiobjinternals?
+ uitk-protection-list
+ uitk-queue
+ uitk-thread
+ uitk-thread-main-loop
+ uitk-timer
+ uitkrectangle.height
+ uitkrectangle.offset
+ uitkrectangle.size
+ uitkrectangle.width
+ uitkrectangle/pp
+ uitkrectangle?
+ uitkwindow.xdisplay
+ uitkwindow.xwindow
+ uitkwindow/pp
+ uitkwindow?
+ unionxregions
+ unwrap-display
+ update-locked-list!
+ used-screen-area
+ v-arrange
+ v-get-hglue
+ v-get-vglue
+ v-size
+ valid-child?
+ valid-color-for-application?
+ valid-color?
+ valid-non-widget?
+ ;;weak-delq!
+ when-idle!
+ when-unreferenced
+ widget->screen-area
+ widget->size
+ widget/widget
+ window/window
+ with-clipping!
+ with-locked-list
+ with-uitk-thread-errors-captured
+ wrap-colormap
+ wrap-display
+ wrap-graphics-context
+ wrap-pixel
+ wrap-region
+ wrap-tk-widget
+ wrap-window
+ wrap-with-scxl-destroy!
+ xallocnamedcolor
+ xchangewindowattributes
+ xcheckmaskevent!?
+ xcleararea
+ xclearwindow
+ xclosedisplay
+ xclosedisplaybynumber
+ xcolor.pixel
+ xconnectionnumber
+ xcopy-event
+ xcreategc
+ xcreateregion
+ xcreatesimplewindow
+ xdecodebuttonevent
+ xdecodeconfigureevent
+ xdecodecrossingevent
+ xdecodeexposeevent
+ xdecodekeyevent
+ xdecodemotionevent
+ xdecodeunknownevent
+ xdecodewindowattributes
+ xdecodexcolor
+ xdefaultcolormap
+ xdefaultrootwindow
+ xdefaultscreen
+ xdestroyregion
+ xdestroywindow
+ xdrawarc
+ xdrawline
+ xdrawrectangle
+ xevent-><event>
+ xevent-type
+ xfillarc
+ xfillrectangle
+ xflush
+ xfreecolormap
+ xfreegc
+ xgetdefault
+ xgetwindowattributes
+ xintersectregion!
+ xloadfont
+ xmake-color
+ xmake-event
+ xmake-gcvalues
+ xmake-setwindowattributes
+ xmapwindow
+ xnextevent
+ xnextevent!
+ xopendisplay
+ xpending
+ xputbackevent
+ xquerypointer
+ xquerytree
+ xscreencount
+ xsetforeground
+ xsetfunction
+ xsetregion
+ xsetwindowattributes-event_mask!
+ xstorename
+ xsubtractregion!
+ xtranslatecoordinates
+ xunionrectspecswithregion!
+ xunionregion!
+ xunloadfont)))
+
+
+(with-working-directory-pathname
+ (directory-pathname (current-load-pathname))
+ (lambda ()
+
+ (in-package (->environment '(SWAT))
+ ;; These get overriden when TK is loaded
+ (define (tk-doevents) 'tk-doevents)
+ (define (tk-init dsp) 'tk-init))
+
+ ;; Dynamically load the microcode. Order important.
+ (load "dynload/scxl")
+ (load "dynload/tcl")
+ (load "dynload/tk")
+ (load "dynload/uitk")
+
+ ;; And now the Scheme level
+ ;;(load "scc-macros")
+ ;;(load "uitk-macros")
+
+ ((access with-directory-rewriting-rule
+ (->environment '(RUNTIME COMPILER-INFO)))
+ (working-directory-pathname)
+ (pathname-as-directory "lib/swat")
+ (lambda ()
+ (let ((load
+ (lambda (file)
+ (load file '(SWAT)))))
+ (load "control-floating-errors")
+ (load "structures")
+ (load "structures2")
+ (load "generics")
+ (load "uitk")
+ (load "xlibCONSTANTS")
+ (load "mit-xlib")
+ (load "tk-mit")
+ (load "mit-xhooks")
+ (load "widget-mit")
+ (load "baseobj")
+ (load "widget")
+ (load "geometry")
+ (load "simple")
+ (load "canvas")
+ (load "menu")
+ (load "text")
+ ;;(load "rtest")
+ ;;(load "btest")
+ )))))
--- /dev/null
+;;; -*- Scheme -*-
+
+;;; <MenuItem> class
+
+(define *all-menus* '())
+
+(define (MenuItem.Menu item)
+ (MenuRecord.Menu (MenuItem.MenuRecord item)))
+
+(define (find-menu-record menu)
+ (let loop ((prev #F)
+ (rest *all-menus*))
+ (cond ((null? rest)
+ (error "Find-Menu-Record: Can't find record" menu))
+ ((null? (weak-car rest))
+ (if prev
+ (weak-set-cdr! prev (weak-cdr rest))
+ (set! *all-menus* (weak-cdr rest)))
+ (loop prev (weak-cdr rest)))
+ ((eq? (MenuRecord.Menu (weak-car rest)) menu)
+ (weak-car rest))
+ (else (loop rest (weak-cdr rest))))))
+
+(define (add-sub-menu menu sub-menu . options)
+ (set-TKWidget%.do-not-gc-protect! sub-menu #T)
+ (UIObj-protect-from-gc! sub-menu menu) ; Keep daddy alive ...
+ ;; Above must happen *before* add-child!, since the menu may already
+ ;; have a drawing surface and then the sub-menu would get it
+ ;; immediately and the protection wouldn't be removed. Get it?
+ (add-child! menu sub-menu)
+ (apply add-to-menu menu 'cascade
+ '-menu (lambda () (tk-widget->pathname sub-menu))
+ options))
+
+(define (menuitem-set-callback! me proc)
+ (if (not (MenuItem.Index me))
+ (error "SET-CALLBACK!: menu item deleted!" me))
+ (set-MenuItem.%callback! me proc)
+ (ask-widget (MenuItem.Menu me)
+ `(entryconfigure
+ ,(MenuItem.Index me)
+ -command
+ ,(string-append "SchemeCallBack "
+ (number->string
+ (hash proc *our-hash-table*))))))
+
+(define (delete-menuitem! item)
+ (let ((menu-record (MenuItem.MenuRecord item))
+ (index (MenuItem.Index item)))
+ (let loop ((rest (MenuRecord.Items menu-record))
+ (count 0)
+ (prev #F))
+ (cond ((null? rest)
+ (ask-widget (MenuRecord.Menu menu-record)
+ `(delete ,(MenuItem.index item)))
+ (set-MenuItem.index! item #F)
+ 'DONE)
+ ((eq? (car rest) item)
+ (if (not (= count Index))
+ (error "Delete-MenuItem!: Inconsistent count"
+ count index me))
+
+ (if prev
+ (set-cdr! prev (cdr rest))
+ (set-MenuRecord.Items! menu-record (cdr rest)))
+ (loop (cdr rest) (+ count 1) prev))
+ ((= count index)
+ (error "Delete-MenuItem!: Missing item" count index me))
+ (else
+ (if (> count index)
+ (Set-MenuItem.Index! (car rest) (- count 1)))
+ (loop (cdr rest) (+ count 1) rest))))))
+
+(define (menuitem-ask-widget me command)
+ ;; For example:
+ ;; (Ask-Widget me `(configure -label "George"))
+ ;; becomes
+ ;; (Ask-Widget menu `(entryconfigure index -label "George"))
+ (if (or (eq? (car command) 'configure)
+ (string=? (car command) "configure"))
+ (ask-widget (MenuItem.Menu me)
+ `(entryconfigure ,(MenuItem.Index me)
+ ,@(cdr command)))
+ (error "MenuItem-Ask-Widget: must be configure command"
+ me command)))
+
+(define (add-to-menu menu which-kind . options)
+ ;; Which-Kind should be 'CHECKBUTTON, 'COMMAND,
+ ;; 'RADIOBUTTON, or 'SEPARATOR. Cascades are made using
+ ;; Add-Sub-Menu, above
+ (let ((menu-record (find-menu-record menu)))
+ (let ((items (MenuRecord.Items Menu-Record)))
+ (let ((new-item
+ (make-menuitem menuitem-ask-widget
+ 'invalid
+ menuitem-set-callback!
+ menu-record
+ '()
+ (length items))))
+ (ask-widget menu `(add ,which-kind ,@options))
+ (set-MenuRecord.Items! Menu-Record
+ (append! items (list new-item)))
+ new-item))))
+
--- /dev/null
+;;; -*- Scheme -*-
+
+#| ******************************
+
+MIT-XHOOKS defines the level of the system that handles event
+processing, and the manipulation of UITK objects just above the X
+level (defined in MIT-XLIB). This layer will differ between
+MIT-Scheme and Scheme-to-C
+
+This file tries to include all the functions that actually call X so
+that the other parts of the system can be rebuilt on a different
+substrate.
+
+ ****************************** |#
+
+#|
+Not used?
+
+(define (with-window display title desired-size context receiver)
+ ;; Call RECEIVER with UITKwindow and actual size
+ (let* ((window (create-top-level-x-window
+ display title desired-size context)))
+ (XMapWindow display window)
+ (report-window-size display window receiver)))
+
+(define (report-window-size display window receiver)
+ (get-window-attributes display window
+ (lambda (x y width height . others)
+ others
+ (receiver (make-uitkwindow display window)
+ (make-size width height)
+ x
+ y))))
+
+
+(define (create-top-level-x-window display title desired-size context)
+ (let ((window
+ (XCreateSimpleWindow
+ display
+ (XDefaultRootWindow display) ; Parent is root window
+ 0 ; X
+ 0 ; Y
+ (size.width desired-size) ; Width
+ (size.height desired-size) ; Height
+ (context.BorderWidth context)
+ (context.Border context)
+ (context.Background context))))
+ (XStoreName display window title)
+ window))
+
+
+(define (destroy-window w)
+ (let ((Xwindow (UITKWindow.XWindow w)))
+ (XDestroyWindow (UITKWindow.XDisplay w) Xwindow)))
+
+
+
+
+
+|#
+
+\f
+;;;;UITK main loop
+
+#| In general, the system will have two threads running -- the
+ordinary REP and the UITK thread, which processes events for the
+widgets.
+
+When an event is signalled, it is placed (at interrupt level) on a
+queue, which is processed at user level by the UITK thread main loop
+|#
+
+;;;UITK thread will wake up at at least this interval, since it needs
+;;;to clean up objects labelld for destruction by the GC, even if
+;;;there are no events to process.
+
+(define *UITK-INTERVAL* (* 30 1000)) ; 30 seconds, in milliseconds
+
+(define uitk-queue 'later) ;code that processes events
+(define idle-queue 'later) ;not used in MIT version
+(define the-agenda 'later) ;processing scheduled by AFTER-DELAY
+(define uitk-thread 'later)
+(define more-work-to-do #F)
+(define uitk-timer #F)
+
+#| #############################################################
+This is some debugging stuff for probing the space usage.
+|#
+
+
+(DEFINE LOOP-COUNTER 0)
+(DEFINE EVENT-COUNTER 0)
+(DEFINE MORE-COUNTER 0)
+(DEFINE SUSPEND-COUNTER 0)
+(DEFINE LOOP-TRACE)
+(DEFINE READ-QUEUE-TRACE)
+(DEFINE RUN-QUEUE-TRACE)
+(define ALLOW-FREE-TRACE? #T)
+
+(define (clear-counters!)
+ (SET! LOOP-COUNTER 0)
+ (SET! EVENT-COUNTER 0)
+ (SET! MORE-COUNTER 0)
+ (SET! SUSPEND-COUNTER 0)
+ 0)
+
+(define ignore-repl #F)
+
+(define (show-counters)
+ (pp
+ `(events: , event-counter loop: ,loop-counter more: ,more-counter suspend: ,suspend-counter)))
+
+(define (make-free-trace n)
+ (cons 0 (make-vector n #f)))
+
+(define (copy-free-traces)
+ (fluid-let ((allow-free-trace? #f))
+ (vector (cons (car loop-trace) (vector-copy (cdr loop-trace)))
+ (cons (car read-queue-trace) (vector-copy (cdr read-queue-trace)))
+ (cons (car run-queue-trace) (vector-copy (cdr run-queue-trace))))))
+
+(define (record-free-pointer trace)
+ (if allow-free-trace?
+ (let-syntax ((ucode-primitive
+ (macro arguments
+ (apply make-primitive-procedure arguments))))
+ (vector-set! (cdr trace)
+ (car trace)
+ ((ucode-primitive primitive-get-free 1) 26))
+ (set-car! trace
+ (if (fix:= (fix:+ (car trace) 1) (vector-length (cdr trace)))
+ 0
+ (fix:+ (car trace) 1))))))
+
+#| #############################################
+end of debugging stuff
+
+|#
+
+
+(define (make-uitk-thread)
+ (set! uitk-thread
+ (create-thread (create-thread-continuation) thread-start))
+ (kick-uitk-thread))
+
+(define initial-thread-state 'later)
+
+(define (thread-start)
+ (call-with-current-continuation
+ (lambda (start-up)
+ (set! initial-thread-state start-up)
+ (uitk-thread-main-loop))))
+
+(define (restart-uitk)
+ (restart-thread uitk-thread #T (lambda () (initial-thread-state 'go))))
+
+(let-syntax ((last-reference
+ (macro (variable)
+ `(let ((foo ,variable))
+ (set! ,variable #F)
+ foo))))
+
+ (define (uitk-thread-main-loop)
+ (define (flush-all-displays)
+ (for-each flush-queued-output
+ (protection-list-referenced-elements
+ display-protection-list)))
+ (define (run thunk) (thunk))
+ (SET! LOOP-COUNTER 0)
+ (SET! EVENT-COUNTER 0)
+ (SET! MORE-COUNTER 0)
+ (SET! SUSPEND-COUNTER 0)
+ (let process-loop ()
+ (SET! LOOP-COUNTER (+ 1 LOOP-COUNTER))
+ (block-thread-events)
+ (set! more-work-to-do #F)
+ ;; Read out the event/idle/delayed thunks
+ (let ((events (read-and-empty-queue! uitk-queue))
+ (idle (read-and-empty-queue! idle-queue))
+ (delayed (read-and-empty-agenda! the-agenda))
+ )
+ (unblock-thread-events)
+ ;;process the thinks that were read, and clear the variables so
+ ;; the thunks can GC away after they are run.
+ (for-each run (last-reference events))
+ (for-each run (last-reference idle))
+ (for-each run (last-reference delayed))
+ ;; Allow tk to do its pending events (includes handling callbacks)
+ (tk-doevents)
+ ;;check if a GC has occurred (the GC daemon sets the flag) and
+ ;;finalize the GC'd objects.
+ (if (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((result *UITK:GC-HAS-OCCURRED?*))
+ (set! *UITK:GC-HAS-OCCURRED?* #F)
+ result)))
+ (begin ; Clean up after GC
+ (finalize-uitk-objects)
+ (close-lost-displays-daemon)))
+ (let ((more? (begin (block-thread-events) more-work-to-do)))
+ ;; MORE? is #T if work arrived while we were handling the
+ ;; previously grabbed event/idle thunks
+ (flush-all-displays)
+ (IF (OR MORE? IGNORE-REPL)
+ (begin
+ (unblock-thread-events)
+ (SET! MORE-COUNTER (+ 1 MORE-COUNTER))
+ (process-loop)) ; Don't give up CPU yet
+ (begin
+ (let ((tk-wake-up (get-interval-to-tk-wakeup))
+ (delayed-wake-up (get-interval-to-next-delayed-event)))
+ ;;get time to wake up to for next TK event or
+ ;;delayed event
+ (let ((wake-up (if tk-wake-up
+ (if delayed-wake-up
+ (min tk-wake-up delayed-wake-up)
+ tk-wake-up)
+ delayed-wake-up)))
+ ;;flush the current timer event if there is one
+ ;;and register the next actual time to wake up
+ (if uitk-timer (deregister-timer-event uitk-timer))
+ (set! uitk-timer
+ (register-timer-event (if wake-up
+ (min wake-up *UITK-INTERVAL*)
+ *UITK-INTERVAL*)
+ (lambda () (set! uitk-timer #F))))))
+ ;;now go to sleep. The timer event, or an X event,
+ ;;will wake us up. We suspend with events still
+ ;;blocked to avoid an interrupt hole, whereby an
+ ;;event is delivered but doesn't wake us up.
+ ;;Suspending atomically unblocks events in the right
+ ;;way to prevent this.
+ (suspend-current-thread)
+ (SET! SUSPEND-COUNTER (+ SUSPEND-COUNTER 1))
+ ;;(allow-thread-event-delivery)
+ (unblock-thread-events)
+ (process-loop))))))
+ ))
+
+(define (with-uitk-thread-errors-captured thunk)
+ (define newline-string "
+")
+ (call-with-current-continuation
+ (lambda (exit-continuation)
+ (fluid-let
+ ((standard-error-handler
+ (lambda (error-condition)
+ (fluid-let ((standard-error-handler standard-error-handler))
+ (newline)
+ (newline)
+ (display
+ (string-append
+ ";Error in UITK thread:" newline-string
+ ";" (condition/report-string error-condition)
+ newline-string
+ ";To debug, type (debug (unhash "
+ (number->string
+ (hash (condition/continuation error-condition)))
+ "))"))
+ (newline)
+ (newline)
+ (exit-continuation 'punt-o-rama)))))
+ (thunk)))))
+
+;;;This forces the UITK thread to wake up
+(define kick-uitk-thread
+ (let ((*uitk-thread-kicked?* #F))
+ (lambda ()
+ (if (not *uitk-thread-kicked?*)
+ (begin
+ (set! *uitk-thread-kicked?* #T)
+ (when-idle!
+ ;; When-Idle! will make the thread awaken
+ (lambda ()
+ (set! *uitk-thread-kicked?* #F))))))))
+
+;;; Redefine hook found in mit-xlib. Running the UITK loop will flush
+;;; all displays.
+(define flush-display-hook kick-uitk-thread)
+
+(define (when-idle! thunk)
+ (signal-thread-event
+ uitk-thread
+ (lambda ()
+ ;; Interrupt level
+ (set! more-work-to-do #T)
+ (enqueue! idle-queue thunk))))
+
+\f
+;;; Registering events for processing
+
+#| For each display connection, we have a permanently
+ registered request to process input from a particular file.
+ FORK-TO-WAIT-ON creates such a registration. When events come in
+ on the display connection, the CHILD-WORK-CODE is enqueued for
+ user-level execution. If the CHILD-WORK-CODE has been GCed away,
+ then code to deregister the handler is executed.
+|#
+
+(define fork-to-wait-on
+ (let ()
+ ;; This group of procedures can NOT be lexically nested inside of
+ ;; fork-to-wait-on because we want the link from the enqueued
+ ;; thunk to child-work-code to be a weak pointer.
+ ;; Thus child-work-code should not be lexically visible to
+ ;; these procedures. If we had a strong pointer, then the
+ ;; registry would point to the child work code and hence to the
+ ;; application, so applications could never be GCd.
+ (define (try-to-run weak)
+ (lambda ()
+ (let ((code (weak-car weak))
+ (wcdr (weak-cdr weak)))
+ (if (and code (not (scxl-destroyed? (weak-car wcdr))))
+ (begin
+ ;; Reinstall interrupt handler, then run user code
+ (register-input-thread-event
+ (XConnectionNumber (weak-car wcdr))
+ uitk-thread (weak-cdr wcdr))
+ (code))))))
+ (define (call-if-still-there weak)
+ ;; WEAK is a weak-list:
+ ;; (desired-code-thunk display #F)
+ ;; In normal use, desired-code-thunk is #F iff the application
+ ;; has vanished. This code creates a procedure to run at
+ ;; interrupt level, replaces the #F with the handler, and
+ ;; returns the handler to the caller.
+ (let ((result
+ (lambda ()
+ ;; Interrupt level
+ (let ((code (weak-car weak)))
+ (if code
+ (begin
+ (set! more-work-to-do #T)
+ (enqueue! uitk-queue (try-to-run weak))
+ 'done
+ ))))))
+ (weak-set-cdr! (weak-cdr weak) result)
+ result))
+ (lambda (display child-work-code child-idle-code)
+ child-idle-code ; Not used by MIT Scheme
+ (let ((file (XConnectionNumber display))
+ (weak (weak-cons child-work-code (weak-cons display #F))))
+ (without-interrupts
+ (lambda ()
+ (register-input-thread-event
+ file uitk-thread (call-if-still-there weak))))))))
+
+(define (destroy-registration registration)
+ (deregister-input-thread-event registration)
+ 'OK)
+
+(define remove-from-registry
+ ;; This is called with a file descriptor when the file is closed to
+ ;; remove any registered requests for activity on the file.
+ (in-package (->environment '(runtime thread))
+ (lambda (descriptor)
+ (let loop ((dentry input-registrations))
+ (cond ((null? dentry) 'NOT-FOUND)
+ ((eq? descriptor (dentry/descriptor dentry))
+ (without-interrupts
+ (lambda ()
+ (remove-from-select-registry! input-registry descriptor)
+ (let ((prev (dentry/prev dentry))
+ (next (dentry/next dentry)))
+ (if prev
+ (set-dentry/next! prev next)
+ (set! input-registrations next))
+ (if next
+ (set-dentry/prev! next prev)))))
+ 'REMOVED)
+ (else (loop (dentry/next dentry))))))))
+
+(define (shut-down-event-server display-number)
+ (remove-from-registry (%XConnectionNumber display-number)))
+\f
+
+;;;Delayed events
+
+;;; Schedule an action to be done later in the UITK thread
+;;; Implementation uses agendas from the 6.001 book
+
+
+(define (after-delay delay action-thunk) ; delay in secs
+ (let ((now (real-time-clock)))
+ (signal-thread-event
+ uitk-thread
+ (lambda ()
+ ;; Interrupt level
+ (set! more-work-to-do #T)
+ (add-to-agenda! (+ (* delay 1000) now) ; in msecs
+ action-thunk
+ the-agenda)))))
+
+(define (make-agenda)
+ (list '*agenda*))
+
+(define (segments agenda) (cdr agenda))
+(define (first-segment agenda) (car (segments agenda)))
+(define (rest-segments agenda) (cdr (segments agenda)))
+(define (set-segments! agenda segments) (set-cdr! agenda segments))
+(define (empty-segments? agenda)
+ (null? (segments agenda)))
+
+(define (add-to-agenda! time action agenda)
+ (define (add-to-segments! segments)
+ (if (= (segment-time (car segments)) time)
+ (enqueue! (segment-queue (car segments))
+ action)
+ (let ((rest (cdr segments)))
+ (if (or (null? rest)
+ (> (segment-time (car rest)) time))
+ (insert-new-time! time action agenda)
+ (add-to-segments! rest)))))
+ (without-interrupts
+ (lambda ()
+ (let ((segs (segments agenda)))
+ (if (null? segs)
+ (insert-new-time! time action agenda)
+ (add-to-segments! segs))))))
+
+
+(define (insert-new-time! time action agenda)
+ (let ((segs (segments agenda))
+ (q (make-queue)))
+ (enqueue! q action)
+ (let ((new-segment (make-time-segment time q)))
+ (if (null? segs)
+ (set-segments! agenda (list new-segment))
+ (set-cdr! segs
+ (cons new-segment (cdr segs)))))))
+
+(define (read-and-empty-agenda! agenda)
+ (let ((now (real-time-clock)))
+ (define (find-all-events-up-to-now events)
+ (if (empty-segments? agenda)
+ events
+ (let ((current-segment (first-segment agenda)))
+ (if (> (segment-time current-segment) now)
+ events
+ (let ((q (segment-queue current-segment)))
+ (if (empty-queue? q)
+ (begin (set-segments! agenda (rest-segments agenda))
+ (find-all-events-up-to-now events))
+ (find-all-events-up-to-now
+ (append events (list (dequeue! q))))))))))
+ (without-interrupts
+ (lambda ()
+ (find-all-events-up-to-now '())))))
+
+(define (empty-agenda? agenda)
+ (without-interrupts
+ (lambda ()
+ (or (empty-segments? agenda)
+ (and (empty-queue? (segment-queue (first-segment agenda)))
+ (null? (rest-segments agenda)))))))
+
+(define (make-time-segment time queue)
+ (cons time queue))
+
+(define (segment-time s) (car s))
+(define (segment-queue s) (cdr s))
+
+(define (current-time agenda)
+ (without-interrupts
+ (lambda ()
+ (and (not (null? (segments agenda)))
+ (segment-time (first-segment agenda))))))
+
+(define (get-interval-to-next-delayed-event)
+ (let ((agenda-time (current-time the-agenda)))
+ (and agenda-time
+ (- agenda-time (real-time-clock)))))
+
+;;; make-enqueueable-thunk is unused. Part of an alternate
+;;; implementation, where the thunk doesn't hold on to the
+;;; application, so that the application can GC away even if there are
+;;; events scheduled.
+
+(define make-enqueueable-thunk
+ (let ()
+ (define (try-to-run weak)
+ (lambda ()
+ (let ((code (weak-car weak)))
+ (if code
+ (debug-print code)
+ (debug-print 'vanished))
+ (if code (code)))))
+ (lambda (thunk)
+ (try-to-run (weak-cons thunk 'IGNORED)))))
+
+\f
+;;;; UITK objects. We almost never work with bare X objects.
+
+
+
+;;;convert an Xevent (string) to a UITK event structure. This defines
+;;;the dispatch only. The actual make-event procedures for the
+;;;various event types are defined in UITK.scm
+
+(define XEvent-><Event>
+ (let ((X-Event-Converters
+ (make-vector LASTEVENT
+ (lambda (event)
+ (decode-unknown-event event
+ (lambda (type serial sent? display window)
+ type serial sent? display
+ (make-unknown-event 'UNUSUAL event window)))))))
+
+ (define (key name)
+ (lambda (e)
+ (decode-key-event e
+ (lambda (type serial sent? display window root subwindow
+ time x y RootX RootY state keycode SameScreen?)
+ type serial sent? display root subwindow
+ time RootX RootY state keycode SameScreen?
+ (make-point-event name e window (Make-Point X Y))))))
+ (vector-set! X-Event-Converters KeyPress (key 'KEY-PRESS))
+ (vector-set! X-Event-Converters KeyRelease (key 'KEY-RELEASE))
+
+ (define (button name)
+ (lambda (e)
+ (decode-button-event e
+ (lambda (type serial sent? display window root subwindow
+ time x y RootX RootY state button SameScreen?)
+ type serial sent? display root subwindow
+ time RootX RootY state button SameScreen?
+ (make-point-event name e window (Make-Point X Y))))))
+ (vector-set! X-Event-Converters ButtonPress (button 'BUTTON-PRESS))
+ (vector-set! X-Event-Converters ButtonRelease (button 'BUTTON-RELEASE))
+
+ (define (motion name)
+ (lambda (e)
+ (decode-motion-event e
+ (lambda (type serial sent? display window root subwindow
+ time x y RootX RootY state IsHint SameScreen?)
+ type serial sent? display window root
+ subwindow time RootX RootY state IsHint SameScreen?
+ (make-point-event name e window (Make-Point X Y))))))
+ (vector-set! X-Event-Converters MotionNotify (motion 'POINTER-MOTION))
+
+ (define (crossing name)
+ (lambda (e)
+ (decode-crossing-event
+ e
+ (lambda (type serial sent? display window root subwindow
+ time x y RootX RootY mode detail SameScreen?
+ Focus? state)
+ type serial sent? display root subwindow
+ time RootX RootY mode detail SameScreen? Focus? state
+ (make-point-event name e window (Make-Point X Y))))))
+ (vector-set! X-Event-Converters EnterNotify (crossing 'ENTER))
+ (vector-set! X-Event-Converters LeaveNotify (crossing 'LEAVE))
+
+ ; (vector-set! X-Event-Converters ConfigureNotify ...)
+ ; (vector-set! X-Event-Converters FocusIn ...)
+ ; (vector-set! X-Event-Converters FocusOut ...)
+ ; (vector-set! X-Event-Converters KeymapNotify ...)
+
+ (define (expose-fn type-name)
+ (lambda (e)
+ (decode-expose-event
+ e
+ (lambda (type serial sent? display
+ window x y width height count)
+ type serial sent? display count width height
+ (make-rectangle-event
+ type-name e window (Make-Point x y)
+ width height)))))
+ (vector-set! X-Event-Converters Expose (expose-fn 'EXPOSURE))
+
+ ; (vector-set! X-Event-Converters GraphicsExpose ...)
+ ; (vector-set! X-Event-Converters NoExpose ...)
+ ; (vector-set! X-Event-Converters VisibilityNotify ...)
+ ; (vector-set! X-Event-Converters CreateNotify ...)
+ ; (vector-set! X-Event-Converters DestroyNotify ...)
+ ; (vector-set! X-Event-Converters UnmapNotify ...)
+ ; (vector-set! X-Event-Converters MapNotify ...)
+ ; (vector-set! X-Event-Converters MapRequest ...)
+ ; (vector-set! X-Event-Converters ReparentNotify ...)
+ ; (vector-set! X-Event-Converters ConfigureNotify ...)
+ ; (vector-set! X-Event-Converters ConfigureRequest ...)
+ ; (vector-set! X-Event-Converters GravityNotify ...)
+ ; (vector-set! X-Event-Converters ResizeRequest ...)
+ ; (vector-set! X-Event-Converters CirculateNotify ...)
+ ; (vector-set! X-Event-Converters CirculateRequest ...)
+ ; (vector-set! X-Event-Converters PropertyNotify ...)
+ ; (vector-set! X-Event-Converters SelectionClear ...)
+ ; (vector-set! X-Event-Converters SelectionRequest ...)
+ ; (vector-set! X-Event-Converters SelectionNotify ...)
+ ; (vector-set! X-Event-Converters ColormapNotify ...)
+ ; (vector-set! X-Event-Converters ClientMessage ...)
+ ; (vector-set! X-Event-Converters MappingNotify ...)
+ (lambda (XEvent)
+ ((vector-ref X-Event-Converters (xevent-type XEvent))
+ XEvent))))
+
+;;This places the XEvent in the given string. It uses the side effect
+;;to avoid allocating a new string and generating garbage in the inner
+;;event processing loop
+
+(define (get-x-event display event-string)
+ (if (zero? (XPending display))
+ #F
+ (XNextEvent! display event-string)))
+
+
+\f
+;;; open a display and return the numeric hook
+
+(define (open-display)
+ (let ((xdisplay (XOpenDisplay "")))
+ (if (or (and (number? xdisplay) (zero? xdisplay))
+ (and (pair? xdisplay) (number? (cdr xdisplay))
+ (zero? (cdr xdisplay))))
+ (error 'OPEN-DISPLAY "Could not open display")
+ xdisplay)))
+
+(define (string->color display)
+ (lambda (string)
+ (let ((result
+ (XAllocNamedColor display
+ (XDefaultColormap display
+ (XDefaultScreen display))
+ string)))
+ ;; Result is (Status ScreenColor ExactColor)
+ (if (zero? (car result))
+ #F ; Error status
+ (list-ref result 1)))))
+
+
+#| Fonts don't work yet
+(define (string->font display)
+ (lambda (string)
+ (XLoadFont display string)))
+|#
+
+\f
+;;;; Event-sensitive windows.
+
+(define (Generate-Events! UITKWindow mask)
+ (let ((attributes (XMake-SetWindowAttributes))
+ (window (UITKWindow.XWindow UITKWindow))
+ (display (UITKWindow.XDisplay UITKWindow)))
+ (XSetWindowAttributes-Event_Mask! attributes mask)
+ (XChangeWindowAttributes display window CWEventMask attributes))
+ (let ((result (XGetWindowAttributes display window)))
+ (if (= (list-ref result 0) 0)
+ (error 'GENERATE-EVENTS!
+ "XGetWindowAttributes failed ~A" result)
+ (list-ref result 1))))
+
+
+(define (handler->sensitivity handler)
+ (case (car handler)
+ ((#T) NoEventMask)
+ ((KEY-PRESS) KeyPressMask)
+ ((KEY-RELEASE) KeyReleaseMask)
+ ((BUTTON-PRESS) ButtonPressMask)
+ ((BUTTON-RELEASE) ButtonReleaseMask)
+ ((ENTER) EnterWindowMask)
+ ((CONFIGURE-NOTIFY) StructureNotifyMask)
+ ((LEAVE) LeaveWindowMask)
+ ((POINTER-MOTION) PointerMotionMask)
+ ; (bit-or PointerMotionMask PointerMotionHintMask)
+ ((BUTTON-1-MOTION) Button1MotionMask)
+ ((BUTTON-2-MOTION) Button2MotionMask)
+ ((BUTTON-3-MOTION) Button3MotionMask)
+ ((BUTTON-4-MOTION) Button4MotionMask)
+ ((BUTTON-5-MOTION) Button5MotionMask)
+ ((BUTTON-MOTION) ButtonMotionMask)
+ ; (bit-or ButtonMotionMask PointerMotionHintMask)
+ ((KEYMAP-STATE) KeyMapStateMask)
+ ((EXPOSURE) ExposureMask)
+ ((VISIBITY-CHANGE) VisibilityChangeMask)
+ ((STRUCTURE-NOTIFY) StructureNotifyMask)
+ ;; I don't understand ResizeRedirect or substructure stuff
+ ((FOCUS-CHANGE) FocusChangeMask)
+ ((PROPERTY) PropertyChangeMask)
+ ;; Ignoring colormap and owner grab
+ (else (error 'HANDLER->SENSITIVITY "Unknown event type ~A" (car handler)))
+ ))
+
+(define (bit-or . integers)
+ (bit-string->unsigned-integer
+ (reduce bit-string-or (unsigned-integer->bit-string 32 0)
+ (map (lambda (n) (unsigned-integer->bit-string 32 n))
+ integers))))
+\f
+;;;; UITK level "X" calls.
+
+#| In UITK, we almost never work with bare X objects. Rather there
+are two levels of embedding. The first is the "wrapper" which is used
+for garbage collection (see MIT-Xlib). This wrapped object is then
+embedded in a UITK structure that bundles together associated
+information. (For example, a UITKWindow holds both an X window and
+its associated X display.) Thus, a user-level procedure such as
+Drawline, operates on UITK windows. It is defined in terms of a lower
+level XDrawline (which operates on wrapped windows) which in tern is
+defined in terms of the X primitive %XDrawline. |#
+
+
+;;;; Graphics contexts
+
+(define (make-simple-graphics-context uitkwindow)
+ (let ((dpy (UITKWindow.XDisplay uitkwindow))
+ (win (UITKWindow.XWindow uitkwindow)))
+ (XCreateGC dpy win 0 (xmake-gcvalues))))
+
+(define (make-colored-graphics-context uitkwindow color-string)
+ (let ((gc (make-simple-graphics-context uitkwindow))
+ (dpy (UITKWindow.XDisplay uitkwindow)))
+ (let ((color ((string->color dpy) color-string)))
+ (if (color? color)
+ (begin
+ (XSetForeground dpy gc color)
+ gc)
+ (error 'make-colored-graphics-context
+ "Can't convert color name to value ~A"
+ color-string)))))
+
+(define (DrawArc uitkwindow gc X Y Width Height angle1 angle2)
+ (XDrawArc (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ gc x y width height angle1 angle2))
+
+(define (DrawLine uitkwindow gc X1 Y1 X2 Y2)
+ (XDrawLine (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ gc x1 y1 x2 y2))
+
+(define (DrawRectangle uitkwindow gc X Y Width Height)
+ (XDrawRectangle (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ gc x y width height))
+
+
+(define (FillRectangle uitkwindow gc X Y Width Height)
+ (XFillRectangle (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ gc x y width height))
+
+(define (FillArc uitkwindow gc X Y Width Height angle1 angle2)
+ (XFillArc (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ gc x y width height angle1 angle2))
+
+(define (ClearArea uitkwindow X Y width height exposures?)
+ (XClearArea (UITKWindow.XDisplay uitkwindow)
+ (UITKWindow.XWindow uitkwindow)
+ x y width height exposures?))
+
+(define (flush-queued-output display)
+ (xflush display))
+
+(define (GetDefaultValue display application-name variable)
+ (XGetDefault display application-name variable))
+
+(define (Decode-Button-Event event receiver)
+ (let ((vect (make-vector 15)))
+ (XDecodeButtonEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Configure-Event event receiver)
+ (let ((vect (make-vector 13)))
+ (XDecodeConfigureEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Crossing-Event event receiver)
+ (let ((vect (make-vector 17)))
+ (XDecodeCrossingEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Expose-Event event receiver)
+ (let ((vect (make-vector 10)))
+ (XDecodeExposeEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Key-Event event receiver)
+ (let ((vect (make-vector 15)))
+ (XDecodeKeyEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Motion-Event event receiver)
+ (let ((vect (make-vector 15)))
+ (XDecodeMotionEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (Decode-Unknown-Event event receiver)
+ (let ((vect (make-vector 5)))
+ (XDecodeUnknownEvent event vect)
+ (apply receiver (vector->list vect))))
+
+(define (XEvent-Type xevent)
+ (Decode-Unknown-Event xevent
+ (lambda (type . others)
+ others ; Ignored
+ type)))
+
+(define (Decode-Window-Attributes attributes receiver)
+ (let ((vect (make-vector 23)))
+ (XDecodeWindowAttributes attributes vect)
+ (apply receiver (vector->list vect))))
+
+(define (Get-Window-Attributes display window receiver)
+ (let ((attributes (list-ref (XGetWindowAttributes display window) 1)))
+ (Decode-Window-Attributes attributes receiver)))
+
+(define (Rectangle->XRegion rectangle)
+ (MakeXRegion (Point.X (UITKRectangle.Offset rectangle))
+ (Point.Y (UITKRectangle.Offset rectangle))
+ (UITKRectangle.Width rectangle)
+ (UITKRectangle.Height rectangle)))
+
+(define (MakeXRegion x y width height)
+ (let ((region (XCreateRegion)))
+ (XUnionRectSpecsWithRegion! x y width height region region)
+ region))
+
+(define (IntersectXRegions x-region-1 x-region-2)
+ (let ((region (XCreateRegion)))
+ (XIntersectRegion! x-region-1 x-region-2 region)
+ region))
+
+(define (UnionXRegions x-region-1 x-region-2)
+ (let ((region (XCreateRegion)))
+ (XUnionRegion! x-region-1 x-region-2 region)
+ region))
+
+(define (CopyXRegion region)
+ (UnionXRegions (XCreateRegion) region))
+
+(define (SubtractXRegions x-region-1 x-region-2)
+ (let ((region (XCreateRegion)))
+ (XSubtractRegion! x-region-1 x-region-2 region)
+ region))
+
+(define (SetClipXRegion window graphics-context XRegion)
+ (XSetRegion (UITKWindow.XDisplay window)
+ graphics-context
+ XRegion))
+\f
+;;;process a mouse drag.
+;;;keep reading motion events and process them
+;;;stop when there is a button release
+
+;;;This procedure is included here because of the X calls.
+
+(define (mouse-drag surface on-motion)
+ ;; *** Maybe this should take an "other events handler" ***
+ (let* ((UITKWindow (DrawingSurface.UITKWindow surface))
+ (xdisplay (uitkwindow.xdisplay UITKWindow)))
+ (without-interrupts
+ (lambda ()
+ (let loop ()
+ (let* ((x-event (XNextEvent xdisplay))) ;**blocks?
+ (Decode-Unknown-Event
+ x-event
+ (lambda (type serial sent? display window)
+ serial sent? display window
+ (cond ((eq? type MotionNotify)
+ (decode-motion-event x-event
+ (lambda (type serial sent? display window root subwindow
+ time x y RootX RootY state IsHint SameScreen?)
+ type serial sent? display window root subwindow
+ time RootX RootY state IsHint SameScreen?
+ (on-motion (make-point x y))))
+ (loop))
+ ((eq? type ButtonRelease) 'endloop)
+ (else (loop)))))))))))
+\f
+;;; GC of UITK objects
+;;; this uses the protrction list mechanism implemented in MIT-Xlib
+
+(define uitk-protection-list 'later)
+
+(define (when-unreferenced obj thunk)
+ (add-to-protection-list! uitk-protection-list obj thunk))
+
+(define (finalize-uitk-objects)
+ (clean-lost-protected-objects uitk-protection-list
+ (lambda (thunk) (thunk))))
+
+(define (finalize-uitk-objects-later)
+ (set! *UITK:GC-HAS-OCCURRED?* #T)
+ ;; (when-idle! finalize-uitk-objects)
+ ;; Handled in the main UITK thread loop. Also calls the scxl daemon
+ ;; there.
+ )
+
+;;; In generating hash numbers for callbacks, etc., we use a private
+;;; hash table, separate from the system one.
+
+(define *our-hash-table* 'later)
+(define *UITK:GC-HAS-OCCURRED?* #F)
+
+#|
+
+Shutting down the event server may be necessary in UITK even though
+the event server is shut down as soon as the UITK application is
+destroyed, because the applcation and display may vanish on the same
+GC.
+
+We must explicitly destroy the tk-widgets for this display (since Xlib
+doesn't know about them). The TK widgets must be destroyed BEFORE the
+display is closed.
+
+|#
+
+(define (initialize-uitk!)
+ (set! uitk-protection-list (make-protection-list))
+ ;; THIS SHOULD BE PUT BACK WHEN remove-gc-daemon! GETS WRITTEN
+ ;; (remove-gc-daemon! close-lost-displays-daemon)
+ (add-gc-daemon! finalize-uitk-objects-later)
+ (set! uitk-queue (make-queue))
+ (set! idle-queue (make-queue))
+ (set! the-agenda (make-agenda))
+ (make-uitk-thread)
+ (SCXL-Install-XCloseDisplay-Callback shut-down-event-server)
+ (set! *our-hash-table* (hash-table/make 4001))
+ )
+
+(initialize-uitk!)
--- /dev/null
+;;; -*- Scheme -*-
+
+#| This file defines the SCXL library for interfacing with X. It is
+similar to Joel Bartlett's Scheme-to-C X library, except that it also
+provides support for cleaning up X objects when the corresponding
+Scheme objects are garbage collected. The low-level primitives (e.g.
+%XDrawline, %XPending) are Scheme entries to the corresponding X
+library rooutines. Microcode support for these is defined in the file
+scxl.c. Users should almost never call these routines directly, but
+instead use the SCXL level routines (e.g., XDrawline, XPending), which
+operate on Scheme objects rather than bare addresses.
+
+We are writing this library for use in UITK (called from mit-xhooks).
+We have tried to organize it so that it can be used as a general X
+library, but this has not been really tested. |#
+
+;;;; Hooks that the library calls -- these should be redefined by
+;;;; systems that use the library
+
+#| FLUSH-DISPLAY-HOOK is called at the end of every SCXL command that
+might require a display flush. In this file, it is defined as a
+no-op. The UITK library redefines it to wake the thread responsible
+for handling this stuff. |#
+
+(define (flush-display-hook)
+ '(when not under UITK this does nothing)
+ '(replaced by mit-xhooks))
+
+#| *XCLOSEDISPLAYCALLBACKS* is a list of thunks that should be run
+before a display is closed. |#
+
+\f
+#| SCXL Primitives operate on Scheme objects that are "wrapped around"
+cells containing the bare numbers that represent X server objects, via
+a call to SCXL-WRAP. This permits us to perform finalization of X
+objects when the Scheme representatives are garbage-collected using
+the protection list mechanism described below. We use cells containing
+the numbers, rather than the numbers themselves, to permit these "bare
+objects" to be shared (e.g., in protection lists) and mutated (e.g.,
+marked as destroyed).
+
+One exception to the wrapping convention is that X events are
+represented at the lowest level as Scheme strings, and so we needn't
+worry about their garbage collection. These low-level events (called
+OS-events in UITK) are components in higher-level UITK event structures.
+
+We maintain a list of strong dependents for these objects to represent
+facts like "if you are holding on to this graphics context, then you
+must also hold on to its display." This prevents the GC from
+prematurely releasing displays (and other objects).
+
+|#
+
+;;;; SCXL Wrapping and Unwrapping
+
+;;; create a wrapped object and (optionally) place it on a protection
+;;; list for GC finalization. The wrapped object may also have
+;;; additional stuff associated with it (for example, a display will
+;;; contain information used to clean up its windows and fonts)
+;;; The "bare object" kept on the protection list is held in a cell to
+;;; allow for mutation (in particular, to mark things as being destroyed).
+
+(define (SCXL-WRAP protection-list type object strong-dependents . rest)
+ (let* ((cell (make-cell object))
+ (result (make-scxl-wrapper type cell strong-dependents rest)))
+ (if protection-list
+ (add-to-protection-list! protection-list result cell))
+ result))
+
+(define (SCXL-WRAPPED? obj) (scxl-wrapper? obj))
+
+(define (type-check-wrapped-object type object)
+ (if (SCXL-DESTROYED? object)
+ (error "attempt to reference destroyed object" object)
+ (if (and (SCXL-WRAPPED? object)
+ (eq? (scxl-wrapper.type object) type))
+ 'OK
+ (error "wrong type wrapped-object" type object))))
+
+(define (is-type-wrapped-object type)
+ (lambda (object)
+ (if (SCXL-DESTROYED? object)
+ (error "attempt to reference destroyed object" object)
+ (and (SCXL-WRAPPED? object)
+ (eq? (scxl-wrapper.type object) type)))))
+
+;;; (SCXL-UNWRAP
+;;; (SCXL-WRAP protection-list type object dependents data1 data2 ...)
+;;; (lambda (object . data-values) ....))
+
+(define (SCXL-UNWRAP wrapped receiver)
+ ;; Note: this doesn't return the strong dependents
+ (apply receiver (cell-contents (scxl-wrapper.wrapped-object wrapped))
+ (scxl-wrapper.other-stuff wrapped)))
+
+#| A destroyed object is the Scheme representitive of an X object that
+has been destroyed. It is generally an error to attempt to use a
+destroyed object any SCXL primitive that has the effect of destroying
+a resource on the server will call SCXL-DESTROY! on the corresponding
+Scheme representative |#
+
+(define (SCXL-DESTROY! obj)
+ (if (scxl-destroyed? obj)
+ 'done
+ (begin
+ (set-cell-contents! (scxl-wrapper.wrapped-object obj) #F)
+ (set-scxl-wrapper.other-stuff!
+ obj
+ (make-list (length (scxl-wrapper.other-stuff obj))
+ #F))
+ (set-scxl-wrapper.strong-dependents! obj '()))))
+
+(define (SCXL-DESTROYED? obj)
+ (and (scxl-wrapped? obj)
+ (eq? (cell-contents (scxl-wrapper.wrapped-object obj)) #F)))
+
+#| wrap-with-SCXL-DESTROY! runs some core procedure on a wrapped
+object and then destroys the object. The procedure will not be run if
+the object is already destroyed. The procedure may also have
+arguments other than the object to be destroyed. Nargs is the number
+of args to the core procedure. Arg-num is the number of the arg that
+is the object to be destroyed. |#
+
+(define (wrap-with-SCXL-DESTROY! nargs arg-num core)
+ ;; (declare (integrable core))
+ (cond ((= nargs 1)
+ (lambda (arg)
+ arg-num ; Not used
+ (if (not (SCXL-WRAPPED? arg))
+ (error "not a wrapped object: wrap-with-SCXL-DESTROY" arg))
+ (if (not (SCXL-DESTROYED? arg))
+ (begin
+ (core arg)
+ (SCXL-DESTROY! arg))
+ #T)))
+ ((= nargs 2)
+ (lambda (arg1 arg2)
+ (define interesting-arg (if (= arg-num 0) arg1 arg2))
+ (if (not (SCXL-WRAPPED? interesting-arg))
+ (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
+ (if (not (SCXL-DESTROYED? interesting-arg))
+ (begin (core arg1 arg2)
+ (SCXL-DESTROY! interestring-arg))
+ #T)))
+ ((= nargs 3)
+ (lambda (arg1 arg2 arg3)
+ (define interesting-arg
+ (cond ((= arg-num 0) arg1)
+ ((= arg-num 1) arg2)
+ (else arg3)))
+ (if (not (SCXL-WRAPPED? interesting-arg))
+ (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
+ (if (not (SCXL-DESTROYED? interesting-arg))
+ (begin (core arg1 arg2 arg3)
+ (SCXL-DESTROY! interestring-arg))
+ #T)))
+ (else
+ (lambda args
+ (define interesting-arg
+ (list-ref args arg-num))
+ (if (not (SCXL-WRAPPED? interesting-arg))
+ (error "not a wrapped object: wrap-with-SCXL-DESTROY" interesting-arg))
+ (if (not (SCXL-DESTROYED? interesting-arg))
+ (begin (apply core args)
+ (SCXL-DESTROY! interestring-arg))
+ #T)))))
+\f
+;;;; Protection lists
+
+#| A protection list is a list of weak pairs (scheme-object . microcode-object)
+the list is scanned at GC time so the system can finalize the
+microcode objects whose associated Scheme objects have been GC'd away |#
+
+(define (make-protection-list)
+ (list 'PROTECTION-LIST))
+
+(define (add-to-protection-list! list scheme-object microcode-object)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set-cdr! list
+ (cons (weak-cons scheme-object microcode-object)
+ (cdr list))))))
+
+(define (remove-from-protection-list! list scheme-object)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)) (previous list))
+ (if (not (null? associations))
+ (if (eq? scheme-object (weak-pair/car? (car associations)))
+ (set-cdr! previous (cdr associations))
+ (loop (cdr associations) associations)))))))
+
+(define (clean-lost-protected-objects list cleaner)
+ (let ((to-be-cleaned
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((result '())
+ (associations (cdr list))
+ (previous list))
+ (if (null? associations)
+ result
+ (if (weak-pair/car? (car associations))
+ (loop result (cdr associations) associations)
+ (let ((next (cdr associations)))
+ (set-cdr! previous next)
+ ;; Re-use associations so we don't CONS
+ (set-car! associations (weak-cdr (car associations)))
+ (set-cdr! associations result)
+ (loop associations next previous)))))))))
+ (for-each cleaner to-be-cleaned)))
+
+;;; In general, the microcode objects in SCXL are held in cells.
+;;; clean-lost-celled-objects clears the cell and runs the cleaner on the
+;;; object in the cell.
+
+(define (clean-lost-celled-objects protection-list fn)
+ (clean-lost-protected-objects
+ protection-list
+ (lambda (cell)
+ (let ((obj (atomic-read-and-clear-cell! cell)))
+ (if obj (fn obj))))))
+
+(define (atomic-read-and-clear-cell! cell)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let ((result (cell-contents cell)))
+ (set-cell-contents! cell #F)
+ result))))
+
+(define (search-protection-list list predicate)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)))
+ (and (not (null? associations))
+ (let ((scheme-object (weak-car (car associations))))
+ (if (and scheme-object (predicate scheme-object))
+ scheme-object
+ (loop (cdr associations)))))))))
+
+(define (find-in-protection-list list scheme-element)
+ ;; Returns the pair whose weak-car is scheme-element
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)))
+ (and (not (null? associations))
+ (let ((scheme-object (weak-car (car associations))))
+ (if (and scheme-object (eq? scheme-element scheme-object))
+ (car associations)
+ (loop (cdr associations)))))))))
+
+(define (protection-list-referenced-elements list)
+ ;; Returns a list of the Scheme-visible objects which are still
+ ;; referenced
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)))
+ (cond ((null? associations)
+ '())
+ ((weak-pair/car? (car associations))
+ (cons (weak-car (car associations))
+ (loop (cdr associations))))
+ (else
+ (loop (cdr associations))))))))
+
+(define (protection-list-all-elements
+ list dereference-ucode-object-fn)
+ ;; Returns a mixed list: returns the Scheme-visible object if it
+ ;; is still referenced. Otherwise returns the associated microcode
+ ;; reference.
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)))
+ (cond ((null? associations)
+ '())
+ ((weak-pair/car? (car associations))
+ (cons (weak-car (car associations))
+ (loop (cdr associations))))
+ (else
+ (cons (dereference-ucode-object-fn
+ (weak-cdr (car associations)))
+ (loop (cdr associations)))))))))
+
+;;; Protection lists for SCXL objects
+
+(define display-protection-list 'INITIALIZED-LATER)
+(define region-protection-list 'INITIALIZED-LATER)
+
+\f
+;;;; Standard wrapping procedures
+
+;;; A display is wrapped along with protection lists for its windows,
+;;; fonts, etc. We need to keep track of these because when the
+;;; display is closed, these objects will be destroyed, soe need to
+;;; mark the Scheme representitives as destroyed.
+
+(define (wrap-display xdisplay)
+ (define (find-default-colormaps wrapped-display)
+ (let ((nscreens (%XScreenCount xdisplay)))
+ (let ((vect (make-vector (+ nscreens 1) #F)))
+ (do ((this-screen 0 (+ this-screen 1)))
+ ((= this-screen nscreens) vect)
+ (vector-set! vect this-screen
+ (wrap-colormap
+ wrapped-display
+ (%XDefaultColormap xdisplay this-screen)))))))
+ (let ((me
+ (SCXL-WRAP display-protection-list
+ 'scxl-display
+ xdisplay
+ '() ; No strong dependents
+ (make-protection-list) ; Windows
+ (make-protection-list) ; Fonts (not used now)
+ (make-protection-list) ; Colormaps
+ (make-protection-list) ; GCs
+ #F ; Later ...
+ #F))) ; Later ...
+ (let ((stuff (scxl-wrapper.other-stuff me)))
+ (set-cdr! (list-tail stuff 3)
+ (list
+ (wrap-window me (%XDefaultRootWindow xdisplay))
+ (Find-Default-Colormaps me))))
+ me))
+
+(define (scxl-display? object)
+ (and (SCXL-WRAPPED? object)
+ (eq? (scxl-wrapper.type object) 'scxl-display)))
+
+(define (unwrap-display dsp receiver)
+ ;; Anyone who uses this must know the order of the protection lists
+ ;; within a display object!
+ (type-check-wrapped-object 'scxl-display dsp)
+ (SCXL-UNWRAP dsp receiver))
+
+(define (display/display user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ window-list font-list colormap-list gc-list
+ default-root-window default-colormaps ; Not used
+ display)))
+
+(define (display/window-list user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ display font-list colormap-list gc-list
+ default-root-window default-colormaps ; Not used
+ window-list)))
+
+(define (display/font-list user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (error "display/font-list: Fonts aren't implemented yet."))
+
+(define (display/colormap-list user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ display window-list font-list gc-list
+ default-root-window default-colormaps ; Not used
+ colormap-list)))
+
+(define (display/gc-list user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ display window-list font-list colormap-list
+ default-root-window default-colormaps ; Not used
+ gc-list)))
+
+(define (display/screen/default-color-map user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ display window-list font-list colormap-list gc-list
+ default-root-window ; Not used
+ default-colormaps)))
+
+(define (display/default-root-window user-visible-display)
+ (type-check-wrapped-object 'scxl-display user-visible-display)
+ (SCXL-UNWRAP user-visible-display
+ (lambda (display window-list font-list colormap-list gc-list
+ default-root-window default-colormaps)
+ display window-list font-list colormap-list gc-list
+ default-colormaps ; Not used
+ default-root-window)))
+
+;;; alternate name
+;;; in general, these ->names are used to extract the bare X pointers
+;;; from the SCXL objects
+(define ->xdisplay display/display)
+
+;;; notice that windows, fonts, etc. are wrapped with a protection
+;;; list for their associated displays. We are not making a separate
+;;; protection list for windows, because we aren't keeping track of
+;;; the window hierarchy pointers that X maintains. Therefore we
+;;; cannot safely destroy a window just because its Scheme
+;;; representitive disappears. On the other other hand, when the
+;;; display is closed, all the wondows go away, so we destroy their
+;;; Scheme represeatitives.
+
+(define (wrap-window display window)
+ (SCXL-WRAP (display/window-list display)
+ 'scxl-window
+ window
+ display)) ; Strong dependent
+
+(define (window/window user-visible-window)
+ (type-check-wrapped-object 'scxl-window user-visible-window)
+ (SCXL-UNWRAP user-visible-window (lambda (window) window)))
+
+(define ->xwindow window/window)
+
+#| Fonts aren't implemented yet. They have to be protected both on
+ the display and the graphics context to correctly reflect the
+ pointers maintained by X.
+
+(define (wrap-font display font)
+ (SCXL-WRAP (display/font-list display) 'scxl-font
+ font
+ display)) ; Strong dependent
+
+(define font? (is-type-wrapped-object 'scxl-font))
+
+(define (font/font font)
+ (type-check-wrapped-object 'scxl-font font)
+ (SCXL-UNWRAP font (lambda (font) font)))
+
+(define ->xfont font/font)
+
+|#
+
+;;; NOTE: GCs maintain a lot of state in C. Their Scheme shadows
+;;; should have strong dependencies on these things, like the XRegion,
+;;; Foreground and Background Pixel, font, etc.
+
+(define (wrap-graphics-context display gc)
+ (SCXL-WRAP (display/gc-list display)
+ 'scxl-graphics-context
+ GC
+ display ; Strong dependent
+ (make-cell #F))) ; No region
+
+(define (gc/gc gc)
+ (type-check-wrapped-object 'scxl-graphics-context gc)
+ (SCXL-UNWRAP gc (lambda (gc region-cell) region-cell gc)))
+
+(define (gc/region gc)
+ (type-check-wrapped-object 'scxl-graphics-context gc)
+ ;; Note gc/region returns a wrapped object
+ (cell-contents (SCXL-UNWRAP gc
+ (lambda (gc region-cell)
+ gc ; Unused
+ region-cell))))
+
+(define (set-gc/region! gc region)
+ (type-check-wrapped-object 'scxl-graphics-context gc)
+ (set-cell-contents!
+ (SCXL-UNWRAP gc
+ (lambda (gc region-cell)
+ gc ; Unused
+ region-cell))
+ region)
+ 'MUNGED)
+
+(define (->xgc user-visible-gc)
+ (type-check-wrapped-object 'scxl-graphics-context user-visible-gc)
+ (cond ((SCXL-WRAPPED? user-visible-gc)
+ (gc/gc user-visible-gc))
+ ((number? user-visible-gc) user-visible-gc)
+ (else (error "->XGc: not a gc" user-visible-gc))))
+
+(define (wrap-colormap display colormap)
+ (SCXL-WRAP (display/colormap-list display)
+ 'scxl-colormap
+ colormap
+ display ; Strong dependent
+ (make-protection-list))) ; Pixel list
+
+(define (colormap/colormap colormap)
+ (type-check-wrapped-object 'scxl-colormap colormap)
+ (SCXL-UNWRAP colormap
+ (lambda (colormap pixels)
+ pixels ; Not used
+ colormap)))
+
+(define (colormap/pixel-list colormap)
+ (type-check-wrapped-object 'scxl-colormap colormap)
+ (SCXL-UNWRAP colormap
+ (lambda (colormap pixels)
+ colormap ; Not used
+ pixels)))
+
+(define ->xcolormap colormap/colormap)
+
+(define (wrap-pixel display colormap pixel)
+ (SCXL-WRAP (colormap/pixel-list colormap)
+ 'scxl-color
+ pixel
+ (list display colormap))) ; Strong dependents
+
+(define color? (is-type-wrapped-object 'scxl-color))
+
+(define (pixel/pixel pixel)
+ (type-check-wrapped-object 'scxl-color pixel)
+ (SCXL-UNWRAP pixel (lambda (pixel) pixel)))
+
+(define ->xpixel pixel/pixel)
+
+(define (wrap-region region)
+ (SCXL-WRAP region-protection-list
+ 'scxl-region
+ region
+ #F)) ; No strong dependents
+
+(define (region/region region)
+ (type-check-wrapped-object 'scxl-region region)
+ (SCXL-UNWRAP region (lambda (region) region)))
+
+(define ->xregion region/region)
+\f
+#| *****************************
+Debugging kludge
+This will print a whole lot of crap. Break glass in case of emergency only.
+
+(define D_EVAL 0)
+(define D_HEX_INPUT 1)
+(define D_FILE_LOAD 2)
+(define D_RELOC 3)
+(define D_INTERN 4)
+(define D_CONT 5)
+(define D_PRIMITIVE 6)
+(define D_LOOKUP 7)
+(define D_DEFINE 8)
+(define D_GC 9)
+(define D_UPGRADE 10)
+(define D_DUMP 11)
+(define D_TRACE_ON_ERROR 12)
+(define D_PER_FILE 13)
+(define D_BIGNUM 14)
+(define D_FLUIDS 15)
+
+(define *spew-crap-out?* #T)
+
+
+(define check-space
+ (let ((get-status (make-primitive-procedure 'gc-space-status))
+ (set-debug-flags! (make-primitive-procedure 'set-debug-flags!)))
+ (lambda ()
+ (let* ((status (get-status))
+ (free (vector-ref status 5))
+ (top (vector-ref status 6))
+ (space (- top free)))
+ (write-line `(space ,space))
+ (if (< space 2800000)
+ (if *spew-crap-out?*
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (debug-print 'space-low!)
+ (set-debug-flags! D_EVAL #T)
+ (set! *spew-crap-out?* #F)
+ 'OK))
+ (begin
+ (debug-print 'end 'print)
+ (set-debug-flags! D_EVAL #F)
+ 'OK)))))))
+
+*****************************************|#
+
+
+#| Finalization of SCXL objects. In UITK, this is scheduled to be
+done by the UITK thread. Other systems may schedule it to be done
+differently, or done immediately. If this is scheduled in the GC, the
+assumptions about (not) interrupt locking the protection lists may be
+incorrect. WATCH OUT!
+
+Note that this daemon has to call the lowest level % primitives rather
+than the wrapped version for lost objects in the cases where the
+wrappers have been lost and we have only the X pointers remianing.
+|#
+
+(define (close-lost-displays-daemon)
+ ;; Step one: clean up any displays that have GCed away
+ (clean-lost-celled-objects display-protection-list XCloseDisplayByNumber)
+ ;; Step two: clean up any regions that have GCed away
+ (clean-lost-celled-objects region-protection-list %XDestroyRegion)
+ ;; Step three: run through all displays that we DO have
+ ;; handles on, and release fonts/colomaps/gcs that we do
+ ;; NOT have handles on.
+ ;; *NOTE*: We do >>not<< close windows that we've lost handles on,
+ ;; because X maintains gazillions of pointers to them that we aren't
+ ;; tracking.
+ (for-each
+ cleanup-vanished-objects-for-display
+ (protection-list-referenced-elements display-protection-list)))
+
+(define (cleanup-vanished-objects-for-display display)
+ (if (not (SCXL-DESTROYED? display))
+ (unwrap-display
+ display
+ (lambda (display-number windows fonts colormaps gcs
+ default-root-window default-colormaps)
+ windows fonts default-root-window default-colormaps ; Don't GC these!
+ (clean-lost-celled-objects
+ colormaps
+ (lambda (colormap-number)
+ (%XFreeColorMap display-number colormap-number)))
+ #| ****************************************
+ By rights, we should release unused colors from all
+ of the allocated color maps *and* the default color
+ map of each screen. However, this would require us
+ to keep track of the foreground and background
+ color in graphics contexts since X keeps these
+ pointers for us.
+ When we fix this, it should use the protection list iterators
+ (if colormaps
+ (do ((associations (cdr colormaps) (cdr associations)))
+ ((null? associations))
+ (let* ((colormap (weak-car (car associations)))
+ (pixels (colormap/pixel-list colormap)))
+ (if (not (null? pixels))
+ (clean-lost-celled-objects
+ pixels
+ (lambda (pixel)
+ (%XFreeColor display-number **doens't work
+ (->colormap colormap)
+ (-> pixel pixel))))))))
+ ******************************************** |#
+ (clean-lost-celled-objects
+ gcs
+ (lambda (gc-number) (%XFreeGC display-number gc-number)))))))
+
+
+\f
+;;;; Primitives written in C
+
+(define-primitives ; X Operations
+ (%XAllocNamedColor 5)
+ (%XChangeWindowAttributes 4)
+ (%XCheckMaskEvent 3)
+ (%XClearArea 7)
+ (%XClearWindow 2)
+ (%XCloseDisplay 1)
+ (%XConnectionNumber 1)
+ (%XCreateGC 4)
+ (%XCreateRegion 0)
+ (%XCreateSimpleWindow 9)
+ (%XDecodeButtonEvent 2)
+ (%XDecodeConfigureEvent 2)
+ (%XDecodeCrossingEvent 2)
+ (%XDecodeExposeEvent 2)
+ (%XDecodeKeyEvent 2)
+ (%XDecodeMotionEvent 2)
+ (%XDecodeUnknownEvent 2)
+ (%XDecodeWindowAttributes 2)
+ (%XDecodeXColor 2)
+ (%XDefaultColormap 2)
+ (%XDefaultRootWindow 1)
+ (%XDefaultScreen 1)
+ (%XDestroyRegion 1)
+ (%XDestroyWindow 2)
+ (%XDrawArc 9)
+ (%XDrawLine 7)
+ (%XDrawRectangle 7)
+ (%XFillArc 9)
+ (%XFillRectangle 7)
+ (%XFlush 1)
+ (%XFreeColormap 2)
+ (%XFreeGC 2)
+ (%XGetDefault 3)
+ (%XGetWindowAttributes 3)
+ (%XInitSCXL! 0)
+ (%XIntersectRegion 3)
+ (%XLoadFont 2)
+ (%XMapWindow 2)
+ (%XNextEvent 2)
+ (%XOpenDisplay 1)
+ (%XPending 1)
+ (%XPutBackEvent 2)
+ (%XQueryPointer 3)
+ (%XQueryTree 2)
+ (%XScreenCount 1)
+ (%XSetForeground 3)
+ (%XSetFunction 3)
+ (%XSetRegion 3)
+ (%XStoreName 3)
+ (%XSubtractRegion 3)
+ (%XSync 2)
+ (%XSynchronize 2)
+ (%XTranslateCoordinates 6)
+ (%XUnionRegion 3)
+ (%XUnionRectSpecsWithRegion! 6)
+ (%XUnloadFont 2))
+
+(define-primitives ; X Data Structure constructors
+ (%XMake-Color 0)
+ (%XMake-Event 0)
+ (%XMake-GCValues 0)
+ (%XMake-GetWindowAttributes 0)
+ (%XMake-SetWindowAttributes 0)
+ (%XMake-Window 0) ; Hold a window identifier
+ (%XMake-XY 0)) ; Hold an X/Y value
+
+(define-primitives ; X data structure mutators
+ (%XSetWindowAttributes-Event_Mask! 2))
+\f
+(define (XColor.Pixel xcolor)
+ (let ((components (make-vector 5)))
+ ;; Returns #(pixel, red, green, blue, flags)
+ (XDecodeXColor xcolor components)
+ (vector-ref components 0)))
+
+;;;; SCXL-level calls to the X primitives
+
+(define (XAllocNamedColor display colormap color-string)
+ ;; Returns list: (Status Color-Allocated Exact-Color)
+ ;; where color-allocated and exact-color are each the cons of a
+ ;; wrapped pixel and a string that is the direct coding of the X
+ ;; color structure.
+ (let ((allocated (%XMake-Color))
+ (exact (%XMake-Color)))
+ (let ((result
+ (%XAllocNamedColor (->XDisplay display)
+ (->XColormap colormap)
+ color-string
+ allocated
+ exact)))
+ (list result
+ (wrap-pixel display colormap (XColor.Pixel allocated))
+ (wrap-pixel display colormap (XColor.Pixel exact))))))
+
+(define (XChangeWindowAttributes display window mask attributes)
+ (%XChangeWindowAttributes (->XDisplay display)
+ (->XWindow window)
+ mask
+ attributes)
+ (flush-display-hook))
+
+(define (XCheckMaskEvent!? display event-mask returned-event)
+ (%XCheckMaskEvent (->XDisplay display)
+ event-mask
+ returned-event))
+
+(define (XClearArea display window x y width height exposures?)
+ (%XClearArea (->XDisplay display)
+ (->XWindow window)
+ x y width height exposures?)
+ (flush-display-hook))
+
+(define (XClearWindow display window)
+ (%XClearWindow (->XDisplay display)
+ (->XWindow window))
+ (flush-display-hook))
+
+#| XCloseDisplay closes the display and destroys the Scheme shadows of
+the associated server objects, and closes tk objects (which aren't
+automatically closed by X). In UITK, XCloseDisplay is NEVER called. The
+lower-level XCloseDisplayByNumber is called from the GC. Anyone who
+writes programs that call XCloseDisplay needs to think carefully about the
+dependencies (on both the Scheme and C side) of objects and processes
+involved in calling destroy operations. Tread carefully here. |#
+
+(define XCloseDisplay
+ (wrap-with-SCXL-DESTROY!
+ 1 0
+ (lambda (dsp)
+ (define (kill-protected-objects protection-list)
+ (for-each SCXL-DESTROY!
+ (protection-list-referenced-elements protection-list)))
+ ;;SCXL-destroy the Scheme representitives of the X objects associated
+ ;;to the display (which are killed by X when the
+ ;;display is closed).
+ (unwrap-display
+ dsp
+ (lambda (xdisplay windows fonts colormaps gcs
+ defaultwindow defaultcolormaps)
+ defaultwindow defaultcolormaps ; Should be, but aren't, used
+ (for-each kill-protected-objects (list windows fonts colormaps gcs))
+ ;;do someting about the default window and colormap
+ (XCloseDisplayByNumber xdisplay))))))
+
+#| *********************************************
+
+XCloseDisplayByNumber is scheduled to be called by the gc-daemon when
+all references to the Scheme display have been lost.
+
+Closing the display will close the (C) windows, GC's, fonts, etc. But
+we do NOT need to destroy their Scheme-side reflections, because we
+have arranged for these to point to the display. Therefore, they
+cannot be around if the Scheme display object has been lost.
+
+*XclosedisplayCallBacks is a list of thinks that should be called when
+a display is closed. In UITK, for example, we need to
+shut down the even server for the display.
+
+ ************************************************ |#
+
+(define *XCloseDisplayCallBacks* '())
+
+(define (XCloseDisplayByNumber display-number)
+ (for-each (lambda (proc) (proc display-number))
+ *XCloseDisplayCallBacks*)
+ (%XCloseDisplay display-number))
+
+(define (SCXL-Install-XCloseDisplay-Callback proc)
+ (set! *XCloseDisplayCallbacks*
+ (cons proc *XCloseDisplayCallBacks*)))
+
+(define (XConnectionNumber display)
+ (%XConnectionNumber (->XDisplay display)))
+
+(define (XCreateGC display window mask gcvalues)
+ (wrap-graphics-context display
+ (%XCreateGC (->XDisplay display)
+ (->XWindow window)
+ mask
+ gcvalues)))
+
+(define (XCreateRegion)
+ (wrap-region (%XCreateRegion)))
+
+(define (XCreateSimpleWindow
+ display parent x y width height
+ border-width border-pixel background-pixel)
+ (wrap-window display
+ (%XCreateSimpleWindow (->XDisplay display)
+ (->XWindow parent)
+ x y width height border-width
+ (->XPixel border-pixel)
+ (->XPixel background-pixel))))
+
+(define (XDecodeButtonEvent event vect)
+ (%XDecodeButtonEvent event vect))
+
+(define (XDecodeConfigureEvent event vect)
+ (%XDecodeConfigureEvent event vect))
+
+(define (XDecodeCrossingEvent event vect)
+ (%XDecodeCrossingEvent event vect))
+
+(define (XDecodeExposeEvent event vect)
+ (%XDecodeExposeEvent event vect))
+
+(define (XDecodeKeyEvent event vect)
+ (%XDecodeKeyEvent event vect))
+
+(define (XDecodeMotionEvent event vect)
+ (%XDecodeMotionEvent event vect))
+
+(define (XDecodeUnknownEvent event vect)
+ (%XDecodeUnknownEvent event vect))
+
+(define (XDecodeWindowAttributes attributes vect)
+ (%XDecodeWindowAttributes attributes vect))
+
+(define (XDecodeXColor XColor vect)
+ (%XDecodeXColor xcolor vect))
+
+(define (XDefaultColormap display screen)
+ (vector-ref (display/screen/default-color-map display) screen))
+
+(define (XDefaultRootWindow display)
+ (display/default-root-window display))
+
+;;; Screens are not wrapped -- they are just integers, because there
+;;; is no real resource that is being allocated here.
+
+(define (XDefaultScreen display)
+ (%XDefaultScreen (->XDisplay display)))
+
+(define XDestroyRegion
+ (wrap-with-SCXL-DESTROY! 1 0
+ (lambda (region)
+ (%XDestroyRegion (->XRegion region)))))
+
+(define XDestroyWindow
+ (wrap-with-SCXL-DESTROY! 2 1
+ (lambda (display window)
+ (%XDestroyWindow (->XDisplay display) (->XWindow window)))))
+
+(define (XDrawArc display window graphics-context
+ x y width height angle1 angle2)
+ (%XDrawArc (->XDisplay display)
+ (->XWindow window)
+ (->XGC graphics-context)
+ x y width height angle1 angle2)
+ (flush-display-hook))
+
+(define (XDrawLine display window graphics-context x1 y1 x2 y2)
+ (%XDrawLine (->XDisplay display)
+ (->XWindow window)
+ (->XGC graphics-context)
+ x1 y1 x2 y2)
+ (flush-display-hook))
+
+(define (XDrawRectangle display window graphics-context x y width height)
+ (%XDrawRectangle (->XDisplay display)
+ (->XWindow window)
+ (->XGC graphics-context)
+ x y width height)
+ (flush-display-hook))
+
+(define (XFillArc display window graphics-context
+ x y width height angle1 angle2)
+ (%XFillArc (->XDisplay display)
+ (->XWindow window)
+ (->XGC graphics-context)
+ x y width height angle1 angle2)
+ (flush-display-hook))
+
+(define (XFillRectangle display window graphics-context x y width height)
+ (%XFillRectangle (->XDisplay display)
+ (->XWindow window)
+ (->XGC graphics-context)
+ x y width height)
+ (flush-display-hook))
+
+(define (XFlush display)
+ (%XFlush (->XDisplay display)))
+
+;;; When we free a colormap, we have to destroy the Scheme
+;;; representitives of the pixels allocated in it.
+
+(define XFreeColormap
+ (wrap-with-SCXL-DESTROY! 2 1
+ (lambda (display colormap)
+ (%XFreeColormap (->XDisplay display) (->XColormap colormap))
+ (if (SCXL-WRAPPED? font)
+ (for-each SCXL-DESTROY!
+ (protection-list-referenced-elements
+ (colormap/pixel-list colormap)))))))
+
+(define XFreeGC
+ (wrap-with-SCXL-DESTROY! 2 1
+ (lambda (display gc)
+ (%XFreeGC (->XDisplay display) (->XGC gc)))))
+
+;;; XGetDefault returns a bare X pointer. Anyone who calls it needs to know
+;;; what is expected and wrap it at the next level up.
+
+(define (XGetDefault display program option)
+ (%XGetDefault (->XDisplay display) program option))
+
+(define (XGetWindowAttributes display window)
+ ;; Returns a list of (Status Attributes)
+ (let ((attributes (%XMake-GetWindowAttributes)))
+ (list (%XGetWindowAttributes (->XDisplay display)
+ (->XWindow window)
+ attributes)
+ attributes)))
+
+(define (XIntersectRegion! source-1 source-2 dest)
+ (%XIntersectRegion
+ (->XRegion source-1)
+ (->XRegion source-2)
+ (->XRegion dest)))
+
+(define (XLoadFont display name)
+ (wrap-font display
+ (%XLoadFont (->Xdisplay display) name)))
+
+(define (XMapWindow display window)
+ (%XMapWindow (->XDisplay display) (->XWindow window))
+ (flush-display-hook))
+
+(define (XNextEvent display)
+ (let ((event (%XMake-Event)))
+ (%XNextEvent (->XDisplay display) event)
+ event))
+
+;;;This is a version that doesn't build up garbage
+(define (XNextEvent! display event-string)
+ (%XNextEvent (->XDisplay display) event-string)
+ event-string)
+
+;;;This is a flag that forces the X server into synchronous mode. It is
+;;;useful for debugging, but slows things down alot.
+
+(define *Synchronizing?* #f)
+
+(define (XOpenDisplay string)
+ (wrap-display
+ (let ((result (%XOpenDisplay string)))
+ (%XSynchronize result *Synchronizing?*)
+ result)))
+
+(define (XPending display)
+ (%XPending (->XDisplay display)))
+
+(define (XPutBackEvent display event)
+ (%XPutBackEvent (->XDisplay display) event))
+
+(define (XQueryTree display window)
+ (%XQueryTree (->XDisplay display)
+ (->XWindow window)))
+
+(define (XQueryPointer display window)
+ (let ((result (make-vector 8)))
+ (%XQueryPointer (->XDisplay display)
+ (->XWindow window)
+ result)
+ result))
+
+(define (XScreenCount display)
+ (%XScreenCount (->XDisplay display)))
+
+(define (XSetForeground display graphics-context pixel-value)
+ (%XSetForeground (->XDisplay display)
+ (->XGC graphics-context)
+ (->XPixel pixel-value))
+ (flush-display-hook))
+
+
+(define (XSetFunction display graphics-context function-number)
+ (%XSetFunction (->XDisplay display)
+ (->XGC graphics-context)
+ function-number))
+
+(define (XSetRegion display graphics-context region)
+ (%XSetRegion (->XDisplay display)
+ (->XGC graphics-context)
+ (->XRegion region))
+ (if (SCXL-WRAPPED? graphics-context)
+ (set-gc/region! graphics-context region)))
+
+(define (XStoreName display window title)
+ (%XStoreName (->XDisplay display)
+ (->XWindow window)
+ title))
+
+(define (XSubtractRegion! source-1 source-2 dest)
+ (%XSubtractRegion
+ (->XRegion source-1)
+ (->XRegion source-2)
+ (->XRegion dest)))
+
+(define (XTranslateCoordinates display from-window to-window x y)
+ ;; Returns a vector (Status X Y Child-Window)
+ (let ((return-vector (make-vector 4)))
+ (%XTranslateCoordinates (->XDisplay display)
+ (->XWindow from-window)
+ (->XWindow to-window)
+ x y return-vector)
+ return-vector))
+
+(define (XUnionRegion! source-1 source-2 dest)
+ (%XUnionRegion
+ (->XRegion source-1)
+ (->XRegion source-2)
+ (->XRegion dest)))
+
+(define (XUnionRectSpecsWithRegion! x y width height in-region out-region)
+ (%XUnionRectSpecsWithRegion! x y width height
+ (->XRegion in-region)
+ (->XRegion out-region)))
+
+(define XUnloadFont
+ (wrap-with-SCXL-DESTROY! 2 1
+ (lambda (display font)
+ (%XUnloadFont (->XDisplay display) (->XFont font)))))
+
+;;;; Constructors
+
+(define (XMake-Color) (%XMake-Color))
+(define (XMake-Event) (%XMake-Event))
+(define (XMake-GCValues) (%XMake-GCValues))
+(define (XMake-SetWindowAttributes) (%XMake-SetWindowAttributes))
+
+;;;; Mutators
+
+(define (XSetWindowAttributes-Event_Mask! object value)
+ (%XSetWindowAttributes-Event_Mask! object value))
+
+;;;; Auxilliary
+
+(define (XCopy-Event event)
+ (string-copy event))
+\f
+(define (initialize-scxl!)
+ (%XInitSCXL!)
+ (set! display-protection-list (make-protection-list))
+ (set! region-protection-list (make-protection-list))
+ ;; Warning: UITK (in mit-xhooks.scm) knows that
+ ;; close-lost-displays-daemon is *the* daemon associated with scxl.
+ ;; It arranges to run it in another thread and removes it from the
+ ;; gc-daemon list.
+ ;;
+ ;; THIS SHOULD BE PUT BACK!
+ ;; (add-gc-daemon! close-lost-displays-daemon)
+ )
+
+(initialize-scxl!)
+
--- /dev/null
+;;; -*- Scheme -*-
+
+;; Test direct to TCL
+
+(define (do* args)
+ (tcl-global-eval *the-default-application* (car args) (cdr args)))
+
+(define (many arg-list) (for-each do* arg-list))
+
+;; Test the Button widget
+
+(define but1)
+(define (btest1)
+ (set! but1 (make-button '(-text "Hello Jim"
+ -foreground blue -activeforeground black
+ -background yellow -activebackground orange)))
+ (set-callback! but1
+ (lambda ()
+ (display "Ouch!")
+ (newline)))
+ (swat-open but1 '-title "Test Scheme Application"))
+
+(define v1)
+(define v2)
+(define v3)
+(define h1)
+(define h2)
+(define h3)
+(define leftframe)
+(define rightframe)
+(define frame)
+(define (btest2)
+ (set! v1 (make-button '(-text "Hello Jim"
+ -foreground blue
+ -activeforeground "hot pink")))
+ (set! v2 (make-button '(-text "Goodbye and Good Luck")))
+ (set! v3 (make-button '(-text "Jane")))
+
+ (set! leftframe (make-vbox v1 v2 v3))
+
+ (set! h1 (make-button '(-text "Button 1")))
+ (set! h2 (make-button '(-text "Button 2")))
+ (set! h3 (make-button '(-text "Button 3")))
+
+ (set! rightframe (make-hbox h1 h2 h3))
+
+ (set! frame (make-hbox leftframe rightframe))
+
+ (set-callback! v1 (lambda ()
+ (display "First button in Vbox")
+ (newline)))
+ (set-callback! h1
+ (lambda ()
+ (display "First button in Hbox")
+ (newline)))
+ (swat-open frame '-title "Test Scheme Application"))
+
+
+(define but3)
+(define (btest3)
+ (set! but3 (make-button '(-text "hello there" -background yellow)))
+ (set-callback!
+ but3
+ (lambda ()
+ (after-delay 2
+ (lambda ()
+ (ask-widget but3 '(configure -background red))))
+ (after-delay 4
+ (lambda ()
+ (ask-widget but3 '(configure -background yellow))))))
+ (swat-open but3 '-title "btest3"))
+
+(define (show-window-attributes uitkwindow)
+ (let ((attributes (list-ref (XGetWindowAttributes
+ (uitkwindow.xdisplay uitkwindow)
+ (uitkwindow.xwindow uitkwindow)) 1)))
+ (Decode-Window-Attributes attributes
+ (lambda (x y width height border_width depth visual root class
+ bit_gravity win_gravity backing_store backing_planes
+ backing_pixel save_under colormap map_installed
+ map_state all_event_masks your_event_mask
+ do_not_propogate_mask override_redirect screen)
+ depth visual root class bit_gravity win_gravity backing_store
+ backing_planes backing_pixel save_under colormap map_installed
+ map_state override_redirect screen
+ (write-line (list 'x x 'y y 'width width
+ 'height height 'b-width border_width))
+ (write-line (list 'all (number->string all_event_masks 16)
+ 'event (number->string your_event_mask 16)
+ 'do-not-prop do_not_propogate_mask))))))
+
+(define scale1)
+(define (stest1)
+ (set! scale1 (make-scale '(-from 0 -to 99
+ -foreground blue -activeforeground red
+ -background yellow -length 500 -orient horiz)))
+#| (set-callback! scale1
+ (lambda (value)
+ (display (list "Ouch!" value))
+ (newline)))
+|#
+ (swat-open scale1 '-title "Scale Test Scheme Application"))
+
+(define scale2)
+(define (stest2)
+ (set! scale2 (make-scale '(-from 0 -to 99 -length 500 -orient horiz
+ -foreground blue -activeforeground red
+ -background yellow)))
+ (set-callback! scale2 (lambda (value) 'ignore))
+ (swat-open scale2 '-title "Scale Test Scheme Application"))
+
+(define e)
+(define (etest1)
+ (set! e (make-entry '(-width 30 -relief sunken
+ -foreground blue -background yellow)))
+ (swat-open e '-title "Entry Test"))
+
+(define sb)
+(define (sbtest1)
+ (set! sb (make-scrollbar '(-width 20 -orient vertical -relief sunken
+ -foreground blue -background yellow)))
+ (swat-open sb '-title "Scrollbar Test"))
+
+(define (sbtest2)
+ (let* ((scroll (make-scrollbar '(-width 30 -orient horizontal -relief sunken
+ -foreground blue -background yellow)))
+ (entry (make-entry '(-width 45)))
+ (me (make-vbox entry scroll)))
+ (swat-open me '-title "Scrollbar Test")
+ me))
+
+(define (suicide-button)
+ (let ((sbut (make-button '(-text "Kill Me"))))
+ (set-callback! sbut
+ (lambda ()
+ (swat-close sbut)))
+ (swat-open sbut)))
+
+
+;;;scheduling the update for when-idle makes things a littel better, but not much.
+;;;GC still interferes
+
+(define (sbtest3)
+ ;; A "better" version is in sbtest4
+ (let ((app (make-application "Play")))
+ (let ((hscroll (make-scrollbar '(-width 20 -orient horizontal)))
+ (vscroll (make-scrollbar '(-width 20 -orient vertical)))
+ (big (make-rect 500 600 "blue"))
+ (small (make-oval 30 40 "yellow"))
+ (scrolly 0)
+ (scrollx 0)
+ (x 0)
+ (y 0))
+ (define (update-vert)
+ (if (not (= y scrolly))
+ (begin (set! y scrolly)
+ (shape-draw big)
+ (assign-location! small (make-point x y))
+ (shape-draw small)
+ (ask-widget vscroll `(set 600 40 ,y ,(+ y 40))))))
+ (define (update-horiz)
+ (if (not (= x scrollx))
+ (begin (set! x scrollx)
+ (shape-draw big)
+ (assign-location! small (make-point x y))
+ (shape-draw small)
+ (ask-widget hscroll `(set 500 30 ,x ,(+ x 30))))))
+
+ (ask-widget vscroll '(set 600 40 0 40))
+ (ask-widget hscroll '(set 500 30 0 30))
+ (let ((hb (make-hbox big vscroll)))
+ (let ((vb (make-vbox hb hscroll)))
+ (add-child! app vb)
+ ))
+
+ (set-callback! vscroll
+ (lambda (value)
+ (let* ((n (string->number value))
+ ;;keep small bar totally on screen
+ (n (max 0 n))
+ (n (min 560 n)))
+ (set! scrolly n)
+ (when-idle! update-vert))))
+ (set-callback! hscroll
+ (lambda (value)
+ (let* ((n (string->number value))
+ ;;keep small bar totally on screen
+ (n (max 0 n))
+ (n (min 470 n)))
+ (set! scrollx n)
+ (when-idle! update-horiz))))
+ (on-geometry-change!
+ big
+ 'ignore
+ (lambda (old-screen-area new-screen-area)
+ (assign-geometry! small
+ (drawing-surface big)
+ (if new-screen-area
+ (copy-rectangle new-screen-area)
+ new-screen-area))
+ (shape-draw big)
+ (shape-draw small)))
+ (handle-exposure big (lambda (rect)
+ (shape-draw big (rectangle->xregion rect))
+ (shape-draw small)))
+ (when-idle! (lambda () (shape-draw small)))
+ `((app ,app)
+ (hscroll ,hscroll)
+ (vscroll ,vscroll)
+ (big ,big)
+ (small ,small)))))
+
+(define (compress-deferred-processing on-callback at-idle)
+ (let ((scheduled? #F))
+ (lambda args
+ (if (not scheduled?)
+ (begin
+ (when-idle!
+ (lambda ()
+ (set! scheduled? #F)
+ (at-idle)))
+ (set! scheduled? #T)))
+ (apply on-callback args))))
+
+(define (sbtest4)
+ (let ((app (make-application "Play")))
+ (let ((hscroll (make-scrollbar '(-width 20 -orient horizontal)))
+ (vscroll (make-scrollbar '(-width 20 -orient vertical)))
+ (big (make-rect 500 600 "blue"))
+ (small (make-oval 30 40 "yellow"))
+ (scrolly 0)
+ (scrollx 0)
+ (x 0)
+ (y 0))
+
+ (define (update-vert)
+ (if (not (= y scrolly))
+ (begin (set! y scrolly)
+ (shape-draw big)
+ (assign-location! small (make-point x y))
+ (shape-draw small)
+ (ask-widget vscroll `(set 600 40 ,y ,(+ y 40))))))
+
+ (define (update-horiz)
+ (if (not (= x scrollx))
+ (begin (set! x scrollx)
+ (shape-draw big)
+ (assign-location! small (make-point x y))
+ (shape-draw small)
+ (ask-widget hscroll `(set 500 30 ,x ,(+ x 30))))))
+
+ (ask-widget vscroll '(set 600 40 0 40))
+ (ask-widget hscroll '(set 500 30 0 30))
+ (add-child! app (make-vbox (make-hbox big vscroll)
+ hscroll))
+ (set-callback! vscroll
+ (compress-deferred-processing
+ (lambda (value)
+ (let* ((n (string->number value))
+ ;;keep small bar totally on screen
+ (n (max 0 n))
+ (n (min 560 n)))
+ (set! scrolly n)))
+ update-vert))
+
+ (set-callback! hscroll
+ (compress-deferred-processing
+ (lambda (value)
+ (let* ((n (string->number value))
+ ;;keep small bar totally on screen
+ (n (max 0 n))
+ (n (min 470 n)))
+ (set! scrollx n)))
+ update-horiz))
+
+ (on-geometry-change!
+ big
+ 'ignore
+ (lambda (old-screen-area new-screen-area)
+ (assign-geometry! small
+ (drawing-surface big)
+ (if new-screen-area
+ (copy-rectangle new-screen-area)
+ new-screen-area))
+ (shape-draw big)
+ (shape-draw small)))
+
+ (handle-exposure big (lambda (rect)
+ (shape-draw big (rectangle->xregion rect))
+ (shape-draw small)))
+
+ (when-idle! (lambda () (shape-draw small)))
+ `((app ,app)
+ (hscroll ,hscroll)
+ (vscroll ,vscroll)
+ (big ,big)
+ (small ,small)))))
+
+;;; canvas tests
+(define (canvas-test)
+ (let ((c (make-canvas '(-width 400 -height 300 -background "light gray"))))
+ (swat-open c)
+ (let ((george
+ (make-arc-on-canvas c 200 200 250 250
+ `(-fill pink -outline black
+ -width 2 -start 0 -extent 300)))
+ (message (make-text-on-canvas c 100 100 '(-text "Hello there")))
+ (last-x #F)
+ (last-y #F)
+ (start 0))
+ (add-event-handler! george "<Enter>"
+ (lambda () (ask-widget george '(configure -fill yellow))))
+ (add-event-handler! george "<Leave>"
+ (lambda () (ask-widget george '(configure -fill pink))))
+ (add-event-handler! george "<ButtonPress-1>"
+ (lambda (x y)
+ (ask-widget message
+ `(configure -text "OUCH!"
+ -font "-Adobe-Helvetica-Bold-R-Normal--*-240-*"))
+ (set! start (modulo (+ start 30) 360))
+ (ask-widget george `(configure -start ,start))
+ (set! last-x x)
+ (set! last-y y))
+ "%x" "%y")
+ (add-event-handler! george "<ButtonRelease-1>"
+ (lambda ()
+ (ask-widget message
+ '(configure -text "Hello there"
+ -font "-Adobe-Helvetica-Bold-R-Normal--*-120-*"))))
+ (add-event-handler! george "<Button1-Motion>"
+ (lambda (x y)
+ (ask-widget george `(move ,(- x last-x) ,(- y last-y)))
+ (set! last-x x)
+ (set! last-y y))
+ "%x" "%y")
+ )))
+
+
+(define (doodle-test)
+ (let ((c (make-canvas '(-width 400 -height 300
+ -background "light gray")))
+ (last-x 0)
+ (last-y 0))
+ (add-event-handler! c
+ "<ButtonPress-1>"
+ (lambda (x y)
+ (ask-widget c `(delete all))
+ (set! last-x x)
+ (set! last-y y))
+ "%x" "%y")
+ (add-event-handler! c
+ "<B1-Motion>"
+ (lambda (x y)
+ (let ((line (make-line-on-canvas c last-x last-y x y)))
+ (ask-widget line '(configure -width 1))
+ (set! last-x x)
+ (set! last-y y)))
+ "%x" "%y")
+ (swat-open c '-title "Canvas Drawing")))
+
+
+(define (ctest)
+ (let ((a (make-application "Canvas Items: IQ Test")))
+ (let ((c (make-canvas '(-width 400 -height 300))))
+ (ask-widget c '(configure -background "light gray"))
+ (add-child! a c)
+
+ (let* ((r1 (make-rectangle-on-canvas c 20 20 60 60))
+ (r2 (make-rectangle-on-canvas c 40 40 80 80))
+ (r3 (make-rectangle-on-canvas c 60 60 100 100))
+
+ (m1 (make-text-on-canvas c 300 20 '(-text "CANVAS EVENTS:")))
+ (m2 (make-text-on-canvas c 300 40 '(-text "B1: east")))
+ (m3 (make-text-on-canvas c 300 60 '(-text "B3: west")))
+ (m4 (make-text-on-canvas c 300 80 '(-text "B2,B1: south")))
+ (m5 (make-text-on-canvas c 300 100 '(-text "B2,B3: north")))
+ (m6 (make-text-on-canvas c 300 140 '(-text "TAG EVENTS:")))
+ (m7 (make-text-on-canvas c 300 160 '(-text "B1: red")))
+ (m8 (make-text-on-canvas c 300 180 '(-text "B2: green")))
+ (m9 (make-text-on-canvas c 300 200 '(-text "B3: blue")))
+
+ (t1 (make-canvas-item-group c (list r1 r2 r3)))
+ (t2 (make-canvas-item-group c (list m2 m3 m4 m5 m7 m8 m9)))
+ )
+ (ask-widget r1 '(configure -fill red))
+ (ask-widget r2 '(configure -fill green))
+ (ask-widget r3 '(configure -fill blue))
+ (ask-widget t2 '(configure -anchor n -fill maroon))
+
+
+ (add-event-handler! c
+ "<ButtonPress-1>"
+ (lambda ()
+ (ask-widget t1 `(move 10 0))))
+ (add-event-handler! c
+ "<ButtonPress-3>"
+ (lambda ()
+ (ask-widget t1 `(move -10 0))))
+ (add-event-handler! c
+ "<ButtonPress-2><ButtonPress-1>"
+ (lambda ()
+ (ask-widget t1 `(move 0 10))))
+ (add-event-handler! c
+ "<ButtonPress-2><ButtonPress-3>"
+ (lambda ()
+ (ask-widget t1 `(move 0 -10))))
+
+ (add-event-handler! t1
+ "<ButtonPress-1>"
+ (lambda ()
+ (ask-widget r1 `(move 10 10))))
+ (add-event-handler! t1
+ "<ButtonPress-2>"
+ (lambda ()
+ (ask-widget r2 `(move 10 10))))
+ (add-event-handler! t1
+ "<ButtonPress-3>"
+ (lambda ()
+ (ask-widget r3 `(move 10 10))))
+
+ (add-event-handler! r1
+ "<Enter>"
+ (lambda ()
+ (ask-widget r1 `(raise))))
+ (add-event-handler! r2
+ "<Enter>"
+ (lambda ()
+ (ask-widget r2 `(raise))))
+ (add-event-handler! r3
+ "<Enter>"
+ (lambda ()
+ (ask-widget r3 `(raise))))
+
+ (add-event-handler! t2
+ "<Enter>"
+ (lambda ()
+ (ask-widget t2 `(configure -fill violetred))))
+ (add-event-handler! t2
+ "<Leave>"
+ (lambda ()
+ (ask-widget t2 `(configure -fill maroon))))
+
+ c))))
+
+(define (ctest1)
+ (let* ((app (make-application "Canvas Widget"))
+ (canvas (make-canvas '(-width 300 -height 300)))
+ (button1 (make-button '(-text "Toggle background color")))
+ (vbox (make-vbox canvas button1)))
+ (ask-widget canvas '(configure -background yellow))
+ (ask-widget button1 '(configure -background cyan
+ -activebackground "light blue"))
+ (add-child! app vbox)
+ (set-callback!
+ button1
+ (lambda ()
+ (let* ((button2 (make-button '(-text "Yellow")))
+ (button3 (make-button '(-text "Red"))))
+ (ask-widget button2 '(configure -background "light blue"
+ -activebackground cyan))
+ (ask-widget button3 '(configure -background "light blue"
+ -activebackground cyan))
+ (let* ((cb2 (make-widget-on-canvas canvas button2 200 250))
+ (cb3 (make-widget-on-canvas canvas button3 250 250))
+ (both (make-canvas-item-group canvas (list cb2 cb3))))
+ (set-callback! button2
+ (lambda ()
+ (ask-widget canvas '(configure -background yellow))
+ (ask-widget both '(delete))))
+ (set-callback! button3
+ (lambda ()
+ (ask-widget canvas '(configure -background red))
+ (ask-widget both '(delete))))))))
+ (list app vbox)))
+
+
+(define (menu-test)
+ ;; No menu button
+ (let ((application (make-application "Menu Test")))
+ (define start-button (make-button '(-text "Go!")))
+ (define main (make-menu))
+ (define sub (make-menu))
+ (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
+ (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
+ (define button-3 (add-sub-menu main sub '-background "blue" '-label "More..."))
+ (define sub-1 (add-to-menu sub 'command '-background "blue" '-label "A"))
+ (define sub-2 (add-to-menu sub 'command '-background "blue" '-label "B"))
+ (define sub-3 (add-to-menu sub 'command '-background "blue" '-label "C"))
+ (define sub-4 (add-to-menu sub 'command '-background "blue" '-label "D"))
+ (ask-widget start-button
+ '(configure -background yellow
+ -font
+ "-adobe-helvetica-bold-r-normal--34-240-100-100-p-182-iso8859-1"))
+ (add-child! application start-button)
+ (add-child! start-button main)
+ (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
+ (set-callback! button-2 (lambda () (write-line 'Two)))
+ (set-callback! button-3 (lambda () (write-line 'Three)))
+ (set-callback! sub-1 (lambda () (write-line 'A)))
+ (set-callback! sub-2 (lambda () (write-line 'B)))
+ (set-callback! sub-3 (lambda () (write-line 'C)))
+ (set-callback! sub-4 (lambda () (write-line 'D)))
+ (set-callback! start-button (lambda () (ask-widget main '(post 10 20))))
+ (lambda ()
+ (list application start-button main sub
+ button-1 button-2 button-3
+ sub-1 sub-2 sub-3 sub-4))))
+
+(define (menu-test2)
+ (let ((application (make-application "Menu Test")))
+ (define main (make-menu))
+ (define start-button (make-menubutton main '(-text "Go!")))
+ (define sub (make-menu))
+ (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
+ (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
+ (define button-3 (add-sub-menu main sub '-background "blue" '-label "More..."))
+ (define sub-1 (add-to-menu sub 'command '-background "blue" '-label "A"))
+ (define sub-2 (add-to-menu sub 'command '-background "blue" '-label "B"))
+ (define sub-3 (add-to-menu sub 'command '-background "blue" '-label "C"))
+ (define sub-4 (add-to-menu sub 'command '-background "blue" '-label "D"))
+ (add-child! application start-button)
+ (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
+ (set-callback! button-2 (lambda () (write-line 'Two)))
+ (set-callback! button-3 (lambda () (write-line 'Three)))
+ (set-callback! sub-1 (lambda () (write-line 'A)))
+ (set-callback! sub-2 (lambda () (write-line 'B)))
+ (set-callback! sub-3 (lambda () (write-line 'C)))
+ (set-callback! sub-4 (lambda () (write-line 'D)))
+ (lambda ()
+ (list application start-button main sub
+ button-1 button-2 button-3
+ sub-1 sub-2 sub-3 sub-4))))
+
+(define (menu-test3)
+ (let ((application (make-application "Menu Test")))
+ (define main (make-menu))
+ (define start-button (make-menubutton main '(-text "Go!")))
+ (define button-1 (add-to-menu main 'command '-background "blue" '-label "Close"))
+ (define button-2 (add-to-menu main 'command '-background "yellow" '-label "Two"))
+ (add-child! application start-button)
+ (set-callback! button-1 (lambda () (ask-widget main '(unpost))))
+ (set-callback! button-2 (lambda () (write-line 'Two)))
+ (lambda ()
+ (list application start-button main
+ button-1 button-2))))
+
+
+(define (mac)
+ (let* ((a (make-application "Microslop Word"))
+ (t (make-text))
+ (sb (make-scrollbar '(-width 20 -orient vertical)))
+ (file-menu (make-menu))
+ (file-mb (make-menubutton file-menu '(-text "File")))
+ (save-menu (make-menu))
+ (edit-menu (make-menu))
+ (edit-mb (make-menubutton edit-menu '(-text "Edit")))
+ (tools-menu (make-menu))
+ (tools-mb (make-menubutton tools-menu '(-text "Tools")))
+ )
+
+ (for-each (lambda (m)
+ (ask-widget m '(configure -background white
+ -activebackground red)))
+ (list file-menu save-menu edit-menu tools-menu
+ file-mb edit-mb tools-mb))
+ (for-each (lambda (b)
+ (ask-widget b '(configure -relief raised)))
+ (list file-mb edit-mb tools-mb))
+
+ (ask-widget t '(configure -background white -wrap word -width 40))
+ (ask-widget sb '(configure -background red))
+ (ask-widget sb '(set 1000 400 0 400))
+
+ (set-callback!
+ sb
+ (lambda (value)
+ (let* ((n (string->number value)))
+ (when-idle!
+ (lambda () (ask-widget sb `(set 1000 400 ,n ,(+ n 400))))))))
+
+ (let ((me (make-vbox (make-hbox file-mb edit-mb tools-mb)
+ (make-hbox t sb))))
+ (add-child! a me)
+
+ (add-to-menu file-menu 'command '-label "Open")
+ (add-to-menu file-menu 'command '-label "Close")
+ (add-sub-menu file-menu save-menu '-label "Save...")
+ (add-to-menu save-menu 'command '-label "There is no salvation")
+ (add-to-menu save-menu 'command '-label "Jesus saves")
+ (add-to-menu file-menu 'command '-label "Exit")
+
+ (let ((paste-button (add-to-menu edit-menu 'command '-label "Paste"))
+ (cut-button (add-to-menu edit-menu 'command '-label "Cut"))
+ (deleted-text #F))
+ (set-callback! cut-button
+ (lambda ()
+ (set! deleted-text
+ (ask-widget t '(get sel.first sel.last)))
+ (ask-widget t '(delete sel.first sel.last))))
+ (set-callback! paste-button
+ (lambda ()
+ (if deleted-text
+ (ask-widget t `(insert insert ,deleted-text))))))
+
+ (add-to-menu edit-menu 'command '-label "Staple")
+ (add-to-menu edit-menu 'command '-label "Mutilate")
+
+ (add-to-menu tools-menu 'command '-label "Hammer")
+ (add-to-menu tools-menu 'command '-label "Saw")
+
+ me)))
+
+(define all-tags '())
+(define all-demos '())
+(define (browser)
+ (let* ((a (make-application "Demo Browser"))
+ (t (make-text))
+ (sb (make-scrollbar '(-width 20 -orient vertical)))
+ (m (make-menu))
+ (mb (make-menubutton m '(-text "Widgets"))))
+
+ (define (switch-to-widget-demos list-of-demos)
+ (for-each (lambda (tag) (ask-widget tag '(delete))) all-tags)
+ (set! all-tags '())
+ (ask-widget t '(delete "1.0" end))
+ (for-each
+ (lambda (demo-thunk-name)
+ (ask-widget t `(insert insert ,demo-thunk-name))
+ (ask-widget t '(insert insert " "))
+ (let ((tag (make-text-tag t "insert linestart" "insert-1c")))
+ ;; gc protect
+ (set! all-tags (cons tag all-tags))
+ (add-event-handler!
+ tag "<Enter>"
+ (lambda () (ask-widget tag '(configure -foreground violetred))))
+ (add-event-handler!
+ tag "<Leave>"
+ (lambda () (ask-widget tag '(configure -foreground blue))))
+ (add-event-handler!
+ tag
+ "<Button-1>"
+ (lambda ()
+ (ask-widget tag '(configure -underline 1))
+ (let ((demo-thunk
+ (ask-widget
+ t
+ `(get ,(string-append (TextTag.name tag) ".first")
+ ,(string-append (TextTag.name tag) ".last")))))
+ ;; gc protect
+ (set! all-demos (cons ((eval (string->symbol demo-thunk)
+ user-initial-environment))
+ all-demos))
+ ))))
+ (ask-widget t '(insert insert "\n")))
+ list-of-demos))
+
+ (ask-widget t `(configure -width 20 -height 10
+ -background "white" -foreground blue))
+ (for-each (lambda (x)
+ (ask-widget x '(configure -background blue -foreground white
+ -activebackground white
+ -activeforeground blue)))
+ (list m mb))
+ #|
+ (set-callback! sb
+ (lambda (n)
+ (ask-widget t `(yview -pickplace ,n))))
+
+ |#
+
+ (let ((me (make-vbox mb (make-hbox t sb))))
+ (add-child! a me)
+
+ (ask-widget t `(configure -yscrollcommand
+ ,(string-append (tk-widget->pathname sb) " set")))
+ (ask-widget sb `(configure
+ -command
+ ,(string-append
+ (tk-widget->pathname t)
+ " yview -pickplace")))
+
+ (let* ((picture-button (add-to-menu m 'command '-label "Picture"))
+ (button-button (add-to-menu m 'command '-label "Button"))
+ (scale-button (add-to-menu m 'command '-label "Scale"))
+ (entry-button (add-to-menu m 'command '-label "Entry"))
+ (scrollbar-button (add-to-menu m 'command '-label "Scrollbar"))
+ (canvas-button (add-to-menu m 'command '-label "Canvas"))
+ (menu-button (add-to-menu m 'command '-label "Menu"))
+ (text-button (add-to-menu m 'command '-label "Text Widget"))
+ (animation-button (add-to-menu m 'command '-label "Animation")))
+
+ (set-callback! picture-button
+ (lambda () (switch-to-widget-demos
+ (list "test1" "test1a" "test2" "test3"))))
+ (set-callback! button-button
+ (lambda () (switch-to-widget-demos
+ (list "btest1" "btest2" "btest3"))))
+ (set-callback! scale-button
+ (lambda () (switch-to-widget-demos (list "stest1" "stest2"))))
+ (set-callback! entry-button
+ (lambda () (switch-to-widget-demos (list "etest1"))))
+ (set-callback! scrollbar-button
+ (lambda () (switch-to-widget-demos
+ (list "sbtest1" "sbtest2" "sbtest3"))))
+ (set-callback! canvas-button
+ (lambda () (switch-to-widget-demos
+ (list "canvas-test" "doodle-test"
+ "ctest" "ctest1"))))
+ (set-callback! menu-button
+ (lambda () (switch-to-widget-demos
+ (list "menu-test" "menu-test2"))))
+ (set-callback! text-button
+ (lambda () (switch-to-widget-demos (list "mac" "browser"))))
+ (set-callback! animation-button
+ (lambda () (switch-to-widget-demos
+ (list "btest3" "animation" "biff" "melt"
+ "balls"))))
+
+ me))))
+
+
+(define app4)
+(define c4)
+(define but4)
+(define (animation)
+ (set! app4 (make-application "Animation"))
+ (set! c4 (make-canvas '(-background white -width 200 -height 200)))
+ (set! but4 (make-button '(-text "START" -background maroon -foreground white
+ -activebackground "hot pink")))
+ (add-child! app4 c4)
+ (make-widget-on-canvas c4 but4 25 185)
+ (set-callback!
+ but4
+ (lambda ()
+ (let ((rect (make-rectangle-on-canvas c4 10 10 40 40)))
+ (ask-widget rect '(configure -fill red))
+ (let loop ((position 10))
+ (if (> position 200)
+ (ask-widget rect '(delete))
+ (begin (ask-widget rect '(move 1 1))
+ (after-delay .05 (lambda () (loop (1+ position))))))))))
+ c4)
+
+
+(define app5)
+(define c5)
+(define (biff)
+ (set! app5 (make-application "biff"))
+ (set! c5 (make-canvas '(-background black -width 70 -height 70)))
+ (add-child! app5 c5)
+ (let* ((file1 "/usr/local/lib/tk/demos/bitmaps/flagdown")
+ (file2 "/usr/local/lib/tk/demos/bitmaps/flagup")
+ (current-bitmap-filename file1)
+ (current-bknd "black")
+ (current-fgnd "cyan"))
+ (define (toggle-bitmap)
+ (let ((old-bknd current-bknd)
+ (old-fgnd current-fgnd))
+ (set! current-bknd old-fgnd)
+ (set! current-fgnd old-bknd))
+ (if (equal? current-bitmap-filename file1)
+ (set! current-bitmap-filename file2)
+ (set! current-bitmap-filename file1)))
+ (define (make-flag)
+ (let ((flag (make-bitmap-on-canvas c5 current-bitmap-filename 35 35)))
+ (ask-widget flag `(configure -background ,current-bknd
+ -foreground ,current-fgnd))
+ flag))
+
+ (let ((flag (make-flag)))
+ (define (toggle)
+ (ask-widget flag '(delete))
+ (toggle-bitmap)
+ (ask-widget c5 `(configure -background ,current-bknd))
+ (set! flag (make-flag)))
+ (after-delay
+ 1
+ (lambda ()
+ (let loop ((count 0))
+ (if (> count 10)
+ 'done
+ (after-delay 1
+ (lambda ()
+ (toggle)
+ (loop (1+ count))))))))
+ (add-event-handler! c5 "<Any-ButtonPress>" toggle))))
+
+
+(define app6)
+(define c6)
+(define but6)
+(define (melt)
+ (define (generate-vertical-line x)
+ (let* ((length (random 30))
+ (start (- (random 30) 30))
+ (end (+ start length))
+ (line (make-line-on-canvas c6 x start x end)))
+ (ask-widget line `(configure -fill white))
+ line))
+
+ (set! app6 (make-application "Mind Melt"))
+ (set! c6 (make-canvas '(-background black -width 200 -height 200)))
+ (set! but6 (make-button '(-text "MELT"
+ -background black -foreground red
+ -activebackground black -activeforeground red)))
+ (let ((me (make-vbox c6 but6)))
+ (add-child! app6 me)
+ (set-callback!
+ but6
+ (lambda ()
+ (let* ((lines (let loop ((x 0) (lines '()))
+ (if (> x 200)
+ lines
+ (loop (+ x 2) (cons (generate-vertical-line x) lines)))))
+ (tag (make-canvas-item-group c6 lines)))
+ (let loop ((position 0))
+ (if (> position 230)
+ (ask-widget tag '(delete))
+ (after-delay .000005
+ (lambda ()
+ (for-each (lambda (line)
+ (ask-widget line `(move 0 ,(random 10))))
+ lines)
+ (loop (1+ position)))))))))
+ me))
+
+
+(define (balls)
+ (define canvas-width 300)
+ (define canvas-height 300)
+ (define min-ball-size 1)
+ (define max-ball-size 30)
+ (define min-delta 1)
+ (define max-delta 8)
+ (define a (/ (- min-delta max-delta) (- max-ball-size min-ball-size)))
+ (define b (- min-delta (* a max-ball-size)))
+ (define (pick-random-color)
+ (define list-of-colors
+ '("green" "yellow" "red" "blue" "hot pink" "orange" "cyan"
+ "maroon" "skyblue" "firebrick" "aquamarine" "violet"
+ "violetred" "navyblue" "darkslateblue" "pink"))
+ (list-ref list-of-colors (random (length list-of-colors))))
+
+ (define (pick-true-or-false)
+ (list-ref '(#T #F) (random 2)))
+
+ (define (make-ball canvas diameter startx starty)
+ (let* ((radius (round->exact (/ diameter 2)))
+ (centerx (+ startx radius))
+ (centery (+ starty radius))
+ (the-ball
+ (make-oval-on-canvas canvas startx starty
+ (+ startx diameter)
+ (+ starty diameter)))
+ (increasing-x? (pick-true-or-false))
+ (increasing-y? (pick-true-or-false))
+ (speed-factor (round->exact (+ (* a diameter) b))))
+ (lambda (m)
+ (case m
+ ((the-ball) the-ball)
+ ((centerx) centerx)
+ ((centery) centery)
+ ((set-centerx!) (lambda (x) (set! centerx x)))
+ ((set-centery!) (lambda (y) (set! centery y)))
+ ((+x?) increasing-x?)
+ ((+y?) increasing-y?)
+ ((set+x?!) (lambda (boolean) (set! increasing-x? boolean)))
+ ((set+y?!) (lambda (boolean) (set! increasing-y? boolean)))
+ ((diameter) diameter)
+ ((speed-factor) speed-factor)))))
+
+ (define (generate-ball canvas)
+ (let* ((diameter (+ min-ball-size (random (- max-ball-size min-ball-size))))
+ (startx (min (random canvas-width) (- canvas-width diameter)))
+ (starty (min (random canvas-height) (- canvas-height diameter)))
+ (ball (make-ball canvas diameter startx starty)))
+ (ask-widget (ball 'the-ball) `(configure -fill ,(pick-random-color)))
+ ball))
+
+ (define (generate-move ball)
+ (let* ((centerx (ball 'centerx))
+ (centery (ball 'centery))
+ (diameter (ball 'diameter))
+ (radius (round->exact (/ diameter 2)))
+ (startx (- centerx radius))
+ (endx (+ centerx radius))
+ (starty (- centery radius))
+ (endy (+ centery radius))
+ (dx-sign (cond ((<= startx 0)
+ ((ball 'set+x?!) #T)
+ 1)
+ ((>= endx canvas-width)
+ ((ball 'set+x?!) #F)
+ -1)
+ ((ball '+x?) 1)
+ (else -1)))
+ (dy-sign (cond ((<= starty 0)
+ ((ball 'set+y?!) #T)
+ 1)
+ ((>= endy canvas-height)
+ ((ball 'set+y?!) #F)
+ -1)
+ ((ball '+y?) 1)
+ (else -1)))
+ (dx (* dx-sign (max 1 (random (ball 'speed-factor)))))
+ (dy (* dy-sign (max 1 (random (ball 'speed-factor))))))
+ ((ball 'set-centerx!) (+ centerx dx))
+ ((ball 'set-centery!) (+ centery dy))
+ `(move ,dx ,dy)))
+
+ (let ((app7 (make-application "Bouncing Balls"))
+ (c7 (make-canvas `(-background black -width ,canvas-width
+ -height ,canvas-height))))
+ (add-child! app7 c7)
+
+ (let ((balls
+ (let loop ((num 0) (balls '()))
+ (if (> num (+ 10 (random 10)))
+ balls
+ (loop (1+ num) (cons (generate-ball c7) balls))))))
+ (let ((go
+ (lambda ()
+ (let loop ()
+ (for-each
+ (lambda (ball)
+ (ask-widget (ball 'the-ball) (generate-move ball)))
+ balls)
+ (after-delay 0.0005 loop)))))
+ (after-delay 1 go)
+ (list app7 c7 balls go)))))
+
+
+(define (canvas-sb-test)
+ (let ((sc (make-scrollable-canvas
+ '(-width 500 -height 500
+ -scrollregion (0 0 1000 1000)))))
+ (swat-open sc)
+ (ask-widget (scrollable-canvas-hscroll sc)
+ `(configure -foreground "yellow"))
+ (ask-widget (scrollable-canvas-vscroll sc)
+ `(configure -foreground "yellow"))
+ (make-rectangle-on-canvas (scrollable-canvas-canvas sc)
+ 100 100 400 400
+ '(-fill red))
+ sc))
+
+
+
+(define (text-sb-test)
+ (let ((st (make-scrollable-text)))
+ (swat-open st)
+ (ask-widget (scrollable-text-vscroll st)
+ '(configure -foreground red))
+ st))
+
+
+
+
+
+
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;; This is a very simple application written in Scheme, withous any
+;;;; TK wigets. It is a surface on which you cna sketch a path with
+;;;; the mouse.
+
+;;;Some geometric shape drawers:
+;;;This might be generally useful -- it saves the higher level from
+;;;worrying about the graphics context.
+
+;;;this doesn't handle clipping. should we create a line-drawer with a
+;;;specified clip region??
+
+(define (geometry-drawer-for-shape shape color drawproc)
+ ;;also set line style, thickness, etc.
+ (let* ((window #F)
+ (gc #F))
+ (lambda args
+ ;;need to init the window and GC and keep it up to date if the
+ ;;window changes
+ ;;is there some way to used cached info for the shape to speed
+ ;;up these tests?
+ (if (not (used-screen-area shape))
+ (error "attempt to draw on background with no screen area"
+ shape))
+ (if (not (eq? window (get-uitkwindow shape)))
+ (begin (set! window (get-uitkwindow shape))
+ (set! gc (make-colored-graphics-context window color))))
+ (apply drawproc (cons window (cons gc args))))))
+
+(define (line-drawer-for-shape shape color)
+ (geometry-drawer-for-shape
+ shape color
+ (lambda (window gc p1 p2)
+ (drawline window gc
+ (point.X p1) (point.Y p1)
+ (point.X p2) (point.Y p2)))))
+
+(define (arc-drawer-for-shape shape color)
+ (geometry-drawer-for-shape
+ shape color
+ (lambda (window gc p w h a1 a2)
+ (drawarc window gc (point.X p) (point.Y p) w h a1 a2))))
+
+(define (rectangle-drawer-for-shape shape color)
+ (geometry-drawer-for-shape
+ shape color
+ (lambda (window gc p w h)
+ (drawrectangle window gc (point.X p) (point.Y p) w h))))
+
+
+
+(define (setup-doodle)
+ (let ((d (make-doodle-surface 400 400 "light gray")))
+ (add-child! (make-application "doodle") d)
+ d))
+
+(define (make-doodle-surface width height background-color)
+ (let* ((line-color "black")
+ (background (make-rect width height background-color))
+ (draw-line (line-drawer-for-shape background line-color))
+ (path '()))
+ (define (collect-points first-event while-grabbed)
+ (shape-draw background) ;clear and erase path
+ (set! path (list (event.offset first-event)))
+ (while-grabbed
+ (lambda (point)
+ (if (point-within? background point)
+ (begin (draw-line (car path) point)
+ (set! path (cons point path)))))
+ (lambda () 'done))) ;nothing to do at end of grab
+ (define (draw-path)
+ (if (not (null? path))
+ (let loop ((path path))
+ (if (null? (cdr path))
+ 'done
+ (begin (draw-line (car path) (cadr path))
+ (loop (cdr path)))))))
+ (handle-exposure
+ background
+ (lambda (exposed-rectangle)
+ (shape-draw background (rectangle->XRegion exposed-rectangle))
+ ;;should clip to exposed rectangle. What's a nice way to do this?
+ (draw-path)))
+ (handle-button-grab
+ background ANYBUTTON
+ (lambda (e while-grabbed)
+ (collect-points e while-grabbed)))
+ (on-geometry-change!
+ background
+ 'ignore
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area
+ (if (UITKRectangle? new-screen-area)
+ (shape-draw background))))
+ background))
+
+
+
+
+
--- /dev/null
+;; Make export list
+
+(define (make-export-list candidates)
+ ;; Call this on the names in the SWAT load environmnet to discover the
+ ;; useful names.
+ (define xlib-names (map second (read-file "xlibCONSTANTS.scm")))
+
+ (define (xlib-name? n) (memq n xlib-names))
+ (define (internal-name? n)
+ (let ((s (symbol-name n)))
+ (or (string-find-next-char s #\%))))
+
+ (sort (list-transform-negative candidates
+ (lambda (name)
+ (or (internal-name? name)
+ (xlib-name? name))))
+ symbol<?))
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;; Plotting Package for Scheme Widget Application Toolkit
+
+;;; Working from the Scheme Prompt
+
+;;;(PLOTTER)
+;;; Creates a new plotter.
+;;;
+;;; Example: (define p (plotter))
+;;;
+;;;(PLOT plotter . options)
+;;; The options list sequentially describes one or more curves to be
+;;; plotted, in the following manner:
+;;;
+;;; (PLOT plotter
+;;; <function1> '<option> <value> '<option> <value> ... ;first curve
+;;; <function2> '<option> <value> ... ;second curve
+;;; ...
+;;; ...)
+;;; Returns a single curve if only one function is specified, and a
+;;; list of curves if more than one function is supplied.
+;;;
+;;; Example: (define c0 (plot p sin 'xmin -10 'xmax 5))
+;;; (define c1&2 (plot p cos 'pt-style 0 tan 'pt-style 5))
+;;;
+;;; The first parameter to PLOT after plotter must always be a
+;;; function. Curve-specific options affect only the function they
+;;; follow, and thus can and should be repeated. Any instance of a
+;;; global option after the first will be ignored.
+;;;
+;;; Global options and arguments:
+;;; 'XMIN: The minimum value of x to be displayed on the plot.
+;;; The default is 0.
+;;; 'XMAX: The maximum value of x to be displayed on the plot.
+;;; The default is 1.
+;;; 'YMIN: The minimum value of y to be displayed on the plot.
+;;; If not specified, the plot will be automatically scaled.
+;;; 'YMAX: The maximum value of y to be displayed on the plot.
+;;; If not specified, the plot will be automatically scaled.
+;;; 'AXIS-X: The value of x at which the y-axis will be drawn.
+;;; The default is 0.
+;;; 'AXIS-Y: The value of y at which the x-axis will be drawn.
+;;; The default is 0.
+;;; 'XTICKS: A list of pairs describing ticks on the x axis. The
+;;; car of each pair is the value of x at which to make
+;;; the tick. The cdr is a string to be displayed as a
+;;; label. The procedure MAKE-VALS can be used to return
+;;; a list of values for labels at regular intervals. If
+;;; not specified, only the extreme values will be labeled.
+;;; 'YTICKS: A list of pairs describing ticks on the y axis. Same
+;;; format as XTICKS. If not specified, only the extreme
+;;; values will be labeled.
+;;;
+;;; Curve-specific options and arguments
+;;; 'NUM-PTS: The number of points to be calculated for the curve.
+;;; The default is one for every 10 pixels.
+;;; 'PT-STYLE: A number representing the style in which the curve
+;;; will be drawn:
+;;; 0 -- lines to the x-axis
+;;; 1 -- large unfilled circles
+;;; 2 -- large unfilled squares
+;;; 3 -- x's
+;;; 4 -- +'s
+;;; 5 -- small filled circles
+;;; 6 -- small filled squares
+;;; 7 -- dots
+;;; 10 -- large unfilled circles with lines to the x-axis
+;;; 20 -- large unfilled squares with lines to the x-axis
+;;; 30 -- x's with lines to the x-axis
+;;; 40 -- +'s with lines to the x-axis
+;;; 50 -- small filled circles with lines to the x-axis
+;;; 60 -- small filled squares with lines to the x-axis
+;;; 100 -- lines between successive points
+;;; The default for the first curve is 0, and for all
+;;; others 100.
+;;; 'COLOR: The color of the curve, as a string or color-value.
+;;; The default for the first curve is black, and for all
+;;; others gray.
+;;; 'SHOW-VALS: A list of values of x at which to label the
+;;; corresponding value of y. The procedure
+;;; MAKE-VALS can be used to return a list of values
+;;; at regular intervals. The default is null.
+;;;
+;;;
+;;;(SET-PLOTTER-PARAMS plotter '<option> <value> ... '<option> <value>)
+;;; Options are the same as global options in PLOT. This does
+;;; basically the same thing as PLOT, but no *new* curve is drawn.
+;;; Parameters are reset and all the existing (non-cleared) curves
+;;; are redrawn. Thus, an alternative way to write the example above
+;;; is:
+;;;
+;;; Example: (set-plotter-params p 'xmin -10 'xmax 5)
+;;; (define c0 (plot p sin))
+;;;
+;;;(RESET-PLOTTER-PARAMS plotter)
+;;; Resets plotter's parameters to default params (the ones you see
+;;; when the plotter first comes up).
+;;;
+;;;
+;;;(MAKE-VALS min max spacing . centered?)
+;;; Returns a list of pairs that can be used for 'XTICKS 'YTICKS, or
+;;; 'SHOW-VALS. If centered? is #t, the ticks will be centered about
+;;; 0, with a tick at 0. Otherwise, the ticks will begin at the min
+;;; value.
+;;;
+;;; Example: (define c0 (plot p sin 'xmin -5 'xmax 5
+;;; 'xticks (make-vals -5 5 1)))
+;;;
+;;;(CHANGE-COLOR curve color)
+;;; Changes the color of the given curve and replots the curve.
+;;; Replots the curve if it's not cleared.
+;;;
+;;;(CHANGE-PT-STYLE curve pt-style)
+;;; Changes the point style of the given curve and replots the curve.
+;;; Replots the curve if it's not cleared.
+;;;
+;;;(CHANGE-NUM-PTS curve num-pts)
+;;; Changes the number of points calculated for the given curve and
+;;; replots the curve. Replots the curve if it's not cleared.
+;;;
+;;;
+;;;(CLEAR-CURVE curve)
+;;; Clears the given curve from the screen without deleting the curve
+;;; from the plotter.
+;;;
+;;;(PLOT-CURVE curve)
+;;; Replots the curve that has been cleared.
+;;;
+;;;(DELETE-CURVE curve)
+;;; Deletes the given curve from the plotter.
+;;;
+;;;(ADD-SHOW-VALS curve show-vals)
+;;; Add show-vals to a curve.
+;;;
+;;;(CLEAR-SHOW-VALS curve)
+;;; Clears all the curve's show vals, w/o deleting them from the curve.
+;;;
+;;;(DRAW-SHOW-VALS curve)
+;;; Redraws the cleared show-vals.
+;;;
+;;;(DELETE-SHOW-VALS curve)
+;;; Clears the curve's show-vals and deletes them from a curve.
+;;;
+;;;
+;;;(ADD-XTICKS plotter xticks)
+;;; Adds the specified xticks.
+;;;
+;;;(ADD-YTICKS plotter yticks)
+;;; Adds the specified yticks.
+;;;
+;;;(CLEAR-TICKS plotter)
+;;; Clears ticks from the axes of the plotter, without deleting them
+;;; from the plotter.
+;;;
+;;;(DRAW-TICKS plotter)
+;;; Redraws the cleared ticks.
+;;;
+;;;(DELETE-TICKS plotter)
+;;; Clears ticks from the axes of the plotter and deletes them from
+;;; the plotter.
+;;;
+;;;
+;;;(CLEAR-PLOTTER plotter)
+;;; Clears all plotter's curves and ticks.
+;;;
+;;;(REPLOT plotter)
+;;; Redraws all plotter's curves and ticks (including the cleared ones).
+;;;
+;;;(RESET-PLOTTER plotter)
+;;; Deletes all plotter's curves and ticks.
+
+
+\f
+;;;-------------------
+;;; Interface Monster
+;;;-------------------
+
+;;; Customizable Variables
+
+(define button-background-color "yellow")
+(define button-active-background-color "red")
+(define button-active-foreground-color "white")
+(define canvas-background-color "white")
+(define canvas-width 500)
+(define canvas-height 300)
+(define canvas-border-size 15)
+(define font "-Adobe-Helvetica-Bold-R-Normal--*-100-*")
+
+(define tick-precision 2)
+(define vals-precision 2)
+
+(define curve-max-num-pts 200)
+
+(define plotter-default-num-pts 50)
+(define plotter-default-pt-style 100)
+(define plotter-default-curve-color "black")
+(define plotter-default-xmin -5)
+(define plotter-default-xmax 5)
+(define plotter-default-ymin -1)
+(define plotter-default-ymax 1)
+(define plotter-default-axis-x 0)
+(define plotter-default-axis-y 0)
+(define plotter-default-xticks '())
+(define plotter-default-yticks '())
+
+\f
+(define (plotter)
+ (let* ((plot-app (make-application "Plotter"))
+ (plotter
+ (make-plot-canvas canvas-width canvas-height canvas-background-color))
+ (plot-canvas (plotter 'the-canvas))
+ (func-button (make-button '(-text "Function")))
+ (func-box #f)
+ (options-menu (make-menu))
+ (options-button (make-menubutton options-menu '(-text "Options")))
+ (precision (add-to-menu options-menu 'command '-label "Precision"))
+ (prec-box #f)
+ (range (add-to-menu options-menu 'command '-label "Range"))
+ (range-box #f)
+ (plot-button (make-button '(-text "Plot")))
+ (reset-button (make-button '(-text "Reset")))
+ (button-box (make-hbox func-button options-button plot-button reset-button))
+ (interface (make-vbox plot-canvas button-box)))
+
+ (for-each (lambda (button)
+ (ask-widget
+ button
+ `(configure -background ,button-background-color
+ -activebackground ,button-active-background-color
+ -activeforeground ,button-active-foreground-color)))
+ (list func-button options-button plot-button reset-button))
+
+ (for-each (lambda (button)
+ (ask-widget
+ button
+ `(configure -background ,button-background-color
+ -activebackground ,button-background-color)))
+ (list range precision))
+
+ (add-event-handler! plot-canvas "<Configure>" (plotter 'handle-resize))
+
+ (set-callback!
+ func-button
+ (lambda ()
+ (if (not func-box)
+ (let ((new-func-box (make-func-box plot-app plotter)))
+ (on-death! new-func-box 'func-dead (lambda () (set! func-box #f)))
+ (set! func-box new-func-box)))))
+
+ (set-callback!
+ precision
+ (lambda ()
+ (if (not prec-box)
+ (let ((new-prec-box (make-prec-box plot-app plotter)))
+ (on-death! new-prec-box 'prec-dead (lambda () (set! prec-box #f)))
+ (set! prec-box new-prec-box)))))
+
+ (set-callback!
+ range
+ (lambda ()
+ (if (not range-box)
+ (let ((new-range-box (make-range-box plot-app plotter)))
+ (on-death! new-range-box 'range-dead (lambda () (set! range-box #f)))
+ (set! range-box new-range-box)))))
+
+ (set-callback! plot-button (lambda () (plotter 'plot-current-func)))
+ (set-callback! reset-button (lambda () (plotter 'clear-curves)))
+
+ (on-death! interface 'interface-dead
+ (lambda ()
+ (if func-box (remove-child! plot-app func-box))
+ (if range-box (remove-child! plot-app range-box))
+ (if prec-box (remove-child! plot-app prec-box))))
+
+ (swat-open-in-application plot-app interface)
+ plotter))
+
+(define (make-func-box plot-app plotter)
+ (let* ((func-entry (make-entry `(-width 40 -background ,canvas-background-color)))
+ (func-ok-button
+ (make-button
+ `(-text "Ok" -background ,button-background-color
+ -activebackground ,button-active-background-color
+ -activeforeground ,button-active-foreground-color)))
+ (func-box (make-hbox func-entry func-ok-button)))
+ (define (function-callback)
+ (let ((exp (ask-widget func-entry '(get))))
+ (if (not (string-null? exp))
+ ;; Of course, this could get an error while evaling; maybe
+ ;; need something more clever.
+ (let ((proc (eval (with-input-from-string exp read)
+ user-initial-environment)))
+ (if (not (procedure? proc))
+ (error "Not a procedure" proc)
+ ((plotter 'set-function) proc))))))
+ (add-event-handler! func-entry "<KeyPress> <Return>" function-callback)
+ (set-callback! func-ok-button function-callback)
+ (swat-open-in-application plot-app func-box '-title "Enter a function of x")
+ func-box))
+
+(define (make-prec-box plot-app plotter)
+ (let* ((prec-scale
+ (make-scale `(-from 0 -to ,curve-max-num-pts -orient horizontal
+ -length ,(inexact->exact (* 1.5 curve-max-num-pts))
+ -background ,canvas-background-color
+ -sliderforeground ,button-background-color
+ -activeforeground ,button-active-background-color)))
+ (prec-redraw
+ (make-button `(-text "Redraw Curves" -background ,button-background-color
+ -activebackground ,button-active-background-color
+ -activeforeground ,button-active-foreground-color)))
+ (prec-box (make-vbox prec-scale prec-redraw)))
+ (ask-widget prec-scale `(set ,(plotter 'default-num-pts)))
+ (add-event-handler!
+ prec-scale
+ "<ButtonRelease-1>"
+ (lambda ()
+ ((plotter 'set-default-num-pts)
+ (string->number (ask-widget prec-scale '(get))))))
+ (set-callback! prec-redraw (lambda () (plotter 'plot-curves)))
+ (swat-open-in-application plot-app prec-box '-title "Number of points:")
+ prec-box))
+
+(define (make-range-box plot-app plotter)
+ (let* ((range-ok-button
+ (make-button `(-text "Ok" -background ,button-background-color
+ -activebackground ,button-active-background-color
+ -activeforeground ,button-active-foreground-color)))
+ (xmin-text (make-active-variable plot-app))
+ (xmax-text (make-active-variable plot-app))
+ (ymin-text (make-active-variable plot-app))
+ (ymax-text (make-active-variable plot-app))
+ (xmin-entry (make-entry `(-textvariable ,xmin-text)))
+ (xmax-entry (make-entry `(-textvariable ,xmax-text)))
+ (ymin-entry (make-entry `(-textvariable ,ymin-text)))
+ (ymax-entry (make-entry `(-textvariable ,ymax-text)))
+ (x-label (make-label '(-text "Values of x:")))
+ (xmin-label (make-label '(-text "From")))
+ (xmax-label (make-label '(-text "To")))
+ (y-label (make-label '(-text "Values of y:")))
+ (ymin-label (make-label '(-text "From")))
+ (ymax-label (make-label '(-text "To")))
+ (x-box
+ (make-vbox x-label
+ (make-hbox xmin-label xmin-entry xmax-label xmax-entry)))
+ (y-box
+ (make-vbox y-label
+ (make-hbox ymin-label ymin-entry ymax-label ymax-entry)))
+ (range-box (make-hbox (make-vbox x-box y-box) range-ok-button)))
+ (for-each (lambda (label)
+ (ask-widget label `(configure -background ,canvas-background-color)))
+ (list x-label xmin-label xmax-label y-label ymin-label ymax-label))
+ (for-each (lambda (entry)
+ ;; background color?
+ (ask-widget entry `(configure -width 5)))
+ (list xmin-entry xmax-entry ymin-entry ymax-entry))
+ (set-callback!
+ range-ok-button
+ (lambda ()
+ (let ((xmin (plotter 'xmin))
+ (xmax (plotter 'xmax))
+ (ymin (plotter 'ymin))
+ (ymax (plotter 'ymax))
+ (new-xmin (string->number (ask-widget xmin-entry '(get))))
+ (new-xmax (string->number (ask-widget xmax-entry '(get))))
+ (new-ymin (string->number (ask-widget ymin-entry '(get))))
+ (new-ymax (string->number (ask-widget ymax-entry '(get)))))
+ (if (not (and (eqv? xmin new-xmin)
+ (eqv? xmax new-xmax)
+ (eqv? ymin new-ymin)
+ (eqv? ymax new-ymax)))
+ (begin
+ ((plotter 'set-xmin) new-xmin)
+ ((plotter 'set-xmax) new-xmax)
+ ((plotter 'set-ymin) new-ymin)
+ ((plotter 'set-ymax) new-ymax)
+ (plotter 'clear)
+ (draw-axes plotter)
+ (plotter 'plot-curves))))))
+ (swat-open-in-application plot-app range-box '-title "Range")
+ (set-active-variable! xmin-text (plotter 'xmin))
+ (set-active-variable! xmax-text (plotter 'xmax))
+ (set-active-variable! ymin-text (plotter 'ymin))
+ (set-active-variable! ymax-text (plotter 'ymax))
+ range-box))
+
+\f
+;;;-------------
+;;; The Plotter
+;;;-------------
+
+(define (make-plot-canvas hsize vsize bgrnd-color)
+ (let ((default-num-pts plotter-default-num-pts)
+ (default-pt-style plotter-default-pt-style)
+ (default-color plotter-default-curve-color)
+ (xmin plotter-default-xmin)
+ (xmax plotter-default-xmax)
+ (ymin plotter-default-ymin)
+ (ymax plotter-default-ymax)
+ (yaxis.xval plotter-default-axis-x)
+ (xaxis.yval plotter-default-axis-y)
+ (xticks plotter-default-xticks)
+ (yticks plotter-default-yticks)
+ (current-func #f)
+ (current-func-curve #f)
+ (curve-list '())
+ (resize-flag #f))
+ (let* ((the-canvas (make-canvas `(-width ,hsize -height ,vsize
+ -background ,bgrnd-color)))
+ (axes-tag (make-canvas-item-group the-canvas '()))
+ (ticks-tag (make-canvas-item-group the-canvas '())))
+ (define (plotter messg)
+ (case messg
+ ((hsize) hsize)
+ ((vsize) vsize)
+ ((the-canvas) the-canvas)
+ ((curve-list) curve-list)
+ ((default-num-pts) default-num-pts)
+ ((set-default-num-pts)
+ (lambda (new-num-pts) (set! default-num-pts new-num-pts)))
+ ((default-pt-style) default-pt-style)
+ ((set-default-pt-style)
+ (lambda (new-pt-style) (set! default-pt-style new-pt-style)))
+ ((default-color) default-color)
+ ((set-default-color)
+ (lambda (new-color) (set! default-color new-color)))
+ ((function) current-func)
+ ((set-function)
+ (lambda (func)
+ (set! current-func-curve #f)
+ (set! current-func func)))
+ ((xmin) xmin)
+ ((set-xmin) (lambda (new-xmin) (set! xmin new-xmin)))
+ ((xmax) xmax)
+ ((set-xmax) (lambda (new-xmax) (set! xmax new-xmax)))
+ ((ymin) ymin)
+ ((set-ymin) (lambda (new-ymin) (set! ymin new-ymin)))
+ ((ymax) ymax)
+ ((set-ymax) (lambda (new-ymax) (set! ymax new-ymax)))
+ ((xaxis.yval) xaxis.yval)
+ ((yaxis.xval) yaxis.xval)
+ ((xaxis.y)
+ (let ((y-range (- ymax ymin)))
+ (if (= y-range 0)
+ (error "ymin and ymax are the same--MAKE-PLOT-CANVAS" ymin)
+ (+ (* (exact->inexact (/ (- (* canvas-border-size 2) vsize)
+ y-range))
+ (- xaxis.yval ymin))
+ vsize
+ (- canvas-border-size)))))
+ ((yaxis.x)
+ (let ((x-range (- xmax xmin)))
+ (if (= x-range 0)
+ (error "xmin and xmax are the same--MAKE-PLOT-CANVAS" xmin)
+ (+ (* (exact->inexact (/ (- hsize (* canvas-border-size 2))
+ (- xmax xmin)))
+ (- yaxis.xval xmin))
+ canvas-border-size))))
+ ((xticks) xticks)
+ ((set-xticks) (lambda (new-xticks) (set! xticks new-xticks)))
+ ((yticks) yticks)
+ ((set-yticks) (lambda (new-yticks) (set! yticks new-yticks)))
+ ((axes-tag) axes-tag)
+ ((ticks-tag) ticks-tag)
+ ((set-params)
+ (lambda (new-xmin new-xmax new-ymin new-ymax
+ new-yaxis.xval new-xaxis.yval new-xticks new-yticks)
+ (set! xmin new-xmin)
+ (set! xmax new-xmax)
+ (set! ymin new-ymin)
+ (set! ymax new-ymax)
+ (set! yaxis.xval new-yaxis.xval)
+ (set! xaxis.yval new-xaxis.yval)
+ (set! xticks new-xticks)
+ (set! yticks new-yticks)
+ 'set))
+ ((x:val->pix) (x:val->pix xmin xmax hsize))
+ ((y:val->pix) (y:val->pix ymin ymax vsize))
+ ((add-curve)
+ (lambda (curve) (set! curve-list (append curve-list (list curve)))))
+ ((plot-current-func)
+ (if (and current-func (not current-func-curve))
+ (let ((new-curve
+ (make-curve plotter current-func default-pt-style
+ default-num-pts default-color #f)))
+ (set! current-func-curve new-curve)
+ (set! curve-list (cons new-curve curve-list))
+ (new-curve 'plot))))
+ ((plot-curves)
+ (for-each (lambda (curve)
+ (if (not (curve 'cleared?))
+ (curve 'plot)))
+ curve-list)
+ 'plotted)
+ ((clear)
+ (ask-widget the-canvas '(delete all))
+ 'cleared)
+ ((clear-curves)
+ (for-each (lambda (curve) (curve 'clear)) curve-list)
+ 'cleared)
+ ((delete-curve)
+ (lambda (curve)
+ (curve 'clear)
+ (set! curve-list (delq curve curve-list))
+ 'deleted))
+ ((delete-curves)
+ (for-each (lambda (curve) (curve 'clear)) curve-list)
+ (set! curve-list #f)
+ 'deleted)
+ ((clear-axes)
+ (ask-widget axes-tag '(delete))
+ 'cleared)
+ ((clear-ticks)
+ (ask-widget ticks-tag '(delete))
+ 'cleared)
+ ((delete-ticks)
+ (set! xticks '())
+ (set! yticks '())
+ (ask-widget ticks-tag '(delete))
+ 'deleted)
+ ((handle-resize)
+ (lambda ()
+ ;; For some reason, the "<Configure>" event gets generated
+ ;; twice per window resize -- so skip one of them.
+ (if (not resize-flag)
+ (set! resize-flag #t)
+ (begin
+ (set! resize-flag #f)
+ (ask-widget the-canvas '(delete all))
+ (let ((old-width hsize)
+ (width (UITKRectangle.width
+ (assigned-screen-area the-canvas)))
+ (height (UITKRectangle.height
+ (assigned-screen-area the-canvas))))
+ (set! hsize width)
+ (set! vsize height)
+ (set! default-num-pts (round (* default-num-pts
+ (/ width old-width))))
+ (draw-axes plotter)
+ (for-each
+ (lambda (curve)
+ (curve-scale-num-pts!
+ curve (exact->inexact (/ width old-width)))
+ (if (not (curve 'cleared?))
+ (begin (curve 'clear)
+ (curve 'plot))))
+ curve-list))))))
+ (else (error "Bad message--PLOTTER" messg))))
+ plotter)))
+\f
+(define ((x:val->pix xmin xmax hsize) x)
+ (+ (* (exact->inexact
+ (/ (- hsize (* canvas-border-size 2))
+ (- xmax xmin)))
+ (- x xmin))
+ canvas-border-size))
+
+(define ((y:val->pix ymin ymax vsize) y)
+ (+ (* (exact->inexact
+ (/ (- (* canvas-border-size 2) vsize)
+ (- ymax ymin)))
+ (- y ymin))
+ vsize
+ (- canvas-border-size)))
+
+(define (draw-xticks plotter)
+ (let ((xticks (plotter 'xticks)))
+ (if xticks
+ (let ((plot-canvas (plotter 'the-canvas))
+ (x:val->pix (plotter 'x:val->pix))
+ (xmin (plotter 'xmin))
+ (xmax (plotter 'xmax))
+ (xaxis.y (plotter 'xaxis.y))
+ (ticks-tag (plotter 'ticks-tag))
+ (factor (expt 10 tick-precision)))
+ (for-each
+ (lambda (tick)
+ (if (> xmax tick xmin)
+ (let ((val (x:val->pix tick))
+ (tag (swat:number->string
+ (/ (truncate (* factor tick)) factor))))
+ (add-to-canvas-item-group
+ ticks-tag
+ (make-line-on-canvas plot-canvas
+ val (- xaxis.y 4)
+ val (+ xaxis.y 4)))
+ (add-to-canvas-item-group
+ ticks-tag
+ (make-text-on-canvas plot-canvas
+ val (- xaxis.y 9)
+ `(-text ,tag -font ,font))))))
+ xticks))))
+ 'drawn)
+
+(define (draw-yticks plotter)
+ (let ((yticks (plotter 'yticks)))
+ (if yticks
+ (let ((plot-canvas (plotter 'the-canvas))
+ (y:val->pix (plotter 'y:val->pix))
+ (ymin (plotter 'ymin))
+ (ymax (plotter 'ymax))
+ (yaxis.x (plotter 'yaxis.x))
+ (ticks-tag (plotter 'ticks-tag))
+ (factor (expt 10 tick-precision)))
+ (for-each
+ (lambda (tick)
+ (if (> ymax tick ymin)
+ (let ((val (y:val->pix tick))
+ (tag (swat:number->string
+ (/ (truncate (* factor tick)) factor))))
+ (add-to-canvas-item-group
+ ticks-tag
+ (make-line-on-canvas plot-canvas
+ (- yaxis.x 4) val
+ (+ yaxis.x 4) val))
+ (add-to-canvas-item-group
+ ticks-tag
+ (make-text-on-canvas plot-canvas
+ (+ yaxis.x 6) val
+ `(-text ,tag -anchor w
+ -font ,font))))))
+ yticks))))
+ 'drawn)
+
+(define (draw-axes plotter)
+ (let* ((plot-canvas (plotter 'the-canvas))
+ (hsize (plotter 'hsize))
+ (vsize (plotter 'vsize))
+ (xmin (plotter 'xmin))
+ (xmax (plotter 'xmax))
+ (ymin (plotter 'ymin))
+ (ymax (plotter 'ymax))
+ (xaxis.yval (plotter 'xaxis.yval))
+ (yaxis.xval (plotter 'yaxis.xval))
+ (xaxis.y (plotter 'xaxis.y))
+ (yaxis.x (plotter 'yaxis.x))
+ (axes-tag (plotter 'axes-tag))
+ (trim 3)
+ (x-.x trim)
+ (x+.x (- hsize trim))
+ (y-.y trim)
+ (y+.y (- vsize trim)))
+ (if (>= ymax xaxis.yval ymin)
+ (begin
+ (add-to-canvas-item-group
+ axes-tag
+ (make-line-on-canvas plot-canvas x+.x xaxis.y x-.x xaxis.y '(-arrow both)))
+ (draw-xticks plotter)
+ (make-text-on-canvas plot-canvas
+ (- hsize trim) (- xaxis.y trim)
+ `(-text ,(swat:number->string xmax) -anchor se)) ;
+ (make-text-on-canvas plot-canvas
+ trim (- xaxis.y trim)
+ `(-text ,(swat:number->string xmin) -anchor sw))))
+ (if (>= xmax yaxis.xval xmin)
+ (begin
+ (add-to-canvas-item-group
+ axes-tag
+ (make-line-on-canvas plot-canvas yaxis.x y+.y yaxis.x y-.y '(-arrow both)))
+ (draw-yticks plotter)
+ (let ((factor (expt 10 tick-precision)))
+ (make-text-on-canvas plot-canvas
+ (+ yaxis.x 8) trim
+ `(-text ,(swat:number->string
+ (/ (round (* ymax factor)) factor))
+ -anchor nw))
+ (make-text-on-canvas plot-canvas
+ (+ yaxis.x 8) vsize
+ `(-text ,(swat:number->string
+ (/ (round (* ymin factor)) factor))
+ -anchor sw)))))
+ 'done))
+\f
+;;;--------
+;;; Curves
+;;;--------
+
+(define (make-curve plotter function pt-style num-pts color show-vals)
+ (let* ((plot-canvas (plotter 'the-canvas))
+ (curve-tag (make-canvas-item-group plot-canvas '()))
+ (outline-tag (make-canvas-item-group plot-canvas '()))
+ (vals-tag (make-canvas-item-group plot-canvas '()))
+ (cleared? #f))
+ (lambda (messg)
+ (case messg
+ ((plotter) plotter)
+ ((num-pts) num-pts)
+ ((set-num-pts) (lambda (new-num-pts) (set! num-pts new-num-pts)))
+ ((show-vals) show-vals)
+ ((set-show-vals) (lambda (new-vals) (set! show-vals new-vals)))
+ ((cleared?) cleared?)
+ ((change-pt-style)
+ (lambda (new-pt-style)
+ (cond ((pt-style? new-pt-style)
+ (set! pt-style new-pt-style))
+ (else (write-line "Not a style--MAKE-CURVE") pt-style))))
+ ((change-color)
+ (lambda (new-color)
+ (set! color new-color)
+ (if (not cleared?)
+ (begin
+ (ask-widget curve-tag `(configure -fill ,color))
+ (ask-widget outline-tag `(configure -outline ,color))
+ (ask-widget vals-tag `(configure -fill ,color))))))
+ ((get-extreme-vals)
+ (lambda (min max)
+ (get-extreme-vals function min max num-pts)))
+ ((plot)
+ (graph function plotter curve-tag outline-tag pt-style num-pts color)
+ (if show-vals
+ (graph-vals function plotter show-vals vals-tag color))
+ (set! cleared? #f)
+ 'plotted)
+ ((draw-vals)
+ (if show-vals
+ (graph-vals function plotter show-vals vals-tag color))
+ 'drawn)
+ ((clear-vals)
+ (ask-widget vals-tag '(delete))
+ 'cleared)
+ ((delete-vals)
+ (ask-widget vals-tag '(delete))
+ (set! show-vals #f)
+ 'removed)
+ ((clear)
+ (ask-widget curve-tag '(delete))
+ (ask-widget outline-tag '(delete))
+ (ask-widget vals-tag '(delete))
+ (set! cleared? #t)
+ 'cleared)
+ (else (error "Bad message--MAKE-CURVE" messg))))))
+
+(define (get-extreme-vals function min max num-pts)
+ (let* ((factor (expt 10 vals-precision))
+ (first-val (function min))
+ (min-val first-val)
+ (max-val first-val)
+ (step (exact->inexact (/ (- max min) num-pts))))
+ (define (calculate x)
+ (let ((val (function x)))
+ (cond ((> x max)
+ (list (/ (round (* min-val factor)) factor)
+ (/ (round (* max-val factor)) factor)))
+ ((< val min-val) (set! min-val val)
+ (calculate (+ x step)))
+ ((> val max-val) (set! max-val val)
+ (calculate (+ x step)))
+ (else (calculate (+ x step))))))
+ (calculate (+ min step))))
+
+(define (pt-style? val)
+ (memv val '(0 1 2 3 4 5 6 7 10 20 30 40 50 60 100)))
+
+(define (curve-scale-num-pts! curve factor)
+ ((curve 'set-num-pts) (round (* (curve 'num-pts) factor))))
+
+(define (maybe-replot-curve curve)
+ (if (not (curve 'cleared?))
+ (begin (curve 'clear)
+ (curve'plot))))
+\f
+(define (graph function plotter curve-tag outline-tag pt-style num-pts color)
+ (let ((plot-canvas (plotter 'the-canvas))
+ (xmin (plotter 'xmin))
+ (xmax (plotter 'xmax))
+ (xaxis.yval (plotter 'xaxis.yval))
+ (x:val->pix (plotter 'x:val->pix))
+ (y:val->pix (plotter 'y:val->pix)))
+ (let ((xaxis.y (y:val->pix xaxis.yval)))
+
+ (define (draw-0 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
+ (define (draw-1 x y)
+ (add-to-canvas-item-group
+ outline-tag
+ (make-oval-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
+ (define (draw-2 x y)
+ (add-to-canvas-item-group
+ outline-tag
+ (make-rectangle-on-canvas plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
+ (define (draw-3 x y)
+ (add-to-canvas-item-group
+ curve-tag
+ (make-line-on-canvas plot-canvas (- x 2) (- y 2) (+ x 3) (+ y 3)))
+ (add-to-canvas-item-group
+ curve-tag
+ (make-line-on-canvas plot-canvas (+ x 2) (- y 2) (- x 2) (+ y 2))))
+ (define (draw-4 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x (- y 2) x (+ y 3)))
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
+ (define (draw-5 x y)
+ (let ((seg (make-oval-on-canvas plot-canvas
+ (- x 2) (- y 2) (+ x 2) (+ y 2))))
+ (add-to-canvas-item-group curve-tag seg)
+ (add-to-canvas-item-group outline-tag seg)))
+ (define (draw-6 x y)
+ (let ((seg (make-rectangle-on-canvas plot-canvas
+ (- x 2) (- y 2) (+ x 2) (+ y 2))))
+ (add-to-canvas-item-group curve-tag seg)
+ (add-to-canvas-item-group outline-tag seg)))
+ (define (draw-7 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-text-on-canvas plot-canvas x (- y 2) '(-text "."))))
+ (define (draw-10 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 3)))
+ (add-to-canvas-item-group
+ outline-tag (make-oval-on-canvas
+ plot-canvas (- x 3) (- y 3) (+ x 3) (+ y 3))))
+ (define (draw-20 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2)))
+ (add-to-canvas-item-group
+ outline-tag
+ (make-rectangle-on-canvas plot-canvas
+ (- x 3) (- y 3) (+ x 3) (+ y 3))))
+ (define (draw-30 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas
+ (- x 2) (- y 2) (+ x 3) (+ y 3)))
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas
+ (+ x 2) (- y 2) (- x 2) (+ y 2)))
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x xaxis.y x y)))
+ (define (draw-40 x y)
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas x (- y 2) x xaxis.y))
+ (add-to-canvas-item-group
+ curve-tag (make-line-on-canvas plot-canvas (- x 2) y (+ x 3) y)))
+ (define (draw-50 x y)
+ (let ((seg1 (make-oval-on-canvas plot-canvas
+ (- x 2) (- y 2) (+ x 2) (+ y 2)))
+ (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
+ (add-to-canvas-item-group outline-tag seg1)
+ (add-to-canvas-item-group curve-tag seg1)
+ (add-to-canvas-item-group curve-tag seg2)))
+ (define (draw-60 x y)
+ (let ((seg1 (make-rectangle-on-canvas plot-canvas
+ (- x 2) (- y 2) (+ x 2) (+ y 2)))
+ (seg2 (make-line-on-canvas plot-canvas x xaxis.y x (+ y 2))))
+ (add-to-canvas-item-group outline-tag seg1)
+ (add-to-canvas-item-group curve-tag seg1)
+ (add-to-canvas-item-group curve-tag seg2)))
+
+ (define (draw-dispatch pt-style)
+ (cond ((= pt-style 0) draw-0)
+ ((= pt-style 1) draw-1)
+ ((= pt-style 2) draw-2)
+ ((= pt-style 3) draw-3)
+ ((= pt-style 4) draw-4)
+ ((= pt-style 5) draw-5)
+ ((= pt-style 6) draw-6)
+ ((= pt-style 7) draw-7)
+ ((= pt-style 10) draw-10)
+ ((= pt-style 20) draw-20)
+ ((= pt-style 30) draw-30)
+ ((= pt-style 40) draw-40)
+ ((= pt-style 50) draw-50)
+ ((= pt-style 60) draw-60)))
+
+ (let* ((draw (draw-dispatch pt-style))
+ (xstep (exact->inexact (/ (- xmax xmin) num-pts))))
+ (define (calc-100 last-x last-y x y)
+ (if (not (> x xmax))
+ (let ((segment
+ (make-line-on-canvas plot-canvas
+ (x:val->pix last-x)
+ (y:val->pix last-y)
+ (x:val->pix x)
+ (y:val->pix y))))
+ (add-to-canvas-item-group curve-tag segment)
+ (calc-100 x y (+ x xstep) (function (+ x xstep))))))
+ (define (calculate x y)
+ (if (not (> x xmax))
+ (begin (draw (x:val->pix x) (y:val->pix y))
+ (calculate (+ x xstep) (function (+ x xstep))))))
+
+ (if (= pt-style 100)
+ (calc-100 xmin (function xmin) (+ xmin xstep) (function (+ xmin xstep)))
+ (calculate xmin (function xmin)))
+ (ask-widget curve-tag `(configure -fill ,color))
+ (ask-widget outline-tag `(configure -outline ,color))))))
+
+(define (graph-vals function plotter show-vals vals-tag color)
+ (let ((factor (expt 10 vals-precision))
+ (x:val->pix (plotter 'x:val->pix))
+ (y:val->pix (plotter 'y:val->pix))
+ (plot-canvas (plotter 'the-canvas)))
+ (let marker ((show-vals show-vals))
+ (if (not (null? show-vals))
+ (let* ((x-val (car show-vals))
+ (x (x:val->pix x-val))
+ (y-val (function x-val))
+ (y (y:val->pix y-val))
+ (pos-y? (>= y-val (plotter 'xaxis.yval))))
+ (add-to-canvas-item-group
+ vals-tag
+ (make-text-on-canvas
+ plot-canvas x (if pos-y? (- y 3) (+ y 6))
+ `(-text ,(swat:number->string (/ (round (* y-val factor)) factor))
+ -anchor ,(if pos-y? 's 'n))))
+ (add-to-canvas-item-group
+ vals-tag
+ (make-text-on-canvas plot-canvas x y '(-text "|")))
+ (marker (cdr show-vals)))))
+ (ask-widget vals-tag `(configure -fill ,color))))
+
+\f
+;;;-------------------------
+;;; Scheme-prompt Interface
+;;;-------------------------
+
+(define (plot plotter . spec-list)
+ (define (package-curves arg-list)
+ (let package-loop ((result (list (car arg-list)))
+ (rest (cdr arg-list)))
+ (cond ((null? rest) (list (reverse result)))
+ ((procedure? (car rest))
+ (cons (reverse result) (package-curves rest)))
+ (else (package-loop (cons (car rest) result) (cdr rest))))))
+ (if (not (null? spec-list))
+ (let* ((curve-desc-list (package-curves spec-list))
+ (old-xmin (plotter 'xmin))
+ (old-xmax (plotter 'xmax))
+ (old-ymin (plotter 'ymin))
+ (old-ymax (plotter 'ymax))
+ (old-axis-y (plotter 'xaxis.yval))
+ (old-axis-x (plotter 'yaxis.xval))
+ (old-xticks (plotter 'xticks))
+ (old-yticks (plotter 'yticks))
+ (xmin~ #f) (axis-x~ #f) (num-pts~ #f)
+ (xmax~ #f) (axis-y~ #f) (pt-style~ #f)
+ (ymin~ #f) (xticks~ #f) (color~ #f)
+ (ymax~ #f) (yticks~ #f) (show-vals~ #f)
+ (default-num-pts (plotter 'default-num-pts))
+ (default-pt-style (plotter 'default-pt-style))
+ (default-color (plotter 'default-color))
+ (curve-list '()))
+
+ (define (process-next-curve curve-desc)
+ (let ((f (car curve-desc))
+ (curve-options (cdr curve-desc)))
+ (let curve-loop ((curve-options curve-options))
+ (if (not (null? curve-options))
+ (let ((option-name (car curve-options)))
+ (cond ((not (symbol? option-name))
+ (error "Bad option--PLOT" option-name))
+ ((null? (cdr curve-options))
+ (error "PLOT: No value specified for option"
+ option-name))
+ (else
+ (let ((option-value (cadr curve-options)))
+ (process-option option-name option-value)
+ (curve-loop (cddr curve-options))))))))
+ (make-curve plotter
+ f
+ (or pt-style~ default-pt-style)
+ (or num-pts~ default-num-pts)
+ (or color~ default-color)
+ show-vals~)))
+
+ (define (process-option name value)
+ (case name
+ ;; global options
+ ((xmin) (if (not xmin~) (set! xmin~ value)))
+ ((xmax) (if (not xmax~) (set! xmax~ value)))
+ ((ymin) (if (not ymin~) (set! ymin~ value)))
+ ((ymax) (if (not ymax~) (set! ymax~ value)))
+ ((axis-x) (if (not axis-x~) (set! axis-x~ value)))
+ ((axis-y) (if (not axis-y~) (set! axis-y~ value)))
+ ((xticks) (if (not xticks~) (set! xticks~ value)))
+ ((yticks) (if (not yticks~) (set! xticks~ value)))
+ ;; curve-specific options
+ ((num-pts) (set! num-pts~ value))
+ ((pt-style) (set! pt-style~ value))
+ ((color) (set! color~ value))
+ ((show-vals) (set! show-vals~ value))
+ (else (error "Illegal option--PLOT" name))))
+
+ (define (reset-options!)
+ (set! num-pts~ #f)
+ (set! pt-style~ #f)
+ (set! color~ #f)
+ (set! show-vals~ #f))
+
+ (let process-loop ((curve-desc-list (reverse curve-desc-list)))
+ (if (not (null? curve-desc-list))
+ (let ((new-curve (process-next-curve (car curve-desc-list))))
+ ((plotter 'add-curve) new-curve)
+ (set! curve-list (cons new-curve curve-list))
+ (reset-options!)
+ (process-loop (cdr curve-desc-list)))))
+
+ (let* ((xmin (or xmin~ old-xmin))
+ (xmax (or xmax~ old-xmax))
+ (get-extremes
+ (lambda (xmin xmax)
+ (map (lambda (curve) ((curve 'get-extreme-vals) xmin xmax))
+ curve-list)))
+ (extremes #f)
+ (ymin
+ (or ymin~
+ (min
+ old-ymin
+ (let ((xtremes (get-extremes xmin xmax)))
+ (set! extremes xtremes)
+ (apply min (cons 0 (map (lambda (e) (car e)) xtremes)))))))
+ (ymax
+ (or ymax~
+ (max
+ old-ymax
+ (let ((xtremes
+ (if extremes extremes (get-extremes xmin xmax))))
+ (apply max (cons 0 (map (lambda (e) (cadr e)) xtremes)))))))
+ (axis-y (or axis-y~ old-axis-y))
+ (axis-x (or axis-x~ old-axis-x)))
+
+ (if (and (= xmin old-xmin)
+ (= xmax old-xmax)
+ (= ymin old-ymin)
+ (= ymax old-ymax)
+ (= axis-x old-axis-x)
+ (= axis-y old-axis-y)
+ (equal? xticks~ old-xticks)
+ (equal? yticks~ old-yticks))
+ ;; only plot the new curves
+ (for-each (lambda (new-curve) (new-curve 'plot))
+ curve-list)
+ ;; if a global param changed, replot everything
+ (begin
+ ((plotter 'set-params)
+ xmin xmax ymin ymax axis-x axis-y xticks~ yticks~)
+ (plotter 'clear)
+ (draw-axes plotter)
+ (plotter 'plot-curves)))
+
+ ;; return the curve if there's only one, list of curves if more.
+ (and (pair? curve-list)
+ (if (= (length curve-list) 1)
+ (car curve-list)
+ curve-list))))))
+
+(define (set-plotter-params plotter . spec-list)
+ (let ((xmin (plotter 'xmin))
+ (xmax (plotter 'xmax))
+ (ymin (plotter 'ymin))
+ (ymax (plotter 'ymax))
+ (axis-x (plotter 'yaxis.xval))
+ (axis-y (plotter 'xaxis.yval))
+ (xticks (plotter 'xticks))
+ (yticks (plotter 'yticks)))
+ (define (process-option name value)
+ (case name
+ ;; global options
+ ((xmin) (set! xmin value))
+ ((xmax) (set! xmax value))
+ ((ymin) (set! ymin value))
+ ((ymax) (set! ymax value))
+ ((axis-x) (set! axis-x value))
+ ((axis-y) (set! axis-y value))
+ ((xticks) (set! xticks value))
+ ((yticks) (set! xticks value))
+ (else (error "Illegal option--SET-PLOTTER-PARAMS" name))))
+ (let process-loop ((options spec-list))
+ (if (not (null? options))
+ (let ((option-name (car options)))
+ (cond ((not (symbol? option-name))
+ (error "Bad option--PLOT" option-name))
+ ((null? (cdr options))
+ (error "SET-PLOTTER-PARAMS: No value specified for option"
+ option-name))
+ (else
+ (let ((option-value (cadr options)))
+ (process-option option-name option-value)
+ (process-loop (cddr options))))))))
+ ((plotter 'set-params) xmin xmax ymin ymax axis-x axis-y xticks yticks)
+ (plotter 'clear)
+ (draw-axes plotter)
+ (plotter 'plot-curves)))
+
+(define (reset-plotter-params plotter)
+ (apply set-plotter-params
+ (list 'xmin plotter-default-xmin
+ 'xmax plotter-default-xmax
+ 'ymin plotter-default-ymin
+ 'ymax plotter-default-ymax
+ 'axis-x plotter-default-axis-x
+ 'axis-y plotter-default-axis-y
+ 'xticks plotter-default-xticks
+ 'yticks plotter-default-yticks)))
+
+\f
+(define (make-vals min max spacing . center?)
+ (let ((min (if center? (* spacing (round (/ min spacing))) min)))
+ (define (tick-maker val)
+ (if (> val max)
+ '()
+ (cons val (tick-maker (+ val spacing)))))
+ (tick-maker min)))
+
+
+(define (change-color curve color)
+ ((curve 'change-color) color))
+
+(define (change-pt-style curve pt-style)
+ ((curve 'change-pt-style) pt-style)
+ (maybe-replot-curve curve))
+
+(define (change-num-pts curve num-pts)
+ ((curve 'set-num-pts) num-pts)
+ (maybe-replot-curve curve))
+
+(define (clear-curve curve)
+ (curve 'clear))
+
+(define (plot-curve curve)
+ (if (curve 'cleared?)
+ (curve 'plot)))
+
+(define (delete-curve curve)
+ (((curve 'plotter) 'delete-curve) curve))
+
+(define (add-show-vals curve show-vals)
+ (curve 'clear-vals)
+ ((curve 'set-show-vals)
+ (append (curve 'show-vals) show-vals))
+ (curve 'draw-vals))
+
+(define (clear-show-vals curve)
+ (curve 'clear-vals))
+
+(define (draw-show-vals curve)
+ (curve 'draw-vals))
+
+(define (delete-show-vals curve)
+ (curve 'delete-vals))
+
+
+(define (add-xticks plotter xticks)
+ ((plotter 'set-xticks)
+ (append (plotter 'xticks) xticks))
+ (plotter 'clear-axes)
+ (draw-axes plotter))
+
+(define (add-yticks plotter yticks)
+ ((plotter 'set-yticks)
+ (append (plotter 'xticks) yticks))
+ (plotter 'clear-axes)
+ (draw-axes plotter))
+
+(define (clear-ticks plotter)
+ (plotter 'clear-ticks))
+
+(define (draw-ticks plotter)
+ (draw-xticks plotter)
+ (draw-yticks plotter))
+
+(define (delete-ticks plotter)
+ (plotter 'delete-ticks))
+
+(define (clear-plotter plotter)
+ (plotter 'clear-curves)
+ (plotter 'clear-ticks))
+
+(define (replot plotter)
+ (draw-ticks plotter)
+ (for-each plot-curve (plotter 'curve-list))
+ 'replotted)
+
+(define (reset-plotter plotter)
+ (plotter 'delete-curves)
+ (plotter 'delete-ticks)
+ (plotter 'clear)
+ (draw-axes plotter)
+ 'reset)
+
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations))
+
+;;;Demo of DT frequency response by frobbing poles and zeros
+
+(define half-window-size 200)
+(define zero-size 5)
+(define pole-size 4)
+(define trim 10)
+(define zero-color "violetred")
+(define pole-color "blue")
+(define canvas-color "white")
+(define text-font "CourR12")
+
+
+(define symbol-font
+ "-adobe-symbol-medium-r-normal--14-100-100-100-p-85-adobe-fontspecific")
+
+(define tracking-coords? #F)
+(define time-to-update-plot? #F)
+(define LOCATION 'later) ; active variable
+(define all-zeros '()) ; alist of zeros(objects)/coords
+(define all-poles '()) ; alist of poles(objects)/coords
+
+(define number-of-points 100)
+(define max-w 3.14159)
+
+;;hack to print numbers to three decimals
+(define (unsigned->string n)
+ (let* ((int-part (floor n))
+ (frac-part (- n int-part))
+ (dec (floor->exact (* frac-part 1000)))
+ (string-dec (number->string dec))
+ (padded-string-dec
+ (cond ((< dec 10) (string-append "00" string-dec))
+ ((< dec 100) (string-append "0" string-dec))
+ (else string-dec))))
+ (string-append (number->string (floor->exact int-part))
+ "."
+ padded-string-dec)))
+
+(define (our-cx->string z)
+ (let* ((r (real-part z))
+ (i (imag-part z))
+ (rs (unsigned->string (abs r)))
+ (is (unsigned->string (abs i)))
+ (signed-r
+ (if (< r 0)
+ (string-append "-" rs)
+ rs))
+ (signed-i
+ (if (< i 0)
+ (string-append "-" is)
+ (string-append "+" is))))
+ (string-append signed-r signed-i "j")))
+
+(define (our-real->string r)
+ (let* ((rs (unsigned->string (abs r)))
+ (signed-r
+ (if (< r 0)
+ (string-append "-" rs)
+ rs)))
+ signed-r))
+
+
+(define (z->canvas-coords z)
+ (let ((x (real-part z))
+ (y (imag-part z)))
+ (list
+ (round->exact
+ (+ (* x (- half-window-size (* 2 trim)))
+ half-window-size))
+ (round->exact
+ (+ (* y (- (* 2 trim) half-window-size))
+ half-window-size)))))
+
+(define (canvas-coords->z xy)
+ (let ((x (exact->inexact (car xy)))
+ (y (exact->inexact (cadr xy))))
+ (let ((real (/ (- x half-window-size)
+ (- half-window-size (* 2 trim))))
+ (imag (/ (- y half-window-size)
+ (- (* 2 trim) half-window-size))))
+ (+ real (* imag +i)))))
+
+;;; Pole/Zero Movement
+(define (move-with-conjugate-pair pole-zero obj1 obj2)
+ (let ((last-x 'later)
+ (last-y 'later))
+ (define (keep-track-of-coords x y)
+ (set! last-x x)
+ (set! last-y y)
+ (if tracking-coords?
+ (let ((z (canvas-coords->z (list last-x last-y))))
+ (set-active-variable! LOCATION (our-cx->string z)))))
+ (define (store-coords)
+ (let* ((zero-entry (assq obj1 all-zeros))
+ (obj1-entry
+ (if zero-entry zero-entry (assq obj1 all-poles)))
+ (obj2-entry
+ (if zero-entry
+ (assq obj2 all-zeros)
+ (assq obj2 all-poles)))
+ (z (canvas-coords->z (list last-x last-y))))
+ (set-cdr! obj1-entry z)
+ (set-cdr! obj2-entry (conjugate z))))
+ (add-event-handler!
+ obj1
+ "<ButtonPress-1>"
+ (lambda (x y)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x y))
+ "%x" "%y")
+ (add-event-handler!
+ obj1
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj1
+ "<B1-Motion>"
+ (lambda (x y)
+ (ask-widget obj1 `(move ,(- x last-x) ,(- y last-y)))
+ (ask-widget obj2 `(move ,(- x last-x) ,(- last-y y)))
+ (keep-track-of-coords x y))
+ "%x" "%y")))
+
+(define (move-by-itself pole-zero obj)
+ (let ((last-x 'later))
+ (define (keep-track-of-coords x)
+ (set! last-x x)
+ (let ((z (canvas-coords->z (list last-x half-window-size))))
+ (if tracking-coords?
+ (set-active-variable! LOCATION (our-real->string z)))))
+ (define (store-coords)
+ (let ((entry
+ (let ((zero (assq obj all-zeros)))
+ (if zero zero (assq obj all-poles))))
+ (z (real-part (canvas-coords->z (list last-x 0)))))
+ (set-cdr! entry z)))
+ (add-event-handler!
+ obj
+ "<ButtonPress-1>"
+ (lambda (x)
+ (set! time-to-update-plot? #F)
+ (keep-track-of-coords x))
+ "%x")
+ (add-event-handler!
+ obj
+ "<ButtonRelease-1>"
+ (lambda ()
+ (store-coords)
+ (maybe-update-plot (pole-zero 'graph-canvas))
+ ))
+ (add-event-handler!
+ obj
+ "<B1-Motion>"
+ (lambda (x)
+ (ask-widget obj `(move ,(- x last-x) 0))
+ (keep-track-of-coords x))
+ "%x")))
+
+
+;;; This isn't quite right. Time-to-update-plot? might be set to #F
+;;; and then back to #T inside the 2 sec interval, so the update will
+;;; come too soon.
+(define (maybe-update-plot graph-canvas)
+ (set! time-to-update-plot? #T)
+ (after-delay
+ 2
+ (lambda ()
+ (if time-to-update-plot?
+ (plot-pole-zero graph-canvas)))))
+
+
+;;; Zeros
+(define (make-zero canvas xy)
+ (let ((x (car xy))
+ (y (cadr xy)))
+ (let ((zero
+ (make-oval-on-canvas canvas
+ (- x zero-size) (- y zero-size)
+ (+ x zero-size) (+ y zero-size))))
+ (set! all-zeros (cons (cons zero (canvas-coords->z xy))
+ all-zeros))
+ (ask-widget zero `(configure -outline ,zero-color -fill ,canvas-color -width 2))
+ zero)))
+
+(define (make-single-zero pole-zero x)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((z (make-zero canvas (list x half-window-size))))
+ (move-by-itself pole-zero z)
+ z)))
+
+(define (make-zero-pair pole-zero x y)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((zero (canvas-coords->z (list x y))))
+ (let ((other-pos
+ (z->canvas-coords (conjugate zero))))
+ (let ((z1 (make-zero canvas (list x y)))
+ (z2 (make-zero canvas other-pos)))
+ (move-with-conjugate-pair pole-zero z1 z2)
+ (move-with-conjugate-pair pole-zero z2 z1))))))
+
+
+;;; Poles
+(define (make-pole canvas xy)
+ (let ((x (car xy))
+ (y (cadr xy)))
+ (let* ((line1
+ (make-line-on-canvas canvas
+ (- x pole-size) (- y pole-size)
+ (+ x pole-size) (+ y pole-size)))
+ (line2
+ (make-line-on-canvas canvas
+ (- x pole-size) (+ y pole-size)
+ (+ x pole-size) (- y pole-size)))
+ (pole (make-canvas-item-group canvas (list line1 line2))))
+ (set! all-poles (cons (cons pole (canvas-coords->z xy))
+ all-poles))
+ (ask-widget pole `(configure -fill ,pole-color -width 2))
+ pole)))
+
+(define (make-single-pole pole-zero x)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((p (make-pole canvas (list x half-window-size))))
+ (move-by-itself pole-zero p)
+ p)))
+
+(define (make-pole-pair pole-zero x y)
+ (let ((canvas (pole-zero 'diagram-canvas)))
+ (let ((pole (canvas-coords->z (list x y))))
+ (let ((other-pos
+ (z->canvas-coords (conjugate pole))))
+ (let ((p1 (make-pole canvas (list x y)))
+ (p2 (make-pole canvas other-pos)))
+ (move-with-conjugate-pair pole-zero p1 p2)
+ (move-with-conjugate-pair pole-zero p2 p1))))))
+
+;;; Button that switches from one label to another
+
+(define (make-switch color to-switch)
+ ;;to-switch is list ((text command) (text command))
+ (let ((n (length to-switch))
+ (button (make-button))
+ (state #F))
+ (define (switch-to-state i)
+ (set! state i)
+ ((cadr (list-ref to-switch i)))
+ (ask-widget button `(configure -text ,(car (list-ref to-switch i)))))
+ (ask-widget button `(configure -background ,color))
+ (switch-to-state 0)
+ (set-callback! button
+ (lambda ()
+ (switch-to-state (modulo (+ state 1) n))))
+ button))
+
+;;; Demo
+(define (make-pole-zero)
+ (set! all-zeros '())
+ (set! all-poles '())
+ (let ((diagram-canvas (make-canvas `(-width ,(* 2 half-window-size)
+ -height ,(* 2 half-window-size))))
+ (graph-canvas #F)
+ (pz 'later)
+ (shape-size 'later)
+ (single-maker 'later)
+ (pair-maker 'later))
+
+ (define (switch-to-zeros)
+ (set! shape-size zero-size)
+ (set! single-maker make-single-zero)
+ (set! pair-maker make-zero-pair))
+
+ (define (switch-to-poles)
+ (set! shape-size pole-size)
+ (set! single-maker make-single-pole)
+ (set! pair-maker make-pole-pair))
+
+ (let* ((maker-button (make-switch "yellow"
+ `(("Zeros" ,switch-to-zeros)
+ ("Poles" ,switch-to-poles))))
+ (clear-button (make-button '(-text "Clear")))
+ (show-coords? (make-active-variable))
+ (coords-button
+ (make-checkbutton `(-text "Show Coords?" -variable ,show-coords?)))
+ (coords-display (make-label))
+ (plot-button (make-button '(-text "Plot"))))
+
+ (set! LOCATION (make-active-variable))
+ (ask-widget coords-display `(configure -width 13 -background ,canvas-color
+ -relief sunken -textvariable ,LOCATION
+ -font ,text-font))
+ (for-each (lambda (b)
+ (ask-widget b `(configure -background "yellow" -font ,text-font)))
+ (list maker-button clear-button coords-button plot-button))
+ (ask-widget diagram-canvas `(configure -background ,canvas-color))
+ (on-death! diagram-canvas 'little-brother-canvas
+ (lambda () (if graph-canvas (swat-close graph-canvas))))
+
+ (set-callback!
+ clear-button
+ (lambda ()
+ (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
+ all-zeros)
+ (for-each (lambda (entry) (ask-widget (car entry) '(delete)))
+ all-poles)
+ (set-active-variable! LOCATION "")
+ (cond (graph-canvas
+ (ask-widget graph-canvas '(delete all))
+ (draw-axes graph-canvas)))
+ (set! all-zeros '())
+ (set! all-poles '())))
+
+ (set-callback!
+ coords-button
+ (lambda ()
+ (if (checkbutton-variable-on? show-coords?)
+ (set! tracking-coords? #T)
+ (begin
+ (set-active-variable! LOCATION "")
+ (set! tracking-coords? #F)))))
+ (set-callback!
+ plot-button
+ (lambda ()
+ (cond ((not graph-canvas)
+ (set! graph-canvas
+ (make-canvas `(-width ,(* 2 half-window-size)
+ -height ,(* 2 half-window-size))))
+ (ask-widget graph-canvas `(configure -background ,canvas-color))
+ (swat-open graph-canvas '-title "Magnitude of Frequency Response")
+ (on-death! graph-canvas 'big-brother-canvas
+ (lambda () (set! graph-canvas #F)))))
+ (plot-pole-zero graph-canvas)))
+ (add-event-handler!
+ diagram-canvas
+ "<Double-ButtonPress-1>"
+ (lambda (x y)
+ (set! time-to-update-plot? #F)
+ (if (< (abs (- y half-window-size)) shape-size)
+ (single-maker pz x)
+ (pair-maker pz x y)))
+ "%x" "%y")
+
+ (let ((me (make-vbox diagram-canvas
+ (make-hbox maker-button clear-button coords-button
+ coords-display plot-button))))
+ (swat-open me '-title "Pole-Zero Diagram")
+ (let ((x-axis (make-line-on-canvas
+ diagram-canvas
+ trim half-window-size
+ (- (* 2 half-window-size) trim) half-window-size))
+ (y-axis (make-line-on-canvas
+ diagram-canvas
+ half-window-size trim
+ half-window-size (- (* 2 half-window-size) trim)))
+ (unit-circle (make-oval-on-canvas
+ diagram-canvas
+ (* 2 trim) (* 2 trim)
+ (* 2 (- half-window-size trim))
+ (* 2 (- half-window-size trim)))))
+ (ask-widget x-axis '(configure -arrow last))
+ (ask-widget y-axis '(configure -arrow first))
+ (ask-widget unit-circle '(configure -outline "gray")))
+
+ (set! pz
+ (lambda (message)
+ (case message
+ ((graph-canvas) graph-canvas)
+ ((diagram-canvas) diagram-canvas)
+ ((add-zero)
+ (lambda (z)
+ (let ((xy (z->canvas-coords z)))
+ (if (= (imag-part z) 0)
+ (make-single-zero pz (car xy))
+ (make-zero-pair pz (car xy) (cadr xy))))))
+ ((add-pole)
+ (lambda (p)
+ (let ((xy (z->canvas-coords p)))
+ (if (= (imag-part p) 0)
+ (make-single-pole pz (car xy))
+ (make-pole-pair pz (car xy) (cadr xy))))))
+ (else "Unknown message -- MAKE-POLE-ZERO" message))))
+ pz))))
+
+
+(define (add-butterworth-poles pole-zero-diagram n)
+ (define pi (* (atan 1 1) 4))
+ (define (make-index-list n start)
+ (if (> start n)
+ '()
+ (cons start (make-index-list n (+ start 1)))))
+ (let ((index-list (make-index-list n (+ (ceiling->exact (/ n 2)) 1)))
+ (w (exp (/ (* 2 +i pi) (* 2 n)))))
+ (for-each (lambda (pole)
+ ((pole-zero-diagram 'add-pole) pole))
+ (map (lambda (s)
+ (let ((t 1))
+ (/ (+ 1 (* (/ t 2) s))
+ (- 1 (* (/ t 2) s)))))
+ (map (lambda (k) (expt w (- k .5)))
+ index-list)))
+ (let loop ((z 1))
+ (if (> z n)
+ 'done
+ (begin ((pole-zero-diagram 'add-zero) -1)
+ (loop (1+ z)))))
+ (plot-pole-zero (pole-zero-diagram 'graph-canvas))))
+
+
+(define (plot-pole-zero graph-canvas)
+ (cond (graph-canvas
+ (ask-widget graph-canvas '(delete all))
+ (draw-axes graph-canvas)
+ (plot-magnitude graph-canvas))))
+
+(define (plot-magnitude graph-canvas)
+ (let ((zero-locations (map cdr all-zeros))
+ (pole-locations (map cdr all-poles)))
+ (let ((fcn
+ (lambda (x)
+ (let ((jw (exp (* x +i))))
+ (let ((numer
+ (apply * (map (lambda (z) (magnitude (- jw z)))
+ zero-locations)))
+ (denom
+ (apply * (map (lambda (z) (magnitude (- jw z)))
+ pole-locations))))
+ (if (< denom 1.e-10)
+ 1.e5
+ (/ numer denom)))))))
+ (plot-graph-on-canvas
+ graph-canvas
+ (let loop ((index 0) (points '()))
+ (if (> index number-of-points)
+ points
+ (let ((w (* index (/ max-w number-of-points))))
+ (loop (+ index 1)
+ (cons (cons w (fcn w)) points)))))))))
+
+(define (plot-graph-on-canvas canvas graph)
+ (let* ((maxval (apply max (map cdr graph)))
+ (canvas-points
+ (map (lambda (graph-point)
+ (magnitude-coords->canvas-coords graph-point maxval))
+ graph)))
+ (let loop ((rest-points (cdr canvas-points))
+ (this-point (car canvas-points)))
+ (if (null? rest-points)
+ 'done
+ (let ((next-point (car rest-points)))
+ (make-line-on-canvas canvas
+ (car this-point)
+ (cdr this-point)
+ (car next-point)
+ (cdr next-point))
+ (loop (cdr rest-points)
+ (car rest-points)))))
+ (let ((maxval-display
+ (make-text-on-canvas
+ canvas (* 3 trim) (* 2 trim) `(-text ,(our-real->string maxval)))))
+ (ask-widget maxval-display
+ `(configure -anchor sw -font ,symbol-font)))))
+
+
+(define (magnitude-coords->canvas-coords xy max-mag)
+ (let ((x (car xy))
+ (y (cdr xy)))
+ (cons (round->exact (+ (* x (/ (- (* 2 half-window-size) (* 4 trim)) max-w))
+ (* 2 trim)))
+ (round->exact (+ (* y (/ (- (* 4 trim) (* 2 half-window-size)) max-mag))
+ (* 2 (- half-window-size trim)))))))
+
+
+(define (draw-axes graph-canvas)
+ (let ((x-axis (make-line-on-canvas
+ graph-canvas
+ trim (* 2 (- half-window-size trim))
+ (- (* 2 half-window-size) trim)
+ (* 2 (- half-window-size trim))))
+ (y-axis (make-line-on-canvas
+ graph-canvas
+ (* 2 trim) trim
+ (* 2 trim) (- (* 2 half-window-size) trim)))
+ (pi (make-text-on-canvas
+ graph-canvas
+ (* 2 (- half-window-size trim)) (- (* 2 half-window-size) trim)
+ '(-text "p"))))
+ (ask-widget x-axis '(configure -arrow last))
+ (ask-widget y-axis '(configure -arrow first))
+ (ask-widget pi `(configure -anchor e -font ,symbol-font))))
+
--- /dev/null
+;;; -*- Scheme -*-
+
+;; to make this possible to debug
+
+; (set! *unparser-list-breadth-limit* 10)
+; (set! *unparser-list-depth-limit* 10)
+
+
+;; GC stress test
+
+(define (a)
+ (gc-flip)
+ (gc-flip)
+ (kick-uitk-thread)
+ (gc-flip)
+ (gc-flip)
+ (kick-uitk-thread))
+
+(define (foo test n)
+ (if (> n 0)
+ (begin
+ (test)
+ (foo test (- n 1)))))
+
+(define (foo2 test n)
+ (if (> n 0)
+ (begin
+ (display n)
+ (test)
+ (gc-flip)
+ (foo2 test (- n 1)))))
+
+
+;; Support for GC debugging
+
+(define gctr (make-primitive-procedure 'gc-trace-references))
+(define refs (make-vector 40))
+
+(define (go obj)
+ (gctr obj refs)
+ (gc-flip)
+ (write-line (list (vector-ref refs 0) (map object-type (vector->list refs)))))
+
+(define (get n) (vector-ref refs n))
+
+
+;; Test the Rectangle widget
+
+;; (define application (make-application "Test Scheme Application"))
+
+(define (make-picture)
+ (define v1 (make-self-painting-rectangle 50 30 "yellow"))
+ (define v2 (make-self-painting-rectangle 100 10 "blue"))
+ (define v3 (make-self-painting-rectangle 10 100 "orange"))
+
+ (define topframe (make-vbox v1 v2 v3))
+
+ (define h1 (make-self-painting-rectangle 10 10 "white"))
+ (define h2 (make-self-painting-rectangle 20 20 "gold"))
+ (define h3 (make-self-painting-rectangle 30 30 "green"))
+
+ (define bottomframe (make-hbox h1 h2 h3))
+
+ (make-hbox topframe bottomframe))
+
+(define (make-bad-picture)
+ (define v1 (make-rect 50 30 "yellow"))
+ (define v2 (make-rect 100 10 "blue"))
+ (define v3 (make-rect 10 100 "orange"))
+
+ (define topframe (make-vbox v1 v2 v3))
+
+ (define h1 (make-rect 10 10 "white"))
+ (define h2 (make-rect 20 20 "gold"))
+ (define h3 (make-rect 30 30 "green"))
+ (set! green h3)
+
+ (define bottomframe (make-hbox h1 h2 h3))
+
+ (make-hbox topframe bottomframe))
+
+(define (simple-picture)
+ (swat-open (make-self-painting-rectangle 50 30 "yellow")))
+
+(define (test0)
+ (simple-picture)
+ 3)
+
+(define (test1)
+ (swat-open (make-picture))
+ 3)
+
+(define (test1a)
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ 3)
+
+(define app2)
+(define (test2)
+ (set! app2 (make-application "Test2-2 "))
+ (add-child! app2 (make-picture))
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ (swat-open (make-picture))
+ (add-child! app2 (make-picture))
+ (add-child! app2 (make-picture))
+ (add-child! app2 (make-picture))
+ (add-child! app2 (make-picture))
+ 3)
+
+(define (make-switch color to-switch)
+ ;;to-switch is list ((text command) (text command))
+ (let ((n (length to-switch))
+ (button (make-button))
+ (state #F))
+ (define (switch-to-state i)
+ (set! state i)
+ ((cadr (list-ref to-switch i)))
+ (ask-widget button `(configure -text ,(car (list-ref to-switch i)))))
+ (ask-widget button `(configure -background ,color))
+ (switch-to-state 0)
+ (set-callback! button
+ (lambda ()
+ (switch-to-state (modulo (+ state 1) n))))
+ button))
+
+(define debug-test3)
+(define (test3)
+ (let* ((surface (make-shape-surface 600 600 "white" "red"))
+ (button1 (make-button '(-text "PANIC!")))
+ (button2 (make-button '(-text "SET COLOR")))
+ (button3 (make-switch
+ "yellow"
+ `(("Ovals" ,(lambda () (surface 'ovals)))
+ ("Rectangles" ,(lambda () (surface 'rectangles))))))
+ (button4 (make-switch
+ "yellow"
+ `(("Outlined" ,(lambda () (surface 'outlined)))
+ ("Filled" ,(lambda () (surface 'filled))))))
+ (e (make-entry '(-width 10))))
+ (define (handle-bad-color)
+ (ask-widget button2 '(configure -background red))
+ (ask-widget button2 '(flash))
+ (ask-widget button2 '(flash))
+ (ask-widget e `(delete 0 end))
+ (ask-widget e `(insert 0 red))
+ ((surface 'set-color!) "red"))
+ (define (change-color)
+ (let ((new-color (ask-widget e '(get))))
+ (if (valid-color? new-color)
+ (begin ((surface 'set-color!) new-color)
+ (ask-widget button2
+ `(configure -background ,new-color)))
+ (handle-bad-color))))
+ (set! debug-test3 (lambda () #f))
+ (ask-widget button1 '(configure
+ -background green -activebackground red
+ -font "-adobe-helvetica-bold-r-normal--34-240-100-100-p-182-iso8859-1"))
+ (ask-widget button2 '(configure -background red -activebackground white))
+ (ask-widget e '(configure -background white -foreground black -relief sunken))
+ (ask-widget e '(insert 0 red))
+ (set-callback! button1 (lambda () (surface 'clear)))
+ (set-callback! button2 change-color)
+ (let ((me (make-vbox (surface 'the-surface)
+ (make-hbox button1 e
+ button2 button3 button4))))
+ (swat-open me '-title "Featureless Drawing Program")
+ me)))
+
+
+
+
--- /dev/null
+; These get overriden when TK is loaded
+(define (tk-doevents) 'tk-doevents)
+(define (tk-init dsp) 'tk-init)
+
+(with-working-directory-pathname
+ "/scheme/8.0/700/swat2/scheme"
+ (lambda ()
+ ; Dynamically load the microcode
+ (load "../c/scxl")
+ (load "../c/uitk")
+
+ ; And now the Scheme level
+ ;;(load "scc-macros")
+ ;;(load "uitk-macros")
+ (load "control-floating-errors")
+ (load "structures")
+ (load "structures2")
+ (load "generics")
+ (load "uitk")
+ (load "xlibCONSTANTS")
+ (load "mit-xlib")
+ (load "tk-mit")
+ (load "mit-xhooks")
+ (load "widget-mit")
+ (load "baseobj")
+ (load "widget")
+ (load "geometry")
+ (load "simple")
+ (load "canvas")
+ (load "menu")
+ (load "text")
+ ;;(load "rtest")
+ ;;(load "btest")
+ ))
--- /dev/null
+ (define b1 (make-button '(-text "button1")))
+ (define b2 (make-button '(-text "button2")))
+ (define b3 (make-button '(-text "button3")))
+ (define b4 (make-button '(-text "button4")))
+ (define b5 (make-button '(-text "button5")))
+ (define b6 (make-button '(-text "very very long button6")))
+ (define b7 (make-button '(-text "b7")))
+ (define b8 (make-button '(-text "b8")))
+ (define b9 (make-button '(-text "b9")))
+ (define s (make-space))
+
+ (define a (make-application "test"))
+ (define ab (make-array-box (list b1 'left b3)
+ (list 'up 'up b6)
+ (list b7 b8 b9)))
+ (add-child! a ab)
+
+(define (test2)
+ (define c (make-canvas '(-width 300 -height 300 -background white)))
+ (define b1 (make-button '(-text "button1" -background red)))
+ (define b2 (make-button '(-text "button2" -background red)))
+ (define b3 (make-button '(-text "button3" -background red)))
+ (define s1 (make-space '(-background red)))
+ (define s2 (make-space '(-background red)))
+ (define hb (make-hbox s1 b1 b2 s2 b3))
+ (define vb (make-vbox c hb))
+ (define a (make-application "test"))
+ (add-child! a vb)
+ a)
+
+#|
+(define c (make-canvas '(-width 200 -height 200)))
+(define b1 (make-button '(-text "button1")))
+(define b2 (make-button '(-text "button2")))
+(define box1 (make-hbox b1 b2))
+(define box2 (make-vbox c box1))
+(define a (make-application "test"))
+(add-child! a box2)
+
+|#
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+(declare (usual-integrations)
+ (integrate-external "/scheme/700/runtime/hash"))
+
+(using-syntax syntax-table/system-internal
+ (define foo-1 'invalid-rehash)
+ (define foo-2 'invalid-bucket)
+ (define foo-3 'unhash-table)
+ (define (foo)
+ (set! foo-1 3)
+ (set! foo-2 3)
+ (set! foo-3 3))
+
+(define *do-validation?* #T)
+
+ (define (count-unhash-table uht)
+ (let ((count 0))
+ (do ((i 0 (+ i 1)))
+ ((= i (vector-length uht)) count)
+ (set! count (+ count (length (cdr (vector-ref uht i))))))))
+
+ (define (valid-bucket-contents? table when y full?)
+ (define (valid? x)
+ (and (list? x)
+ (or (null? x)
+ (and (pair? x)
+ (weak-pair? (car x))
+ (let ((hash-number (weak-cdr (car x))))
+ (and (number? hash-number)
+ (or (not full?)
+ (not (weak-car (car x)))
+ (= hash-number (hash (weak-car (car x)) table))
+ (let ((table (car (cons table #f)))
+ (x (car (cons x #f)))
+ (y (car (cons y #f)))
+ (forty-two (car (cons 42 #f))))
+ (write-line
+ (list "invalid rehash" when table hash-number (car x)))
+ (table)
+ (list table x y forty-two)))))
+ (valid? (cdr x))))))
+ (or (valid? y)
+ (begin
+ (write-line (list "Invalid unhash bucket" table when))
+ (+ 2 foo-2))))
+
+ (define (validate table when full?)
+ (if *Do-Validation?*
+ (fluid-let ((*Do-Validation?* #F))
+ (let ((uht (hash-table/unhash-table table)))
+ (for-each
+ (lambda (bucket)
+ (valid-bucket-contents? table when (cdr bucket) full?))
+ (vector->list uht))))
+ 'OK))
+
+ (define (show-unhash-table uht)
+ (for-each
+ (lambda (x) (if (not (number? x))
+ (begin
+ (write-line (list "show-unhash-table: not a number" x))
+ (+ 3 foo-3)))
+ (display x)
+ (display #\space))
+ (reduce append '()
+ (map (lambda (bucket)
+ (map weak-cdr (cdr bucket)))
+ (vector->list uht))))
+ (newline))
+
+ (define (our-rehash-all-gc-daemon)
+ (let loop ((l all-hash-tables)
+ (n (weak-cdr all-hash-tables)))
+ (cond ((null? n)
+ (weak-set-cdr! l n))
+ ((not (weak-pair/car? n))
+ (loop l (weak-cdr n)))
+ (else
+ (weak-set-cdr! l n)
+ (let* ((table (weak-car n)))
+ (validate table 'before #F)
+ ; (write-line (list 'before (count-unhash-table uht)))
+ (hash-table/rehash table)
+ (validate table 'after #T)
+ ; (write-line (list 'after (count-unhash-table uht)))
+ ; (show-unhash-table uht)
+ (loop n (weak-cdr n)))))))
+
+ (delq! rehash-all-gc-daemon
+ (access gc-daemons (->environment '(runtime gc-daemons))))
+ (add-gc-daemon! our-rehash-all-gc-daemon)
+
+ (let ((old-hash object-hash))
+ (set! object-hash
+ (lambda (object #!optional table insert?)
+ (let ((table
+ (if (default-object? table)
+ default-hash-table
+ (begin
+ (if (not (hash-table? table))
+ (error:wrong-type-argument table
+ "object-hash table"
+ 'OBJECT-HASH))
+ table)))
+ (insert? (or (default-object? insert?) insert?)))
+ (let ((result (old-hash object table insert?)))
+ (validate table 'hash #F)
+ result)))))
+
+ (let ((old-unhash object-unhash))
+ (set! object-unhash
+ (lambda (number #!optional table)
+ (let ((table
+ (if (default-object? table)
+ default-hash-table
+ (begin
+ (if (not (hash-table? table))
+ (error:wrong-type-argument table
+ "object-hash table"
+ 'OBJECT-UNHASH))
+ table))))
+ (let ((result (old-unhash number table)))
+ (validate table 'unhash #T)
+ result)))))
+
+)
--- /dev/null
+;;;; -*-Scheme-*-
+;;; $Id: scc-macros.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+
+(syntax-table-define system-global-syntax-table
+ 'DEFINE-CONSTANT
+ (macro (name value) `(DEFINE-INTEGRABLE ,name ,value)))
+
+(syntax-table-define system-global-syntax-table
+ 'DEFINE-IN-LINE
+ (macro (arg-list . body)
+ `(DEFINE-INTEGRABLE ,arg-list . ,body)))
+
+(syntax-table-define system-global-syntax-table
+ 'SCC-DEFINE-SYNTAX
+ (macro (name-and-arglist . body)
+ (let ((name (car name-and-arglist))
+ (arglist (cdr name-and-arglist)))
+ `(SYNTAX-TABLE-DEFINE SYSTEM-GLOBAL-SYNTAX-TABLE
+ ',name
+ (MACRO ,arglist ,@body)))))
+
+(define-integrable *running-in-mit-scheme* #T)
--- /dev/null
+;;;;; -*- Scheme -*-
+;;;;; Simple objects for UITK
+;;;; derived from simple.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
+
+;;;; Simplest drawing object
+
+;;;This is meant to be the external interface. We need to implement these
+;;;in some standard way.
+
+
+(define (with-clipping! shape user-fn Clip-to-XRegion)
+ (let ((screen-area (Used-Screen-Area shape))
+ (window (Get-UITKWindow shape))
+ (gc (Shape%.graphics-context shape)))
+ (if (and window screen-area)
+ (let ((clip (rectangle->xregion screen-area)))
+ (define (intersect! xregion)
+ (if xregion
+ (XIntersectRegion! xregion clip clip)))
+ (if (not (null? Clip-to-XRegion))
+ (intersect! (car Clip-to-XRegion)))
+ (intersect! (clip-region shape))
+ (SetClipXRegion window gc clip)
+ (user-fn window gc (UITKRectangle.Offset screen-area))
+ (XDestroyRegion clip)))))
+
+(define (shape-draw shape . Clip-to-XRegion)
+ (ensure-graphics-context shape)
+ (with-clipping! shape (Shape%.x-draw shape) Clip-to-XRegion))
+
+(define (shape-erase-maybe shape . Clip-to-XRegion)
+ (ensure-graphics-context shape)
+ (let ((e (Shape%.x-erase shape)))
+ (and e
+ (begin (with-clipping! shape e Clip-to-XRegion)
+ #T))))
+
+(define (shape-copy shape)
+ (let ((new (make-shape
+ (Shape%.x-draw shape)
+ (Shape%.calculate-used-screen-area shape)
+ (shape%.point-within? shape)
+ (Shape%.rectangle-overlaps? shape)
+ (%desired-size shape)
+ (Shape%.color shape))))
+ (set-clip-region! new (clip-region shape))
+ (assign-geometry! new
+ (drawing-surface shape)
+ (copy-rectangle (used-screen-area shape)))
+ new))
+
+(define (shape-set-color! shape color)
+ (set-Shape%.color! shape color)
+ (set-Shape%.graphics-context! shape false))
+
+(define (shape-draw-function shape)
+ (Shape%.x-draw shape))
+
+(define (shape-set-gc-function! shape function-number)
+ (set-Shape%.gc-function! shape function-number)
+ (set-Shape%.graphics-context! shape false))
+
+(define (shape-set-erase-function! shape fcn)
+ (set-Shape%.x-erase! shape fcn))
+
+(define (shape-point-within? Shape Offset)
+ (if (not (vector? Offset))
+ (error "SHAPE-POINT-WITHIN?: Bad offset" Offset))
+ (let ((screen-area (used-screen-area shape)))
+ (and screen-area
+ ((Shape%.point-within? shape)
+ (UITKRectangle.Offset screen-area)
+ Offset))))
+
+(define (shape-rectangle-overlaps? Shape Offset W H)
+ (if (not (vector? Offset))
+ (error "SHAPE-RECTANGLE-OVERLAPS?: Bad offset" Offset))
+ (if (not (number? W))
+ (error "SHAPE-RECTANGLE-OVERLAPS?: Bad width" W))
+ (if (not (number? H))
+ (error "SHAPE-RECTANGLE-OVERLAPS?: Bad height" H))
+ (let ((screen-area (used-screen-area shape)))
+ (and screen-area
+ ((Shape%.rectangle-overlaps? shape)
+ (UITKRectangle.Offset screen-area)
+ offset w h))))
+
+(define (generate-graphics-context! shape)
+ ;; (define-primitives (set-debug-flags! 2))
+ (let ((window (Get-UITKWindow shape)))
+ (if window
+ (begin
+ (set-Shape%.graphics-context!
+ shape
+ (make-colored-graphics-context window (Shape%.color shape)))
+ (let ((Xdisplay (UITKWindow.XDisplay
+ (DrawingSurface.UITKWindow
+ (Drawing-Surface shape)))))
+ (XSetFunction Xdisplay
+ (Shape%.graphics-context shape)
+ (Shape%.gc-function shape)))
+ 'OK)
+ #F)))
+
+(define (ensure-graphics-context shape)
+ (if (not (Shape%.graphics-context shape))
+ (let ((gc (generate-graphics-context! shape)))
+ (or gc
+ (begin (debug-print 'error)
+ (error "cannot make graphics context"))))))
+
+(define (shape-assign-screen-area! shape screen-area)
+ (cond ((vector? screen-area)
+ (let ((old (used-screen-area shape))
+ (used ((Shape%.calculate-used-screen-area shape)
+ screen-area))) ; Calculate bounding box, etc.
+ (set-used-screen-area! shape used)
+ (set-assigned-screen-area! shape screen-area)
+ (geometry-change! shape old used)
+ used))
+ ((not screen-area)
+ ;; Screen-Area is #F to retract the area.
+ ;; Just inform any objects interested and don't draw
+ ;; anything.
+ (let ((old (used-screen-area shape)))
+ (if old
+ (begin
+ (set-used-screen-area! shape #F)
+ (set-assigned-screen-area! shape #F)
+ (geometry-change! shape old #F)
+ #F))))
+ (error "SHAPE-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area)))
+
+;; Use default ASSIGN-DRAWING-SURFACE!
+
+(define (shape-assign-glue! me)
+ ;; infinitely stretchable
+ (let* ((size (get-desired-size me))
+ (my-width (size.width size))
+ (my-height (size.height size)))
+ (set-%hglue! me (make-fill-glue my-width 1))
+ (set-%vglue! me (make-fill-glue my-height 1))))
+
+;; Shape Maker
+(define (shape-maker x-drawing-routine calculate-used-screen-area
+ point-within? rectangle-overlaps? color-string)
+ (make-Shape%
+ (make-UIObjInternals 'invalid
+ 'invalid
+ UIObj-set-context! ; Defaults
+ shape-assign-screen-area!
+ UIObj-assign-drawing-surface!
+ shape-point-within?
+ shape-rectangle-overlaps?
+ UIObj-handle-event
+ UIObj-get-desired-size
+ UIObj-assigned-screen-area
+ UIObj-used-screen-area
+ UIObj-set-assigned-screen-area!
+ UIObj-set-used-screen-area!
+ shape-assign-glue!)
+ x-drawing-routine
+ calculate-used-screen-area
+ color-string
+ point-within?
+ rectangle-overlaps?
+ GXCOPY))
+
+(define (make-shape x-drawing-routine calculate-used-screen-area
+ point-within? rectangle-overlaps?
+ desired-size color-string)
+ (let ((me (shape-maker x-drawing-routine
+ calculate-used-screen-area
+ point-within?
+ rectangle-overlaps?
+ color-string)))
+ (set-%desired-size! me desired-size)
+ me))
+\f
+(define (make-rect width height color-string . filled?)
+ ;;defaults to filled
+ (let* ((width (round->exact width))
+ (height (round->exact height))
+ (Width-1 (- width 1))
+ (Height-1 (- height 1))
+ (Xdraw (if (or (null? filled?) (car filled?))
+ (lambda (uitkw gc x y)
+ (FillRectangle uitkw gc x y width height))
+ (lambda (uitkw gc x y)
+ ;;!!@%$^$^$$#@#@#!! X!!
+ (DrawRectangle uitkw gc x y Width-1 Height-1)))))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (XDraw UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (make-UITKRectangle (UITKRectangle.offset assigned-screen-area)
+ (make-size width height)))
+ (lambda (My-Offset Offset) ; Point within?
+ (point-in-rectangle? Offset My-Offset Width Height))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?
+ (rectangle-overlaps-rectangle?
+ My-Offset Width Height Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string)))
+
+(define (make-scaling-rect color-string . filled?)
+ ;;defaults to filled
+ (let* ((Width #F)
+ (Height #F)
+ (Width-1 #F)
+ (Height-1 #F)
+ (Xdraw (if (or (null? filled?) (car filled?))
+ (lambda (uitkw gc x y)
+ (FillRectangle uitkw gc x y width height))
+ (lambda (uitkw gc x y)
+ ;;!!@%$^$^$$#@#@#!! X!!
+ (DrawRectangle uitkw gc x y Width-1 Height-1)))))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (XDraw UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (set! height (UITKRectangle.Height assigned-screen-area))
+ (set! width (UITKRectangle.Width assigned-screen-area))
+ (set! height-1 (- height 1))
+ (set! width-1 (- width 1))
+ assigned-screen-area)
+ (lambda (My-Offset Offset) ; Point within?
+ (point-in-rectangle? Offset My-Offset Width Height))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?
+ (rectangle-overlaps-rectangle?
+ My-Offset Width Height Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string)))
+
+(define (make-filled-rectangle width height color-string)
+ (make-rect width height color-string #T))
+
+(define (make-unfilled-rectangle width height color-string)
+ (make-rect width height color-string #F))
+
+(define (make-oval width height color-string . filled?)
+ (let* ((width (round->exact width))
+ (height (round->exact height))
+ (Width-1 (- width 1))
+ (Height-1 (- height 1))
+ (angle (* 360 64)) ; X uses degrees/64
+ (Xdraw (if (or (null? filled?) (car filled?))
+ (lambda (uitkw gc x y)
+ (FillArc uitkw gc x y width height 0 angle))
+ (lambda (uitkw gc x y)
+ (DrawArc uitkw gc x y width-1 height-1 0 angle))))
+ (a (/ width 2.0))
+ (b (/ height 2.0))
+ (center (make-point a b)))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (Xdraw UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (make-UITKRectangle (UITKRectangle.Offset assigned-screen-area)
+ (make-size width height)))
+ (lambda (My-Offset Offset) ; Point within?
+ (and (point-in-rectangle? Offset My-Offset width height)
+ (let* ((dv (sub-vectors (add-vectors my-offset center) offset))
+ (dx/a (/ (point.x dv) a))
+ (dy/b (/ (point.y dv) b)))
+ (< (+ (* dx/a dx/a) (* dy/b dy/b)) 1.0))))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?
+ (rectangle-overlaps-rectangle?
+ My-Offset diameter diameter Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string)))
+
+(define (make-scaling-oval color-string . filled?)
+ (let ((width #F)
+ (height #F)
+ (width-1 #F)
+ (height-1 #F)
+ (a #F)
+ (b #F)
+ (center #F))
+ (let* ((angle (* 360 64)) ; X uses degrees/64
+ (Xdraw (if (or (null? filled?) (car filled?))
+ (lambda (uitkw gc x y)
+ (FillArc uitkw gc x y width height 0 angle))
+ (lambda (uitkw gc x y)
+ (DrawArc uitkw gc x y width-1 height-1 0 angle)))))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (Xdraw UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (set! width (UITKRectangle.Width assigned-screen-area))
+ (set! height (UITKRectangle.Height assigned-screen-area))
+ (set! width-1 (- width 1))
+ (set! height-1 (- height 1))
+ (set! a (/ width 2.0))
+ (set! b (/ height 2.0))
+ (set! center (make-point a b))
+ assigned-screen-area)
+ (lambda (My-Offset Offset) ; Point within?
+ (and (point-in-rectangle? Offset My-Offset width height)
+ (let* ((dv (sub-vectors (add-vectors my-offset center) offset))
+ (dx/a (/ (point.x dv) a))
+ (dy/b (/ (point.y dv) b)))
+ (< (+ (* dx/a dx/a) (* dy/b dy/b)) 1.0))))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?
+ (rectangle-overlaps-rectangle?
+ My-Offset width height Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string))))
+
+(define (make-filled-oval width height color-string)
+ (make-oval width height color-string #T))
+
+(define (make-unfilled-oval width height color-string)
+ (make-oval width height color-string #F))
+
+(define (make-filled-circle radius color-string)
+ (make-filled-oval (* radius 2) (* radius 2) color-string))
+
+(define (make-unfilled-circle radius color-string)
+ (make-unfilled-oval (* radius 2) (* radius 2) color-string))
+
+;;;not right? do lines need to be oriented (from to)
+
+(define (make-line width height color-string . filled?)
+ filled? ;ignore
+ (let ((width (round->exact width))
+ (height (round->exact height)))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (DrawLine UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)
+ (+ width (Point.X offset)) (+ height (Point.Y offset))))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (make-UITKRectangle (UITKRectangle.offset assigned-screen-area)
+ (make-size width height)))
+ (lambda (My-Offset Offset) ; Point within?!!FIX
+ (point-in-rectangle? Offset My-Offset Width Height))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?!!FIX
+ (rectangle-overlaps-rectangle?
+ My-Offset Width Height Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string)))
+
+
+;;;*******Still not right for rubber-banding (I think)
+
+(define (make-scaling-line color-string . filled?)
+ filled? ;ignore
+ (let ((width #F)
+ (height #F))
+ (make-shape
+ (lambda (UITKWindow graphics-context offset) ; Draw
+ (DrawLine UITKWindow graphics-context
+ (Point.X offset) (Point.Y offset)
+ (+ width (Point.X offset)) (+ height (Point.Y offset))))
+ (lambda (assigned-screen-area) ; Calculate-Used-Screen-Area
+ (set! height (UITKRectangle.Height assigned-screen-area))
+ (set! width (UITKRectangle.Width assigned-screen-area))
+ assigned-screen-area)
+ (lambda (My-Offset Offset) ; Point within?!!FIX
+ (point-in-rectangle? Offset My-Offset Width Height))
+ (lambda (My-Offset Offset W H) ; Rectangle overlaps?!!FIX
+ (rectangle-overlaps-rectangle?
+ My-Offset Width Height Offset W H))
+ (make-size width height) ; Desired-Size
+ color-string)))
+
+
+
+#|
+;;; points is a list of points. The offset of a path is the upper left-most
+;;; corner of the bounding box of the path. Make-path comes born with
+;;; a used screen area
+(define (make-path points color)
+ (if (null? points)
+ (error "no points in path -- MAKE-PATH"))
+ (let* ((xcors (map point.x points))
+ (ycors (map point.y points))
+ (xmin (apply min xcors))
+ (xmax (apply max xcors))
+ (ymin (apply min ycors))
+ (ymax (apply max ycors))
+ (width (- xmax xmin))
+ (height (- ymax ymin))
+ ;;adjust points so relative to upper-left
+ (xpoints (map (lambda (x) (- x xmin)) xcors))
+ (ypoints (map (lambda (y) (- y ymin)) ycors))
+ (shape
+ (make-shape
+ (lambda (UITKWindow graphics-context offset)
+ (let* ((ox (point.x offset))
+ (oy (point.y offset))
+ (xs (map (lambda (x) (+ x ox)) xpoints))
+ (ys (map (lambda (y) (+ y oy)) ypoints)))
+ (let loop ((fx (car xs))
+ (fy (car ys))
+ (restx (cdr xs))
+ (resty (cdr ys)))
+ (if (null? restx)
+ 'done
+ (begin (DrawLine UITKWindow graphics-context
+ fx fy (car restx) (car resty))
+ (loop (car restx) (car resty)
+ (cdr restx) (cdr resty)))))))
+ (lambda (assigned-screen-area)
+ ??????)
+ (lambda (point) ())
+ (lambda (rect) ())
+ desired-size
+ color)))
+ set up the used screen-area???
+ shape))
+
+FOO do just a line first
+
+
+or maybe just do draw path and draw line given some shape for which to
+use the uitkwindow.
+
+
+|#
+
+
+(define (self-paint! shape)
+ (handle-exposure shape
+ (lambda (exposed-rectangle)
+ (shape-draw shape (Rectangle->XRegion exposed-rectangle))))
+ (on-geometry-change! shape 'REASON
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area new-screen-area ; Not used
+ (if new-screen-area (shape-draw shape))))
+ 'done)
+
+(define (make-self-painting-rectangle width height color)
+ (let ((me (make-rect width height color)))
+ (self-paint! me)
+ me))
+
+(define (make-self-painting-unfilled-rectangle width height color)
+ (let ((me (make-unfilled-rectangle width height color)))
+ (self-paint! me)
+ me))
+
+(define (make-self-painting-circle radius color)
+ (let ((me (make-circle radius color)))
+ (self-paint! me)
+ me))
+
+
+;;; This is a surface that generates rectangles or ovals when you click on it.
+;;; Shapes grow with rubber banding.
+;;; After a shape is generated, it can be moved around.
+;;; You can choose either solid or outline mode for moving the shapes.
+;;;This is a little ugly, because I want to make sure that
+;;;make-rect is never called with negative width or height.
+
+(define (make-shape-surface width height background-color new-shape-color)
+ (let ((rubber-from #F)
+ (move-offset #F) ;offset of moving shape relative to mouse
+ (shadow-shape #F)
+ (fill-shadow-shapes? #F)
+ (shape-maker make-rect)
+ (rubber-shape-maker make-scaling-rect)
+ (shapes-and-areas '())
+ (shape->maker-map '())
+ (outer-rectangle (make-rect width height background-color)))
+
+ (define (shape->shape-and-area shape)
+ (cons shape (used-screen-area shape)))
+ (define (shape-and-area->shape s-and-a) (car s-and-a))
+ (define (shape-and-area->area s-and-a) (cdr s-and-a))
+ (define (set-shape-and-area-area! s-and-a area)
+ (let ((shape (shape-and-area->shape s-and-a)))
+ (assign-screen-area! shape area)
+ (set-cdr! s-and-a (used-screen-area shape))))
+
+ (define (process-click-on-shape shape-and-area e while-grabbed)
+ (let ((shape (shape-and-area->shape shape-and-area))
+ (area (shape-and-area->area shape-and-area)))
+ (set! move-offset
+ (sub-vectors (Event.Offset e)
+ (UITKRectangle.offset area)))
+ ;;;put shape at top
+ (set! shapes-and-areas
+ (append (delq! shape-and-area shapes-and-areas)
+ (list shape-and-area)))
+ (shape-draw shape)
+ (set! shadow-shape (shape->moving-shape shape))
+ (shape-erase shape) ;because shadow draws in XOR
+ (shape-draw shadow-shape)
+ (while-grabbed
+ (lambda (point) ; Motion procedure
+ (if (point-within? outer-rectangle point)
+ (begin
+ (shape-erase shadow-shape)
+ (assign-location! shadow-shape
+ (sub-vectors point move-offset))
+ (shape-draw shadow-shape))))
+ (lambda () ;finalization procedure
+ (set-shape-and-area-area! shape-and-area
+ (used-screen-area shadow-shape))
+ (shape-erase shadow-shape)
+ (shape-draw shape)))))
+
+ (define (process-click-on-background e while-grabbed)
+ (set! rubber-from (Event.Offset e))
+ (set! shadow-shape (make-rubber-shape))
+ (shape-draw shadow-shape)
+ (while-grabbed
+ (lambda (point) ; Motion procedure
+ (if (point-within? outer-rectangle point)
+ (grow-shadow-shape point)))
+ instantiate-shadow-shape)) ;finalization procedure
+
+ (define (instantiate-shadow-shape)
+ (let ((new-shape (screen-area->shape
+ shape-maker
+ (used-screen-area shadow-shape)
+ new-shape-color
+ #T))) ;always fill
+ (shape-erase shadow-shape)
+ (shape-draw new-shape)
+ (set! shapes-and-areas
+ (append shapes-and-areas
+ (list (shape->shape-and-area new-shape))))
+ ;;remember proc that shape was made with
+ (set! shape->maker-map
+ (cons (cons new-shape shape-maker)
+ shape->maker-map))))
+
+ (define (shape->moving-shape shape)
+ (let ((entry (assq shape shape->maker-map)))
+ (if (null? entry)
+ (error "shape not in shape->maker-map" shape))
+ (let ((moving-shape
+ (screen-area->shape (cdr entry)
+ (used-screen-area shape)
+ background-color
+ fill-shadow-shapes?)))
+ (set-xor-draw! moving-shape)
+ moving-shape)))
+
+ (define (screen-area->shape maker screen-area color fill?)
+ (let ((new-shape (maker (UITKRectangle.Width screen-area)
+ (UITKRectangle.Height screen-area)
+ color
+ fill?)))
+ (set-clip-region! new-shape
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))
+ (assign-geometry! new-shape
+ (drawing-surface outer-rectangle)
+ (copy-rectangle screen-area))
+ new-shape))
+
+ (define (make-rubber-shape)
+ (let ((new-shape
+ (rubber-shape-maker new-shape-color fill-shadow-shapes?)))
+ (set-clip-region! new-shape
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))
+ (set-shape-geometry! new-shape rubber-from rubber-from)
+ (set-xor-draw! new-shape)
+ new-shape))
+
+ (define (set-shape-geometry! shape from to)
+ (let ((x1 (point.x from))
+ (y1 (point.y from))
+ (x2 (point.x to))
+ (y2 (point.y to)))
+ (let* ((dx (- x2 x1))
+ (dy (- y2 y1))
+ (x-left (if (>= dx 0) x1 x2))
+ (y-top (if (>= dy 0) y1 y2)))
+ (assign-geometry! shape
+ (drawing-surface outer-rectangle)
+ (make-UITKRectangle (make-point x-left y-top)
+ (make-size (abs dx) (abs dy))))
+ 'DONE)))
+
+ (define (grow-shadow-shape to)
+ (shape-erase shadow-shape)
+ (set-shape-geometry! shadow-shape rubber-from to)
+ (shape-draw shadow-shape))
+
+ (define (find-shape-under-event event)
+ (let loop ((more-shapes (reverse shapes-and-areas)))
+ (cond ((null? more-shapes) #F)
+ ((event-within?
+ (shape-and-area->shape (car more-shapes)) event)
+ (car more-shapes))
+ (else (loop (cdr more-shapes))))))
+
+ (define (shape-erase shape)
+ (or (shape-erase-maybe shape)
+ (redraw-surface-except
+ shape
+ (rectangle->Xregion (used-screen-area shape)))))
+
+ (define (set-xor-draw! shape)
+ (shape-set-gc-function! shape GXXOR)
+ (shape-set-erase-function! shape (shape-draw-function shape))
+ (shape-set-color! shape background-color))
+
+ (define (redraw-surface-except shape clip-region)
+ (shape-draw outer-rectangle clip-region)
+ (for-each
+ (lambda (shape) (shape-draw shape clip-region))
+ (map shape-and-area->shape
+ (list-transform-negative shapes-and-areas
+ (lambda (shape-and-area)
+ (eq? shape (shape-and-area->shape shape-and-area)))))))
+
+ (define (redraw-surface clip-region)
+ (shape-draw outer-rectangle clip-region)
+ (for-each (lambda (shape) (shape-draw shape clip-region))
+ (map shape-and-area->shape shapes-and-areas)))
+
+ (handle-exposure outer-rectangle
+ (lambda (exposed-rectangle)
+ (redraw-surface (Rectangle->XRegion exposed-rectangle))))
+
+ (handle-button-grab
+ outer-rectangle ANYBUTTON
+ (lambda (e while-grabbed) ; When the button goes down
+ (let ((shape (find-shape-under-event e)))
+ (cond (shape (process-click-on-shape shape e while-grabbed))
+ ((event-within? outer-rectangle e)
+ (process-click-on-background e while-grabbed))
+ (else
+ (while-grabbed
+ (lambda (point) point 'OK) ; Nothing to do
+ (lambda () 'OK)))))))
+
+ (on-geometry-change!
+ outer-rectangle 'ignore
+ (lambda (old-screen-area new-screen-area)
+ (if (not (screen-area= old-screen-area new-screen-area))
+ (if (UITKRectangle? new-screen-area)
+ (let ((Clip (rectangle->XRegion new-screen-area)))
+ (for-each
+ (lambda (shape-and-area)
+ (let ((shape (shape-and-area->shape shape-and-area))
+ (area (shape-and-area->area shape-and-area)))
+ (set-clip-region! shape clip)
+ (set-shape-and-area-area!
+ shape-and-area
+ (make-UITKRectangle
+ (UITKRectangle.offset area)
+ (UITKRectangle.Size new-screen-area)))))
+ shapes-and-areas)
+ (redraw-surface clip))
+ (for-each (lambda (shape-and-area)
+ (let ((shape
+ (shape-and-area->shape shape-and-area)))
+ (set-clip-region! shape #F)
+ (assign-screen-area! shape #F)))
+ shapes-and-areas)))))
+ (lambda (message)
+ (case message
+ ((the-surface) outer-rectangle)
+ ((set-color!)
+ (lambda (string)
+ (set! new-shape-color string)))
+ ((rectangles)
+ (set! rubber-shape-maker make-scaling-rect)
+ (set! shape-maker make-rect))
+ ((ovals)
+ (set! rubber-shape-maker make-scaling-oval)
+ (set! shape-maker make-oval))
+ ((lines)
+ (set! rubber-shape-maker make-scaling-line)
+ (set! shape-maker make-line))
+ ((outlined) (set! fill-shadow-shapes? #F))
+ ((filled) (set! fill-shadow-shapes? #T))
+ ((clear)
+ (begin (set! shapes-and-areas '())
+ (set! shape->maker-map '())
+ (redraw-surface
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))))
+ (else (error "unknown message"))))))
+
+
+
+
+;;;;******This isn't working. I don't understand how to manage the
+;;;;event queue
+
+(define debug-surface)
+
+(define (make-drop-rubber-rectangle-surface app width height color shape-color)
+ (let ((rubber-from #F) ; X,Y of click relative to dragging shape
+ (rubber-to #F)
+ (active-shape #F)
+ (shadow-shape #F)
+ (fill-rubber-shapes? #F)
+ (shape-maker make-rect)
+ (shadow-shape-maker make-scaling-rect)
+ (shapes '())
+ (outer-rectangle (make-rect width height color)))
+ (set! debug-surface (lambda () 'foo))
+ (define (pick-random-shape)
+ (let ((l (length shapes)))
+ (list-ref shapes (random l))))
+ (define (drop)
+ (if (not (null? shapes))
+ (let* ((s (pick-random-shape)))
+ (redraw-surface-except s (rectangle->Xregion (used-screen-area s)))
+ (let* ((p (UITKRectangle.offset (used-screen-area s)))
+ (x (point.x p))
+ (y (point.y p)))
+ (if (> y (+ (point.y (UITKRectangle.offset
+ (used-screen-area outer-rectangle)))
+ height))
+ (begin (set! shapes (delq! s shapes))
+ 'OK)
+ (begin (assign-location! s (make-point x (+ y 5)))
+ (shape-draw s))))
+ (when-idle! app drop))))
+ (define (find-shape event)
+ (let loop ((more-shapes (reverse shapes)))
+ (cond ((null? more-shapes) #F)
+ ((event-within? (car more-shapes) event)
+ (let ((this (car more-shapes)))
+ (set! shapes (append (delq! this shapes) (list this)))
+ this))
+ (else (loop (cdr more-shapes))))))
+ (define (process-click-on-active-shape e while-grabbed)
+ (let ((Click (Event.Offset e))
+ (screen-area (used-screen-area active-shape)))
+ (set! rubber-from (sub-vectors Click
+ (UITKRectangle.offset screen-area)))
+ ;;bring active shape to top
+ (shape-draw active-shape)
+ (while-grabbed
+ (lambda (point) ; Motion procedure ...
+ (if (point-within? outer-rectangle point) ; maybe
+ (move-active-shape (sub-vectors point rubber-from))))
+ (lambda () (set! active-shape #F)) ;finalize
+ )))
+ (define (process-click-on-background e while-grabbed)
+ (let ((Click (Event.Offset e)))
+ (initialize-rubber-rectangle Click)
+ (while-grabbed
+ (lambda (point) ; Motion procedure ...
+ (if (point-within? outer-rectangle point) ; maybe
+ (grow-rubber-rectangle point)))
+ instantiate-rubber-rectangle))) ;finalize
+
+ (define (instantiate-rubber-rectangle)
+ (let* ((used (used-screen-area shadow-shape))
+ (new-shape (shape-maker (UITKRectangle.Width used)
+ (UITKRectangle.Height used)
+ new-shape-color)))
+ (shape-erase shadow-shape)
+ (set! shadow-shape #F)
+ (set-clip-region! new-shape
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))
+ (set-shape-geometry! new-shape)
+ (shape-draw new-shape)
+ (set! shapes (append shapes (list new-shape)))
+ (when-idle! app drop)))
+
+ (define (initialize-rubber-rectangle Click)
+ (set! rubber-from Click)
+ (make-rubber-rectangle Click))
+
+ (define (make-rubber-rectangle to)
+ (set! rubber-to to)
+ (set! shadow-shape (shadow-shape-maker "white" fill-rubber-shapes?))
+ (set-clip-region! shadow-shape
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))
+ (set-shape-geometry! shadow-shape)
+ (shape-set-gc-function! shadow-shape GXXOR)
+ (shape-set-erase-function! shadow-shape
+ (shape-draw-function shadow-shape))
+ (shape-draw shadow-shape))
+
+ (define (set-shape-geometry! shape)
+ (let ((x1 (point.x rubber-from))
+ (y1 (point.y rubber-from))
+ (x2 (point.x rubber-to))
+ (y2 (point.y rubber-to)))
+ (let* ((dx (- x2 x1))
+ (dy (- y2 y1))
+ (x-left (if (>= dx 0) x1 x2))
+ (y-top (if (>= dy 0) y1 y2)))
+ (assign-geometry! shape
+ (drawing-surface outer-rectangle)
+ (make-UITKRectangle (make-point x-left y-top)
+ (make-size (abs dx) (abs dy))))
+ 'DONE)))
+
+ (define (grow-rubber-rectangle point)
+ (set! rubber-to point)
+ (shape-erase shadow-shape) ; Can't fail!
+ (set-shape-geometry! shadow-shape)
+ (shape-draw shadow-shape))
+
+ (define (redraw-surface-except shape clip-region)
+ (shape-draw outer-rectangle clip-region)
+ (for-each (lambda (shape) (shape-draw shape clip-region))
+ (delq shape shapes)))
+ (define (redraw-surface clip-region)
+ (shape-draw outer-rectangle clip-region)
+ (for-each (lambda (shape) (shape-draw shape clip-region))
+ shapes))
+ (define (move-active-shape to-point)
+ (let ((screen-area (used-screen-area active-shape)))
+ (redraw-surface-except active-shape
+ (rectangle->XRegion screen-area))
+ (assign-location! active-shape to-point)
+ (shape-draw active-shape)))
+
+ (handle-exposure outer-rectangle
+ (lambda (exposed-rectangle)
+ (redraw-surface (Rectangle->XRegion exposed-rectangle))))
+
+ (handle-button-grab
+ outer-rectangle ANYBUTTON
+ (lambda (e while-grabbed) ; When the button goes down
+ (set! active-shape (find-shape e))
+ (cond (active-shape (process-click-on-active-shape e while-grabbed))
+ ((event-within? outer-rectangle e)
+ (process-click-on-background e while-grabbed))
+ (else
+ (while-grabbed
+ (lambda (point) point 'OK) ; Nothing to do
+ (lambda () (set! active-shape #F)))))))
+
+ (on-geometry-change!
+ outer-rectangle 'ignore
+ (lambda (old-screen-area new-screen-area)
+ old-screen-area
+ (let ((ds (drawing-surface outer-rectangle)))
+ (if (UITKRectangle? new-screen-area)
+ (let ((Clip (rectangle->XRegion new-screen-area)))
+ (for-each
+ (lambda (shape)
+ (set-clip-region! shape clip)
+ (assign-geometry! shape ds new-screen-area))
+ shapes)
+ (redraw-surface clip))
+ (for-each (lambda (shape)
+ (set-clip-region! shape #F)
+ (assign-screen-area! shape #F))
+ shapes)))))
+ (when-idle! app drop)
+ (lambda (message)
+ (case message
+ ((the-surface) outer-rectangle)
+ ((set-color!)
+ (lambda (new-shape-color-name)
+ (let* ((dsp (UITKWindow.XDisplay
+ (DrawingSurface.UITKWindow
+ (Drawing-Surface outer-rectangle))))
+ (color ((string->color dsp) new-shape-color-name)))
+ (if color
+ (begin
+ (set! new-shape-color new-color-name)
+ 'OK)
+ #F))))
+ ((rectangles)
+ (set! shadow-shape-maker make-scaling-rect)
+ (set! shape-maker make-rect))
+ ((ovals)
+ (set! shadow-shape-maker make-scaling-oval)
+ (set! shape-maker make-oval))
+ ((outlined) (set! fill-rubber-shapes? #F))
+ ((filled) (set! fill-rubber-shapes? #T))
+ ((clear)
+ (begin (set! shapes '())
+ (redraw-surface
+ (rectangle->XRegion
+ (used-screen-area outer-rectangle)))))
+ (else (error "unknown message"))))))
--- /dev/null
+;;;;; -*- Scheme -*-
+;;;;;
+;;;;; derived from uitk.scm at MIT on April 24, 1993
+;;;;; $Id: structures.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+
+;;;; Commonly used structure definitions. They are here so that the
+;;;; macro versions can be loaded to improve performance.
+
+(scc-define-structure UITKWindow
+ xdisplay ; X display connection
+ xwindow) ; X window ID
+
+(scc-define-structure ToolKitWindow ; For TK or whatever
+ Application ; For GC protection of TK Widgets
+ Top-Level-Geometry-Callback ; From TK to us (for GC, too)
+ TK-Window) ; *Un*wrapped!
+
+(scc-define-structure DrawingSurface
+ ToolKitWindow
+ UITKWindow
+ (Weak-List-of-Widgets '())) ; Ones that use this surface
+
+(scc-define-structure Point X Y)
+
+(scc-define-structure UITKRectangle Offset Size)
+
+(scc-define-structure Size Width Height)
+
+(scc-define-structure context
+ activebackground activeforeground anchor background
+ border borderwidth
+ ;; cursor
+ ;; font
+ foreground relief)
+
+(scc-define-structure alert reason function)
+
+(scc-define-structure queue
+ (%head #F)
+ (%tail #F))
+
+(scc-define-structure locked-list
+ (%mutex (make-thread-mutex))
+ (%data '()))
+
+(scc-define-structure surface-sensitivity
+ Weak-Surface
+ Mask
+ Sensitivities)
+
+(scc-define-structure sensitivity
+ %weak-<interactor>
+ Masks)
+
+(scc-define-structure sensitive-surface
+ DrawingSurface
+ Handlers)
+
+(scc-define-structure TK-variable
+ application
+ tk-name
+ callback ;on writes
+ )
+
+(scc-define-structure scxl-wrapper
+ type
+ wrapped-object
+ strong-dependents
+ other-stuff)
+
+
+(scc-define-structure Event
+ Point-or-rectangle?
+ Type
+ OS-Event
+ Window
+ Offset
+ Width
+ Height)
+
+(scc-define-structure Glue
+ minsize
+ class
+ value)
+
+;;; Applications, interactors, boxes, shapes, tkwidgets
+;;; all share these internals. These slots will be the first thing in
+;;; the structure.
+
+(scc-define-structure UIObjInternals
+ Add-Child!-procedure
+ Remove-Child!-procedure
+ Set-Context!-procedure
+ Assign-Screen-Area!-procedure
+ Assign-Drawing-Surface!-procedure
+ Point-Within?-procedure
+ Rectangle-Overlaps?-procedure
+ Handle-Event-procedure
+ Get-Desired-Size-procedure
+ Assigned-Screen-Area-procedure
+ Used-Screen-Area-procedure
+ Set-Assigned-Screen-Area!-procedure
+ Set-Used-Screen-Area!-procedure
+ Assign-Glue!-procedure
+ (%geometry-alerts '())
+ (%event-alerts '())
+ (%context-alerts '())
+ (%death-alerts '())
+ (Assigned-Screen-Area #F)
+ (Used-Screen-Area #F)
+ (clip-region #F)
+ (drawing-surface 'UNASSIGNED)
+ (%desired-size #F)
+ (%vglue #F) ; for boxes, shapes
+ (%hglue #F) ; and tkwidgets only
+ ;; Hal says:
+ ;; "Success has many parents, but a UIObj has only one"
+ (already-have-a-parent? #F)
+ ;; Second '() is a special list for canvas and text items, that
+ ;; might need to be un-gc-protected all at once.
+ (crud-that-I-dont-want-to-gc-away (cons '() '()))
+ )
+
+;;;Generic procedures on objects that have UIObj internals
+
+(define-integrable uiobjinternals-index 1)
+
+
--- /dev/null
+;;; -*- Scheme -*-
+
+;;; More structures. With all this macro expansion, the compiler runs
+;;; out of space if they are all in one file.
+
+(scc-define-structure Application%
+ UIObjInternals
+ %child-windows ; Locked list of all children
+ %%%code%%% ; Asynchronous code to be
+ ; executed when data arrives
+ ; from the display connection
+ application-name
+ Xdisplay ; A SCXL-wrapped display
+ TKMainWindow
+ context)
+
+(scc-define-structure Interactor%
+ UIObjInternals
+ handlers
+ ;; Map from children of the interactor -- things it manages --
+ ;; to Sensitive-Surface data structures. These are implemented
+ ;; at the end of the file and maintain the correspondence
+ ;; between drawing surfaces, event generation masks, and
+ ;; <interactor> objects.
+ (sensitive-surface-map '()))
+
+(scc-define-structure Shape%
+ UIObjInternals
+ x-draw
+ calculate-used-screen-area
+ color
+ point-within?
+ rectangle-overlaps?
+ (x-erase #F)
+ gc-function
+ (graphics-context #F))
+
+(scc-define-structure Box%
+ UIObjInternals
+ sizer
+ arranger
+ get-hglue
+ get-vglue
+ (kids '()))
+
+(scc-define-structure ArrayBox%
+ UIObjInternals
+ kids-lists
+ (kids '()))
+
+(scc-define-structure TKWidget%
+ UIObjInternals
+ Ask-Widget-procedure
+ Add-Event-Handler!-procedure
+ Set-Callback!-procedure
+ (deferred-ask-widget-commands '())
+ (how-to-make-me 'later)
+ ;; Parent-Window -- stored as assigned screen area
+ (Set-Glue!-procedure 'later)
+ (%c-callback 'later)
+ (%binding-callbacks '())
+ (%scheme-geometry-manager 'later)
+ (%scheme-callback-hash 'later)
+ (%callback #F)
+ (%callback-command #F)
+ (%children '())
+ (handle #F)
+ (do-screen-area? 'later)
+ ;; The following is weird. TK does finalization of some TK objects
+ ;; (sub-menus bit us ...) and we can *not* destroy these on our own.
+ ;; We simply reflect the ownership (via add-child!) to prevent them
+ ;; from being GCed away if the TK parent exists. And the child
+ ;; better hold on to the parent, too.
+ (do-not-gc-protect #F))
+
+(scc-define-structure CanvasItem
+ Ask-Widget-procedure
+ Add-Event-Handler!-procedure
+ Set-Callback!-procedure
+ Name
+ Canvas
+ %binding-callbacks)
+
+(scc-define-structure CanvasItemGroup
+ Ask-Widget-procedure
+ Add-Event-Handler!-procedure
+ Set-Callback!-procedure
+ Tag
+ Canvas
+ %binding-callbacks)
+
+(scc-define-structure MenuRecord Menu Items)
+
+(scc-define-structure MenuItem
+ ask-widget-procedure
+ Add-event-handler!-procedure
+ Set-callback!-procedure
+ MenuRecord
+ %callback
+ index)
+
+(scc-define-structure TextTag
+ ask-widget-procedure
+ Add-event-handler!-procedure
+ Set-callback!-procedure
+ Name
+ Text
+ Callbacks)
+
+;;; procedures that are generic over CanvasItem, CanvasTag, MenuItem,
+;;; TextTag, and TKWidget
+
+(define-integrable ask-widget-procedure-index 1)
+(define-integrable add-event-handler!-procedure-index 2)
+(define-integrable set-callback!-procedure-index 3)
+
+
+
--- /dev/null
+;;; -*-Scheme-*-
+
+;;(define (cf-conditionally filename)
+;; (sf-conditionally filename)
+;; (if (not (file-processed? filename "bin" "com"))
+;; (compile-bin-file filename)))
+;;
+;;
+;;(fluid-let ((sf/default-syntax-table syntax-table/system-internal)
+;; (sf/default-declarations (cons '(usual-integrations)
+;; sf/default-declarations)))
+;; (cf-conditionally "scc-macros")
+;; (load "scc-macros")
+;; (cf-conditionally "uitk-macros")
+;; (load "uitk-macros")
+;; (cf-conditionally "control-floating-errors")
+;; (cf-conditionally "structures")
+;; (cf-conditionally "structures2")
+;; (cf-conditionally "generics")
+;; (cf-conditionally "widget-mit")
+;; (cf-conditionally "tk-mit")
+;; (cf-conditionally "uitk")
+;; (cf-conditionally "xlibCONSTANTS")
+;; (cf-conditionally "mit-xlib")
+;; (cf-conditionally "mit-xhooks")
+;; (cf-conditionally "baseobj")
+;; (cf-conditionally "widget")
+;; (cf-conditionally "geometry")
+;; (cf-conditionally "simple")
+;; (cf-conditionally "canvas")
+;; (cf-conditionally "menu")
+;; (cf-conditionally "text")
+;;
+;; )
+;;
+
+
+
+(compile-directory ".")
+
+;; For `make install':
+
+(with-output-to-file "compiled"
+ (lambda ()
+ (write "Scheme compiled")))
\ No newline at end of file
--- /dev/null
+
+(fluid-let ((sf/default-syntax-table syntax-table/system-internal)
+ (sf/default-declarations
+ `((usual-integrations) ,@sf/default-declarations)))
+
+ (sf-conditionally "scc-macros")
+ (load "scc-macros")
+ (sf-conditionally "uitk-macros")
+ (load "uitk-macros")
+ (sf-conditionally "structures")
+ (sf-conditionally "structures2")
+ (sf-conditionally "xlibCONSTANTS")
+
+ (fluid-let ((sf/default-declarations
+ `((integrate-external "structures")
+ (integrate-external "structures2")
+ (integrate-external "xlibCONSTANTS")
+ ,@sf/default-declarations)))
+ (sf-conditionally "control-floating-errors")
+ (sf-conditionally "generics")
+ (sf-conditionally "widget-mit")
+ (sf-conditionally "tk-mit")
+ (sf-conditionally "uitk")
+ (sf-conditionally "mit-xlib")
+ (sf-conditionally "mit-xhooks")
+ (sf-conditionally "baseobj")
+ (sf-conditionally "widget")
+ (sf-conditionally "geometry")
+ (sf-conditionally "simple")
+ (sf-conditionally "canvas")
+ (sf-conditionally "menu")
+ (sf-conditionally "text")
+ ))
+
+;;(load-option 'CREF)
+;;(cref/generate-constructors "swat")
+;;(sf "swat.con")
+;;(sf "swat.ldr")
\ No newline at end of file
--- /dev/null
+;;; -*- Scheme -*-
+
+;;; Scrollable text widgets (only vertical scrollbar makes sense,
+;;; since text can't be extended horizontally without changing the
+;;; size of the top level window).
+
+#|
+(define (make-scrollable-text . options)
+ (let ((text (apply make-text options))
+ (vscroll (make-scrollbar '(-orient vert))))
+ (let ((sb-command
+ (lambda ()
+ (ask-widget
+ vscroll
+ `(configure -command
+ ,(string-append (tk-widget->pathname text)
+ " yview")))))
+ (c-command
+ (lambda ()
+ (ask-widget
+ text
+ `(configure -yscrollcommand
+ ,(string-append (tk-widget->pathname vscroll) " set"))))))
+ (defer text sb-command)
+ (defer vscroll c-command)
+ (make-hbox text vscroll))))
+|#
+
+(define (make-scrollable-text . options)
+ (let ((text (apply make-text options))
+ (vscroll (make-scrollbar '(-orient vert))))
+ (let ((c-command
+ (lambda ()
+ (ask-widget
+ text
+ `(configure -yscrollcommand
+ ,(string-append (tk-widget->pathname vscroll) " set"))))))
+ (defer vscroll c-command)
+ (set-callback!
+ vscroll
+ (lambda (n)
+ (let ((n (string->number n)))
+ (ask-widget text `(yview -pickplace ,n)))))
+ (make-hbox text vscroll))))
+
+(define (scrollable-text-text scrollable-text)
+ (car (box-children scrollable text)))
+
+(define (scrollable-text-vscroll scrollable-text)
+ (cadr (box-children scrollable-text)))
+
+
+
+;;; Text has special protect-from-gc! procedures
+
+(define (text-protect-from-gc! text stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away text)))
+ (set-cdr! crud (cons stuff (cdr crud))))
+ 'done)
+
+(define (text-unprotect-from-gc! text stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away text)))
+ (set-cdr! crud (delq! stuff (cdr crud))))
+ 'done)
+
+(define (text-flush-protect-list! text)
+ (let ((crud (crud-that-I-dont-want-to-gc-away text)))
+ (set-cdr! crud '()))
+ 'done)
+
+
+
+;;; TextTags
+
+(define (make-text-tag text index1 . index2)
+ (let ((name (tk-gen-name "texttag")))
+ (ask-widget text `(tag add ,name ,index1 ,@index2))
+ (let ((texttag (make-texttag texttag-ask-widget
+ texttag-add-event-handler!
+ 'invalid
+ name
+ text
+ '())))
+ (text-protect-from-gc! text texttag)
+ texttag)))
+
+(define (texttag-add-event-handler! tag event handler substitutions)
+ (let ((text (TextTag.text tag))
+ (handler (proc-with-transformed-args handler substitutions)))
+ (set-texttag.callbacks! tag
+ (cons handler (texttag.callbacks tag)))
+ (ask-widget text
+ `(tag bind
+ ,(TextTag.name tag)
+ ,event
+ ("SchemeCallBack" ,(object-hash handler *our-hash-table*)
+ ,@substitutions)))))
+
+(define (texttag-ask-widget tag arg-list)
+ (let* ((tag-name (TextTag.name tag))
+ (text (TextTag.text tag))
+ (command (car arg-list))
+ (new-arg-list (cons "tag"
+ (cons command
+ (cons tag-name (cdr arg-list))))))
+ (let ((result (ask-widget text new-arg-list)))
+ (if (eq? command 'delete)
+ (text-unprotect-from-gc! text tag))
+ result)))
+
--- /dev/null
+; -*- Scheme -*-
+;;;;; C external interfaces to Tk procedures not associated with
+;;;;; a particular widget.
+;;;; $Id: tk-mit.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+
+;;;; This is the lowest level Scheme interface to general TK/TCL data
+;;;; structures. Primitives are defined in tk-mit.c and tk.c
+
+(define-primitives
+ (%tclGlobalEval 2)
+ (%tkCompletelyHandlesEvent? 1)
+ (%tkCreateTopLevelWindow 3)
+ (%tkDoEvents 0)
+ (%tkDrainCallBacks 2)
+ (%tkGenerateSchemeEvent 2)
+ (%tkInit 2)
+ (%tkInvokeCommand -1)
+ (%tkKillApplication 1)
+ (%tkManageGeometry 2)
+ (%tkMapWindow 1)
+ (%tkMoveResizeWindow 5)
+ (%tkMoveWindow 3)
+ (%tkNextWakeup 0)
+ (%tkResizeWindow 3)
+ (%tkUnmapWindow 1)
+ (%tkWidget.tkwin 1)
+ (%tkWinDisplay 1)
+ (%tkWinReqHeight 1)
+ (%tkWinReqWidth 1)
+ (%tkWinHeight 1)
+ (%tkWinIsMapped? 1)
+ (%tkWinName 1)
+ (%tkWinPathName 1)
+ (%tkWinWidth 1)
+ (%tkWinWindow 1)
+ (%tkWinX 1)
+ (%tkWinY 1)
+)
+
+;;;; Support code
+
+(define tk-gen-name
+ (let ((count 0))
+ (lambda (name)
+ (set! count (+ 1 count))
+ (string-append name (number->string count)))))
+\f
+;;;; Entry points in alphabetical order
+
+(define (get-interval-to-tk-wakeup)
+ (%tkNextWakeup))
+
+
+;;; A not-so-precise number->string that is faster and more than
+;;; sufficient for our purposes.
+
+(define (swat:number->string x)
+
+ (define (digits x n tail)
+ (define (next* ch x*)
+ (cons ch (digits x* (fix:- n 1) tail)))
+ (define-integrable (next ch delta)
+ (next* ch (flo:* (flo:- x delta) 10.0)))
+ (cond ((< n 0) tail)
+ ((flo:< x 1.e-10) tail)
+ ((flo:< x 1.0) (next #\0 0.0))
+ ((flo:< x 2.0) (next #\1 1.0))
+ ((flo:< x 3.0) (next #\2 2.0))
+ ((flo:< x 4.0) (next #\3 3.0))
+ ((flo:< x 5.0) (next #\4 4.0))
+ ((flo:< x 6.0) (next #\5 5.0))
+ ((flo:< x 7.0) (next #\6 6.0))
+ ((flo:< x 8.0) (next #\7 7.0))
+ ((flo:< x 9.0) (next #\8 8.0))
+ (else (next #\9 9.0))))
+
+ (define (format-exponent e)
+ (define (format-integer n tail)
+ (define (+digit k) (cons (ascii->char (fix:+ k 48)) tail))
+ (if (fix:< n 10)
+ (+digit n)
+ (let ((front (fix:quotient n 10))
+ (back (fix:remainder n 10)))
+ (format-integer front (+digit back)))))
+ (cond ((fix:= e 0) '())
+ ((fix:< e 0)
+ (cons* #\e #\- (format-integer (fix:- 0 e) '())))
+ (else
+ (cons* #\e (format-integer e '())))))
+
+ (define (scale x e)
+ (cond ((flo:< x 1.0e-30) '(#\0 #\. #\0))
+ ((flo:< x 1.0) (scale (flo:* x 1000.0) (- e 3)))
+ ((flo:< x 10.0)
+ (let* ((tail (format-exponent e))
+ (ds (digits x 8 tail)))
+ (if (eq? (cdr ds) tail)
+ (cons* (car ds) #\. #\0 (cdr ds))
+ (cons* (car ds) #\. (cdr ds)))))
+ (else (scale (flo:* x 0.1) (+ e 1)))))
+
+ (if (flo:flonum? x)
+ (list->string
+ (if (flo:< x 0.0)
+ (cons #\- (scale (flo:- 0.0 x) 0))
+ (scale x 0)))
+ (number->string x 10)))
+
+
+#|
+;;; This is a kludge to prevent tk from thinking that .7 is a name and
+;;; not a number.
+(define (number->tk-string n)
+ (let ((abs-n (abs n)))
+ (if (< abs-n 1)
+ (let ((s (swat:number->string abs-n)))
+ (if (< n 0)
+ (string-append "-0" s)
+ (string-append "0" s)))
+ (swat:number->string n))))
+|#
+
+(define (stringify-for-tk arg)
+ (define (->string arg)
+ (cond ((string? arg) arg)
+ ((number? arg)
+ ;;(number->tk-string arg)
+ (swat:number->string arg)
+ )
+ ((symbol? arg) (symbol->string arg))
+ ((TK-variable? arg) (TK-variable.tk-name arg))
+ ((pair? arg) (apply string-append (map stringify-for-tk arg)))
+ ((procedure? arg) (->string (arg)))
+ (else (error "tcl-global-eval: Unknown argument type"
+ arg))))
+ (string-append "{" (->string arg) "} "))
+
+(define (tk-op thunk)
+ (let ((result (thunk)))
+ (kick-uitk-thread)
+ result))
+
+(define (tcl-global-eval application command-name args)
+ (tk-op
+ (lambda ()
+ (%tclGlobalEval
+ (application->TKMainWindow application)
+ (apply string-append
+ (map stringify-for-tk (cons command-name args)))))))
+
+;;;turn off all floating errors around TK processing
+;;;Note that we don't need a dynamic wind because
+;;;%tkCompletelyHandlesEvent? always completes. If the argument is
+;;;bad it returns a 0.
+
+(define (tk-completely-handles-event? os-event)
+ (let ((old-mask (set-floating-error-mask! 0)))
+ (let ((result (%tkCompletelyHandlesEvent? os-event)))
+ (set-floating-error-mask! old-mask)
+ (if (eq? result 0)
+ (error "bad argument to tk-completely-handles-event?" os-event)
+ result))))
+
+(define (tk-create-top-level-window main-window callbackhash)
+ (tk-op
+ (lambda ()
+ (%tkCreateTopLevelWindow main-window
+ (tk-gen-name "top-level-window")
+ callbackhash))))
+
+(define (tk-doevents)
+ ;; Turn off floating errors
+ (let ((old-mask (set-floating-error-mask! 0)))
+ ;; Do all pending Tk events, which should only be do-when-idles
+ (%tkDoEvents)
+ (set-floating-error-mask! old-mask))
+ (do-tk-callbacks))
+
+(define (tk-generate-Scheme-event event-mask unwrapped-tk-window)
+ ;; Cause TK to signal us that Scheme wants to know about these kinds
+ ;; of events on this window.
+ (%tkGenerateSchemeEvent event-mask unwrapped-tk-window))
+
+(define (tk-init xdisplay)
+ ;; Set up an initial environment with a Tcl interpreter
+ (tk-op
+ (lambda ()
+ (%tkInit (->xdisplay xdisplay)
+ (tk-gen-name
+ (string-append "main-window-for-display-"
+ (number->string (->xdisplay xdisplay))))))))
+
+(define (tk-invoke-command command-name main-window arg-strings)
+ (define commands
+ `((After . 0)
+ (Bind . 1)
+ (Destroy . 2)
+ (Focus . 3)
+ (Grab . 4)
+ (Option . 5)
+ (Pack . 6)
+ (Place . 7)
+ (Selection . 8)
+ (Tk . 9)
+ (Tkwait . 10)
+ (Update . 11)
+ (Winfo . 12)
+ (Wm . 13)))
+ (tk-op
+ (lambda ()
+ (apply %tkInvokeCommand (cdr (assq command-name commands))
+ main-window
+ arg-strings))))
+
+(define (tk-kill-application main-window)
+ ;; main-window is an integer, not wrapped
+ (%tkKillApplication main-window))
+
+(define (tk-manage-geometry widget manager-procedure)
+ ;; Arrange for manager-procedure to be called with no arguments
+ ;; whenever TK requests geometry operations on widget.
+ (tk-op
+ (lambda ()
+ (%tkManageGeometry (tk-widget.tkwin widget)
+ (and manager-procedure
+ (hash manager-procedure
+ *our-hash-table*))))))
+
+(define (tk-map-window tkwin)
+ (tk-op (lambda () (%tkmapwindow tkwin))))
+
+(define (tk-move-resize-widget widget screen-area)
+ (tk-op
+ (lambda ()
+ (%tkMoveResizeWindow (tk-widget.tkwin widget)
+ (Point.X (UITKRectangle.Offset screen-area))
+ (Point.Y (UITKRectangle.Offset screen-area))
+ (UITKRectangle.Width screen-area)
+ (UITKRectangle.Height screen-area)))))
+
+(define (TK-Unmap-Window tkwin)
+ (tk-op (lambda () (%tkUnmapWindow tkwin))))
+
+(define (tk-widget.tkwin widget)
+ (%tkWidget.tkwin (->widget widget)))
+
+(define (tkwin.display tkwin)
+ (%tkWinDisplay tkwin))
+
+(define (tkwin.req-height tkwin)
+ (%tkWinReqHeight tkwin))
+
+(define (tkwin.req-width tkwin)
+ (%tkWinReqWidth tkwin))
+
+(define (tkwin.height tkwin)
+ (%tkWinHeight tkwin))
+
+(define (tkwin.IsMapped? tkwin)
+ (%tkWinIsMapped? tkwin))
+
+(define (tkwin.width tkwin)
+ (%tkWinWidth tkwin))
+
+(define (tkwin.window tkwin)
+ ;; Deliberately don't do a wrap-window. Instead, allow a higher
+ ;; level to do it, since the server maintains the window hierarchy
+ ;; and effectively keeps pointers for us.
+ (%tkWinWindow tkwin))
+
+(define (tkwin.name tkwin)
+ (%tkWinName tkwin))
+
+(define (tkwin.pathname tkwin)
+ (%tkWinPathName tkwin))
+
+(define (tkwin.x tkwin)
+ (%tkWinX tkwin))
+
+(define (tkwin.y tkwin)
+ (%tkWinY tkwin))
+\f
+;;;; TK Callback handling
+
+(define (do-tk-callbacks-from-string string)
+ ;; The string has the following format:
+ ;; <char. count>
+ ;; <nchars>chars
+ ;; <nchars>chars
+ ;; ...
+ ;; where <char. count> is the number of characters in the object ID
+ ;; and its associated string arguments. The "<" and ">" are NOT
+ ;; meta-characters; they are used for separating the entries and
+ ;; error detection.
+ (define (split-string-by-number string receiver)
+ ;; Expects a character count in angle brackets. Calls receiver
+ ;; with the counted string and the rest, or #F/#F if the string is
+ ;; empty.
+ (cond
+ ((string-null? string) (receiver #F #F))
+ ((not (char=? (string-ref string 0) #\<))
+ (error "Split-String-By-Number: Badly formed entry"
+ string))
+ (else
+ (let ((break-at (string-find-next-char string #\>)))
+ (if (not break-at)
+ (error "Split-String-By-Number: entry not terminated"
+ string)
+ (let ((count (string->number (substring string 1 break-at)))
+ (after-count (+ break-at 1))
+ (slength (string-length string)))
+ (cond
+ ((not count)
+ (error "Split-String-By-Number: non-numeric count" string))
+ ((> (+ after-count count) slength)
+ (error "Split-String-By-Number: count too big" string))
+ (else
+ (let ((end (+ after-count count)))
+ (receiver (substring string after-count end)
+ (substring string end slength)))))))))))
+ (define (parse-entry string receiver)
+ ;; Entry starts with a character count in angle brackets
+ ;; Receiver is called with an object, a vector of strings, and the
+ ;; remaining string.
+ (split-string-by-number string
+ (lambda (entry after-entry)
+ (let loop ((rest entry)
+ (strings '()))
+ (split-string-by-number rest
+ (lambda (this-string rest-of-strings)
+ (if this-string
+ (loop rest-of-strings
+ (cons this-string strings))
+ (let ((all-strings (reverse strings)))
+ (if (null? all-strings)
+ (error "Parse-Entry: no entries" string))
+ (let* ((Object-Name (car all-strings))
+ (Object-ID (string->number object-name)))
+ (if (not object-id)
+ (error "Parse-Entry: non-number object ID"
+ string object-name))
+ ;; Note that the object associated with object-id
+ ;; may have been GCed away!
+ (receiver (object-unhash object-id *our-hash-table*)
+ (cdr all-strings)
+ after-entry))))))))))
+ (if string
+ (let callback-loop ((string string))
+ (if (string-null? string)
+ 'done
+ (parse-entry string
+ (lambda (callback list-of-string-args rest-of-string)
+ ;; "callback" will be #F if it GC'ed away
+ (if callback
+ (our-with-thread-mutex-locked
+ 'do-tk-callback
+ *event-processing-mutex*
+ (lambda ()
+ (apply callback list-of-string-args))))
+ (callback-loop rest-of-string))))))
+ 'OK)
+
+(define *event-processing-mutex* (make-thread-mutex))
+
+(define do-tk-callbacks
+ (let ((nchars 0)
+ (string (make-string 0)))
+ (lambda ()
+ (let ((nchars-ready (%tkDrainCallBacks nchars string)))
+ (if nchars-ready
+ (if
+ (positive? nchars-ready)
+ (begin
+ (set! nchars nchars-ready)
+ (set! string (make-string nchars-ready))
+ (do-tk-callbacks))
+ 'OK)
+ (do-tk-callbacks-from-string string))))))
+
--- /dev/null
+;;;; -*-Scheme-*-
+;;; $Id: uitk-macros.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+;;; derived from macros.sc,v 1.1 1993/02/16 14:04:09 jmiller Exp $
+;;; Primitive X toolkit for Scheme->C.
+;;; RHH, September, 1989.
+;;; Macro definitions.
+
+;;; Stolen on January 17, 1993 by Jim Miller for use with UITK
+;;; Updated on June 27, 1993 by a bunch of us to use records instead
+;;; of vectors.
+
+;;;; SCC-DEFINE-STRUCTURE
+
+;;;; Components can be:
+;;;; a symbol (name of structure component)
+;;;; a pair (name and default value)
+;;;; Produces (in-lined)
+;;;; predicate procedure: (<name>? object)
+;;;; accessor procedures: (<name>.<component> object)
+;;;; mutator procedures: (SET-<name>.<component>! object new-value)
+;;;; internal constants: *-<name>.<component>-*
+;;;; internal contant: *-<name>.STRUCTURE-SIZE-*
+;;;; (re-)initialization procedure: (INIT-<name> object comp1 ...)
+;;;; creator procedure: (MAKE-<name> comp1 ...)
+
+;;;; Note: The MAKE- and INIT- procedures have required arguments
+;;;; for all components that do not have default values.
+
+;;;; Example:
+;;;; (scc-define-structure dot x y (color 'black))
+;;;; (define a-dot (make-dot 3 4))
+;;;; (set-dot.color! a-dot 'green)
+;;;; (list (dot.x a-dot) (dot.color a-dot)) -> (3 green)
+
+(scc-define-syntax (scc-define-structure name . components)
+ (define (symbol-format . args)
+ (string->symbol
+ (apply string-append
+ (map (lambda (object)
+ (cond ((string? object) object)
+ ((symbol? object) (symbol->string object))
+ (else (error
+ 'SYMBOL-FORMAT
+ "Neither symbol nor string ~A"
+ object))))
+ args))))
+ (let ((size-name (symbol-format "*-" name '-STRUCTURE-SIZE "-*"))
+ (self-varname (lambda (fn-name)
+ (symbol-format 'SELF "/" name "/" fn-name)))
+ (predicate-name (symbol-format name "?")))
+
+ (define (component-name component)
+ (if (pair? component) (car component) component))
+
+ (define (accessor-name component)
+ (symbol-format name "." (component-name component)))
+
+ (define (set-symbol component)
+ (symbol-format 'SET "-" name "." (component-name component) "!"))
+
+ (define (gen-accessors components counter)
+ (if (null? components)
+ `((DEFINE-CONSTANT ,size-name ,counter))
+ (let ((cname (component-name (car components))))
+ (let ((offset-name (symbol-format "*-" name "." cname "-*"))
+ (self (self-varname cname)))
+ `((DEFINE-CONSTANT ,offset-name ,counter)
+ (DEFINE-IN-LINE (,(accessor-name cname) ,self)
+ (IF (,predicate-name ,self)
+ (VECTOR-REF ,self ,offset-name)
+ (ERROR ',(accessor-name cname)
+ "Object not correct type ~A" ,self)))
+ (DEFINE-IN-LINE (,(set-symbol cname) ,self NEW-VALUE)
+ (IF (,predicate-name ,self)
+ (BEGIN
+ (VECTOR-SET! ,self ,offset-name NEW-VALUE)
+ 'MODIFIED!)
+ (ERROR ',(set-symbol cname)
+ "Object not correct type ~A" ,self)))
+ ,@(if *running-in-mit-scheme*
+ '()
+ `((DEFINE (,(accessor-name cname) ,self)
+ (IF (,predicate-name ,self)
+ (VECTOR-REF ,self ,offset-name)
+ (ERROR ',(accessor-name cname)
+ "Object not correct type ~A" ,self)))
+ (DEFINE (,(set-symbol cname) ,self NEW-VALUE)
+ (IF (,predicate-name ,self)
+ (BEGIN
+ (VECTOR-SET! ,self ,offset-name NEW-VALUE)
+ 'MODIFIED!)
+ (ERROR ',(set-symbol cname)
+ "Object not correct type ~A" ,self)))))
+ ,@(gen-accessors (cdr components) (+ counter 1)))))))
+
+ (define (make-bvl components)
+ (cond ((null? components) '())
+ ((pair? (car components)) (make-bvl (cdr components)))
+ (else (cons (car components) (make-bvl (cdr components))))))
+
+ (define (gen-structure-initialization self-name components)
+ (if (null? components)
+ '()
+ `((,(set-symbol (car components))
+ ,self-name
+ ,@(if (pair? (car components))
+ (cdar components)
+ (list (car components))))
+ ,@(gen-structure-initialization self-name (cdr components)))))
+
+ (let ((init-name (symbol-format 'INIT "-" name))
+ (init-self-name (self-varname 'INIT))
+ (init-bvl (make-bvl components))
+ (accessors (gen-accessors components 1))
+ (tag (symbol-format "#[" name "]")))
+ `(begin
+ (if ,*running-in-mit-scheme*
+ (ADD-UNPARSER-SPECIAL-OBJECT!
+ ',tag
+ (lambda (obj)
+ (display "#[scc-object ")
+ (display ',name)
+ (display " ")
+ (display (hash obj))
+ (display "]"))))
+ ,@accessors
+ (DEFINE (,(symbol-format name '/pp) OBJ)
+ (IF (NUMBER? OBJ) (SET! OBJ (UNHASH OBJ)))
+ (FOR-EACH (LAMBDA (FIELD-NAME ACCESSOR)
+ (PP (LIST FIELD-NAME (ACCESSOR OBJ))))
+ ',(map component-name components)
+ (LIST ,@(map accessor-name components))))
+ (DEFINE (,predicate-name OBJ)
+ (AND (VECTOR? OBJ)
+ (= (VECTOR-LENGTH OBJ) ,size-name)
+ (EQ? (VECTOR-REF OBJ 0) ',tag)))
+ (DEFINE (,init-name ,init-self-name ,@init-bvl)
+ (VECTOR-SET! ,init-self-name 0 ',tag)
+ ,@(gen-structure-initialization init-self-name components)
+ ,init-self-name)
+ (DEFINE (,(symbol-format 'MAKE "-" name) ,@init-bvl)
+ (,init-name (make-vector ,size-name) ,@init-bvl))))))
--- /dev/null
+;;;;; -*- scheme -*-
+;;;;;
+;;;;; derived from uitk.sc,v 1.2 1993/02/25 14:13:22 jmiller exp $
+;;;;; $id: uitk.scm,v 1.11 1993/02/26 15:10:23 jmiller exp jmiller $
+
+(define debugging-port #f)
+
+(define (debug-print . args)
+ (let ((port (or debugging-port (current-output-port)))
+ (string (with-output-to-string
+ (lambda ()
+ (display (cons 'debugging (cons (current-thread) args)))))))
+ (without-interrupts
+ (lambda () (display string port) (newline port)))))
+
+;;;; notes
+
+;;;; message flows define relationships. normally, an operation that
+;;;; changes state on an object will use one of these relationships to
+;;;; alert other objects of the change. this permits an external
+;;;; constraint satisfaction system to propagate changes through the
+;;;; system. here are the flows currently
+;;;; assumed:
+;;;; (1) geometry. all object can report a desired size which
+;;;; includes stretch, shrink, and minimum size. this is a
+;;;; pure query and does not establish a relationship. the
+;;;; relationship commences with a call to either
+;;;; assign-screen-area! or assign-geometry!. these
+;;;; specify an area to be used and alert any object
+;;;; monitoring for geometry changes.
+;;;; (2) events. an object may have children to whom it reports
+;;;; events. event directors take an event and a list of
+;;;; children and propagate the event to the correct child
+;;;; or take a default action. this is a one-way interaction
+;;;; (i.e. children don't know about parents).
+;;;; (3) contexts.
+
+;;;; i'd like to use tiny clos as a means for handling the private
+;;;; slot in UIObj. this allows the common operations to be as fast
+;;;; as possible (i.e. not using generic dispatch) while still
+;;;; permitting extensibility. for the moment, however, i'm using
+;;;; simple structures and type-specific operations.
+
+;;;; when assign-screen-area! is called with #f instead of a screen
+;;;; area it means that it has had its area retracted. this happens
+;;;; when the geometric parent is told to remove it as a child. if it
+;;;; has been using the parent's window, it better clean up -- this
+;;;; may mean reparenting its own window to the root, i guess.
+\f
+(define (sub-vectors point-1 point-2)
+ (make-point
+ (- (point.x point-1) (point.x point-2))
+ (- (point.y point-1) (point.y point-2))))
+
+(define (add-vectors point-1 point-2)
+ (make-point
+ (+ (point.x point-1) (point.x point-2))
+ (+ (point.y point-1) (point.y point-2))))
+
+(define (point= point1 point2)
+ (or (eq? point1 point2)
+ (and
+ (= (point.x point1) (point.x point2))
+ (= (point.y point1) (point.y point2)))))
+
+(define (size= size1 size2)
+ (or (eq? size1 size2)
+ (and
+ (= (size.width size1) (size.width size2))
+ (= (size.height size1) (size.height size2)))))
+
+(define (copy-rectangle rect)
+ (vector-copy rect))
+
+(define (UITKRectangle.Width rect)
+ (size.width (UITKRectangle.Size rect)))
+
+(define (UITKRectangle.Height rect)
+ (size.height (UITKRectangle.Size rect)))
+
+(define (rectangle= rect1 rect2)
+ (or (eq? rect1 rect2)
+ (and (point= (UITKRectangle.offset rect1) (UITKRectangle.offset rect2))
+ (size= (UITKRectangle.Size rect1) (UITKRectangle.Size rect2)))))
+
+(define (screen-area= sa1 sa2)
+ (or (and sa1 sa2 (rectangle= sa1 sa2))
+ (and (not sa1) (not sa2))))
+
+(define (translate-rectangle rect point)
+ (and rect
+ (make-UITKRectangle point (UITKRectangle.Size rect))))
+
+\f
+;;;; event objects
+
+(define (make-point-event type os-event window offset)
+ (make-event 'point type os-event window offset 'invalid 'invalid))
+
+(define (make-rectangle-event type os-event window offset width height)
+ (make-event 'rectangle type os-event window offset width height))
+
+(define (make-unknown-event type os-event window)
+ (make-event 'unknown type os-event window 'invalid 'invalid 'invalid))
+
+(define (point-event? obj)
+ (and (event? obj)
+ (eq? (event.point-or-rectangle? obj) 'point)))
+
+(define (rectangle-event? obj)
+ (and (event? obj)
+ (eq? (event.point-or-rectangle? obj) 'rectangle)))
+
+\f
+;;;; General support procedures
+
+(define (make-lookup key-fn)
+ (lambda (object list)
+ (let loop ((list list))
+ (cond ((null? list) #F)
+ ((eq? object (key-fn (car list))) (car list))
+ (else (loop (cdr list)))))))
+
+(define (make-del-op! test?)
+ (lambda (op)
+ (lambda (key op-list)
+ (define (loop previous current)
+ (cond ((null? current) op-list)
+ ((test? (op (car current)) key)
+ (set-cdr! previous (cdr current))
+ op-list)
+ (else (loop current (cdr current)))))
+ (cond ((null? op-list) '())
+ ((test? (op (car op-list)) key)
+ (cdr op-list))
+ (else (loop op-list (cdr op-list)))))))
+
+(define del-op! (make-del-op! eq?))
+
+(define del-assq! (del-op! car))
+(define del-assv! ((make-del-op! eqv?) car))
+
+(define (make-weak-lookup key-fn)
+ (lambda (object list)
+ (let loop ((list list))
+ (cond ((null? list) #F)
+ ((eq? object (key-fn (weak-car list))) (weak-car list))
+ (else (loop (weak-cdr list)))))))
+
+(define (make-weak-del-op! test?)
+ (lambda (op)
+ (lambda (key op-list)
+ (define (loop previous current)
+ (cond ((null? current) op-list)
+ ((test? (op (weak-car current)) key)
+ (weak-set-cdr! previous (weak-cdr current))
+ op-list)
+ (else (loop current (weak-cdr current)))))
+ (cond ((null? op-list) '())
+ ((test? (op (weak-car op-list)) key)
+ (weak-cdr op-list))
+ (else (loop op-list (weak-cdr op-list)))))))
+\f
+;;;; UI Objects
+
+(define (one-parent-only! child object)
+ (let ((child-guts (uiobjinternals child)))
+ (if (UIObjInternals.already-have-a-parent? child-guts)
+ (error
+ "ADD-CHILD!: Hal says 'success has many parents, but a UIObj has only one'"
+ object child)
+ (set-UIObjInternals.already-have-a-parent?! child-guts #T))))
+
+(define (get-UITKWindow obj)
+ (let ((surface (drawing-surface obj)))
+ (and (DrawingSurface? surface)
+ (DrawingSurface.UITKWindow surface))))
+
+(define (DrawingSurface.Application ds)
+ (ToolKitWindow.Application (DrawingSurface.ToolKitWindow ds)))
+
+
+;;; The alerts are stored as alists with the key being, typically, the
+;;; reason the alert was added. This allows the alert to be removed
+;;; if/when the reason is retracted. The alert function is called
+;;; with the reason as its argument.
+
+(define make-add-alert!
+ (let ((find-alert (make-lookup alert.reason)))
+ (lambda (accessor mutator!)
+ (lambda (object key alert-fn)
+ (let* ((previous (accessor object))
+ (old-value (find-alert key previous)))
+ (if old-value
+ (begin
+ ;;(set-alert.function! old-value alert)
+ ;; (bkpt "gottcha in make-add-alert!")
+ (debug-print 'gottcha!))
+ (mutator! object `(,(make-alert key alert-fn) ,@previous)))
+ 'added)))))
+
+(define make-remove-alert!
+ (let ((del-alert! (del-op! alert.reason)))
+ (lambda (accessor mutator!)
+ (lambda (object key)
+ (mutator! object (del-alert! key (accessor object)))
+ 'removed))))
+
+(define (make-alert! arity accessor)
+ ;; Arity is the arity expected of the alert function. Some alerts
+ ;; pass additional information -- geometry, for example, passes both
+ ;; the previous screen-area and the new screen-area. The alert
+ ;; function can generally be assumed to have lexical access to both
+ ;; the reason for the alert (specified when the alert is created)
+ ;; and the object that generated the alert.
+ (case arity
+ ((0) (lambda (object)
+ (for-each (lambda (alert) ((alert.function alert)))
+ (accessor object))))
+ ((1) (lambda (object arg)
+ (for-each (lambda (alert) ((alert.function alert) arg))
+ (accessor object))))
+ ((2) (lambda (object arg1 arg2)
+ (for-each (lambda (alert) ((alert.function alert) arg1 arg2))
+ (accessor object))))
+ (else (lambda (object . args)
+ (for-each (lambda (alert) (apply (alert.function alert) args))
+ (accessor object))))))
+\f
+;;; Geometry alerts:
+;;; Initiated when ASSIGN-SCREEN-AREA! is acted on by an object, by
+;;; calling
+;;; (GEOMETRY-CHANGE! object
+;;; old-used-screen-area new-used-screen-area)
+;;; An alert is added by calling
+;;; (ON-GEOMETRY-CHANGE! object reason
+;;; (lambda (old new) ...))
+;;; The new-used-screen-area may be #T indicating that an object is
+;;; requesting a new area, or it may be #F or an actual area
+;;; indicating that it has been given (via ASSIGN-SCREEN-AREA!) a
+;;; specific area to use.
+(define on-geometry-change!
+ (make-add-alert! %geometry-alerts set-%geometry-alerts!))
+(define forget-geometry-change!
+ (make-remove-alert! %geometry-alerts set-%geometry-alerts!))
+(define geometry-change! (make-alert! 2 %geometry-alerts))
+
+;;; Event alerts:
+;;; Initiated when HANDLE-EVENT is acted on by an object, by calling
+;;; (EVENT! object event)
+;;; An alert is added by calling
+;;; (ON-EVENT! object reason
+;;; (lambda (event) ...))
+(define on-event!
+ (make-add-alert! %event-alerts set-%event-alerts!))
+(define forget-event!
+ (make-remove-alert! %event-alerts set-%event-alerts!))
+(define event! (make-alert! 1 %event-alerts))
+
+;;; Context alerts:
+;;; Initiated when SET-CONTEXT! is acted on by an object, by calling
+;;; (CONTEXT-CHANGE! object new-context)
+;;; An alert is added by calling
+;;; (ON-CONTEXT-CHANGE! object reason
+;;; (lambda (new-context) ...))
+;;; NOTE: This protocol is not well worked out.
+(define on-context-change!
+ (make-add-alert! %context-alerts set-%context-alerts!))
+(define forget-context-change!
+ (make-remove-alert! %context-alerts set-%context-alerts!))
+(define context-change! (make-alert! 1 %context-alerts))
+
+;;; Death alerts:
+;;; Initiated when an object has decided it is dead by calling
+;;; (DEATH! object)
+;;; An alert is added by calling
+;;; (ON-DEATH! object reason (lambda () ...))
+(define on-death!
+ (make-add-alert! %death-alerts set-%death-alerts!))
+(define forget-death-notification!
+ (make-remove-alert! %death-alerts set-%death-alerts!))
+(define death! (make-alert! 0 %death-alerts))
+
+(define (forget! reporter reason)
+ (forget-geometry-change! reporter reason)
+ (forget-event! reporter reason)
+ (forget-death-notification! reporter reason)
+ (forget-context-change! reporter reason))
+\f
+;;;; Queues for communication between interrupt level and user level
+
+(define (empty-queue? queue)
+ (without-interrupts
+ (lambda ()
+ (not (queue.%head queue)))))
+
+(define (enqueue! queue value)
+ (let ((element (list value)))
+ (without-interrupts
+ (lambda ()
+ (if (queue.%head queue)
+ (set-cdr! (queue.%tail queue) element)
+ (set-queue.%head! queue element))
+ (set-queue.%tail! queue element)))))
+
+(define (dequeue! queue)
+ ;; Not safe to use if the queue is empty!
+ (without-interrupts
+ (lambda ()
+ (let* ((head (queue.%head queue))
+ (next (cdr head)))
+ (if (null? next)
+ (begin
+ (set-queue.%head! queue #F)
+ (set-queue.%tail! queue #F))
+ (set-queue.%head! queue next))
+ (car head)))))
+
+(define (read-and-empty-queue! queue)
+ ;; Returns a list of items, and leaves the queue empty
+ (let ((quick-result
+ (without-interrupts
+ (lambda ()
+ (let ((result (queue.%head queue)))
+ (set-queue.%head! queue #F)
+ (set-queue.%tail! queue #F)
+ result)))))
+ (or quick-result '())))
+\f
+
+(define (update-locked-list! locked-list receiver)
+ ;; Receiver gets the contents and returns a replacement
+ (our-with-thread-mutex-locked
+ 'update-locked-list!
+ (locked-list.%mutex locked-list)
+ (lambda ()
+ (set-locked-list.%data!
+ locked-list
+ (receiver (locked-list.%data locked-list)))
+ ))
+ 'DONE)
+
+(define (with-locked-list locked-list receiver)
+ ;; Receiver gets the contents
+ (our-with-thread-mutex-locked
+ 'with-locked-list
+ (locked-list.%mutex locked-list)
+ (lambda ()
+ (receiver (locked-list.%data locked-list))
+ )))
+
+(define (our-with-thread-mutex-locked reason mutex thunk)
+ reason
+ (with-thread-mutex-locked mutex thunk))
+\f
+
+;;; The default for these is just to do information propagation
+;;; through the alert mechanism.
+
+(define (UIObj-set-context! UIObj Context)
+ (if (vector? Context)
+ (context-change! UIObj Context)
+ (error "UIOBJ-SET-CONTEXT!: Bad context" Context)))
+
+(define (UIObj-assign-screen-area! UIObj Screen-Area)
+ (if (or (UITKRectangle? Screen-Area)
+ (eq? #F Screen-Area))
+ (begin
+ (set-assigned-screen-area! UIObj Screen-Area)
+ (let ((old (used-screen-area UIObj)))
+ (set-used-screen-area! UIObj screen-area)
+ (geometry-change! UIObj old screen-area))
+ screen-area)
+ (error "UIOBJ-ASSIGN-SCREEN-AREA!: Bad screen area" Screen-Area)))
+
+(define (assign-location! object point)
+ ;; There may be a better way to do this by making it part of the
+ ;; geometry protocol.
+ (assign-screen-area! object
+ (translate-rectangle (used-screen-area object) point)))
+
+(define (UIObj-assign-drawing-surface! UIObj Surface)
+ (check-drawing-surface! UIObj Surface)
+ (geometry-change! UIObj #F #F)
+ 'OK)
+
+(define (check-drawing-surface! UIObj Surface)
+ ;; Surface should be one of 'UNASSIGNED, 'RETRACTED, or a
+ ;; DrawingSurface
+ ;; This is used by internal routines that want to do the default
+ ;; operation (UIObj-assign-drawing-surface!) but don't want to
+ ;; announce the geometry change yet.
+ (let ((old (Drawing-Surface UIObj)))
+ (cond ((eq? old Surface) 'UNCHANGED)
+ ((or (eq? Surface 'RETRACTED)
+ (eq? old 'UNASSIGNED))
+ (set-drawing-surface! UIObj Surface)
+ 'CHANGED)
+ (else
+ (error "UIOBJ-ASSIGN-DRAWING-SURFACE!: Can't change surface"
+ UIObj old surface)))))
+
+(define (assign-geometry! UIObj Surface Rectangle)
+ (assign-drawing-surface! UIObj surface)
+ (assign-screen-area! UIObj rectangle))
+\f
+(define (point-in-rectangle? point rect-offset width height)
+ (let ((rect-x (Point.X rect-offset))
+ (rect-y (Point.Y rect-offset))
+ (x (Point.X point))
+ (y (Point.Y point)))
+ (and (<= rect-x X)
+ (< X (+ rect-x Width))
+ (<= rect-Y Y)
+ (< Y (+ rect-Y Height)))))
+
+(define (rectangle-overlaps-rectangle? p w h p2 w2 h2)
+ (define (rectangles-overlap? LowEdge LowDelta HighEdge)
+ (<= HighEdge (+ LowEdge LowDelta)))
+ (let ((x (Point.X p))
+ (y (Point.Y p))
+ (x2 (Point.X p2))
+ (y2 (Point.Y p2)))
+ (and (if (< X X2)
+ (rectangles-overlap? X W X2)
+ (rectangles-overlap? X2 W2 X))
+ (if (< Y Y2)
+ (rectangles-overlap? Y H Y2)
+ (Rectangles-Overlap? Y2 H2 Y)))))
+
+(define (uiobj-point-within? UIObj Point)
+ (if (vector? Point)
+ (let ((screen-area (Used-Screen-Area UIObj)))
+ (and screen-area
+ (let ((Offset (UITKRectangle.Offset screen-area))
+ (Height (UITKRectangle.Height screen-area))
+ (Width (UITKRectangle.Width screen-area)))
+ (point-in-rectangle? Point Offset Width Height))))
+ (error "UIOBJ-POINT-WITHIN?: Bad point" point)))
+
+(define (UIObj-rectangle-overlaps? UIObj P1 W1 H1)
+ (if (not (vector? P1))
+ (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad point" P1))
+ (if (not (number? W1))
+ (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad width" W1))
+ (if (not (number? H1))
+ (error "UIOBJ-RECTANGLE-OVERLAPS?: Bad height" H1))
+ (let ((screen-area (Used-Screen-Area UIObj)))
+ (and
+ screen-area
+ (let ((P2 (UITKRectangle.Offset screen-area))
+ (H2 (UITKRectangle.Height screen-area))
+ (W2 (UITKRectangle.Width screen-area)))
+ (rectangle-overlaps-rectangle? p1 w1 h1 p2 w2 h2)))))
+
+
+(define (event-within? UIObj Event)
+ (cond ((point-event? event)
+ (point-event-within? UIObj event))
+ ((rectangle-event? event)
+ (rectangle-event-within? UIObj event))
+ (else (error "EVENT-WITHIN?: Bad event" event))))
+
+(define (point-event-within? UIObj Event)
+ (let ((window (Get-UITKWindow UIObj)))
+ (and window
+ (= (->XWindow (UITKWindow.xwindow window))
+ (Event.Window Event))
+ (point-within? UIObj (event.Offset event)))))
+
+(define (rectangle-event-within? UIObj Event)
+ (let ((window (Get-UITKWindow UIObj)))
+ (and window
+ (= (->XWindow (UITKWindow.xwindow window))
+ (Event.Window Event))
+ (Rectangle-Overlaps? UIObj
+ (event.Offset event)
+ (event.Width event)
+ (event.Height event)))))
+\f
+(define (UIObj-handle-event UIObj Event)
+ (if (event? event)
+ (if (event-within? UIObj event)
+ (event! UIObj event))
+ (error "UIOBJ-HANDLE-EVENT: Bad event" event)))
+
+(define (UIObj-get-desired-size object)
+ (define (->size datum)
+ (or datum (make-size 0 0)))
+ (->size (%desired-size object)))
+
+
+;;; Default assigned-screen-area and used-screen-area (accessors and
+;;; mutators) simply look in or modify the appropriate slots in the
+;;; structure.
+(define (UIObj-assigned-screen-area UIObj)
+ (UIObjInternals.assigned-screen-area (UIObjInternals UIObj)))
+
+(define (UIObj-set-assigned-screen-area! UIObj Screen-area)
+ (set-UIObjInternals.assigned-screen-area! (UIObjInternals UIObj)
+ Screen-Area))
+
+(define (UIObj-used-screen-area UIObj)
+ (UIObjInternals.used-screen-area (UIObjInternals UIObj)))
+
+(define (UIObj-set-used-screen-area! UIObj Screen-Area)
+ (set-UIObjInternals.used-screen-area! (UIObjInternals UIObj)
+ Screen-Area))
+
+(define (UIObj-protect-from-gc! UIObj stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away UIObj)))
+ (set-car! crud (cons stuff (car crud))))
+ 'done)
+
+(define (UIObj-unprotect-from-gc! UIObj stuff)
+ (let ((crud (crud-that-I-dont-want-to-gc-away UIObj)))
+ (set-car! crud (delq! stuff (car crud))))
+ 'done)
+
+
+\f
+;;;; Context procedures
+
+(define (create-default-context name display)
+ ;; Looks in appropriate customization locations to create a default
+ ;; context for the application specified by NAME
+ (define (convert converter predicate)
+ (lambda (default)
+ (define (get-default)
+ (cond ((procedure? default) (default))
+ ((string? default) (converter default))
+ (else default)))
+ (lambda (string)
+ (if (and (string? string) (not (zero? (string-length string))))
+ (let ((result (converter string)))
+ (if (predicate result)
+ result
+ (get-default)))
+ (get-default)))))
+ ;;;**** this doesn't make sense to me. What are the predicates testing, really?
+ ;;; changed XLoadFont to return a wrapped object,so string->font will also
+
+ (let ((->symbol (convert string->symbol symbol?))
+ (->number (convert string->number number?))
+ (->color (convert (string->color display) color?))
+ ;; (->font (convert (string->font display) font?))
+ ;; (->cursor (convert string->cursor cursor?))
+ )
+ (apply make-context
+ (map (lambda (entry)
+ (let ((converter (car entry))
+ (string (cadr entry)))
+ ;;;;********beware: getdefaultvalue is returning an unwrapped object!!
+ ;;;; fix this to add the wrappers
+ (converter (GetDefaultValue display name string))))
+ `((,(->color "White") "ActiveBackground")
+ (,(->color "Black") "ActiveForeground")
+ (,(->symbol 'nw) "Anchor")
+ (,(->color "Black") "Background")
+ (,(->color "White") "Border")
+ (,(->number 0) "BorderWidth")
+ ;; (,(->cursor "Block") "Cursor")
+ ;; (,(->font #F) "Font")
+ (,(->color "White") "Foreground")
+ (,(->symbol 'raised) "Relief"))))))
--- /dev/null
+; -*- Scheme -*-
+;;;;; Tk interface code for a button
+;;; $Id: widget-mit.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+
+;;; Lowest-level makers for various kinds of TK widgets. These call C
+;;; primitives in widget-c-mit.c, and are called by the higher-level
+;;; widget object makers in widget.scm
+
+
+(define-primitives
+ (%tkDeleteDisplay 1)
+ (%tkDestroyWidget 1)
+ (%tkMakeButton 2)
+ (%tkMakeCanvas 2)
+ (%tkMakeCheckbutton 2)
+ (%tkMakeEntry 2)
+ (%tkMakeLabel 2)
+ (%tkMakeListbox 2)
+ (%tkMakeMenu 2)
+ (%tkMakeMenubutton 2)
+ (%tkMakeMessage 2)
+ (%tkMakeRadiobutton 2)
+ (%tkMakeScale 2)
+ (%tkMakeScrollBar 2)
+ (%tkMakeText 2)
+ )
+
+#| Widgets hold strong pointers to the display and the application.
+Therefore, when we GC away the display or applcation, we can assume
+that there are no pointers to the widgets still around. However, the
+C end may need to be closed |#
+
+;;; display->tk-widgets is a map that associates to each display a
+;;; protection list of the tk-widgets for the display
+(define display->tk-widgets 'INITIALIZED-LATER)
+
+(define (add-widget-list-for-display-number! display-number)
+ (set! display->tk-widgets
+ (cons (cons display-number (make-protection-list))
+ display->tk-widgets)))
+
+(define (find-tk-protection-list display)
+ (find-tk-protection-list-from-number (->xdisplay display)))
+
+(define (find-tk-protection-list-from-number number)
+ (let ((list (assv number display->tk-widgets)))
+ (if (null? list)
+ #F
+ (cdr list))))
+
+;;; The item on the protection list is a cell containing the widget
+;;; pointer. This permits us to mark the cell when the C object is
+;;; destroyed so we don't try to destroy it twice.
+
+(define (Wrap-TK-widget surface name maker)
+ (let ((ToolKitParent (DrawingSurface.ToolKitWindow surface)))
+ ;; Note that the DrawingSurface's UITKWindow may not yet exist.
+ (let ((parent-tk-window (ToolKitWindow.TK-window ToolKitParent))
+ (application (ToolKitWindow.Application ToolKitParent)))
+ (let ((display (Application->Display application)))
+ (let ((new-window-name
+ (string-append
+ (tkwin.pathname parent-tk-window) "." name)))
+ (let ((wrapped-object #F))
+ (define (kill-me)
+ ;; Called when the object is destroyed
+ (SCXL-DESTROY! wrapped-object))
+ (set! wrapped-object
+ (SCXL-WRAP
+ (or (find-tk-protection-list display)
+ (error "No tk-protection-list for this display" display))
+ 'tk-widget
+ (tk-op
+ (lambda ()
+ (maker parent-tk-window new-window-name)))
+ (list display surface kill-me) ;strong dependents
+ ))
+ (tk-invoke-command
+ 'BIND (Application->TKMainWindow application)
+ (list new-window-name "<Destroy>"
+ (string-append "SchemeCallBack "
+ (number->string
+ (hash kill-me *our-hash-table*)))))
+ wrapped-object))))))
+
+(define (widget/widget widget)
+ (type-check-wrapped-object 'tk-widget widget)
+ (SCXL-UNWRAP widget (lambda (w) w)))
+
+(define ->widget widget/widget)
+
+(define (%tk-really-destroy-widget handle)
+ ;; Given a lowest-level TK handle or #F
+ (if handle (tk-op (lambda() (%TkDestroyWidget handle))))
+ 'destroyed)
+
+(define tk-widget-destroy
+ ;; This will actually close the TK widget only if the wrapper isn't
+ ;; already marked destroyed. But that should be OK -- we shouldn't
+ ;; be able to find a wrapper that's destroyed if the contents
+ ;; haven't been closed.
+ (wrap-with-SCXL-DESTROY! 1 0
+ (lambda (scxl-wrapped-widget)
+ (tk-op (lambda ()
+ (%tkDestroyWidget (->widget scxl-wrapped-widget)))))))
+
+(define (tk-delete-display disp)
+ (tk-op (lambda () (%tkDeleteDisplay (->Xdisplay disp)))))
+
+(define (tk-make-button drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeButton parent-tk-window real-name))))
+
+(define (tk-make-canvas drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeCanvas parent-tk-window real-name))))
+
+(define (tk-make-checkbutton drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeCheckButton parent-tk-window real-name))))
+
+(define (tk-make-entry drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeEntry parent-tk-window real-name))))
+
+(define (tk-make-label drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeLabel parent-tk-window real-name))))
+
+(define (tk-make-listbox drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeListbox parent-tk-window real-name))))
+
+(define (tk-make-menu drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeMenu parent-tk-window real-name))))
+
+(define (tk-make-menubutton drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeMenuButton parent-tk-window real-name))))
+
+(define (tk-make-message drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeMessage parent-tk-window real-name))))
+
+(define (tk-make-radiobutton drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeRadioButton parent-tk-window real-name))))
+
+(define (tk-make-scale drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeScale parent-tk-window real-name))))
+
+(define (tk-make-scrollbar drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeScrollBar parent-tk-window real-name))))
+
+(define (tk-make-text drawing-surface name)
+ (Wrap-TK-widget drawing-surface name
+ (lambda (parent-tk-window real-name)
+ (%tkMakeText parent-tk-window real-name))))
+
+(define (initialize-mit-widgets!)
+ (set! display->tk-widgets '()))
+
+(initialize-mit-widgets!)
--- /dev/null
+;;;;; -*- Scheme -*-
+;;;;; $Id: widget.scm,v 1.1 1995/08/02 21:26:49 adams Exp $
+;;;;; derived from button.sc,v 1.2 1993/02/26 00:49:36 jmiller Exp $
+
+;;;;;;;;;; Widget Definitions
+
+(define tk-widget->pathname
+ (let ((->handle (lambda (widget)
+ (if (not (tkwidget%? widget))
+ (pp `(tkh 2 ,widget)))
+ (TKWidget%.handle widget))))
+ (lambda (tk-widget)
+ (tkwin.pathname (tk-widget.tkwin (->handle tk-widget))))))
+
+(define (tkwin->size tkwindow)
+ (make-size (tkwin.width tkwindow) (tkwin.height tkwindow)))
+
+#| display->tk-widgets maps a display-number to a protection list,
+ which is a list of weak-pairs. Each pair is <WRAPPED-OBJ or #F .
+ cell with (handle or #F)> #F on the left means that the Scheme
+ object has been lost. #F on the right means that the TK widget has
+ been closed. In UITK, both the wrapped object and the TK object
+ should be destroyed when the Scheme reference is lost. However,
+ when we close a display the TK objects may still be around. The
+ Scheme objects should not be around if we close the display from
+ GC, but (brave) users may wish to close displays explicitly. |#
+
+(define (destroy-associated-tk-widgets display-number)
+ (let ((tk-widgets (find-tk-protection-list-from-number display-number)))
+ (if tk-widgets
+ (begin
+ ;;canonical Lisp bug #27: we need to do the set! here
+ (set! display->tk-widgets
+ (del-assv! display-number display->tk-widgets))
+ (for-each
+ (lambda (entry)
+ ;; An entry is either the left side of the pair described
+ ;; above, or the (former) contents of the cell on the
+ ;; right.
+ (if (SCXL-WRAPPED? entry)
+ (tk-widget-destroy entry)
+ (%tk-really-destroy-widget entry)))
+ (protection-list-all-elements tk-widgets
+ atomic-read-and-clear-cell!)))))
+ (%tkDeleteDisplay display-number) ; Make TK forget the display exists
+ 'done)
+
+(define (TKWidget-assign-drawing-surface! me Surface)
+ (let ((old (Drawing-Surface me))
+ (kids (TKWidget%.%children me)))
+ (cond
+ ;; Three kinds of Surface: 'RETRACTED, 'UNASSIGNED, or DrawingSurface?
+ ;; The default is 'UNASSIGNED and this is NOT a legal value to
+ ;; assign later!
+ ((and (eq? Surface 'UNASSIGNED)
+ (eq? old 'UNASSIGNED))
+ 'nothing-to-do)
+ ((eq? Surface 'RETRACTED)
+ (set-drawing-surface! me 'RETRACTED)
+ (if (DrawingSurface? old)
+ (tk-widget-destroy (TKWidget%.handle me)))
+ (if (not (eq? old 'RETRACTED)) (death! me)))
+ ((not (DrawingSurface? Surface))
+ (error "TKWIDGET-ASSIGN-DRAWING-SURFACE!: Bad surface" Surface))
+ ;; All of the kids need to receive a drawing surface now. It
+ ;; should be on the same application and XDisplay as me, but
+ ;; should use my own XWindow for the parent, and my TK Window as
+ ;; the TK Parent window. Drawing surfaces are assigned TWICE:
+ ;; first with a valid ToolKitWindow, and then with both a
+ ;; ToolKitWindow and a UITKWindow (see baseobj.scm). We mimic
+ ;; that here.
+ ((eq? old 'UNASSIGNED)
+ ;; Create the widget drawing surface is first assigned
+ (set-drawing-surface! me Surface)
+ (let ((wrapped-tk-widget ((TKWidget%.how-to-make-me me) Surface))
+ (application (DrawingSurface.Application Surface)))
+#|
+ (define (kill-me)
+ (debug-print '<destroy> 'call 'back me)
+ (set-drawing-surface! me 'RETRACTED)
+ (death! me))
+ (UIObj-Protect-From-GC! me kill-me)
+ (tk-invoke-command
+ 'BIND (Application->TKMainWindow application)
+ (list (tk-widget->pathname me) "<Destroy>"
+ (string-append "+SchemeCallBack "
+ (number->string
+ (hash kill-me *our-hash-table*)))))
+|#
+ (set-TKWidget%.handle! me wrapped-tk-widget)
+ (if (TKWidget%.do-not-gc-protect me)
+ (remove-from-protection-list!
+ (find-tk-protection-list-from-number
+ (->xdisplay
+ (Application->Display Application)))
+ wrapped-tk-widget)))
+ (let ((kid-surface (make-DrawingSurface
+ (make-ToolKitWindow
+ (DrawingSurface.Application Surface)
+ #F
+ (tk-widget.tkwin (TKWidget%.handle me)))
+ #F)))
+ (for-each (lambda (kid) (ASSIGN-DRAWING-SURFACE! kid kid-surface))
+ kids))
+ (for-each (lambda (thunk) (thunk))
+ (reverse
+ (TKWidget%.deferred-ask-widget-commands me)))
+ (set-TKWidget%.deferred-ask-widget-commands! me '())
+ (geometry-change! me #F #F))
+ ((eq? old Surface)
+ ;; 2nd pass now modifies that drawing surface to reflect a
+ ;; possibly updated UITK window
+ (if (not (null? kids))
+ (let ((new (drawing-surface (car kids))))
+ (set-DrawingSurface.UITKWindow!
+ new
+ (make-UITKWindow
+ (UITKWindow.XDisplay (DrawingSurface.UITKWindow Surface))
+ (tkwin.window (tk-widget.tkwin (TKWidget%.handle me)))))
+ (for-each (lambda (kid) (ASSIGN-DRAWING-SURFACE! kid new))
+ kids)))
+ (geometry-change! me #F #F))
+ (else
+ (error "TKWIDGET-ASSIGN-DRAWING-SURFACE!: Can't change surface"
+ old Surface))))
+ 'OK)
+
+(define (TKWidget-add-child! me kid)
+ (one-parent-only! kid me)
+ (let ((current-kids (TKWidget%.%children me)))
+ (if (not (null? current-kids))
+ (assign-drawing-surface! kid (drawing-surface (car current-kids)))
+ (let ((Surface (drawing-surface me)))
+ (if (not (DrawingSurface? Surface))
+ (assign-drawing-surface! kid Surface)
+ (let* ((parent-tkwin (tk-widget.tkwin (TKWidget%.handle me)))
+ (kid-surface
+ (make-DrawingSurface
+ (make-ToolKitWindow
+ (DrawingSurface.Application Surface)
+ #F ; Top-level geometry callback
+ parent-tkwin)
+ (make-UITKWindow
+ (UITKWindow.XDisplay (DrawingSurface.UITKWindow Surface))
+ (tkwin.window parent-tkwin)))))
+ (assign-drawing-surface! kid kid-surface)))))
+ (set-TKWidget%.%children! me (cons kid current-kids))))
+
+(define (TKWidget-assign-screen-area! me screen-area)
+ (cond ((vector? screen-area)
+ (if (TKWidget%.do-screen-area? me)
+ (let ((tk-handle (TKWidget%.handle me)))
+ (if (not (assigned-screen-area me))
+ (begin
+ (tk-map-window (tk-widget.tkwin tk-handle))
+ (tk-manage-geometry tk-handle
+ (TKWidget%.%scheme-geometry-manager me))))
+ (tk-move-resize-widget tk-handle screen-area)))
+ (geometry-change! me screen-area screen-area)
+ screen-area)
+ ((not Screen-Area)
+ (if (TKWidget%.do-screen-area? me)
+ (let ((tk-handle (TKWidget%.handle me)))
+ (TK-Unmap-Window (tk-widget.tkwin tk-handle))
+ (tk-manage-geometry tk-handle #F)))
+ (geometry-change! me screen-area screen-area)
+ screen-area)
+ (else
+ (error "TKWIDGET-ASSIGN-SCREEN-AREA!: Bad screen-area" screen-area))))
+
+(define (widget->screen-area widget)
+ (let ((tkwin (tk-widget.tkwin (TKWidget%.handle widget))))
+ (and (tkwin.ismapped? tkwin)
+ (make-UITKRectangle
+ (make-point (tkwin.x tkwin) (tkwin.y tkwin))
+ (make-size (tkwin.width tkwin)
+ (tkwin.height tkwin))))))
+
+(define (TKWidget-assigned-screen-area me)
+ (widget->screen-area me))
+(define (TKWidget-used-screen-area me)
+ (widget->screen-area me))
+
+(define (TKWidget-set-assigned-screen-area! me anything)
+ (if (and (eq? (drawing-surface me) 'RETRACTED)
+ (eq? anything #F))
+ 'OK
+ (error "You can't set the screen area for a TK Widget" me anything)))
+(define (TkWidget-set-used-screen-area! me anything)
+ (if (and (eq? (drawing-surface me) 'RETRACTED)
+ (eq? anything #F))
+ 'OK
+ (error "You can't set the screen area for a TK Widget" me anything)))
+
+(define (TKWidget-get-desired-size object)
+ (widget->size object tkwin->requested-size))
+
+(define (TKWidget-assign-glue! me)
+ (let* ((size (get-desired-size me))
+ (my-width (size.Width size))
+ (my-height (size.Height size)))
+ ((TKWidget%.set-glue!-procedure me) me my-width my-height)))
+
+(define (maybe-defer me command)
+ (if (not (tkwidget%? me))
+ (pp `(tkh 3 ,me)))
+ (if (TKWidget%.handle me)
+ (command)
+ (defer me command)))
+
+(define (defer me command)
+ (set-TKWidget%.deferred-ask-widget-commands!
+ me
+ (cons command (TKWidget%.deferred-ask-widget-commands me)))
+ #F)
+
+(define (TKWidget-add-event-handler! object event handler substitutions)
+ ;;for example
+ ;; (add-event-handler! obj "<ButtonPress>"
+ ;; (lambda (path button) ....)
+ ;; "%W" "%b")
+ ;; see TK manual (bind) for what these %frobs mean
+ ;;hang this on the widget to GC protect it
+ (let ((handler (proc-with-transformed-args handler substitutions)))
+ (set-TKWidget%.%binding-callbacks!
+ object
+ (cons handler (TKWidget%.%binding-callbacks object)))
+ (let ((command
+ (lambda ()
+ (tk-invoke-command
+ 'bind
+ (application->TKMainWindow
+ (DrawingSurface.Application
+ (Drawing-Surface object)))
+ (list
+ (tk-widget->pathname object)
+ event
+ ;; "event" should be a string because TCL is
+ ;; case sensitive, (e.g. <ButtonPress>)
+ (apply
+ string-append
+ "SchemeCallBack "
+ (number->string (hash handler *our-hash-table*))
+ (map (lambda (s)
+ (string-append " " s))
+ substitutions)))))))
+ (maybe-defer object command))))
+
+(define (TKWidget-ask-widget me arg-list)
+ ;; If the widget doesn't have a drawing surface yet, then the TK
+ ;; object hasn't been created and we can't actually execute the
+ ;; command.
+ (let ((command
+ (lambda ()
+ (if (not (tkwidget%? me))
+ (pp `(tkh 1 ,me)))
+ (if (SCXL-DESTROYED? (tkwidget%.handle me))
+ 'punt
+ (tcl-global-eval
+ (ToolKitWindow.Application
+ (DrawingSurface.ToolKitWindow (drawing-surface me)))
+ (tk-widget->pathname me)
+ arg-list)))))
+ (maybe-defer me command)))
+
+
+(define (current-size widget)
+ (widget->size widget tkwin->size))
+
+(define (widget->size widget ->size)
+ (let ((h (TKWidget%.handle widget)))
+ (if h
+ (->size (tk-widget.tkwin h))
+ (error "widget->size: widget not instantiated" widget))))
+
+(define (tk-has-requested-new-size object)
+ (let ((old-size (current-size object))
+ (new-size (get-desired-size object)))
+ (if (and (= (size.height old-size) (size.height new-size))
+ (= (size.width old-size) (size.width new-size)))
+ 'OK
+ (geometry-change! object (used-screen-area object) #T))))
+
+;; method to attach callback to the widget
+(define (TKWidget-set-callback! me proc)
+ (set-TKWidget%.%callback! me proc)
+ (if (TKWidget%.%callback-command me)
+ ((TKWidget%.%callback-command me) me (TKWidget%.%scheme-callback-hash me))
+ (error "SET-CALLBACK!: not allowed" me proc)))
+
+;; TKWidget Maker
+(define (TKWidget-maker)
+ (make-tkwidget%
+ (make-UIObjInternals TKWidget-add-child!
+ 'invalid ; Remove-Child!-procedure
+ UIObj-set-context!
+ TKWidget-assign-screen-area!
+ TKWidget-assign-drawing-surface!
+ UIObj-point-within?
+ UIObj-rectangle-overlaps?
+ UIObj-handle-event
+ TKWidget-get-desired-size
+ TKWidget-assigned-screen-area
+ TKWidget-used-screen-area
+ TKWidget-set-assigned-screen-area!
+ TKWidget-set-used-screen-area!
+ TKWidget-assign-glue!)
+ TKWidget-ask-widget
+ TKWidget-add-event-handler!
+ TKWidget-set-callback!))
+
+(define (tkwin->requested-size tkwindow)
+ (make-size (tkwin.req-width tkwindow)
+ (tkwin.req-height tkwindow)))
+
+(define (make-TK-widget type widget-maker callback-command do-screen-area? set-glue!)
+ ;; The Main widget-maker
+ (lambda args
+ (let ((me (TKWidget-maker)))
+ (let ((geometry-callback
+ (lambda () (tk-has-requested-new-size me)))
+ (the-real-callback
+ (lambda args
+ (apply (TKWidget%.%callback me) args))))
+ (let ((%scheme-callback-hash
+ (hash the-real-callback *our-hash-table*)))
+ (set-TKWidget%.%c-callback! me the-real-callback)
+ (set-TKWidget%.%scheme-geometry-manager! me geometry-callback)
+ (set-TKWidget%.%scheme-callback-hash! me %scheme-callback-hash)
+ (set-TKWidget%.%callback-command! me callback-command)
+ (set-TKWidget%.how-to-make-me!
+ me
+ (lambda (parent-drawing-surface)
+ (apply widget-maker parent-drawing-surface (tk-gen-name type) args)))
+ (set-TKWidget%.do-screen-area?! me do-screen-area?)
+ (set-TKWidget%.set-glue!-procedure! me set-glue!)
+ me))))
+ )
+
+(define (make-arg-transformers argspecs)
+ (let ((id (lambda (x) x)))
+ (map (lambda (spec)
+ (if (member spec
+ '("%b" "%c" "%h" "%k" "%t" "%w" "%x" "%y" "%X" "%Y"))
+ string->number
+ id))
+ argspecs)))
+
+(define (proc-with-transformed-args proc argspecs)
+ (let ((transformers
+ (make-arg-transformers argspecs)))
+ (lambda args
+ (apply proc (map (lambda (t a) (t a))
+ transformers args)))))
+
+\f
+
+(define button-stretch 2)
+(define canvas-stretch 20)
+(define entry-height-stretch 1)
+
+(define make-button
+ (let ((maker (make-tk-widget
+ "button" tk-make-button
+ (lambda (button scheme-callback-hash-number)
+ (ask-widget
+ button
+ `(configure -command
+ ,(string-append
+ "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (button button-width button-height)
+ (set-%hglue! button (make-fill-glue button-width button-stretch))
+ (set-%vglue! button (make-fill-glue button-height button-stretch))
+ ))))
+ (lambda options ;but don't use -callback!
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((button (maker)))
+ (ask-widget button `(configure ,@configure-options))
+ button)))))
+
+(define remember-on-canvas!
+ (let ((fix! (lambda (widget value)
+ (set-TKWidget%.%binding-callbacks! widget value)))
+ (fetch (lambda (widget) (TKWidget%.%binding-callbacks widget))))
+ (lambda (canvas thing-to-remember)
+ (fix! canvas (cons thing-to-remember (fetch canvas))))))
+
+(define make-canvas
+ (let ((maker (make-tk-widget
+ "canvas" tk-make-canvas #F #T
+ (lambda (canvas canvas-width canvas-height)
+ (set-%hglue! canvas (make-fill-glue canvas-width canvas-stretch))
+ (set-%vglue! canvas (make-fill-glue canvas-height canvas-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((canvas (maker)))
+ (ask-widget canvas `(configure ,@configure-options))
+ canvas)))))
+
+(define make-checkbutton
+ (let ((maker (make-tk-widget
+ "checkbutton" tk-make-checkbutton
+ (lambda (checkbutton scheme-callback-hash-number)
+ (ask-widget
+ checkbutton
+ `(configure -command
+ ,(string-append
+ "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (checkbutton cb-width cb-height)
+ (set-%hglue! checkbutton (make-fill-glue cb-width button-stretch))
+ (set-%vglue! checkbutton (make-fill-glue cb-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((checkbutton (maker)))
+ (ask-widget checkbutton `(configure ,@configure-options))
+ checkbutton)))))
+
+(define make-entry
+ (let ((maker
+ (make-tk-widget
+ "entry"
+ tk-make-entry
+ (lambda (entry scheme-callback-hash-number)
+ (ask-widget
+ entry
+ `(configure -Scrollcommand
+ ,(string-append "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (entry entry-width entry-height)
+ (set-%hglue! entry (make-fill-glue entry-width button-stretch))
+ (set-%vglue! entry (make-fill-glue entry-height entry-height-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((entry (maker)))
+ (ask-widget entry `(configure ,@configure-options))
+ entry)))))
+
+(define make-label
+ (let ((maker (make-tk-widget
+ "label" tk-make-label
+ #F ; No callbacks allowed
+ #T ; Normal screen-area handling
+ (lambda (label label-width label-height)
+ (set-%hglue! label (make-fill-glue label-width button-stretch))
+ (set-%vglue! label (make-fill-glue label-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((label (maker)))
+ (ask-widget label `(configure ,@configure-options))
+ label)))))
+
+(define make-listbox
+ (let ((maker (make-tk-widget
+ "listbox" tk-make-listbox
+ #F ; No callbacks allowed
+ #T ; Normal screen-area handling
+ (lambda (listbox listbox-width listbox-height)
+ (set-%hglue! listbox (make-fill-glue listbox-width button-stretch))
+ (set-%vglue! listbox (make-fill-glue listbox-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((listbox (maker)))
+ (ask-widget listbox `(configure ,@configure-options))
+ listbox)))))
+
+(define make-menu
+ (let ((maker (make-tk-widget
+ "menu" tk-make-menu
+ #F ; No callbacks allowed
+ #F ; No screen area assignment code
+ (lambda (menu menu-width menu-height)
+ (set-%hglue! menu (make-fill-glue menu-width button-stretch))
+ (set-%vglue! text (make-fill-glue menu-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let* ((menu (maker))
+ (mr (make-menurecord menu '())))
+ (set! *all-menus* (weak-cons mr *all-menus*))
+ (uiobj-protect-from-gc! menu mr)
+ (ask-widget menu `(configure ,@configure-options))
+ menu)))))
+
+(define make-menubutton
+ (let ((maker (make-tk-widget
+ "menubutton"
+ tk-make-menubutton
+ #F ; No callbacks allowed
+ #T ; Normal screen-area handling
+ (lambda (menubutton mb-width mb-height)
+ (set-%hglue! menubutton (make-fill-glue mb-width button-stretch))
+ (set-%vglue! menubutton (make-fill-glue mb-height button-stretch))))))
+ (lambda (menu . options) ; options can't include -menu
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((menubutton (maker)))
+ (add-child! menubutton menu)
+ (ask-widget menubutton `(configure ,@configure-options))
+ (ask-widget menubutton
+ `(configure -menu
+ ,(lambda () (tk-widget->pathname menu))))
+ menubutton)))))
+
+(define make-message
+ (let ((maker (make-tk-widget
+ "message" tk-make-message
+ #F ; No callbacks allowed
+ #T ; Normal screen-area handling
+ (lambda (message message-width message-height)
+ (set-%hglue! message (make-fill-glue message-width button-stretch))
+ (set-%vglue! message (make-fill-glue message-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((message (maker)))
+ (ask-widget message `(configure ,@configure-options))
+ message)))))
+
+(define make-radiobutton
+ (let ((maker (make-tk-widget
+ "radiobutton" tk-make-radiobutton
+ (lambda (radiobutton scheme-callback-hash-number)
+ (ask-widget
+ radiobutton
+ `(configure -command
+ ,(string-append
+ "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (radiobutton rb-width rb-height)
+ (set-%hglue! radiobutton (make-fill-glue rb-width button-stretch))
+ (set-%vglue! radiobutton (make-fill-glue rb-height button-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((radiobutton (maker)))
+ (ask-widget radiobutton `(configure ,@configure-options))
+ radiobutton)))))
+
+(define (after-last-space string)
+ (let ((index (string-find-previous-char string #\Space)))
+ (if index
+ (substring string (+ index 1) (string-length string))
+ (error "String does not contain a space" string))))
+
+(define (get-tk-widget-orientation tk-widget)
+ ;; returns 'v or 'h.
+ (string->symbol
+ (string-downcase
+ (substring
+ (after-last-space
+ (ask-widget tk-widget '(configure -orient)))
+ 0
+ 1))))
+
+(define make-scale
+ (let ((maker
+ (make-tk-widget
+ "scale"
+ tk-make-scale
+ (lambda (scale scheme-callback-hash-number)
+ (ask-widget scale
+ `(configure -command
+ ,(string-append
+ "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (scale scale-width scale-height)
+ (let ((orientation (get-tk-widget-orientation scale)))
+ (cond ((eq? orientation 'v)
+ (set-%hglue! scale (make-rigid-glue scale-width 1))
+ (set-%vglue! scale (make-fill-glue scale-height button-stretch)))
+ ((eq? orientation 'h)
+ (set-%hglue! scale (make-fill-glue scale-width button-stretch))
+ (set-%vglue! scale (make-rigid-glue scale-height 1)))
+ (else (error "Bad orientation: Must be 'h or 'v" orientation))))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((scale (maker)))
+ (ask-widget scale `(configure ,@configure-options))
+ scale)))))
+
+(define make-scrollbar
+ (let ((maker
+ (make-tk-widget
+ "scrollbar"
+ tk-make-scrollbar
+ (lambda (scrollbar scheme-callback-hash-number)
+ (ask-widget
+ scrollbar
+ `(configure -command
+ ,(string-append "SchemeCallBack "
+ (number->string
+ scheme-callback-hash-number)))))
+ #T
+ (lambda (scrollbar scrollbar-width scrollbar-height)
+ (let ((orientation (get-tk-widget-orientation scrollbar)))
+ (cond ((eq? orientation 'v)
+ (set-%hglue! scrollbar (make-rigid-glue scrollbar-width 1))
+ (set-%vglue! scrollbar (make-fil-glue scrollbar-height 1)))
+ ((eq? orientation 'h)
+ (set-%hglue! scrollbar (make-fil-glue scrollbar-width 1))
+ (set-%vglue! scrollbar (make-rigid-glue scrollbar-height 1)))
+ (else (error "Bad orientation: must be 'h or 'v" orientation))))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((scrollbar (maker)))
+ (ask-widget scrollbar `(configure ,@configure-options))
+ scrollbar)))))
+
+(define make-text
+ (let ((maker (make-tk-widget
+ "text"
+ tk-make-text
+ #F ; No callbacks allowed
+ #T ; Normal screen-area handling
+ (lambda (text text-width text-height)
+ (set-%hglue! text (make-fill-glue text-width canvas-stretch))
+ (set-%vglue! text (make-fill-glue text-height canvas-stretch))))))
+ (lambda options
+ (let ((configure-options
+ (if (null? options)
+ '()
+ (car options))))
+ (let ((text (maker)))
+ (ask-widget text `(configure ,@configure-options))
+ text)))))
+\f
+;;; TK has "active variables"
+
+;;; Ask-widget should be changed so that TK-variables get replaced by
+;;; their names [WHAT DOES THIS MEAN?? -- Hal]
+
+(define (make-active-variable . application)
+ (let ((application (if (null? application)
+ *the-default-application*
+ (car application))))
+ (let* ((tk-name (tk-gen-name "variable"))
+ (variable (make-TK-variable application tk-name #F)))
+ (UIObj-protect-from-gc! application variable)
+ variable)))
+
+(define (active-variable-value var)
+ (tcl-global-eval
+ (TK-variable.application var)
+ "expr"
+ (list (string-append "$" (TK-variable.tk-name var)))))
+
+(define (set-active-variable! var value)
+ (tcl-global-eval
+ (TK-variable.application var)
+ "set"
+ (list (TK-variable.tk-name var) value)))
+
+(define (set-active-variable-callback! var thunk)
+ (let ((app (TK-variable.application var))
+ (name (TK-variable.tk-name var))
+ (cb (TK-variable.callback var)))
+ (if cb
+ (tcl-global-eval
+ app "trace"
+ (list "vdelete" name "w" `("SchemeCallBack"
+ ,(object-hash cb *our-hash-table*)))))
+ (let ((the-callback
+ (lambda (arg1 arg2 arg3) ;tcl generates these
+ arg1 arg2 arg3 ;but we'll ignore them
+ (thunk))))
+ (tcl-global-eval
+ app "trace"
+ (list "variable" name "w"
+ `("SchemeCallBack"
+ ,(object-hash the-callback *our-hash-table*))
+ ))
+ (set-TK-variable.callback! var the-callback))))
+
+(define (checkbutton-variable-on? var)
+ (equal? (active-variable-value var) "1"))
+
+\f
+(define (initialize-widgets!)
+ (SCXL-Install-XCloseDisplay-Callback
+ destroy-associated-tk-widgets))
+
+(initialize-widgets!)
--- /dev/null
+(define-constant X_PROTOCOL 11)
+(define-constant X_PROTOCOL_REVISION 0)
+(define-constant NONE 0)
+(define-constant PARENTRELATIVE 1)
+(define-constant COPYFROMPARENT 0)
+(define-constant POINTERWINDOW 0)
+(define-constant INPUTFOCUS 1)
+(define-constant POINTERROOT 1)
+(define-constant ANYPROPERTYTYPE 0)
+(define-constant ANYKEY 0)
+(define-constant ANYBUTTON 0)
+(define-constant ALLTEMPORARY 0)
+(define-constant CURRENTTIME 0)
+(define-constant NOSYMBOL 0)
+(define-constant NOEVENTMASK 0)
+(define-constant KEYPRESSMASK 1)
+(define-constant KEYRELEASEMASK 2)
+(define-constant BUTTONPRESSMASK 4)
+(define-constant BUTTONRELEASEMASK 8)
+(define-constant ENTERWINDOWMASK 16)
+(define-constant LEAVEWINDOWMASK 32)
+(define-constant POINTERMOTIONMASK 64)
+(define-constant POINTERMOTIONHINTMASK 128)
+(define-constant BUTTON1MOTIONMASK 256)
+(define-constant BUTTON2MOTIONMASK 512)
+(define-constant BUTTON3MOTIONMASK 1024)
+(define-constant BUTTON4MOTIONMASK 2048)
+(define-constant BUTTON5MOTIONMASK 4096)
+(define-constant BUTTONMOTIONMASK 8192)
+(define-constant KEYMAPSTATEMASK 16384)
+(define-constant EXPOSUREMASK 32768)
+(define-constant VISIBILITYCHANGEMASK 65536)
+(define-constant STRUCTURENOTIFYMASK 131072)
+(define-constant RESIZEREDIRECTMASK 262144)
+(define-constant SUBSTRUCTURENOTIFYMASK 524288)
+(define-constant SUBSTRUCTUREREDIRECTMASK 1048576)
+(define-constant FOCUSCHANGEMASK 2097152)
+(define-constant PROPERTYCHANGEMASK 4194304)
+(define-constant COLORMAPCHANGEMASK 8388608)
+(define-constant OWNERGRABBUTTONMASK 16777216)
+(define-constant KEYPRESS 2)
+(define-constant KEYRELEASE 3)
+(define-constant BUTTONPRESS 4)
+(define-constant BUTTONRELEASE 5)
+(define-constant MOTIONNOTIFY 6)
+(define-constant ENTERNOTIFY 7)
+(define-constant LEAVENOTIFY 8)
+(define-constant FOCUSIN 9)
+(define-constant FOCUSOUT 10)
+(define-constant KEYMAPNOTIFY 11)
+(define-constant EXPOSE 12)
+(define-constant GRAPHICSEXPOSE 13)
+(define-constant NOEXPOSE 14)
+(define-constant VISIBILITYNOTIFY 15)
+(define-constant CREATENOTIFY 16)
+(define-constant DESTROYNOTIFY 17)
+(define-constant UNMAPNOTIFY 18)
+(define-constant MAPNOTIFY 19)
+(define-constant MAPREQUEST 20)
+(define-constant REPARENTNOTIFY 21)
+(define-constant CONFIGURENOTIFY 22)
+(define-constant CONFIGUREREQUEST 23)
+(define-constant GRAVITYNOTIFY 24)
+(define-constant RESIZEREQUEST 25)
+(define-constant CIRCULATENOTIFY 26)
+(define-constant CIRCULATEREQUEST 27)
+(define-constant PROPERTYNOTIFY 28)
+(define-constant SELECTIONCLEAR 29)
+(define-constant SELECTIONREQUEST 30)
+(define-constant SELECTIONNOTIFY 31)
+(define-constant COLORMAPNOTIFY 32)
+(define-constant CLIENTMESSAGE 33)
+(define-constant MAPPINGNOTIFY 34)
+(define-constant LASTEVENT 35)
+(define-constant SHIFTMASK 1)
+(define-constant LOCKMASK 2)
+(define-constant CONTROLMASK 4)
+(define-constant MOD1MASK 8)
+(define-constant MOD2MASK 16)
+(define-constant MOD3MASK 32)
+(define-constant MOD4MASK 64)
+(define-constant MOD5MASK 128)
+(define-constant SHIFTMAPINDEX 0)
+(define-constant LOCKMAPINDEX 1)
+(define-constant CONTROLMAPINDEX 2)
+(define-constant MOD1MAPINDEX 3)
+(define-constant MOD2MAPINDEX 4)
+(define-constant MOD3MAPINDEX 5)
+(define-constant MOD4MAPINDEX 6)
+(define-constant MOD5MAPINDEX 7)
+(define-constant BUTTON1MASK 256)
+(define-constant BUTTON2MASK 512)
+(define-constant BUTTON3MASK 1024)
+(define-constant BUTTON4MASK 2048)
+(define-constant BUTTON5MASK 4096)
+(define-constant ANYMODIFIER 32768)
+(define-constant BUTTON1 1)
+(define-constant BUTTON2 2)
+(define-constant BUTTON3 3)
+(define-constant BUTTON4 4)
+(define-constant BUTTON5 5)
+(define-constant NOTIFYNORMAL 0)
+(define-constant NOTIFYGRAB 1)
+(define-constant NOTIFYUNGRAB 2)
+(define-constant NOTIFYWHILEGRABBED 3)
+(define-constant NOTIFYHINT 1)
+(define-constant NOTIFYANCESTOR 0)
+(define-constant NOTIFYVIRTUAL 1)
+(define-constant NOTIFYINFERIOR 2)
+(define-constant NOTIFYNONLINEAR 3)
+(define-constant NOTIFYNONLINEARVIRTUAL 4)
+(define-constant NOTIFYPOINTER 5)
+(define-constant NOTIFYPOINTERROOT 6)
+(define-constant NOTIFYDETAILNONE 7)
+(define-constant VISIBILITYUNOBSCURED 0)
+(define-constant VISIBILITYPARTIALLYOBSCURED 1)
+(define-constant VISIBILITYFULLYOBSCURED 2)
+(define-constant PLACEONTOP 0)
+(define-constant PLACEONBOTTOM 1)
+(define-constant FAMILYINTERNET 0)
+(define-constant FAMILYDECNET 1)
+(define-constant FAMILYCHAOS 2)
+(define-constant PROPERTYNEWVALUE 0)
+(define-constant PROPERTYDELETE 1)
+(define-constant COLORMAPUNINSTALLED 0)
+(define-constant COLORMAPINSTALLED 1)
+(define-constant GRABMODESYNC 0)
+(define-constant GRABMODEASYNC 1)
+(define-constant GRABSUCCESS 0)
+(define-constant ALREADYGRABBED 1)
+(define-constant GRABINVALIDTIME 2)
+(define-constant GRABNOTVIEWABLE 3)
+(define-constant GRABFROZEN 4)
+(define-constant ASYNCPOINTER 0)
+(define-constant SYNCPOINTER 1)
+(define-constant REPLAYPOINTER 2)
+(define-constant ASYNCKEYBOARD 3)
+(define-constant SYNCKEYBOARD 4)
+(define-constant REPLAYKEYBOARD 5)
+(define-constant ASYNCBOTH 6)
+(define-constant SYNCBOTH 7)
+(define-constant REVERTTONONE 0)
+(define-constant REVERTTOPOINTERROOT 1)
+(define-constant REVERTTOPARENT 2)
+(define-constant SUCCESS 0)
+(define-constant BADREQUEST 1)
+(define-constant BADVALUE 2)
+(define-constant BADWINDOW 3)
+(define-constant BADPIXMAP 4)
+(define-constant BADATOM 5)
+(define-constant BADCURSOR 6)
+(define-constant BADFONT 7)
+(define-constant BADMATCH 8)
+(define-constant BADDRAWABLE 9)
+(define-constant BADACCESS 10)
+(define-constant BADALLOC 11)
+(define-constant BADCOLOR 12)
+(define-constant BADGC 13)
+(define-constant BADIDCHOICE 14)
+(define-constant BADNAME 15)
+(define-constant BADLENGTH 16)
+(define-constant BADIMPLEMENTATION 17)
+(define-constant FIRSTEXTENSIONERROR 128)
+(define-constant LASTEXTENSIONERROR 255)
+(define-constant INPUTOUTPUT 1)
+(define-constant INPUTONLY 2)
+(define-constant CWBACKPIXMAP 1)
+(define-constant CWBACKPIXEL 2)
+(define-constant CWBORDERPIXMAP 4)
+(define-constant CWBORDERPIXEL 8)
+(define-constant CWBITGRAVITY 16)
+(define-constant CWWINGRAVITY 32)
+(define-constant CWBACKINGSTORE 64)
+(define-constant CWBACKINGPLANES 128)
+(define-constant CWBACKINGPIXEL 256)
+(define-constant CWOVERRIDEREDIRECT 512)
+(define-constant CWSAVEUNDER 1024)
+(define-constant CWEVENTMASK 2048)
+(define-constant CWDONTPROPAGATE 4096)
+(define-constant CWCOLORMAP 8192)
+(define-constant CWCURSOR 16384)
+(define-constant CWX 1)
+(define-constant CWY 2)
+(define-constant CWWIDTH 4)
+(define-constant CWHEIGHT 8)
+(define-constant CWBORDERWIDTH 16)
+(define-constant CWSIBLING 32)
+(define-constant CWSTACKMODE 64)
+(define-constant FORGETGRAVITY 0)
+(define-constant NORTHWESTGRAVITY 1)
+(define-constant NORTHGRAVITY 2)
+(define-constant NORTHEASTGRAVITY 3)
+(define-constant WESTGRAVITY 4)
+(define-constant CENTERGRAVITY 5)
+(define-constant EASTGRAVITY 6)
+(define-constant SOUTHWESTGRAVITY 7)
+(define-constant SOUTHGRAVITY 8)
+(define-constant SOUTHEASTGRAVITY 9)
+(define-constant STATICGRAVITY 10)
+(define-constant UNMAPGRAVITY 0)
+(define-constant NOTUSEFUL 0)
+(define-constant WHENMAPPED 1)
+(define-constant ALWAYS 2)
+(define-constant ISUNMAPPED 0)
+(define-constant ISUNVIEWABLE 1)
+(define-constant ISVIEWABLE 2)
+(define-constant SETMODEINSERT 0)
+(define-constant SETMODEDELETE 1)
+(define-constant DESTROYALL 0)
+(define-constant RETAINPERMANENT 1)
+(define-constant RETAINTEMPORARY 2)
+(define-constant ABOVE 0)
+(define-constant BELOW 1)
+(define-constant TOPIF 2)
+(define-constant BOTTOMIF 3)
+(define-constant OPPOSITE 4)
+(define-constant RAISELOWEST 0)
+(define-constant LOWERHIGHEST 1)
+(define-constant PROPMODEREPLACE 0)
+(define-constant PROPMODEPREPEND 1)
+(define-constant PROPMODEAPPEND 2)
+(define-constant GXCLEAR 0)
+(define-constant GXAND 1)
+(define-constant GXANDREVERSE 2)
+(define-constant GXCOPY 3)
+(define-constant GXANDINVERTED 4)
+(define-constant GXNOOP 5)
+(define-constant GXXOR 6)
+(define-constant GXOR 7)
+(define-constant GXNOR 8)
+(define-constant GXEQUIV 9)
+(define-constant GXINVERT 10)
+(define-constant GXORREVERSE 11)
+(define-constant GXCOPYINVERTED 12)
+(define-constant GXORINVERTED 13)
+(define-constant GXNAND 14)
+(define-constant GXSET 15)
+(define-constant LINESOLID 0)
+(define-constant LINEONOFFDASH 1)
+(define-constant LINEDOUBLEDASH 2)
+(define-constant CAPNOTLAST 0)
+(define-constant CAPBUTT 1)
+(define-constant CAPROUND 2)
+(define-constant CAPPROJECTING 3)
+(define-constant JOINMITER 0)
+(define-constant JOINROUND 1)
+(define-constant JOINBEVEL 2)
+(define-constant FILLSOLID 0)
+(define-constant FILLTILED 1)
+(define-constant FILLSTIPPLED 2)
+(define-constant FILLOPAQUESTIPPLED 3)
+(define-constant EVENODDRULE 0)
+(define-constant WINDINGRULE 1)
+(define-constant CLIPBYCHILDREN 0)
+(define-constant INCLUDEINFERIORS 1)
+(define-constant UNSORTED 0)
+(define-constant YSORTED 1)
+(define-constant YXSORTED 2)
+(define-constant YXBANDED 3)
+(define-constant COORDMODEORIGIN 0)
+(define-constant COORDMODEPREVIOUS 1)
+(define-constant COMPLEX 0)
+(define-constant NONCONVEX 1)
+(define-constant CONVEX 2)
+(define-constant ARCCHORD 0)
+(define-constant ARCPIESLICE 1)
+(define-constant GCFUNCTION 1)
+(define-constant GCPLANEMASK 2)
+(define-constant GCFOREGROUND 4)
+(define-constant GCBACKGROUND 8)
+(define-constant GCLINEWIDTH 16)
+(define-constant GCLINESTYLE 32)
+(define-constant GCCAPSTYLE 64)
+(define-constant GCJOINSTYLE 128)
+(define-constant GCFILLSTYLE 256)
+(define-constant GCFILLRULE 512)
+(define-constant GCTILE 1024)
+(define-constant GCSTIPPLE 2048)
+(define-constant GCTILESTIPXORIGIN 4096)
+(define-constant GCTILESTIPYORIGIN 8192)
+(define-constant GCFONT 16384)
+(define-constant GCSUBWINDOWMODE 32768)
+(define-constant GCGRAPHICSEXPOSURES 65536)
+(define-constant GCCLIPXORIGIN 131072)
+(define-constant GCCLIPYORIGIN 262144)
+(define-constant GCCLIPMASK 524288)
+(define-constant GCDASHOFFSET 1048576)
+(define-constant GCDASHLIST 2097152)
+(define-constant GCARCMODE 4194304)
+(define-constant GCLASTBIT 22)
+(define-constant FONTLEFTTORIGHT 0)
+(define-constant FONTRIGHTTOLEFT 1)
+(define-constant FONTCHANGE 255)
+(define-constant XYBITMAP 0)
+(define-constant XYPIXMAP 1)
+(define-constant ZPIXMAP 2)
+(define-constant ALLOCNONE 0)
+(define-constant ALLOCALL 1)
+(define-constant DORED 1)
+(define-constant DOGREEN 2)
+(define-constant DOBLUE 4)
+(define-constant CURSORSHAPE 0)
+(define-constant TILESHAPE 1)
+(define-constant STIPPLESHAPE 2)
+(define-constant AUTOREPEATMODEOFF 0)
+(define-constant AUTOREPEATMODEON 1)
+(define-constant AUTOREPEATMODEDEFAULT 2)
+(define-constant LEDMODEOFF 0)
+(define-constant LEDMODEON 1)
+(define-constant KBKEYCLICKPERCENT 1)
+(define-constant KBBELLPERCENT 2)
+(define-constant KBBELLPITCH 4)
+(define-constant KBBELLDURATION 8)
+(define-constant KBLED 16)
+(define-constant KBLEDMODE 32)
+(define-constant KBKEY 64)
+(define-constant KBAUTOREPEATMODE 128)
+(define-constant MAPPINGSUCCESS 0)
+(define-constant MAPPINGBUSY 1)
+(define-constant MAPPINGFAILED 2)
+(define-constant MAPPINGMODIFIER 0)
+(define-constant MAPPINGKEYBOARD 1)
+(define-constant MAPPINGPOINTER 2)
+(define-constant DONTPREFERBLANKING 0)
+(define-constant PREFERBLANKING 1)
+(define-constant DEFAULTBLANKING 2)
+(define-constant DISABLESCREENSAVER 0)
+(define-constant DISABLESCREENINTERVAL 0)
+(define-constant DONTALLOWEXPOSURES 0)
+(define-constant ALLOWEXPOSURES 1)
+(define-constant DEFAULTEXPOSURES 2)
+(define-constant SCREENSAVERRESET 0)
+(define-constant SCREENSAVERACTIVE 1)
+(define-constant HOSTINSERT 0)
+(define-constant HOSTDELETE 1)
+(define-constant ENABLEACCESS 1)
+(define-constant DISABLEACCESS 0)
+(define-constant STATICGRAY 0)
+(define-constant GRAYSCALE 1)
+(define-constant STATICCOLOR 2)
+(define-constant PSEUDOCOLOR 3)
+(define-constant TRUECOLOR 4)
+(define-constant DIRECTCOLOR 5)
+(define-constant LSBFIRST 0)
+(define-constant MSBFIRST 1)
+(define-constant XA_PRIMARY 1)
+(define-constant XA_SECONDARY 2)
+(define-constant XA_ARC 3)
+(define-constant XA_ATOM 4)
+(define-constant XA_BITMAP 5)
+(define-constant XA_CARDINAL 6)
+(define-constant XA_COLORMAP 7)
+(define-constant XA_CURSOR 8)
+(define-constant XA_CUT_BUFFER0 9)
+(define-constant XA_CUT_BUFFER1 10)
+(define-constant XA_CUT_BUFFER2 11)
+(define-constant XA_CUT_BUFFER3 12)
+(define-constant XA_CUT_BUFFER4 13)
+(define-constant XA_CUT_BUFFER5 14)
+(define-constant XA_CUT_BUFFER6 15)
+(define-constant XA_CUT_BUFFER7 16)
+(define-constant XA_DRAWABLE 17)
+(define-constant XA_FONT 18)
+(define-constant XA_INTEGER 19)
+(define-constant XA_PIXMAP 20)
+(define-constant XA_POINT 21)
+(define-constant XA_RECTANGLE 22)
+(define-constant XA_RESOURCE_MANAGER 23)
+(define-constant XA_RGB_COLOR_MAP 24)
+(define-constant XA_RGB_BEST_MAP 25)
+(define-constant XA_RGB_BLUE_MAP 26)
+(define-constant XA_RGB_DEFAULT_MAP 27)
+(define-constant XA_RGB_GRAY_MAP 28)
+(define-constant XA_RGB_GREEN_MAP 29)
+(define-constant XA_RGB_RED_MAP 30)
+(define-constant XA_STRING 31)
+(define-constant XA_VISUALID 32)
+(define-constant XA_WINDOW 33)
+(define-constant XA_WM_COMMAND 34)
+(define-constant XA_WM_HINTS 35)
+(define-constant XA_WM_CLIENT_MACHINE 36)
+(define-constant XA_WM_ICON_NAME 37)
+(define-constant XA_WM_ICON_SIZE 38)
+(define-constant XA_WM_NAME 39)
+(define-constant XA_WM_NORMAL_HINTS 40)
+(define-constant XA_WM_SIZE_HINTS 41)
+(define-constant XA_WM_ZOOM_HINTS 42)
+(define-constant XA_MIN_SPACE 43)
+(define-constant XA_NORM_SPACE 44)
+(define-constant XA_MAX_SPACE 45)
+(define-constant XA_END_SPACE 46)
+(define-constant XA_SUPERSCRIPT_X 47)
+(define-constant XA_SUPERSCRIPT_Y 48)
+(define-constant XA_SUBSCRIPT_X 49)
+(define-constant XA_SUBSCRIPT_Y 50)
+(define-constant XA_UNDERLINE_POSITION 51)
+(define-constant XA_UNDERLINE_THICKNESS 52)
+(define-constant XA_STRIKEOUT_ASCENT 53)
+(define-constant XA_STRIKEOUT_DESCENT 54)
+(define-constant XA_ITALIC_ANGLE 55)
+(define-constant XA_X_HEIGHT 56)
+(define-constant XA_QUAD_WIDTH 57)
+(define-constant XA_WEIGHT 58)
+(define-constant XA_POINT_SIZE 59)
+(define-constant XA_RESOLUTION 60)
+(define-constant XA_COPYRIGHT 61)
+(define-constant XA_NOTICE 62)
+(define-constant XA_FONT_NAME 63)
+(define-constant XA_FAMILY_NAME 64)
+(define-constant XA_FULL_NAME 65)
+(define-constant XA_CAP_HEIGHT 66)
+(define-constant XA_WM_CLASS 67)
+(define-constant XA_WM_TRANSIENT_FOR 68)
+(define-constant XA_LAST_PREDEFINED 68)
+(define-constant QUEUEDALREADY 0)
+(define-constant QUEUEDAFTERREADING 1)
+(define-constant QUEUEDAFTERFLUSH 2)
+(define-constant ALLPLANES -1)
+(define-constant NULL 0)
+(define-constant NULLQUARK 0)
+(define-constant NULLSTRING 0)
+(define-constant XRMBINDTIGHTLY 0)
+(define-constant XRMBINDLOOSELY 1)
+(define-constant XRMOPTIONNOARG 0)
+(define-constant XRMOPTIONISARG 1)
+(define-constant XRMOPTIONSTICKYARG 2)
+(define-constant XRMOPTIONSEPARG 3)
+(define-constant XRMOPTIONRESARG 4)
+(define-constant XRMOPTIONSKIPARG 5)
+(define-constant XRMOPTIONSKIPLINE 6)
+(define-constant NOVALUE 0)
+(define-constant XVALUE 1)
+(define-constant YVALUE 2)
+(define-constant WIDTHVALUE 4)
+(define-constant HEIGHTVALUE 8)
+(define-constant ALLVALUES 15)
+(define-constant XNEGATIVE 16)
+(define-constant YNEGATIVE 32)
+(define-constant USPOSITION 1)
+(define-constant USSIZE 2)
+(define-constant PPOSITION 4)
+(define-constant PSIZE 8)
+(define-constant PMINSIZE 16)
+(define-constant PMAXSIZE 32)
+(define-constant PRESIZEINC 64)
+(define-constant PASPECT 128)
+(define-constant PALLHINTS 252)
+(define-constant INPUTHINT 1)
+(define-constant STATEHINT 2)
+(define-constant ICONPIXMAPHINT 4)
+(define-constant ICONWINDOWHINT 8)
+(define-constant ICONPOSITIONHINT 16)
+(define-constant ICONMASKHINT 32)
+(define-constant WINDOWGROUPHINT 64)
+(define-constant ALLHINTS 127)
+(define-constant DONTCARESTATE 0)
+(define-constant NORMALSTATE 1)
+(define-constant ZOOMSTATE 2)
+(define-constant ICONICSTATE 3)
+(define-constant INACTIVESTATE 4)
+(define-constant RECTANGLEOUT 0)
+(define-constant RECTANGLEIN 1)
+(define-constant RECTANGLEPART 2)
+(define-constant VISUALNOMASK 0)
+(define-constant VISUALIDMASK 1)
+(define-constant VISUALSCREENMASK 2)
+(define-constant VISUALDEPTHMASK 4)
+(define-constant VISUALCLASSMASK 8)
+(define-constant VISUALREDMASKMASK 16)
+(define-constant VISUALGREENMASKMASK 32)
+(define-constant VISUALBLUEMASKMASK 64)
+(define-constant VISUALCOLORMAPSIZEMASK 128)
+(define-constant VISUALBITSPERRGBMASK 256)
+(define-constant VISUALALLMASK 511)
+(define-constant BITMAPSUCCESS 0)
+(define-constant BITMAPOPENFAILED 1)
+(define-constant BITMAPFILEINVALID 2)
+(define-constant BITMAPNOMEMORY 3)
+(define-constant XCSUCCESS 0)
+(define-constant XCNOMEM 1)
+(define-constant XCNOENT 2)
+(define-constant XK_BACKSPACE 65288)
+(define-constant XK_TAB 65289)
+(define-constant XK_LINEFEED 65290)
+(define-constant XK_CLEAR 65291)
+(define-constant XK_RETURN 65293)
+(define-constant XK_PAUSE 65299)
+(define-constant XK_ESCAPE 65307)
+(define-constant XK_DELETE 65535)
+(define-constant XK_MULTI_KEY 65312)
+(define-constant XK_KANJI 65313)
+(define-constant XK_HOME 65360)
+(define-constant XK_LEFT 65361)
+(define-constant XK_UP 65362)
+(define-constant XK_RIGHT 65363)
+(define-constant XK_DOWN 65364)
+(define-constant XK_PRIOR 65365)
+(define-constant XK_NEXT 65366)
+(define-constant XK_END 65367)
+(define-constant XK_BEGIN 65368)
+(define-constant XK_SELECT 65376)
+(define-constant XK_PRINT 65377)
+(define-constant XK_EXECUTE 65378)
+(define-constant XK_INSERT 65379)
+(define-constant XK_UNDO 65381)
+(define-constant XK_REDO 65382)
+(define-constant XK_MENU 65383)
+(define-constant XK_FIND 65384)
+(define-constant XK_CANCEL 65385)
+(define-constant XK_HELP 65386)
+(define-constant XK_BREAK 65387)
+(define-constant XK_MODE_SWITCH 65406)
+(define-constant XK_SCRIPT_SWITCH 65406)
+(define-constant XK_NUM_LOCK 65407)
+(define-constant XK_KP_SPACE 65408)
+(define-constant XK_KP_TAB 65417)
+(define-constant XK_KP_ENTER 65421)
+(define-constant XK_KP_F1 65425)
+(define-constant XK_KP_F2 65426)
+(define-constant XK_KP_F3 65427)
+(define-constant XK_KP_F4 65428)
+(define-constant XK_KP_EQUAL 65469)
+(define-constant XK_KP_MULTIPLY 65450)
+(define-constant XK_KP_ADD 65451)
+(define-constant XK_KP_SEPARATOR 65452)
+(define-constant XK_KP_SUBTRACT 65453)
+(define-constant XK_KP_DECIMAL 65454)
+(define-constant XK_KP_DIVIDE 65455)
+(define-constant XK_KP_0 65456)
+(define-constant XK_KP_1 65457)
+(define-constant XK_KP_2 65458)
+(define-constant XK_KP_3 65459)
+(define-constant XK_KP_4 65460)
+(define-constant XK_KP_5 65461)
+(define-constant XK_KP_6 65462)
+(define-constant XK_KP_7 65463)
+(define-constant XK_KP_8 65464)
+(define-constant XK_KP_9 65465)
+(define-constant XK_F1 65470)
+(define-constant XK_F2 65471)
+(define-constant XK_F3 65472)
+(define-constant XK_F4 65473)
+(define-constant XK_F5 65474)
+(define-constant XK_F6 65475)
+(define-constant XK_F7 65476)
+(define-constant XK_F8 65477)
+(define-constant XK_F9 65478)
+(define-constant XK_F10 65479)
+(define-constant XK_F11 65480)
+(define-constant XK_L1 65480)
+(define-constant XK_F12 65481)
+(define-constant XK_L2 65481)
+(define-constant XK_F13 65482)
+(define-constant XK_L3 65482)
+(define-constant XK_F14 65483)
+(define-constant XK_L4 65483)
+(define-constant XK_F15 65484)
+(define-constant XK_L5 65484)
+(define-constant XK_F16 65485)
+(define-constant XK_L6 65485)
+(define-constant XK_F17 65486)
+(define-constant XK_L7 65486)
+(define-constant XK_F18 65487)
+(define-constant XK_L8 65487)
+(define-constant XK_F19 65488)
+(define-constant XK_L9 65488)
+(define-constant XK_F20 65489)
+(define-constant XK_L10 65489)
+(define-constant XK_F21 65490)
+(define-constant XK_R1 65490)
+(define-constant XK_F22 65491)
+(define-constant XK_R2 65491)
+(define-constant XK_F23 65492)
+(define-constant XK_R3 65492)
+(define-constant XK_F24 65493)
+(define-constant XK_R4 65493)
+(define-constant XK_F25 65494)
+(define-constant XK_R5 65494)
+(define-constant XK_F26 65495)
+(define-constant XK_R6 65495)
+(define-constant XK_F27 65496)
+(define-constant XK_R7 65496)
+(define-constant XK_F28 65497)
+(define-constant XK_R8 65497)
+(define-constant XK_F29 65498)
+(define-constant XK_R9 65498)
+(define-constant XK_F30 65499)
+(define-constant XK_R10 65499)
+(define-constant XK_F31 65500)
+(define-constant XK_R11 65500)
+(define-constant XK_F32 65501)
+(define-constant XK_R12 65501)
+(define-constant XK_R13 65502)
+(define-constant XK_F33 65502)
+(define-constant XK_F34 65503)
+(define-constant XK_R14 65503)
+(define-constant XK_F35 65504)
+(define-constant XK_R15 65504)
+(define-constant XK_SHIFT_L 65505)
+(define-constant XK_SHIFT_R 65506)
+(define-constant XK_CONTROL_L 65507)
+(define-constant XK_CONTROL_R 65508)
+(define-constant XK_CAPS_LOCK 65509)
+(define-constant XK_SHIFT_LOCK 65510)
+(define-constant XK_META_L 65511)
+(define-constant XK_META_R 65512)
+(define-constant XK_ALT_L 65513)
+(define-constant XK_ALT_R 65514)
+(define-constant XK_SUPER_L 65515)
+(define-constant XK_SUPER_R 65516)
+(define-constant XK_HYPER_L 65517)
+(define-constant XK_HYPER_R 65518)
+(define-constant XK_SPACE 32)
+(define-constant XK_EXCLAM 33)
+(define-constant XK_QUOTEDBL 34)
+(define-constant XK_NUMBERSIGN 35)
+(define-constant XK_DOLLAR 36)
+(define-constant XK_PERCENT 37)
+(define-constant XK_AMPERSAND 38)
+(define-constant XK_QUOTERIGHT 39)
+(define-constant XK_PARENLEFT 40)
+(define-constant XK_PARENRIGHT 41)
+(define-constant XK_ASTERISK 42)
+(define-constant XK_PLUS 43)
+(define-constant XK_COMMA 44)
+(define-constant XK_MINUS 45)
+(define-constant XK_PERIOD 46)
+(define-constant XK_SLASH 47)
+(define-constant XK_0 48)
+(define-constant XK_1 49)
+(define-constant XK_2 50)
+(define-constant XK_3 51)
+(define-constant XK_4 52)
+(define-constant XK_5 53)
+(define-constant XK_6 54)
+(define-constant XK_7 55)
+(define-constant XK_8 56)
+(define-constant XK_9 57)
+(define-constant XK_COLON 58)
+(define-constant XK_SEMICOLON 59)
+(define-constant XK_LESS 60)
+(define-constant XK_EQUAL 61)
+(define-constant XK_GREATER 62)
+(define-constant XK_QUESTION 63)
+(define-constant XK_AT 64)
+(define-constant XK_A 65)
+(define-constant XK_B 66)
+(define-constant XK_C 67)
+(define-constant XK_D 68)
+(define-constant XK_E 69)
+(define-constant XK_F 70)
+(define-constant XK_G 71)
+(define-constant XK_H 72)
+(define-constant XK_I 73)
+(define-constant XK_J 74)
+(define-constant XK_K 75)
+(define-constant XK_L 76)
+(define-constant XK_M 77)
+(define-constant XK_N 78)
+(define-constant XK_O 79)
+(define-constant XK_P 80)
+(define-constant XK_Q 81)
+(define-constant XK_R 82)
+(define-constant XK_S 83)
+(define-constant XK_T 84)
+(define-constant XK_U 85)
+(define-constant XK_V 86)
+(define-constant XK_W 87)
+(define-constant XK_X 88)
+(define-constant XK_Y 89)
+(define-constant XK_Z 90)
+(define-constant XK_BRACKETLEFT 91)
+(define-constant XK_BACKSLASH 92)
+(define-constant XK_BRACKETRIGHT 93)
+(define-constant XK_ASCIICIRCUM 94)
+(define-constant XK_UNDERSCORE 95)
+(define-constant XK_QUOTELEFT 96)
+(define-constant XK_LCA 97)
+(define-constant XK_LCB 98)
+(define-constant XK_LCC 99)
+(define-constant XK_LCD 100)
+(define-constant XK_LCE 101)
+(define-constant XK_LCF 102)
+(define-constant XK_LCG 103)
+(define-constant XK_LCH 104)
+(define-constant XK_LCI 105)
+(define-constant XK_LCJ 106)
+(define-constant XK_LCK 107)
+(define-constant XK_LCL 108)
+(define-constant XK_LCM 109)
+(define-constant XK_LCN 110)
+(define-constant XK_LCO 111)
+(define-constant XK_LCP 112)
+(define-constant XK_LCQ 113)
+(define-constant XK_LCR 114)
+(define-constant XK_LCS 115)
+(define-constant XK_LCT 116)
+(define-constant XK_LCU 117)
+(define-constant XK_LCV 118)
+(define-constant XK_LCW 119)
+(define-constant XK_LCX 120)
+(define-constant XK_LCY 121)
+(define-constant XK_LCZ 122)
+(define-constant XK_BRACELEFT 123)
+(define-constant XK_BAR 124)
+(define-constant XK_BRACERIGHT 125)
+(define-constant XK_ASCIITILDE 126)
+(define-constant XK_NOBREAKSPACE 160)
+(define-constant XK_EXCLAMDOWN 161)
+(define-constant XK_CENT 162)
+(define-constant XK_STERLING 163)
+(define-constant XK_CURRENCY 164)
+(define-constant XK_YEN 165)
+(define-constant XK_BROKENBAR 166)
+(define-constant XK_SECTION 167)
+(define-constant XK_DIAERESIS 168)
+(define-constant XK_COPYRIGHT 169)
+(define-constant XK_ORDFEMININE 170)
+(define-constant XK_GUILLEMOTLEFT 171)
+(define-constant XK_NOTSIGN 172)
+(define-constant XK_HYPHEN 173)
+(define-constant XK_REGISTERED 174)
+(define-constant XK_MACRON 175)
+(define-constant XK_DEGREE 176)
+(define-constant XK_PLUSMINUS 177)
+(define-constant XK_TWOSUPERIOR 178)
+(define-constant XK_THREESUPERIOR 179)
+(define-constant XK_ACUTE 180)
+(define-constant XK_MU 181)
+(define-constant XK_PARAGRAPH 182)
+(define-constant XK_PERIODCENTERED 183)
+(define-constant XK_CEDILLA 184)
+(define-constant XK_ONESUPERIOR 185)
+(define-constant XK_MASCULINE 186)
+(define-constant XK_GUILLEMOTRIGHT 187)
+(define-constant XK_ONEQUARTER 188)
+(define-constant XK_ONEHALF 189)
+(define-constant XK_THREEQUARTERS 190)
+(define-constant XK_QUESTIONDOWN 191)
+(define-constant XK_AGRAVE 192)
+(define-constant XK_AACUTE 193)
+(define-constant XK_ACIRCUMFLEX 194)
+(define-constant XK_ATILDE 195)
+(define-constant XK_ADIAERESIS 196)
+(define-constant XK_ARING 197)
+(define-constant XK_AE 198)
+(define-constant XK_CCEDILLA 199)
+(define-constant XK_EGRAVE 200)
+(define-constant XK_EACUTE 201)
+(define-constant XK_ECIRCUMFLEX 202)
+(define-constant XK_EDIAERESIS 203)
+(define-constant XK_IGRAVE 204)
+(define-constant XK_IACUTE 205)
+(define-constant XK_ICIRCUMFLEX 206)
+(define-constant XK_IDIAERESIS 207)
+(define-constant XK_ETH 208)
+(define-constant XK_NTILDE 209)
+(define-constant XK_OGRAVE 210)
+(define-constant XK_OACUTE 211)
+(define-constant XK_OCIRCUMFLEX 212)
+(define-constant XK_OTILDE 213)
+(define-constant XK_ODIAERESIS 214)
+(define-constant XK_MULTIPLY 215)
+(define-constant XK_OOBLIQUE 216)
+(define-constant XK_UGRAVE 217)
+(define-constant XK_UACUTE 218)
+(define-constant XK_UCIRCUMFLEX 219)
+(define-constant XK_UDIAERESIS 220)
+(define-constant XK_YACUTE 221)
+(define-constant XK_THORN 222)
+(define-constant XK_SSHARP 223)
+(define-constant XK_LCAGRAVE 224)
+(define-constant XK_LCAACUTE 225)
+(define-constant XK_LCACIRCUMFLEX 226)
+(define-constant XK_LCATILDE 227)
+(define-constant XK_LCADIAERESIS 228)
+(define-constant XK_LCARING 229)
+(define-constant XK_LCAE 230)
+(define-constant XK_LCCCEDILLA 231)
+(define-constant XK_LCEGRAVE 232)
+(define-constant XK_LCEACUTE 233)
+(define-constant XK_LCECIRCUMFLEX 234)
+(define-constant XK_LCEDIAERESIS 235)
+(define-constant XK_LCIGRAVE 236)
+(define-constant XK_LCIACUTE 237)
+(define-constant XK_LCICIRCUMFLEX 238)
+(define-constant XK_LCIDIAERESIS 239)
+(define-constant XK_LCETH 240)
+(define-constant XK_LCNTILDE 241)
+(define-constant XK_LCOGRAVE 242)
+(define-constant XK_LCOACUTE 243)
+(define-constant XK_LCOCIRCUMFLEX 244)
+(define-constant XK_LCOTILDE 245)
+(define-constant XK_LCODIAERESIS 246)
+(define-constant XK_DIVISION 247)
+(define-constant XK_OSLASH 248)
+(define-constant XK_LCUGRAVE 249)
+(define-constant XK_LCUACUTE 250)
+(define-constant XK_LCUCIRCUMFLEX 251)
+(define-constant XK_LCUDIAERESIS 252)
+(define-constant XK_LCYACUTE 253)
+(define-constant XK_LCTHORN 254)
+(define-constant XK_YDIAERESIS 255)
+(define-constant DXK_RING_ACCENT 268500656)
+(define-constant DXK_CIRCUMFLEX_ACCENT 268500574)
+(define-constant DXK_CEDILLA_ACCENT 268500524)
+(define-constant DXK_ACUTE_ACCENT 268500519)
+(define-constant DXK_GRAVE_ACCENT 268500576)
+(define-constant DXK_TILDE 268500606)
+(define-constant DXK_DIAERESIS 268500514)
+(define-constant DXK_REMOVE 268500736)
+(define-constant XC_NUM_GLYPHS 154)
+(define-constant XC_X_CURSOR 0)
+(define-constant XC_ARROW 2)
+(define-constant XC_BASED_ARROW_DOWN 4)
+(define-constant XC_BASED_ARROW_UP 6)
+(define-constant XC_BOAT 8)
+(define-constant XC_BOGOSITY 10)
+(define-constant XC_BOTTOM_LEFT_CORNER 12)
+(define-constant XC_BOTTOM_RIGHT_CORNER 14)
+(define-constant XC_BOTTOM_SIDE 16)
+(define-constant XC_BOTTOM_TEE 18)
+(define-constant XC_BOX_SPIRAL 20)
+(define-constant XC_CENTER_PTR 22)
+(define-constant XC_CIRCLE 24)
+(define-constant XC_CLOCK 26)
+(define-constant XC_COFFEE_MUG 28)
+(define-constant XC_CROSS 30)
+(define-constant XC_CROSS_REVERSE 32)
+(define-constant XC_CROSSHAIR 34)
+(define-constant XC_DIAMOND_CROSS 36)
+(define-constant XC_DOT 38)
+(define-constant XC_DOTBOX 40)
+(define-constant XC_DOUBLE_ARROW 42)
+(define-constant XC_DRAFT_LARGE 44)
+(define-constant XC_DRAFT_SMALL 46)
+(define-constant XC_DRAPED_BOX 48)
+(define-constant XC_EXCHANGE 50)
+(define-constant XC_FLEUR 52)
+(define-constant XC_GOBBLER 54)
+(define-constant XC_GUMBY 56)
+(define-constant XC_HAND1 58)
+(define-constant XC_HAND2 60)
+(define-constant XC_HEART 62)
+(define-constant XC_ICON 64)
+(define-constant XC_IRON_CROSS 66)
+(define-constant XC_LEFT_PTR 68)
+(define-constant XC_LEFT_SIDE 70)
+(define-constant XC_LEFT_TEE 72)
+(define-constant XC_LEFTBUTTON 74)
+(define-constant XC_LL_ANGLE 76)
+(define-constant XC_LR_ANGLE 78)
+(define-constant XC_MAN 80)
+(define-constant XC_MIDDLEBUTTON 82)
+(define-constant XC_MOUSE 84)
+(define-constant XC_PENCIL 86)
+(define-constant XC_PIRATE 88)
+(define-constant XC_PLUS 90)
+(define-constant XC_QUESTION_ARROW 92)
+(define-constant XC_RIGHT_PTR 94)
+(define-constant XC_RIGHT_SIDE 96)
+(define-constant XC_RIGHT_TEE 98)
+(define-constant XC_RIGHTBUTTON 100)
+(define-constant XC_RTL_LOGO 102)
+(define-constant XC_SAILBOAT 104)
+(define-constant XC_SB_DOWN_ARROW 106)
+(define-constant XC_SB_H_DOUBLE_ARROW 108)
+(define-constant XC_SB_LEFT_ARROW 110)
+(define-constant XC_SB_RIGHT_ARROW 112)
+(define-constant XC_SB_UP_ARROW 114)
+(define-constant XC_SB_V_DOUBLE_ARROW 116)
+(define-constant XC_SHUTTLE 118)
+(define-constant XC_SIZING 120)
+(define-constant XC_SPIDER 122)
+(define-constant XC_SPRAYCAN 124)
+(define-constant XC_STAR 126)
+(define-constant XC_TARGET 128)
+(define-constant XC_TCROSS 130)
+(define-constant XC_TOP_LEFT_ARROW 132)
+(define-constant XC_TOP_LEFT_CORNER 134)
+(define-constant XC_TOP_RIGHT_CORNER 136)
+(define-constant XC_TOP_SIDE 138)
+(define-constant XC_TOP_TEE 140)
+(define-constant XC_TREK 142)
+(define-constant XC_UL_ANGLE 144)
+(define-constant XC_UMBRELLA 146)
+(define-constant XC_UR_ANGLE 148)
+(define-constant XC_WATCH 150)
+(define-constant XC_XTERM 152)
projects / mit-scheme.git / commitdiff