From: Stephen Adams Date: Wed, 2 Aug 1995 21:28:26 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~6078 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cfa81105f5965cd96a05f6b97c784c14332d4291;p=mit-scheme.git Initial revision --- diff --git a/v7/src/swat/Makefile b/v7/src/swat/Makefile new file mode 100644 index 000000000..81581e977 --- /dev/null +++ b/v7/src/swat/Makefile @@ -0,0 +1,56 @@ +## +## $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 diff --git a/v7/src/swat/c/MITScheme.c b/v7/src/swat/c/MITScheme.c new file mode 100644 index 000000000..0311d5ab3 --- /dev/null +++ b/v7/src/swat/c/MITScheme.c @@ -0,0 +1,9 @@ +#include "scheme.h" +#include "prims.h" + +extern char *EXFUN (dload_initialize_file, (void)); + +char * + DEFUN_VOID (dload_initialize_file) +{ return "#NoMITSchemePrimitives"; +} diff --git a/v7/src/swat/c/Makefile b/v7/src/swat/c/Makefile new file mode 100644 index 000000000..8302e9a48 --- /dev/null +++ b/v7/src/swat/c/Makefile @@ -0,0 +1,147 @@ +## +## $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 + + diff --git a/v7/src/swat/c/scxl.c b/v7/src/swat/c/scxl.c new file mode 100644 index 000000000..647d684ff --- /dev/null +++ b/v7/src/swat/c/scxl.c @@ -0,0 +1,1011 @@ +/* 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 +#include +#include +#include +#include +#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"; +} diff --git a/v7/src/swat/c/tk-c-mit.c b/v7/src/swat/c/tk-c-mit.c new file mode 100644 index 000000000..ebc9fd9b3 --- /dev/null +++ b/v7/src/swat/c/tk-c-mit.c @@ -0,0 +1,410 @@ +/* -*- 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 + 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)); +} + +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] = ""; + 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)))); +} + diff --git a/v7/src/swat/c/tk-c.c b/v7/src/swat/c/tk-c.c new file mode 100644 index 000000000..af982d399 --- /dev/null +++ b/v7/src/swat/c/tk-c.c @@ -0,0 +1,308 @@ +/* -*- 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 +#include + +/* 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 */ +); + +/* 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; +} + +/* + * 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; +} + +/* + * 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) */ +/*****************************************************************/ diff --git a/v7/src/swat/c/tk3.2-custom/Makefile b/v7/src/swat/c/tk3.2-custom/Makefile new file mode 100644 index 000000000..6c855853e --- /dev/null +++ b/v7/src/swat/c/tk3.2-custom/Makefile @@ -0,0 +1,150 @@ +# +# 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 diff --git a/v7/src/swat/c/tk3.2-custom/library/emacs.tcl b/v7/src/swat/c/tk3.2-custom/library/emacs.tcl new file mode 100644 index 000000000..68cb66241 --- /dev/null +++ b/v7/src/swat/c/tk3.2-custom/library/emacs.tcl @@ -0,0 +1,203 @@ +#----------------------------------------------------------------------------- +# 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 { + 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 { + %W yview -pickplace insert +} +bind Text { + %W yview -pickplace insert +} +bind Text { + %W yview -pickplace insert +} +bind Text { + %W yview -pickplace insert +} + +set tk_last_deleted "" +bind Text { + global tk_last_deleted + set tk_last_deleted [%W get insert {insert lineend}] + %W delete insert {insert lineend} +} +bind Text { + global tk_last_deleted + %W insert insert $tk_last_deleted + %W yview -pickplace insert +} + +bind Text {emacs-text-move %W insert-1l} +bind Text {emacs-text-move %W insert+1l} +bind Text {emacs-text-move %W insert-1c} +bind Text {emacs-text-move %W insert+1c} + +bind Text {emacs-text-move %W {insert linestart}} +bind Text {emacs-text-move %W insert-1c} +bind Text {%W delete insert insert+1c} +bind Text {emacs-text-move %W {insert lineend}} +bind Text {emacs-text-move %W insert+1c} +bind Text {emacs-backspace %W} +bind Text {emacs-text-move %W insert+1l} +bind Text {%W insert insert "\n"; emacs-text-move %W insert-1c} +bind Text {emacs-text-move %W insert-1l} +bind Text {emacs-twiddle %W} +bind Text {emacs-move-page %W +} + +bind Text {emacs-move-page %W -} +bind Text {emacs-move-page %W +} +bind Text {emacs-backspace %W} + +bind Text { + %W insert insert $tk_priv(cutbuffer) + %W yview -pickplace insert +} + +bind Text