diff --git a/ChangeLog.n b/ChangeLog.n
index 5fb014bb6c1e9e8222635ae58f6a30429e756363..a435beee10c6cbe98f899a7ee7ca974b8b516363 100644
--- a/ChangeLog.n
+++ b/ChangeLog.n
@@ -1,3 +1,408 @@
+------------------------------------------------------------
+Sun Dec  4 15:51:34 PST 1994  Colin Meldrum (colin@vapor)
+
+silica/db-button.lisp, silica/db-label.lisp, 
+silica/db-slider.lisp, silica/scroll-pane.lisp
+clim/db-list.lisp, clim/db-menu.lisp, clim/db-text.lisp
+			REMOVED (moved to homegrown)
+
+homegrown/db-button.lisp, homegrown/db-label.lisp, 
+homegrown/db-slider.lisp, homegrown/scroll-pane.lisp
+homegrown/db-list.lisp, homegrown/db-menu.lisp, homegrown/db-text.lisp
+			NEW FILE (originally from clim and silica)
+
+Makefile.hp700, Makefile.sun4.motif-1.1.4
+			REMOVED
+
+make-symbolic-links.sh	NEW FILE - used for handling multiple fasl trees
+
+Makefile		default host changed to 'unknown'
+
+Makefile.cobjs		sorted out DEBUGLIB stuff
+
+Makefile.dec3100	got rid of MOTIFLIB_d
+
+Makefile.defs		updated to include panes and new homegrown
+			directory 
+			general cleanup
+
+
+Makefile.generic	no longer use si::system-compile-wrapper
+			general cleanup
+
+Makefile.hpprism	use default CL=/usr/fi/climdcl-devel
+			removed bogus ref to Makefile.hp700
+			removed MOTIFLIB_d
+			added XTSUPPORTINCLUDES
+
+Makefile.sgi4d-svr4	removed MOTIFLIB_d - use DEBUGLIB instead
+
+Makefile.sun4		update to use Motif-1.2.4
+			sorted out DEBUGLIB stuff
+			cleanup of OL lib/includes
+
+Makefile.sun4-svr4	update to use Motif-1.2.4
+			sorted out DEBUGLIB stuff
+			cleanup of OL lib/includes
+
+clim/accept-values.lisp added foreground and text-style to avv own-window dialogs 
+			fixed bogus margin for exit-box pane
+			reformatting changes
+			added support for default ok button
+
+clim/clim-defs.lisp	support for foreground and text-style in avv
+			own-window dialogs
+
+clim/command.lisp	fixed process-command-table-menu to deal with
+			inherit-menu correctly
+
+clim/cursor.lisp	fixed cursor-set-position to bind cursor-state
+			rather than cursor-active to nil
+			fixed cursor-visibility as per spec
+
+clim/db-stream		made window-visibility more robust
+
+clim/default-frame.lisp	fixed arglists of frame-manager-notify-user and
+			frame-manager-select-file as per spec.
+
+clim/defresource.lisp	fixed clear-resource to nil the object vector
+
+clim/dragging-output.lisp
+			avoid repainting dragged record twice
+
+clim/frames.lisp	added frame foreground, and text-style slots
+			added color-stream-p trampoline method for
+			encapsulating streams
+			fixed :layouts, :pane, :panes as per spec
+			fixed frame geometry processing
+			moved a bunch of code to clim/panes.lisp
+
+clim/panes.lisp		NEW FILE - code taken from clim/frames.lisp
+
+clim/gadget-output.lisp	fixed gadget-includes-prompt-p 
+			fixed label/prompt confusion for various gadgets
+			handle activate-callback for text-fields and text-editors
+			fixed bug with accept-values-string-field-changed-callback 
+			and delimiter gestures
+
+clim/gestures.lisp	keyboard-event-matches-gesture-name-p fixed to be
+			deal with case sensitive gestures
+			ditto for parse-gesture-spec
+
+clim/graphics-recording.lisp	
+			fixed refined-position-test for thick lines
+
+clim/input-defs.lisp	setf pointer-sheet now binds *application-frame*
+			fixes presentation-highlighting bug
+			removed bogus dynamic-extent decl
+			fixed recursive repaint problem with cursor refresh
+			fixed setf port-keyboard-input-focus to deal with
+			disabled sheets
+
+clim/interactive-protocol.lisp
+			fixed stream-yes-or-no-p and friends to deal with
+			null format-string and put them all in the stream
+			package 
+
+clim/menus.lisp		added :foreground,:background :x-position,
+			:y-position to menu-choose
+			fixed open-window-stream wrt forground, background
+			and text-style
+			sorted out with-menu semantics as per spec
+			fixes to menu-choose-from-drawer for scroll-bars
+
+
+clim/noting-progress.lisp
+			fixed dolist-noting-progress wrt note-var
+			fixed dotimes-noting-progress wrt not-var
+
+clim/presentations.lisp	removed bogus dynamic-extent decl
+
+clim/recording-protocol.lisp
+			fixed handling of errorp in delete-output-record
+
+clim/standard-types.lisp
+			re-implementation of read-recursive and accept of
+			expression/form ptype
+
+clim/text-formatting.lisp
+			fixed bug in cursor-positioning with filling-stream
+
+
+clim/tracking-pointer.lisp
+			removed bogus dynamic-extent decl
+			added finish-on-release to pointer-input-rectangle(*)
+			fixed bug in pointer-place-rubber-band-line*
+
+climtoys/calendar.lisp	NEW FILE - the calander demo
+
+demo/default-frame-top-level.lisp
+			updated to be in sync with code in clim/frames.lisp
+
+demo/demo-last.lisp
+			add provide :climdemo, climdemoxm, climdemool
+
+demo/plot.lisp		simplified the plotting-points interface so as to
+			not involve quite so many nested flets.
+
+demo/README		NEW FILE - instructions for running clim demos
+
+misc/climgccursor.c	use NUll cursor to undefine cursor - removed
+			call to XUndefineCursor
+
+misc/compile-1.lisp	added compile-system 'clim-homegrown
+
+misc/train.lisp		moved a bunch of output files to notes directory
+
+misc/undefinedsymbols.xt
+			added XtCloseDisplay XtDestroyApplicationContext
+	
+misc/xtsupport.c	XtAppIntervalNextTimer no longer sparc specific
+			removed 1+ hack to avoid rounding errors
+
+notes/times/clim2-beta2.n, notes/times/clim2-final.n
+			NEW FILE
+
+postscript/postscript-medium.lisp
+			fixed handling of thick lines
+			added support for clipping regions
+
+postscript/postscript-port.lisp
+			added support for clipping regions
+			sorted out landscape mode, co-ordinate
+			transformations, scale-to-fit and multi-page
+			and various misc cleanups
+
+silica/db-scroll.lisp
+			added drag-scroll-slot to scroller-pane
+			major re-implementation of scrolling as per spec
+			added mirror-region-updated :after method to
+			update-scroll-bars when layouts change
+
+silica/event.lisp
+			made repaint sheet robust to portless sheets
+			fixed bug with wrong co-ordinates being used with
+			grabbed sheets.
+
+silica/framem.lisp	support for frame foreground and text-style
+			fixed arglists of frame-manager-notify-user and
+			frame-manager-select-file as per spec.
+
+silica/gadgets.lisp	sorted value-gadgets and invoke-callback stuff
+			made all callback :around methods always call
+			primary method even if callback slot non-NIL
+			reimplemented sliders and scroll-bars as per spec
+			fixed radio-box and check-box handling of :choices
+			initarg + improved error messages for invalid choices
+
+silica/layout.lisp	improved print-method for space requirements
+
+silica/medium.lisp	support for pixel resource values and device-colors
+
+silica/port.lisp	fixed race condition in port creation
+
+silica/sheet.lisp	added dynamic-extent arg decl to map-over-sheets
+
+silica/text-style.lisp	removed fully-merged-text-style-p
+
+sys/sysdcl.lisp		moved a bunch of db-xxx files to clim-homegrown module
+
+test/test-driver.lisp	removed call to run-benchmarks-to-dummy-file
+
+test/test-suite.lisp	added slider labels to slider-dialog test
+			added test to test list-panes with varios scrolling
+			combinations
+			combined run-benchmarks-to-dummy-file and run-benchmarks
+			together into run-benchmarks
+
+tk/conveninece.lisp	fixed malloc leak
+			added support for xm-message-dialog
+
+tk/event.lisp		fixed wait-for-event to deal with async port
+			termination 
+			removed XtAppIntervalNextTimer hacks
+
+tk/foreign.lisp		register address of display objects
+
+tk/load-ol.lisp		moved provides to tk-silica/last.lisp
+
+tk/load-ol.lisp, tk/load-xm.lisp, tk/ol-init.lisp, tk/xm-init.lisp
+			fixed up svr4 reinitialize-toolkit stuff
+
+tk/macros		added with-malloced-objects - support for avoiding
+			malloc leaks
+
+tk/make-classes.lisp	improved performance of get-resource-internal,
+			lispify-tk-name, tkify-lisp-name
+
+tk/ol-defs.lisp		added provide :clim-debugol
+tk/xm-defs.lisp		added provide :clim-debugxm
+
+tk/ol-widgets.lisp	added focus-widget resource to notice-shell
+			support for ol notification dialog
+
+tk/resources.lisp	fixed malloc leak in set-values, fill-gv-cache
+			get-values, convert-resource-out methods
+			added convert-resource-out method for
+			man-foreground-pixmap (used in message boxes)
+			added motif navigation-type resource (for explict focus)
+
+tk/widget.lisp		fixed malloc leak in app-create-shell, create-widget-1, 
+			create-popup-shell
+
+tk/xlib.lisp		fixed X resource lookup to deal with pixel values
+			fixes to error handling when port asyn destroyed
+			fix malloc leak in convert-string
+			new macro def-foreign-array-resource
+			resourcd xcolor, xsegment, xpoint, xrectangle
+			xarc arrays
+			added get-image - support for make-pattern-from-pixmap
+
+tk/xm-font-list.lisp	fixed malloc leaks
+
+tk/xm-funs.lisp		new defforeigns to support above
+
+tk/xm-protocols.lisp	simplified and merged with general xt callback
+			mechanism 
+			fixed malloc leaks
+
+tk/xm-widgets.lisp	fixed malloc leaks
+			resource-conversion for motif default button handling
+			resource-conversion for motif string tables
+			resource-conversion for named pixmaps
+
+tk/xt-defs.lisp		removed several old explicit array def-c-type's
+			now in xlib/xlib-defs.lisp
+
+tk/xt-funs.lisp		new defforeigns to support asyn port termination
+			handling 
+			XtAppIntervalNextTimer now returns signed value
+
+tk-silica/gc-cursor.lisp
+			fixed bug with null cursor
+
+tk-silica/image.lisp	fixed zombie child process bug and improved error
+			handling in read-image-file with a filter
+			added support for xpm images with chars-per-pixel>1
+
+tk-silica/last.lisp	added provides for :climxm, :climol
+
+tk-silica/ol-gadgets.lisp
+			re-implementation of scroll-bars, sliders
+			support for patterns as gadget-labels
+			further hacking to make ol-text-fields work better
+			improved consistency wrt labels for ol-toggle-button
+			misc fixes to ol notify user
+
+tk-silica/xm-frames.lisp
+			major changes to menu-bar realization code
+			partial implementation of motif help menu support
+			support for foreground background and text-style in
+			motif pop up menus 
+			partial support for documentation callbacks for
+			cascade buttons
+
+tk-silica/xm-gadgets.lisp
+			motif-value-changed-callback-pane and
+			motif-losing-focus-callback-pane not longer inherit
+			from motif-value-pane
+			setf gadget-value method now an :after method - see
+			changes in silica/gadgets.lisp
+			support for patterns as gadget-labels
+			space-requirements for label gadgets fixed for 
+			variable width fonts
+			support for default-button in dialogs
+			re-implementation of scroll-bars, sliders
+			added *xm-dialog-style* for olwm losers
+			got rid of map-callback for dialogs - not required
+			fixed list-panes with various scroll-bar combinations
+			added setf list-pane-mode for motif-list-pane
+			fixed option-menus to deal with X resources + other
+			misc fixes
+			added foreground, background, x-position, y-position
+			to notify-user
+			support for user pixmaps in notify user
+			added default-button to notify-user dialog
+			background + foreground for file selection
+			rewrote text-style -> font-list mapping for
+			sheet-with-resources-mixin 
+
+tk-silica/xm-silica.lisp
+			got rid of map-callback for dialogs - not required
+
+tk-silica/xt-frames.lisp
+			added support for foreground, background,
+			x/y-position, scrolling to xt menu-choose
+			added support for default button in dialogs
+			got rid of invoke-with-menu-as-popup method
+
+tk-silica/xt-gadgets.lisp
+			support for pixel resource values
+			support for noting frame deiconification
+			re-implementation of scrolling
+
+tk-silica/xt-graphics.lisp
+			added decoding of device-colors for pixel resources
+			implemented dynamic changing of a frame's palette
+			fixed ol lookup-color bug
+			resourced a whole bunch of xstructs in xlib call to
+			reduce consing
+			a bunch of other optimizations in various medium-draw-xxx 
+			functions to reduce consing
+			improved handling of palette-full condition
+			got rid of a bunch of floating point calculations
+			fixed several co-ordinate rounding errors leading
+			to mismatch between bounding rectangle and output
+			fixed bug in call to xbell specifying wrong volume
+
+tk-silica/xt-pixmaps.lisp
+			implemented make-pattern-from-pixmap
+
+tk-silica/xt-silica.lisp
+			patched up a number of problems with async port
+			termination + xlib/xt error handling
+			support for noting frame deiconification
+			ignoring bogus linefeed xt-keysym defn
+			fixed case-sensitive handling of accelerators
+			define cursor when top-level-sheet enabled
+			fixed bug in mirror-visible-p
+			redone much of the x cursor stuff
+			fixed pointer-grabbing to allow scroll-bars to work
+			in menu-frames
+
+utils/base-designs.lisp	added device-colors
+			added pattern-array, pattern-designs readers
+
+utils/designs.lisp	separated out convert-rgb-to-ihs and
+			convert-ihs-to-rgb for general use
+			added device-colors
+
+utils/lisp-utilities.lisp
+			fixed rounding bug and eliminated consing in 
+			fix-coordinate
+			added macro define-dynamic-extent-args
+
+utils/packages.lisp	new exports
+
+utils/processes.lisp	removed bogus dynamic-extent decl
+
+utils/utilities.lisp	removed unecessary deftype boolean 
+
+xlib/ffi.lisp		defforeign-functions-now changed from macro to fn
+			extended def-exported-foreign-struct to take :array
+			option automatically defines array def-c-type 
+			changed default-return type to void in
+			def-exported-foreign-function
+		
+xlib/last.lisp		added provide :clim-debug
+
+xlib/xlib-defs.lisp	added a bunch of def-exported-foreign-structs
+			and removed old explicit def-c-type's
+			
+xlib/xlib-funs.lisp	fixed several def-exported-foreign-functions
+			with bogus return-type 
+
+------------------------------------------------------------
 Wed Nov 23 13:26:58 1994  Steve Haflich  (smh@vapor)
 
 General notes:
@@ -61,7 +466,6 @@ General notes:
 	* tk-silica/xt-graphics.lisp
 	Clos extension key changed from :fixed-index to clos::fixed-index.
 
-
 (for 4.2.devel.26 merge):
 
 Tue Jun  7 23:44:53 1994  Duane Rettig  (duane at clay)
@@ -96,6 +500,7 @@ Changed files:
 
 	* utils/lisp-utilities.lisp: Generalize and fix evacuate-list
 
+------------------------------------------------------------
 Tue Jan 11 15:30:15 1994  George Jacob  (georgej@lava)
 
 * utils/excl-verification.lisp: Changed version to CLIM2.0
@@ -104,6 +509,7 @@ Tue Jan 11 15:30:15 1994  George Jacob  (georgej@lava)
 
 * Makefile.cobjs: Changed the MAIN_OBJ rule to use stub files directly
 
+------------------------------------------------------------
 from colin: Mon Dec  6 21:46:54 PST 1993
 
 tk-silica/ol-silica.lisp	fixed typo
diff --git a/Makefile b/Makefile
index 508edb27c0b871b9f9fc97acd36657a498012419..f9de8acc84284c96bc9e7b258ee53afa5fec2cf5 100644
--- a/Makefile
+++ b/Makefile
@@ -1,6 +1,9 @@
-# $fiHeader: Makefile,v 1.76 93/04/28 17:18:58 layer Exp $
+# $fiHeader: Makefile,v 1.78 1994/06/08 06:56:21 duane Exp $
 
-HOST = sun4
+# If no HOST specified then we'd like to get an error immediately
+# rather than ploughing on with an inappropriate default
+
+HOST = unknown
 stubs =
 
 include Makefile.$(HOST)
diff --git a/Makefile.cobjs b/Makefile.cobjs
index dae67b65e5d7e3bcba63db7bfbf1f1937f441d13..f47ac9f27fcdf3bdf28d5d5a362d94957e51fac2 100644
--- a/Makefile.cobjs
+++ b/Makefile.cobjs
@@ -1,23 +1,17 @@
-# $fiHeader: Makefile.cobjs,v 1.3 93/05/13 16:22:37 cer Exp $
+# $fiHeader: Makefile.cobjs,v 1.7 1994/06/08 06:56:23 duane Exp $
 #
 #  Makefile.cobj for CLIM 2.0, containing non-svr4 C rules
 #
 
-# Removed lib dependencies; these were bogus because the libraries will tend to
-# be older anyway.  MAKE CLEAN instead.
-clim-motif.o	: stub-motif.o stub-xt.o
-	ld -r $(LDFLAGS) -o clim-motif.o stub-motif.o stub-xt.o $(MOTIFXTRAOS) $(MOTIFLIB)
+clim-motif$(DEBUGLIB).o	: stub-motif.o stub-xt.o
+	ld -r $(LDFLAGS) -o clim-motif$(DEBUGLIB).o \
+		stub-motif.o stub-xt.o $(MOTIFLIB) $(MOTIFXTRAOS)
 
-clim-olit.o	: stub-olit.o stub-xt.o
-	ld -r $(LDFLAGS) -o clim-olit.o stub-olit.o stub-xt.o $(LIBXOL)
+clim-olit$(DEBUGLIB).o : stub-olit.o stub-xt.o
+	ld -r $(LDFLAGS) -o clim-olit$(DEBUGLIB).o \
+		stub-olit.o stub-xt.o $(OPENLOOKLIB)
 
-clim-motif_d.o	: stub-motif.o stub-xt.o
-	ld -r  $(LDFLAGS) -o clim-motif_d.o stub-motif.o stub-xt.o $(MOTIFXTRAOS) $(MOTIFLIB_d)
-
-clim-olit_d.o	: stub-olit.o  stub-xt.o
-	ld -r $(LDFLAGS) -o clim-olit_d.o stub-olit.o stub-xt.o $(LIBXOL_d)
-
-xlibsupport.o	: xlib/xlibsupport.c 
+xlibsupport.o : xlib/xlibsupport.c 
 	$(CC) -c $(CFLAGS) $(XINCLUDES) -o xlibsupport.o xlib/xlibsupport.c
 
 xtsupport.o: misc/xtsupport.c
diff --git a/Makefile.dec3100 b/Makefile.dec3100
index 3c7252894bd259c34422d4182ec9c181730a6df8..9f9b1a0264e38e9a19b327a3188f23fe781eceab 100644
--- a/Makefile.dec3100
+++ b/Makefile.dec3100
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.dec3100,v 1.3 93/05/13 16:22:40 cer Exp $
+# $fiHeader: Makefile.dec3100,v 1.5 1993/07/29 20:51:13 layer Exp $
 #
 #  Makefile.dec3100 for CLIM 2.0
 #
@@ -8,7 +8,6 @@ include Makefile.defs
 Makefile=Makefile.dec3100
 
 MOTIFLIB=/usr/lib/DXM/lib/Xm/libXm.a
-MOTIFLIB_d=/usr/lib/DXM/lib/Xm/libXm.a
 XTLIB=/usr/lib/DXM/lib/Xt/libXt.a
 XLIB=/usr/lib/libX11.a
 MV=mv 
diff --git a/Makefile.defs b/Makefile.defs
index 935a4781304e68f84a3955847be4d9edb3b0cb07..4a4e83c1b3a96ca493a402e54857fe85cdb16a9b 100644
--- a/Makefile.defs
+++ b/Makefile.defs
@@ -1,12 +1,9 @@
-# $fiHeader: Makefile.defs,v 1.27 1993/11/23 19:58:26 cer Exp $
+# $fiHeader: Makefile.defs,v 1.29 1994/11/23 23:28:29 smh Exp $
 #
 #  Makefile.defs for CLIM 2.0
 #
 
 CL	= /usr/fi/dcl-devel
-
-PWD	= /usr/tech/cer/stuff/clim-2.0
-DUMP-CL	= $(CL)
 CLOPTS	= -qq
 
 DEVICE	= /dev/null
@@ -19,11 +16,6 @@ TAGS	= /usr/fi/etags
 TMP	= /usr/tmp
 MV	= /usr/fi/mv-nfs
 
-# If you try and execute this as the -f argument to `make', then you forgot
-# to put a `Makefile' variable definition in your machine specific
-# Makefile (ie, Makefile.sun4).
-Makefile = Makefile.bogus
-
 # Training
 
 TRAIN_TIMES=1
@@ -69,8 +61,6 @@ COMPILE_PRINT=nil
 # where to dump the CLIM images
 CLIM-SMALL	= ./slim-small
 CLIM		= ./slim
-CLIMOL		= $(CLIM)
-CLIMXM		= $(CLIM)
 
 CFLAGS	= -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD
 LDFLAGS=
@@ -83,11 +73,13 @@ DIRS0	=  tk tk-silica misc cloe climtoys hpgl
 DIRS	= $(PUBDIRS) xlib $(DIRS0)
 CHEAP_CLEAN	= $(PUBDIRS) $(DIRS0)
 
-SRC_FILES = */*.lisp *.lisp Makefile Makefile.* misc/make-stub-file \
-	    misc/undefinedsymbols misc/undefinedsymbols.olit misc/undefinedsymbols.colit \
-	    misc/undefinedsymbols.motif misc/undefinedsymbols.cmotif misc/undefinedsymbols.xt \
-	    xlib/xlibsupport.c misc/MyDrawingA*.[hc] misc/olsupport.c \
-	    misc/clos-preload.cl misc/xtsupport.c misc/climgccursor.c
+SRC_FILES = */*.lisp *.lisp Makefile.* misc/make-stub-file \
+	misc/undefinedsymbols \
+	misc/undefinedsymbols.olit misc/undefinedsymbols.colit \
+	misc/undefinedsymbols.motif misc/undefinedsymbols.cmotif \
+	misc/undefinedsymbols.xt \
+	xlib/xlibsupport.c misc/MyDrawingA*.[hc] misc/olsupport.c \
+	misc/clos-preload.cl misc/xtsupport.c misc/climgccursor.c
 
 # These are the files that make up the source code product.
 
@@ -95,18 +87,7 @@ PRODUCT_SRC_FILES = sys/*.lisp utils/*.lisp  silica/*.lisp clim/*.lisp \
 	demo/*.lisp test/test-suite.lisp
 
 DEST=/dev/null
-
-CL_SRC=/usr/tech/cer/cl/src
-OPENWINHOME=/usr/openwin-3.0
-
-
 DEBUGLIB=
-XLIBS= $(XTLIB) $(XLIB)
-
-OLCOPYLIB=/net/vapor/x11/olit-3.0/lib3/sun4
-OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a
-LIBXOL=$(OLCOPYLIB)/libXol.a
-LIBXOL_d=$(LIBXOL)
 
 # This has to be kept consistent with xlib.lisp
 UNDEFS=misc/undefinedsymbols
@@ -127,7 +108,6 @@ OLC_UNDEFS=misc/undefinedsymbols.colit
 CLIM_GENERIC_FASLS=climg.fasl  clim-debug.fasl climps.fasl climgg.fasl climhpgl.fasl climdemo.fasl
 CLIM_OL_FASLS= climol.fasl clim-debugol.fasl
 CLIM_XM_FASLS= climxm.fasl clim-debugxm.fasl
-# clim1compat.fasl
 
 CLIMFASLS=  $(CLIM_GENERIC_FASLS) $(CLIM_OL_FASLS) $(CLIM_XM_FASLS)
 
@@ -137,13 +117,9 @@ XM_PUBLIC_OBJS= stub-motif.o MyDrawingA.o
 OL_PUBLIC_OBJS= stub-olit.o olsupport.o
 
 PUBLIC_OBJS= $(GENERIC_PUBLIC_OBJS) $(XM_PUBLIC_OBJS) $(OL_PUBLIC_OBJS)
-OL_LICENSED_OBJS = clim-olit.o clim-olit_d.o
 
-# mostly not used.
-#CLIMMOTIF_D= clim-motif_d.o
-CLIMMOTIF_D=
-
-XM_LICENSED_OBJS = $(CLIMMOTIF_D) clim-motif.o 
+OL_LICENSED_OBJS = clim-olit$(DEBUGLIB).o
+XM_LICENSED_OBJS = clim-motif$(DEBUGLIB).o 
 
 MOTIF_OBJS= $(GENERIC_PUBLIC_OBJS) $(XM_PUBLIC_OBJS) $(XM_LICENSED_OBJS)
 OPENLOOK_OBJS= $(GENERIC_PUBLIC_OBJS) $(OL_PUBLIC_OBJS) $(OL_LICENSED_OBJS)
@@ -155,10 +131,6 @@ INSTALLED_CLIMOBJS = $(PUBLIC_OBJS) $(XM_LICENSED_OBJS) $(OL_LICENSED_OBJS)
 CLIM_OLFASLS_TO_MAKE = makeclimolfasls
 CLIM_FASLS_TO_MAKE = makeclimxmfasls $(CLIM_OLFASLS_TO_MAKE)
 
-#FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-motif.o \
-#	    `pwd`/stub-xt.o `pwd`/stub-x.o \
-#	   `pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o `pwd`/xtsupport.o
-
 # These are built into xm-dcl and ol-dcl.
 COMPOSEROBJS= $(CL_SRC)/code/excldep.o $(CL_SRC)/code/socket.o \
 	      $(CL_SRC)/code/gc_cursor.o \
@@ -166,414 +138,220 @@ COMPOSEROBJS= $(CL_SRC)/code/excldep.o $(CL_SRC)/code/socket.o \
 	      $(CL_SRC)/code/io.o $(CL_SRC)/code/exclio.o \
 	      $(CL_SRC)/code/RunStatus.o
 
-
-
-ALLMALLOCOBJS= $(PWD)/malloclib/malloc.o $(PWD)/malloclib/free.o $(PWD)/malloclib/realloc.o \
-	    $(PWD)/malloclib/calloc.o $(PWD)/malloclib/string.o \
-	    $(PWD)/malloclib/malloc_chk.o $(PWD)/malloclib/malloc_chn.o \
-	    $(PWD)/malloclib/memory.o $(PWD)/malloclib/tostring.o \
-	    $(PWD)/malloclib/m_perror.o $(PWD)/malloclib/m_init.o \
-	    $(PWD)/malloclib/mallopt.o $(PWD)/malloclib/dump.o $(PWD)/malloclib/leak.o
-# Uncomment to enable malloc debugging.
-#MALLOCOBJS =ALLMALLOCOBJS=
-MALLOCOBJS =
-
 # "Compile time objects" -- these go into clim-debug.fasl
 #
 DEBUG-OBJS = xlib/ffi.fasl xlib/xlib-defs.fasl xlib/xlib-funs.fasl \
-	     xlib/x11-keysyms.fasl tk/xt-defs.fasl tk/xt-funs.fasl 
+	     xlib/x11-keysyms.fasl tk/xt-defs.fasl tk/xt-funs.fasl \
+             xlib/last.fasl
 
-XM-DEBUG-OBJS = tk/xm-defs.fasl tk/xm-funs.fasl xlib/last.fasl
-OL-DEBUG-OBJS = tk/ol-defs.fasl tk/ol-funs.fasl xlib/last.fasl
+XM-DEBUG-OBJS = tk/xm-defs.fasl tk/xm-funs.fasl 
+OL-DEBUG-OBJS = tk/ol-defs.fasl tk/ol-funs.fasl
 
 #
 # "Load time objects" -- these go into clim.fasl
 #
-CLIM-UTILS-OBJS = utils/excl-verification.fasl \
-                   utils/lisp-package-fixups.fasl \
-                   utils/defpackage.fasl \
-                   utils/packages.fasl \
-                   utils/defun-utilities.fasl \
-                   utils/reader.fasl \
-                   utils/clos-patches.fasl \
-                   utils/clos.fasl \
-                   utils/utilities.fasl \
-                   utils/lisp-utilities.fasl \
-                   utils/processes.fasl \
-                   utils/queue.fasl \
-		   utils/timers.fasl \
-                   utils/protocols.fasl \
-                   utils/clim-streams.fasl \
-                   utils/excl-streams.fasl \
-                   utils/clim-macros.fasl \
-                   utils/transformations.fasl \
-                   utils/regions.fasl \
-                   utils/region-arithmetic.fasl \
-                   utils/extended-regions.fasl \
-		   utils/base-designs.fasl \
-                   utils/designs.fasl
-
-CLIM-SILICA-OBJS = silica/classes.fasl \
-                    silica/text-style.fasl \
-                    silica/macros.fasl \
-                    silica/sheet.fasl \
-                    silica/mirror.fasl \
-                    silica/event.fasl \
-                    silica/port.fasl \
-                    silica/medium.fasl \
-                    silica/framem.fasl \
-                    silica/graphics.fasl \
-		    silica/pixmaps.fasl \
-                    silica/std-sheet.fasl \
-                    silica/layout.fasl \
-                    silica/db-layout.fasl \
-                    silica/db-box.fasl \
-                    silica/db-table.fasl \
-                    silica/gadgets.fasl \
-                    silica/db-scroll.fasl \
-                    silica/db-border.fasl
-
-CLIM-STANDALONE-OBJS = clim/gestures.fasl \
-                        clim/defprotocol.fasl \
-                        clim/stream-defprotocols.fasl \
-                        clim/defresource.fasl \
-                        clim/temp-strings.fasl \
-                        clim/clim-defs.fasl \
-                        clim/stream-class-defs.fasl \
-                        clim/interactive-defs.fasl \
-                        clim/cursor.fasl \
-                        clim/view-defs.fasl \
-                        clim/input-defs.fasl \
-                        clim/input-protocol.fasl \
-                        clim/output-protocol.fasl \
-                        clim/recording-protocol.fasl \
-			clim/recording-defs.fasl \
-			clim/text-recording.fasl \
-			clim/graphics-recording.fasl \
-                        clim/interactive-protocol.fasl \
-                        clim/input-editor-commands.fasl \
-                        clim/formatted-output-defs.fasl \
-                        clim/incremental-redisplay.fasl \
-                        clim/coordinate-sorted-set.fasl \
-			clim/r-tree.fasl \
-                        clim/window-stream.fasl \
-                        clim/pixmap-streams.fasl \
-                        clim/ptypes1.fasl \
-                        clim/completer.fasl \
-                        clim/presentations.fasl \
-                        clim/translators.fasl \
-                        clim/histories.fasl \
-                        clim/ptypes2.fasl \
-			clim/excl-presentations.fasl \
-                        clim/standard-types.fasl \
-                        clim/table-formatting.fasl \
-                        clim/graph-formatting.fasl \
-                        clim/surround-output.fasl \
-                        clim/text-formatting.fasl \
-                        clim/tracking-pointer.fasl \
-                        clim/dragging-output.fasl \
-                        clim/db-stream.fasl \
-                        clim/gadget-output.fasl \
-                        clim/accept.fasl \
-                        clim/present.fasl \
-                        clim/command.fasl \
-                        clim/command-processor.fasl \
-                        clim/basic-translators.fasl \
-                        clim/frames.fasl \
-			clim/default-frame.fasl \
-                        clim/activities.fasl \
-			clim/noting-progress.fasl \
-                        clim/menus.fasl \
-                        clim/accept-values.fasl \
-			clim/drag-and-drop.fasl \
-                        clim/item-list-manager.fasl \
-			postscript/pkgdcl.fasl \
-			postscript/postscript-s.fasl \
-                        clim/stream-trampolines.fasl
-
-GENERIC-GADGETS = clim/db-menu.fasl clim/db-list.fasl clim/db-text.fasl silica/db-button.fasl \
-	    silica/db-slider.fasl silica/scroll-pane.fasl silica/db-label.fasl
-
-
-DEMO-OBJS= demo/packages.fasl \
-	demo/demo-driver.fasl \
-	demo/listener.fasl \
-	demo/graphics-demos.fasl \
-	demo/cad-demo.fasl \
-	demo/navdata.fasl \
-	demo/navfun.fasl \
-	demo/puzzle.fasl \
-	demo/address-book.fasl \
-	demo/thinkadot.fasl \
-	demo/plot.fasl \
-	demo/color-editor.fasl \
-	demo/graphics-editor.fasl \
-	demo/bitmap-editor.fasl \
-	demo/ico.fasl \
-	demo/browser.fasl \
-	demo/peek-frame.fasl \
-	demo/process-browser.fasl \
-	demo/custom-records.fasl \
-	demo/demo-activity.fasl \
-	test/test-suite.fasl \
-	demo/demo-last.fasl
 
-XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl
+CLIM-UTILS-OBJS = \
+	utils/excl-verification.fasl utils/lisp-package-fixups.fasl \
+	utils/defpackage.fasl utils/packages.fasl \
+	utils/defun-utilities.fasl utils/reader.fasl \
+	utils/clos-patches.fasl utils/clos.fasl utils/utilities.fasl \
+	utils/lisp-utilities.fasl utils/processes.fasl utils/queue.fasl \
+	utils/timers.fasl utils/protocols.fasl utils/clim-streams.fasl \
+	utils/excl-streams.fasl utils/clim-macros.fasl \
+	utils/transformations.fasl utils/regions.fasl \
+	utils/region-arithmetic.fasl utils/extended-regions.fasl \
+	utils/base-designs.fasl utils/designs.fasl
+
+CLIM-SILICA-OBJS = \
+	silica/classes.fasl silica/text-style.fasl silica/macros.fasl \
+	silica/sheet.fasl silica/mirror.fasl silica/event.fasl \
+	silica/port.fasl silica/medium.fasl silica/framem.fasl \
+	silica/graphics.fasl silica/pixmaps.fasl silica/std-sheet.fasl \
+	silica/layout.fasl silica/db-layout.fasl silica/db-box.fasl \
+	silica/db-table.fasl silica/gadgets.fasl silica/db-scroll.fasl \
+	silica/db-border.fasl
+
+CLIM-STANDALONE-OBJS = \
+	clim/gestures.fasl clim/defprotocol.fasl \
+	clim/stream-defprotocols.fasl clim/defresource.fasl \
+	clim/temp-strings.fasl clim/clim-defs.fasl \
+	clim/stream-class-defs.fasl clim/interactive-defs.fasl \
+	clim/cursor.fasl clim/view-defs.fasl clim/input-defs.fasl \
+	clim/input-protocol.fasl clim/output-protocol.fasl \
+	clim/recording-protocol.fasl clim/recording-defs.fasl \
+	clim/text-recording.fasl clim/graphics-recording.fasl \
+	clim/interactive-protocol.fasl clim/input-editor-commands.fasl \
+	clim/formatted-output-defs.fasl clim/incremental-redisplay.fasl \
+	clim/coordinate-sorted-set.fasl clim/r-tree.fasl \
+	clim/window-stream.fasl clim/pixmap-streams.fasl \
+	clim/ptypes1.fasl clim/completer.fasl clim/presentations.fasl \
+	clim/translators.fasl clim/histories.fasl clim/ptypes2.fasl \
+	clim/excl-presentations.fasl clim/standard-types.fasl \
+	clim/table-formatting.fasl clim/graph-formatting.fasl \
+	clim/surround-output.fasl clim/text-formatting.fasl \
+	clim/tracking-pointer.fasl clim/dragging-output.fasl \
+	clim/db-stream.fasl clim/gadget-output.fasl clim/accept.fasl \
+	clim/present.fasl clim/command.fasl clim/command-processor.fasl \
+	clim/basic-translators.fasl clim/frames.fasl clim/panes.fasl \
+	clim/default-frame.fasl clim/activities.fasl \
+	clim/noting-progress.fasl clim/menus.fasl clim/accept-values.fasl \
+	clim/drag-and-drop.fasl clim/item-list-manager.fasl \
+	postscript/pkgdcl.fasl postscript/postscript-s.fasl \
+	clim/stream-trampolines.fasl
+
+GENERIC-GADGETS = \
+	homegrown/db-menu.fasl homegrown/db-list.fasl \
+	homegrown/db-text.fasl homegrown/db-button.fasl \
+	homegrown/db-slider.fasl homegrown/scroll-pane.fasl \
+	homegrown/db-label.fasl homegrown/last.fasl
+
+DEMO-OBJS = \
+	demo/packages.fasl demo/demo-driver.fasl demo/listener.fasl \
+	demo/graphics-demos.fasl demo/cad-demo.fasl demo/navdata.fasl \
+	demo/navfun.fasl demo/puzzle.fasl demo/address-book.fasl \
+	demo/thinkadot.fasl demo/plot.fasl demo/color-editor.fasl \
+	demo/graphics-editor.fasl demo/bitmap-editor.fasl demo/ico.fasl \
+	demo/browser.fasl demo/peek-frame.fasl demo/process-browser.fasl \
+	demo/custom-records.fasl demo/demo-activity.fasl \
+	test/test-suite.fasl demo/demo-last.fasl
 
+XLIB-CLIM-OBJS = xlib/pkg.fasl xlib/load-xlib.fasl
 
-LOAD-XM-OBJS=	tk/load-xm.fasl
-LOAD-OL-OBJS=	tk/load-ol.fasl
-
-XT-TK-OBJS =  	tk/pkg.fasl \
-                tk/foreign-obj.fasl \
-                tk/macros.fasl \
-                tk/xlib.fasl \
-                tk/font.fasl \
-                tk/gcontext.fasl \
-                tk/graphics.fasl \
-                tk/meta-tk.fasl \
-                tk/make-classes.fasl \
-                tk/foreign.fasl \
-                tk/widget.fasl \
-                tk/resources.fasl \
-                tk/event.fasl \
-                tk/callbacks.fasl \
-                tk/xt-classes.fasl \
-                tk/xt-init.fasl
-
-XM-TK-OBJS = tk/xm-classes.fasl \
-		tk/xm-callbacks.fasl \
-                tk/xm-init.fasl \
-                tk/xm-widgets.fasl \
-                tk/xm-font-list.fasl \
-                tk/xm-protocols.fasl \
-                tk/convenience.fasl \
-                tk/make-widget.fasl
-
-OL-CLIM-OBJS = tk/ol-classes.fasl \
-                tk/ol-init.fasl \
-		tk/ol-widgets.fasl \
-                tk/ol-callbacks.fasl \
-                tk/make-widget.fasl
-
-MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \
-                   tk-silica/xt-silica.fasl \
-                   tk-silica/xt-stipples.fasl \
-                   tk-silica/xm-silica.fasl \
-                   tk-silica/xt-graphics.fasl \
-                   tk-silica/image.fasl \
-                   tk-silica/xt-frames.fasl \
-                   tk-silica/xm-frames.fasl \
-                   tk-silica/xm-dialogs.fasl \
-                   tk-silica/xt-gadgets.fasl \
-                   tk-silica/xm-gadgets.fasl \
-                   tk-silica/xt-pixmaps.fasl \
-		   tk-silica/gc-cursor.fasl \
-                   tk-silica/last.fasl
-
-
-OPENLOOK-CLIM-OBJS = tk-silica/pkg.fasl \
-                      tk-silica/xt-silica.fasl \
-                      tk-silica/xt-stipples.fasl \
-                      tk-silica/ol-silica.fasl \
-                      tk-silica/xt-graphics.fasl \
-                      tk-silica/image.fasl \
-                      tk-silica/xt-frames.fasl \
-                      tk-silica/ol-frames.fasl \
-                      tk-silica/xt-gadgets.fasl \
-                      tk-silica/ol-gadgets.fasl \
-                      tk-silica/xt-pixmaps.fasl \
-		      tk-silica/gc-cursor.fasl \
-		      tk-silica/last.fasl
-
-POSTSCRIPT_CLIM= postscript/postscript-port.fasl \
-	postscript/postscript-medium.fasl \
-	postscript/laserwriter-metrics.fasl 
-
-HPGL_OBJS= hpgl/pkg.fasl hpgl/hpgl-port.fasl hpgl/hpgl-medium.fasl
+LOAD-XM-OBJS = tk/load-xm.fasl
+LOAD-OL-OBJS = tk/load-ol.fasl
+
+XT-TK-OBJS = \
+	tk/pkg.fasl tk/foreign-obj.fasl tk/macros.fasl tk/xlib.fasl \
+	tk/font.fasl tk/gcontext.fasl tk/graphics.fasl tk/meta-tk.fasl \
+	tk/make-classes.fasl tk/foreign.fasl tk/widget.fasl \
+	tk/resources.fasl tk/event.fasl tk/callbacks.fasl \
+	tk/xt-classes.fasl tk/xt-init.fasl
+
+XM-TK-OBJS = \
+	tk/xm-classes.fasl tk/xm-callbacks.fasl tk/xm-init.fasl \
+	tk/xm-widgets.fasl tk/xm-font-list.fasl tk/xm-protocols.fasl \
+	tk/convenience.fasl tk/make-widget.fasl
+
+OL-CLIM-OBJS = \
+	tk/ol-classes.fasl tk/ol-init.fasl tk/ol-widgets.fasl \
+	tk/ol-callbacks.fasl tk/make-widget.fasl
+
+MOTIF-CLIM-OBJS = \
+	tk-silica/pkg.fasl tk-silica/xt-silica.fasl \
+	tk-silica/xt-stipples.fasl tk-silica/xm-silica.fasl \
+	tk-silica/xt-graphics.fasl tk-silica/image.fasl \
+	tk-silica/xt-frames.fasl tk-silica/xm-frames.fasl \
+	tk-silica/xm-dialogs.fasl tk-silica/xt-gadgets.fasl \
+	tk-silica/xm-gadgets.fasl tk-silica/xt-pixmaps.fasl \
+	tk-silica/gc-cursor.fasl tk-silica/last.fasl
+
+
+OPENLOOK-CLIM-OBJS = \
+	tk-silica/pkg.fasl tk-silica/xt-silica.fasl \
+	tk-silica/xt-stipples.fasl tk-silica/ol-silica.fasl \
+	tk-silica/xt-graphics.fasl tk-silica/image.fasl \
+	tk-silica/xt-frames.fasl tk-silica/ol-frames.fasl \
+	tk-silica/xt-gadgets.fasl tk-silica/ol-gadgets.fasl \
+	tk-silica/xt-pixmaps.fasl tk-silica/gc-cursor.fasl \
+	tk-silica/last.fasl
+
+POSTSCRIPT_CLIM = \
+	postscript/postscript-port.fasl postscript/postscript-medium.fasl \
+	postscript/laserwriter-metrics.fasl
+
+HPGL_OBJS= \
+	hpgl/pkg.fasl hpgl/hpgl-port.fasl hpgl/hpgl-medium.fasl
 
 # Used for tags
-ALL_SRC =	sys/defsystem.lisp \
-		sys/distribution-script.lisp \
-		sys/load-clim2.lisp \
-		sys/sysdcl.lisp \
-                   utils/excl-verification.lisp \
-                   utils/lisp-package-fixups.lisp \
-                   utils/defpackage.lisp \
-                   utils/packages.lisp \
-                   utils/defun-utilities.lisp \
-                   utils/reader.lisp \
-                   utils/clos-patches.lisp \
-                   utils/clos.lisp \
-                   utils/utilities.lisp \
-                   utils/lisp-utilities.lisp \
-                   utils/processes.lisp \
-                   utils/queue.lisp \
-                   utils/protocols.lisp \
-                   utils/clim-streams.lisp \
-                   utils/excl-streams.lisp \
-                   utils/clim-macros.lisp \
-                   utils/transformations.lisp \
-                   utils/regions.lisp \
-                   utils/region-arithmetic.lisp \
-                   utils/extended-regions.lisp \
-                   utils/designs.lisp \
-		    silica/classes.lisp \
-                    silica/text-style.lisp \
-                    silica/macros.lisp \
-                    silica/sheet.lisp \
-                    silica/mirror.lisp \
-                    silica/event.lisp \
-                    silica/port.lisp \
-                    silica/medium.lisp \
-                    silica/framem.lisp \
-                    silica/graphics.lisp \
-                    silica/pixmaps.lisp \
-                    silica/std-sheet.lisp \
-                    silica/layout.lisp \
-                    silica/db-layout.lisp \
-                    silica/db-box.lisp \
-                    silica/db-table.lisp \
-                    silica/gadgets.lisp \
-                    silica/db-border.lisp \
-                    silica/db-scroll.lisp \
-                    silica/db-button.lisp \
-		    silica/db-label.lisp \
-                    silica/db-slider.lisp \
-			clim/gestures.lisp \
-                        clim/defprotocol.lisp \
-                        clim/stream-defprotocols.lisp \
-                        clim/defresource.lisp \
-                        clim/temp-strings.lisp \
-                        clim/clim-defs.lisp \
-                        clim/stream-class-defs.lisp \
-                        clim/interactive-defs.lisp \
-                        clim/cursor.lisp \
-                        clim/view-defs.lisp \
-                        clim/input-defs.lisp \
-                        clim/input-protocol.lisp \
-                        clim/output-protocol.lisp \
-                        clim/recording-defs.lisp \
-                        clim/recording-protocol.lisp \
-                        clim/text-recording.lisp \
-                        clim/graphics-recording.lisp \
-                        clim/interactive-protocol.lisp \
-                        clim/input-editor-commands.lisp \
-                        clim/formatted-output-defs.lisp \
-                        clim/incremental-redisplay.lisp \
-                        clim/coordinate-sorted-set.lisp \
-                        clim/window-stream.lisp \
-                        clim/pixmap-streams.lisp \
-                        clim/ptypes1.lisp \
-                        clim/completer.lisp \
-                        clim/presentations.lisp \
-                        clim/translators.lisp \
-                        clim/histories.lisp \
-                        clim/ptypes2.lisp \
-                        clim/standard-types.lisp \
-                        clim/excl-presentations.lisp \
-                        clim/table-formatting.lisp \
-                        clim/graph-formatting.lisp \
-                        clim/surround-output.lisp \
-                        clim/text-formatting.lisp \
-                        clim/tracking-pointer.lisp \
-                        clim/dragging-output.lisp \
-                        clim/db-stream.lisp \
-                        clim/gadget-output.lisp \
-                        clim/accept.lisp \
-                        clim/present.lisp \
-                        clim/command.lisp \
-                        clim/command-processor.lisp \
-                        clim/basic-translators.lisp \
-                        clim/frames.lisp \
-                        clim/default-frame.lisp \
-                        clim/noting-progress.lisp \
-                        clim/menus.lisp \
-                        clim/accept-values.lisp \
-                        clim/drag-and-drop.lisp \
-                        clim/item-list-manager.lisp \
-                        clim/stream-trampolines.lisp \
-	     xlib/pkg.lisp \
-             xlib/ffi.lisp \
-             xlib/xlib-defs.lisp \
-             xlib/load-xlib.lisp \
-             xlib/xlib-funs.lisp \
-             xlib/x11-keysyms.lisp \
-             xlib/last.lisp \
-	      tk/load-xm.lisp \
-              tk/load-ol.lisp \
-	      tk/pkg.lisp \
-              tk/macros.lisp \
-              tk/xt-defs.lisp \
-              tk/foreign-obj.lisp \
-              tk/xlib.lisp \
-              tk/font.lisp \
-              tk/gcontext.lisp \
-              tk/graphics.lisp \
-              tk/meta-tk.lisp \
-              tk/make-classes.lisp \
-              tk/foreign.lisp \
-              tk/widget.lisp \
-              tk/resources.lisp \
-              tk/event.lisp \
-              tk/callbacks.lisp \
-              tk/xt-classes.lisp \
-              tk/xt-init.lisp \
-              tk/xm-defs.lisp \
-              tk/xm-classes.lisp \
-              tk/xm-callbacks.lisp \
-              tk/xt-funs.lisp \
-              tk/xm-funs.lisp \
-              tk/xm-classes.lisp \
-              tk/xm-init.lisp \
-              tk/xm-widgets.lisp \
-              tk/xm-font-list.lisp \
-              tk/xm-protocols.lisp \
-              tk/convenience.lisp \
-              tk/make-widget.lisp \
-		   tk-silica/pkg.lisp \
-                   tk-silica/xt-silica.lisp \
-                   tk-silica/xt-stipples.lisp \
-                   tk-silica/xm-silica.lisp \
-                   tk-silica/xt-graphics.lisp \
-                   tk-silica/image.lisp \
-                   tk-silica/xt-frames.lisp \
-                   tk-silica/xm-frames.lisp \
-                   tk-silica/xt-gadgets.lisp \
-                   tk-silica/xm-gadgets.lisp \
-                   tk-silica/xt-pixmaps.lisp \
-	      tk/ol-defs.lisp \
-              tk/ol-funs.lisp \
-              tk/ol-classes.lisp \
-              tk/ol-init.lisp \
-              tk/ol-widgets.lisp \
-              tk/ol-callbacks.lisp \
-                      tk-silica/ol-silica.lisp \
-                      tk-silica/ol-frames.lisp \
-                      tk-silica/ol-gadgets.lisp \
-	misc/MyDrawingA.c \
-	misc/MyDrawingA.h \
-	misc/MyDrawingAP.h \
-	misc/climgccursor.c \
-	misc/olsupport.c \
-	misc/xtsupport.c \
-	xlib/xlibsupport.c \
-	stub-xt.c \
-	stub-x.c \
-	stub-motif.c \
+
+ALL_SRC = \
+	sys/defsystem.lisp sys/distribution-script.lisp \
+	sys/load-clim2.lisp sys/sysdcl.lisp \
+	utils/excl-verification.lisp utils/lisp-package-fixups.lisp \
+	utils/defpackage.lisp utils/packages.lisp \
+	utils/defun-utilities.lisp utils/reader.lisp \
+	utils/clos-patches.lisp utils/clos.lisp utils/utilities.lisp \
+	utils/lisp-utilities.lisp utils/processes.lisp utils/queue.lisp \
+	utils/protocols.lisp utils/clim-streams.lisp \
+	utils/excl-streams.lisp utils/clim-macros.lisp \
+	utils/transformations.lisp utils/regions.lisp \
+	utils/region-arithmetic.lisp utils/extended-regions.lisp \
+	utils/designs.lisp silica/classes.lisp silica/text-style.lisp \
+	silica/macros.lisp silica/sheet.lisp silica/mirror.lisp \
+	silica/event.lisp silica/port.lisp silica/medium.lisp \
+	silica/framem.lisp silica/graphics.lisp silica/pixmaps.lisp \
+	silica/std-sheet.lisp silica/layout.lisp silica/db-layout.lisp \
+	silica/db-box.lisp silica/db-table.lisp silica/gadgets.lisp \
+	silica/db-border.lisp silica/db-scroll.lisp \
+	homegrown/db-menu.lisp homegrown/db-list.lisp \
+	homegrown/db-text.lisp homegrown/db-button.lisp \
+	homegrown/db-slider.lisp homegrown/db-label.lisp \
+	homegrown/scroll-pane.lisp homegrown/last.lisp clim/gestures.lisp \
+	clim/defprotocol.lisp clim/stream-defprotocols.lisp \
+	clim/defresource.lisp clim/temp-strings.lisp clim/clim-defs.lisp \
+	clim/stream-class-defs.lisp clim/interactive-defs.lisp \
+	clim/cursor.lisp clim/view-defs.lisp clim/input-defs.lisp \
+	clim/input-protocol.lisp clim/output-protocol.lisp \
+	clim/recording-defs.lisp clim/recording-protocol.lisp \
+	clim/text-recording.lisp clim/graphics-recording.lisp \
+	clim/interactive-protocol.lisp clim/input-editor-commands.lisp \
+	clim/formatted-output-defs.lisp clim/incremental-redisplay.lisp \
+	clim/coordinate-sorted-set.lisp clim/window-stream.lisp \
+	clim/pixmap-streams.lisp clim/ptypes1.lisp clim/completer.lisp \
+	clim/presentations.lisp clim/translators.lisp clim/histories.lisp \
+	clim/ptypes2.lisp clim/standard-types.lisp \
+	clim/excl-presentations.lisp clim/table-formatting.lisp \
+	clim/graph-formatting.lisp clim/surround-output.lisp \
+	clim/text-formatting.lisp clim/tracking-pointer.lisp \
+	clim/dragging-output.lisp clim/db-stream.lisp \
+	clim/gadget-output.lisp clim/accept.lisp clim/present.lisp \
+	clim/command.lisp clim/command-processor.lisp \
+	clim/basic-translators.lisp clim/frames.lisp clim/panes.lisp \
+	clim/default-frame.lisp clim/noting-progress.lisp clim/menus.lisp \
+	clim/accept-values.lisp clim/drag-and-drop.lisp \
+	clim/item-list-manager.lisp clim/stream-trampolines.lisp \
+	xlib/pkg.lisp xlib/ffi.lisp xlib/xlib-defs.lisp \
+	xlib/load-xlib.lisp xlib/xlib-funs.lisp xlib/x11-keysyms.lisp \
+	xlib/last.lisp tk/load-xm.lisp tk/load-ol.lisp tk/pkg.lisp \
+	tk/macros.lisp tk/xt-defs.lisp tk/foreign-obj.lisp tk/xlib.lisp \
+	tk/font.lisp tk/gcontext.lisp tk/graphics.lisp tk/meta-tk.lisp \
+	tk/make-classes.lisp tk/foreign.lisp tk/widget.lisp \
+	tk/resources.lisp tk/event.lisp tk/callbacks.lisp \
+	tk/xt-classes.lisp tk/xt-init.lisp tk/xm-defs.lisp \
+	tk/xm-classes.lisp tk/xm-callbacks.lisp tk/xt-funs.lisp \
+	tk/xm-funs.lisp tk/xm-classes.lisp tk/xm-init.lisp \
+	tk/xm-widgets.lisp tk/xm-font-list.lisp tk/xm-protocols.lisp \
+	tk/convenience.lisp tk/make-widget.lisp tk-silica/pkg.lisp \
+	tk-silica/xt-silica.lisp tk-silica/xt-stipples.lisp \
+	tk-silica/xm-silica.lisp tk-silica/xt-graphics.lisp \
+	tk-silica/image.lisp tk-silica/xt-frames.lisp \
+	tk-silica/xm-frames.lisp tk-silica/xt-gadgets.lisp \
+	tk-silica/xm-gadgets.lisp tk-silica/xt-pixmaps.lisp \
+	tk/ol-defs.lisp tk/ol-funs.lisp tk/ol-classes.lisp \
+	tk/ol-init.lisp tk/ol-widgets.lisp tk/ol-callbacks.lisp \
+	tk-silica/ol-silica.lisp tk-silica/ol-frames.lisp \
+	tk-silica/ol-gadgets.lisp \
+	misc/MyDrawingA.c misc/MyDrawingA.h misc/MyDrawingAP.h \
+	misc/climgccursor.c misc/olsupport.c misc/xtsupport.c \
+	xlib/xlibsupport.c stub-xt.c stub-x.c stub-motif.c \
 	misc/clos-preload.cl
 
-GENERIC-OBJS= $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS)
-MOTIF-OBJS = $(LOAD-XM-OBJS) $(XT-TK-OBJS) $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS) 
-OPENLOOK-OBJS = $(LOAD-OL-OBJS) $(XT-TK-OBJS) $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS)
+GENERIC-OBJS = \
+	 $(CLIM-UTILS-OBJS) $(CLIM-SILICA-OBJS) $(CLIM-STANDALONE-OBJS)
+
+MOTIF-OBJS = \
+	 $(LOAD-XM-OBJS) $(XT-TK-OBJS) $(XM-TK-OBJS) $(MOTIF-CLIM-OBJS)
+
+OPENLOOK-OBJS = \
+	$(LOAD-OL-OBJS) $(XT-TK-OBJS) $(OL-CLIM-OBJS) $(OPENLOOK-CLIM-OBJS)
 
 make = make SPEED=${SPEED} SAFETY=${SAFETY} DEBUG=${DEBUG} \
 	LOAD_SOURCE_FILE_INFO=${LOAD_SOURCE_FILE_INFO} \
 	RECORD_SOURCE_FILE_INFO=${RECORD_SOURCE_FILE_INFO} \
 	LOAD_XREF_INFO=${LOAD_XREF_INFO} \
 	RECORD_XREF_INFO=${RECORD_XREF_INFO} CL=${CL} \
-	CLIM=${CLIM} CLIMOL=${CLIMOL} CLIMXM=${CLIMXM} \
-	COMPILE_PRINT=${COMPILE_PRINT} TMP=${TMP} -f ${Makefile}
+	CLIM=${CLIM} COMPILE_PRINT=${COMPILE_PRINT} TMP=${TMP} -f ${Makefile}
 
 CLIM1COMPAT= compatibility/packages.fasl compatibility/clim1-compatibility.fasl
 
diff --git a/Makefile.generic b/Makefile.generic
index ff5de2a8acdc29e0282f06bdda4dd23aeb46550c..495b8bed169db45d78c77b667be13180a732ef84 100644
--- a/Makefile.generic
+++ b/Makefile.generic
@@ -1,9 +1,8 @@
-# $fiHeader: Makefile.generic,v 1.23 1993/11/24 03:56:46 duane Exp $
+# $fiHeader: Makefile.generic,v 1.26 1994/11/23 23:28:33 smh Exp $
 #
 #  Makefile.generic for CLIM 2.0
 #
 
-
 FORCE:
 
 default: all-xm
@@ -19,48 +18,41 @@ all-ol:	compile-ol cat-ol clim-ol
 
 compile-xm:	$(MOTIF_OBJS) FORCE
 	$(ECHO) "\
-	(si::system-compile-wrapper \
-	 (function \
-	  (lambda () \
-	    (load-logical-pathname-translations \"clim2\") \
-	    (setq *compile-print* $(COMPILE_PRINT)) \
-	    (setq sys::*libxt-pathname* \"$(XTLIB)\") \
-	    (setq sys::*libx11-pathname* \"$(XLIB)\") \
-	    (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
-	    (setq *ignore-package-name-case* t) \
-	    (set-case-mode :case-insensitive-lower) \
-	    (load \"misc/compile-1.lisp\") \
-	    (compile-it 'motif-clim))) \
-	 :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \
-	 :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \
-	 :record-xref-info $(RECORD_XREF_INFO) \
-	 :load-source-file-info $(LOAD_SOURCE_FILE_INFO) \
-	 :load-xref-info $(LOAD_XREF_INFO) \
-	 :compile-print nil :compile-verbose nil \
-	 :redefinition-warnings t :gcprint nil)" | $(CL) $(CLOPTS) -batch -backtrace-on-error
+	(progn \
+	  (load \"misc/compile-1.lisp\") \
+	  (load-logical-pathname-translations \"clim2\") \
+	  (setq sys::*libxt-pathname* \"$(XTLIB)\") \
+	  (setq sys::*libx11-pathname* \"$(XLIB)\") \
+	  (setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
+	  (proclaim '(optimize (speed $(SPEED)) (debug $(DEBUG)) (safety $(SAFETY)))) \
+	  (let ((*compile-print $(COMPILE_PRINT)) \
+		(*compile-verbose* t) \
+		(excl:*redefinition-warnings* t) \
+		(excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \
+		(excl:*load-source-file-info* $(LOAD_SOURCE_FILE_INFO)) \
+		(excl:*record-xref-info* $(RECORD-XREF-INFO)) \
+		(excl:*load-xref-info* $(LOAD_XREF_INFO))) \
+	    (compile-it 'motif-clim)))" \
+     | $(CL) $(CLOPTS) -batch -backtrace-on-error
 
 compile-ol:	$(OPENLOOK_OBJS) FORCE
 	$(ECHO) "\
-	(si::system-compile-wrapper \
-	 (function \
-	  (lambda () \
-	    (load-logical-pathname-translations \"clim2\") \
-	    (setq *compile-print* $(COMPILE_PRINT)) \
-	    (setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
-	    (setq sys::*libxt-pathname* \"$(OLXTLIB)\") \
-	    (setq sys::*libx11-pathname* \"$(OLXLIB)\") \
-	    (setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
-	    (setq *ignore-package-name-case* t) \
-	    (set-case-mode :case-insensitive-lower) \
-	    (load \"misc/compile-1.lisp\") \
-	    (compile-it 'openlook-clim))) \
-	 :speed $(SPEED) :debug $(DEBUG) :safety $(SAFETY) \
-	 :record-source-file-info $(RECORD_SOURCE_FILE_INFO) \
-	 :record-xref-info $(RECORD_XREF_INFO) \
-	 :load-source-file-info $(LOAD_SOURCE_FILE_INFO) \
-	 :load-xref-info $(LOAD_XREF_INFO) \
-	 :compile-print nil :compile-verbose nil \
-	 :redefinition-warnings t :gcprint nil)" | $(CL) $(CLOPTS) -batch -backtrace-on-error
+	(progn \
+	  (load \"misc/compile-1.lisp\") \
+	  (load-logical-pathname-translations \"clim2\") \
+	  (setq sys::*libxt-pathname* \"$(OLXTLIB)\") \
+	  (setq sys::*libx11-pathname* \"$(OLXLIB)\") \
+	  (setq sys::*clim-motif-pathname* \"clim-olit$(DEBUGLIB).o\") \
+	  (proclaim '(optimize (speed $(SPEED)) (debug $(DEBUG)) (safety $(SAFETY)))) \
+	  (let ((*compile-print $(COMPILE_PRINT)) \
+		(*compile-verbose* t) \
+		(excl:*redefinition-warnings* t) \
+		(excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \
+		(excl:*load-source-file-info* $(LOAD_SOURCE_FILE_INFO)) \
+		(excl:*record-xref-info* $(RECORD-XREF-INFO)) \
+		(excl:*load-xref-info* $(LOAD_XREF_INFO))) \
+	    (compile-it 'openlook-clim)))" \
+     | $(CL) $(CLOPTS) -batch -backtrace-on-error
 
 # Concatenation
 
@@ -148,7 +140,7 @@ tk/xm-defs.fasl : tk/xm-defs.lisp
 # Building
 
 clim-xm:	FORCE $(MOTIF_OBJS)
-	-$(RM) -f $(CLIMXM)
+	-$(RM) -f $(CLIM)
 	$(ECHO) " \
 		(load-logical-pathname-translations \"clim2\") \
 		(setq sys::*libxt-pathname* \"$(XTLIB)\") \
@@ -157,15 +149,15 @@ clim-xm:	FORCE $(MOTIF_OBJS)
 		(load \"misc/dev-load-1.lisp\") \
 		(load-it 'motif-clim) \
 		(setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \
-		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error
-	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMXM)
-	ls -lLt $(CLIMXM) >> Clim-sizes.n
-	size $(CLIMXM) >> Clim-sizes.n
-	ls -lLt $(CLIMXM)
+		(load \"misc/dump.lisp\")" | $(CL) $(CLOPTS) -batch -backtrace-on-error
+	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
+	ls -lLt $(CLIM) >> Clim-sizes.n
+	size $(CLIM) >> Clim-sizes.n
+	ls -lLt $(CLIM)
 	echo CLIM-XM built!!!!	
 
 clim-ol:	FORCE $(OPENLOOK_OBJS)
-	-$(RM) -f $(CLIMOL)
+	-$(RM) -f $(CLIM)
 	$(ECHO) " \
 		(load-logical-pathname-translations \"clim2\") \
 		(setq sys::*libxt-pathname* \"$(OLXTLIB)\") \
@@ -174,11 +166,11 @@ clim-ol:	FORCE $(OPENLOOK_OBJS)
 		(load \"misc/dev-load-1.lisp\") \
 		(load-it 'openlook-clim) \
 		(setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \
-		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error
-	$(MV) $(TMP)/clim.temp_`whoami` $(CLIMOL)
-	ls -lLt $(CLIMOL) >> Clim-sizes.n
-	size $(CLIMOL) >> Clim-sizes.n
-	ls -lLt $(CLIMOL)
+		(load \"misc/dump.lisp\")" | $(CL) $(CLOPTS) -batch -backtrace-on-error
+	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
+	ls -lLt $(CLIM) >> Clim-sizes.n
+	size $(CLIM) >> Clim-sizes.n
+	ls -lLt $(CLIM)
 	echo CLIM-OL built!!!!		
 
 clim-small:	FORCE
@@ -186,7 +178,7 @@ clim-small:	FORCE
 		(load-logical-pathname-translations \"clim2\") \
 		(load \"misc/load-xm.lisp\") \
 		(setq sys::*clim-dump-name* \"$(TMP)/clim.temp_`whoami`\") \
-		(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch -backtrace-on-error
+		(load \"misc/dump.lisp\")" | $(CL) $(CLOPTS) -batch -backtrace-on-error
 	$(MV) $(TMP)/clim.temp_`whoami` $(CLIM-SMALL)
 	ls -lt $(CLIM-SMALL) >> Clim-sizes.n
 	size $(CLIM-SMALL) >> Clim-sizes.n
@@ -322,33 +314,11 @@ makeclimobjs: $(CLIMOBJS)
 
 ################## Lower level Makefile stuff
 
-echo-xm-ucl-xtras: 
-	@echo $(PWD)/stub-x.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(PWD)/xtsupport.o   $(MOTIFLIB) $(XTLIB) $(XLIB) $(XMDCLXTRAS)
-
-ol-dcl	:  stub-x.o stub-xt.o clim-olit.o xlibsupport.o olsupport.o xtsupport.o  $(MALLOCOBJS)
-	cd $(CL_SRC) ; /bin/mv ucl ucl.climsave ;\
-	make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs=$(PREMALLOCS) ucl_xtras='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/clim-olit.o $(PWD)/xlibsupport.o $(PWD)/olsupport.o $(PWD)/xtsupport.o $(COMPOSEROBJS) $(MALLOCOBJS) $(OLXLIBS)' dcl ;\
-	/bin/mv ucl.climsave ucl
-
-xm-dcl	: stub-x.o stub-xt.o stub-motif.o xlibsupport.o xtsupport.o  MyDrawingA.o $(MALLOCOBJS)
-	cd $(CL_SRC) ; /bin/mv ucl ucl.climsave ;\
-	make initial_oldspace=$(OLDSPACE) oldspace=$(OLDSPACE) newspace=$(NEWSPACE) premallocs=$(PREMALLOCS) stubs=$(stubs) user_objects='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(PWD)/xtsupport.o $(COMPOSEROBJS) $(MOTIFLIB) $(MALLOCOBJS) $(XTLIB) $(XLIB) $(XMDCLXTRAS)' dcl ;\
-	/bin/mv ucl.climsave ucl
-
-# xm-dcl	: stub-x.o stub-xt.o stub-motif.o xlibsupport.o xtsupport.o  MyDrawingA.o $(MALLOCOBJS)
-# 	cd $(CL_SRC) ; \
-# 	ld -o xm-dcl -bI:/lib/syscalls.exp dcl $(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(PWD)/xtsupport.o $(COMPOSEROBJS) $(MOTIFLIB) $(MALLOCOBJS) $(XTLIB) $(XLIB) -lm -lld -lbsd
-
-
-ucl.clim: stub-x.o stub-xt.o stub-motif.o xlibsupport.o xtsupport.o  MyDrawingA.o $(MALLOCOBJS)
+ucl.clim: stub-x.o stub-xt.o stub-motif.o xlibsupport.o xtsupport.o  MyDrawingA.o
 	cd $(CL_SRC) ; /bin/mv ucl ucl.climsave ; /bin/mv dcl dcl.climsave ;\
-	make stubs=$(stubs) user_objects='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(PWD)/xtsupport.o $(MOTIFLIB) $(MOTIFXTRAOS) $(MALLOCOBJS) $(XTLIB) $(XLIB) $(XMDCLXTRAS)' ucl ;\
+	make stubs=$(stubs) user_objects='$(PWD)/stub-x.o $(PWD)/stub-xt.o $(PWD)/stub-motif.o $(PWD)/xlibsupport.o $(PWD)/MyDrawingA.o $(PWD)/xtsupport.o $(MOTIFLIB) $(MOTIFXTRAOS) $(XTLIB) $(XLIB) $(XMDCLXTRAS)' ucl ;\
 	/bin/mv ucl ucl.clim ; /bin/mv ucl.climsave ucl ; /bin/mv dcl.climsave dcl
 
-dcl	: 
-	cd $(CL_SRC) ; /bin/rm -f ucl ;\
-	make dcl	
-
 # these were moved here from Makefile.cobjs because SVR4 needs them, too
 # (and I didn't want to duplicate them in Makefile.cobjs-svr4).
 
diff --git a/Makefile.hpprism b/Makefile.hpprism
index ea4a72d53b88f92a86dc4fbef66fd2b914e632d6..9964faf0bd41c66ac5d82587029e376be6d3ed03 100644
--- a/Makefile.hpprism
+++ b/Makefile.hpprism
@@ -1,20 +1,19 @@
-# $fiHeader: Makefile.hp700,v 1.2 93/05/13 16:22:43 cer Exp $
+# $fiHeader: Makefile.hpprism,v 1.3 1993/12/04 00:32:01 duane Exp $
 #
 #  Makefile.hp700 for CLIM 2.0
 #
 
 include Makefile.defs
 
-Makefile=Makefile.hp700
+Makefile=Makefile.hpprism
 
-CL=/usr/fi/dcl-devel
+CL=/usr/fi/climdcl-devel
 
 CFLAGS	= -O -D_NO_PROTO -DSTRINGS_ALIGNED -DNO_REGEX -DNO_ISDIR -DUSE_RE_COMP -DUSER_GETWD -Wp,-H1280000
 
 # 
-
+XTSUPPORTINCLUDES=-I/net/vapor/x11/R5/src/mit/lib/Xt
 MOTIFLIB=/usr/lib/Motif1.2/libXm.a
-MOTIFLIB_d=/usr/lib/Motif1.2/libXm.a
 XTLIB=/usr/lib/X11R5/libXt.a
 XLIB=/usr/lib/X11R5/libX11.a
 XINCLUDES= -I/usr/include/Motif1.2 -I/usr/include/X11R5
diff --git a/Makefile.sgi4d-svr4 b/Makefile.sgi4d-svr4
index fbb63044a559a9908a187d62b6be36bfd7904d17..e0aa4018c186f5a84fd2e9f176cc73a44a6b0cbc 100644
--- a/Makefile.sgi4d-svr4
+++ b/Makefile.sgi4d-svr4
@@ -1,14 +1,15 @@
-# $fiHeader: Makefile.svr4,v 1.3 1993/05/13 16:22:49 cer Exp $
+# $fiHeader: Makefile.sgi4d-svr4,v 1.2 1994/06/08 06:56:29 duane Exp $
 
 include Makefile.defs
 
 Makefile=Makefile.sgi4d-svr4
 
 MOTIFHOME=
-MOTIFLIB=
-MOTIFLIB_d=$(MOTIFHOME)/usr/lib/libXm.a
+MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm$(DEBUGLIB).a
 XLIB=$(MOTIFHOME)/usr/lib/libX11$(DEBUGLIB)_s.a 
+
 MAINOBJXLIB=
+
 XTLIB=$(MOTIFHOME)/usr/lib/libXt$(DEBUGLIB).a
 XINCLUDES=-I$(MOTIFHOME)/usr/include
 XMINCLUDES=-I$(MOTIFHOME)/usr/include
diff --git a/Makefile.sun4 b/Makefile.sun4
index 760e1bacb873729ec3e2830e59732c801c1e2457..83f7cb6b12b1d1e0e87ce767e9c86a0e167951c4 100644
--- a/Makefile.sun4
+++ b/Makefile.sun4
@@ -1,4 +1,4 @@
-# $fiHeader: Makefile.sun4,v 1.5 1993/05/13 16:22:45 cer Exp $
+# $fiHeader: Makefile.sun4,v 1.8 1993/09/17 06:34:14 duane Exp $
 #
 #  Makefile.sun4 for CLIM 2.0
 #
@@ -7,11 +7,9 @@ include Makefile.defs
 
 Makefile=Makefile.sun4
 
-MOTIFHOME=/net/vapor/3rd/motif-1.2.2
+MOTIFHOME=/net/vapor/3rd/motif-1.2.4
 MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm$(DEBUGLIB).a
-#MOTIFLIB_d=$(MOTIFHOME)/usr/lib/libXm_d.a
-MOTIFLIB_d=$(MOTIFHOME)/usr/lib/libXm.a
-XLIB= $(MOTIFHOME)/usr/lib/libX11$(DEBUGLIB).a 
+XLIB=$(MOTIFHOME)/usr/lib/libX11$(DEBUGLIB).a 
 XTLIB=$(MOTIFHOME)/usr/lib/libXt$(DEBUGLIB).a
 
 XINCLUDES=-I$(MOTIFHOME)/usr/include
@@ -22,9 +20,10 @@ XTSUPPORTINCLUDES=-I/net/vapor/x11/R5/src/mit/lib/Xt
 # MOTIFXTRAOS=$(MOTIFHOME)/usr/lib/Motif/Sun/dlsym.o
 
 OPENLOOKHOME=/net/vapor/x11/olit-3.0
-OLXLIB= $(OPENLOOKHOME)/lib/libX11.a
+OPENLOOKLIB=$(OPENLOOKHOME)/lib/libXol.a
+OLXLIB=$(OPENLOOKHOME)/lib/libX11.a
 OLXTLIB=$(OPENLOOKHOME)/lib/libXt.a
-# don't use OPENLOOKHOME because there are no include files there
-OLINCLUDES=-I/usr/openwin/include
+
+OLINCLUDES=-I$(OPENLOOKHOME)/OWV3/src/include/
 
 include Makefile.generic
diff --git a/Makefile.sun4-svr4 b/Makefile.sun4-svr4
index 03f744dfacce81de8eb4191d518896fbb8b61cf4..e7763bb93fdea6dea982fc044d67f1e57bf00bee 100644
--- a/Makefile.sun4-svr4
+++ b/Makefile.sun4-svr4
@@ -1,12 +1,11 @@
-# $fiHeader: Makefile.svr4,v 1.3 1993/05/13 16:22:49 cer Exp $
+# $fiHeader: Makefile.sun4-svr4,v 1.3 1994/06/08 06:56:30 duane Exp $
 
 include Makefile.defs
 
 Makefile=Makefile.sun4-svr4
 
-MOTIFHOME=/net/vapor/3rd/motif-1.2.2-sol2/ICS/Motif
+MOTIFHOME=/net/vapor/3rd/motif-1.2.4-sol2
 MOTIFLIB=$(MOTIFHOME)/usr/lib/libXm$(DEBUGLIB).a
-MOTIFLIB_d=$(MOTIFHOME)/usr/lib/libXm.a
 XLIB=$(MOTIFHOME)/usr/lib/libX11$(DEBUGLIB).a 
 MAINOBJXLIB=$(XLIB)
 XTLIB=$(MOTIFHOME)/usr/lib/libXt$(DEBUGLIB).a
@@ -17,7 +16,8 @@ MOTIFXTRAOS=-lgen
 XTSUPPORTINCLUDES=-I/net/vapor/x11/R5/src/mit/lib/Xt
 
 OPENLOOKHOME=/usr/openwin
-OLXLIB= $(OPENLOOKHOME)/lib/libX11.a
+OPENLOOKLIB=$(OPENLOOKHOME)/lib/libXol.a
+OLXLIB=$(OPENLOOKHOME)/lib/libX11.a
 OLXTLIB=$(OPENLOOKHOME)/lib/libXt.a
 OLINCLUDES=-I$(OPENLOOKHOME)/include
 
diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp
index d27e9d28a9bfc9a551bf332da6dc7fc0361f468d..c35ba554322eae25d7d2c5a070aefe61c2157412 100644
--- a/clim/accept-values.lisp
+++ b/clim/accept-values.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: accept-values.lisp,v 1.73 1993/11/23 19:58:34 cer Exp $
+;; $fiHeader: accept-values.lisp,v 1.74 1993/12/07 05:33:30 colin Exp $
 
 (in-package :clim-internals)
 
@@ -278,7 +278,6 @@
 (define-application-frame accept-values-own-window (accept-values)
     ((help-window :initform nil)
      (scroll-bars :initform nil :initarg :scroll-bars)
-     (background :initform nil :initarg :background)
      (align-prompts :initform nil :initarg :align-prompts))
     (:pane 
      (let ((frame *application-frame*)
@@ -338,7 +337,7 @@
 
 (defun invoke-accepting-values (stream continuation
 				 &key frame-class command-table
-				      own-window background
+				      own-window background foreground text-style
 				      (exit-boxes 
 					(frame-manager-default-exit-boxes
 					  (frame-manager stream)))
@@ -386,6 +385,8 @@
 			:resize-frame resize-frame
 			:scroll-bars scroll-bars
 			:background background
+			:foreground foreground
+			:text-style text-style
 			:align-prompts align-prompts
 			:view view)))
 	   (when command-table
@@ -532,7 +533,8 @@
 		         #'(lambda (pane w h)
 			     (change-space-requirements pane 
 			       :width w :min-width w :max-width w
-			       :height h :min-height h :max-height h))))
+			       :height h :min-height h :max-height h))
+			 :right-margin 0 :bottom-margin 0))
 		     (when own-window
 		       (size-frame-from-contents own-window
 			 :width own-window-width
@@ -626,7 +628,6 @@
 
 (defmethod invoke-with-aligned-prompts ((stream accept-values-stream) continuation 
 								      &key (align-prompts t))
-  (declare (dynamic-extent continuation))
   (setq align-prompts (ecase align-prompts
 			((t :right) :right)
 			((:left) :left)
@@ -639,7 +640,6 @@
 
 (defmethod invoke-with-aligned-prompts ((stream t) continuation &key align-prompts)
   (declare (ignore align-prompts))
-  (declare (dynamic-extent continuation))
   (funcall continuation stream))
 
 (defmethod frame-manager-display-input-editor-error
@@ -710,7 +710,8 @@
 
 (define-presentation-type accept-values-exit-box ())
 
-(defmacro with-exit-box-decoded ((value label text-style documentation) exit-box labels &body body)
+(defmacro with-exit-box-decoded ((value label text-style documentation show-as-default)
+				 exit-box labels &body body)
   `(let* ((,value (if (consp ,exit-box) (first ,exit-box) ,exit-box))
 	  (,label (or (and (consp ,exit-box)
 			   (second ,exit-box))
@@ -720,7 +721,10 @@
 			   (getf (cddr (assoc ,value ,labels)) :text-style)))
 	  (,documentation (or (and (consp ,exit-box)
 				   (getf (cddr ,exit-box) :documentation))
-			      (getf (cddr (assoc ,value ,labels)) :documentation))))
+			      (getf (cddr (assoc ,value ,labels)) :documentation)))
+	  (,show-as-default (or (and (consp ,exit-box)
+			     (getf (cddr ,exit-box) :show-as-default))
+			(getf (cddr (assoc ,value ,labels)) :show-as-default))))
      ,@body))
 
 ;;; Applications can create their own AVV class and specialize this method in
@@ -735,8 +739,9 @@
     (updating-output (stream :unique-id stream :cache-value 'exit-boxes)
       (with-slots (exit-boxes) frame
 	(dolist (exit-box exit-boxes)
-	  (with-exit-box-decoded (value label text-style documentation) exit-box labels
-	    (declare (ignore documentation))
+	  (with-exit-box-decoded (value label text-style documentation show-as-default)
+	    exit-box labels
+	    (declare (ignore documentation show-as-default))
 	    (when label
 	      (with-text-style (stream text-style)
 		(with-output-as-presentation (stream value 'accept-values-exit-box)
@@ -937,7 +942,7 @@
   (let ((frame *application-frame*))
     (with-slots (stream) frame
       (when (verify-queries frame stream (slot-value stream 'avv-record))
-	(frame-exit *application-frame*)))))
+	(frame-exit frame)))))
 
 
 (defun verify-queries (frame stream avv-record)
@@ -1448,20 +1453,22 @@
 			       :cache-value 'exit-boxes)
 	(formatting-table (stream :equalize-column-widths nil)
 	  (dolist (exit-box exit-boxes)
-	    (with-exit-box-decoded (value label text-style documentation) exit-box labels
-		(when label
+	    (with-exit-box-decoded (value label text-style documentation show-as-default)
+	      exit-box labels
+	      (when label
 		(when text-style
 		  (setq text-style `(:text-style ,text-style)))
 		(formatting-column (stream)
 		  (formatting-cell (stream)
 		    (with-output-as-gadget (stream)
 		      (apply #'make-pane 'push-button
-			:label label
-			:help-callback documentation
-			:client frame :id value
-			:activate-callback #'handle-exit-box-callback
-			:name :accept-values-exit-button
-			text-style))))))))))))
+			     :label label
+			     :help-callback documentation
+			     :client frame :id value
+			     :activate-callback #'handle-exit-box-callback
+			     :name :accept-values-exit-button
+			     :show-as-default show-as-default
+			     text-style))))))))))))
 
 (defun handle-exit-box-callback (gadget)
   (if *editting-field-p*
@@ -1509,16 +1516,17 @@
 
 ;; This is how we associate an output-record with the button
 
-(defun invoke-accept-values-command-button (stream continuation view prompt
-					    &rest options
-					    &key (documentation (if (stringp prompt)
-								    prompt
-								  ;;-- What is the right thing to do?
-								  (ignore-errors
-								   (with-output-to-string (stream)
-								     (funcall prompt stream)))))
-						 (query-identifier (list ':button documentation))
-					    &allow-other-keys)
+(defun invoke-accept-values-command-button
+    (stream continuation view prompt
+     &rest options
+     &key (documentation (if (stringp prompt)
+			     prompt
+			   ;;-- What is the right thing to do?
+			   (ignore-errors
+			    (with-output-to-string (stream)
+			      (funcall prompt stream)))))
+	  (query-identifier (list ':button documentation))
+     &allow-other-keys)
   (typecase view
     (null)
     (symbol (setq view (make-instance view)))
@@ -1617,7 +1625,10 @@
 
 
 
-(defmethod clim-internals::frame-manager-position-dialog ((framem standard-frame-manager)
+;;; why do we need this - doesn't update-frame-settings do this for
+;;; us?
+
+(defmethod frame-manager-position-dialog ((framem standard-frame-manager)
 							  frame
 							  own-window-x-position own-window-y-position)
   (multiple-value-bind (x y)
diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp
index 8eafe12ecaf71dd006fc0e001928e53bdebf069b..25928b486c4f623cc8a5cfc7966bc6003aa1e2d6 100644
--- a/clim/clim-defs.lisp
+++ b/clim/clim-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: clim-defs.lisp,v 1.23 93/05/13 16:28:29 colin Exp $
+;; $fiHeader: clim-defs.lisp,v 1.24 1993/07/27 01:38:23 colin Exp $
 
 (in-package :clim-internals)
 
@@ -304,7 +304,8 @@
 ;;; From ACCEPTING-VALUES.LISP
 (defmacro accepting-values ((&optional stream &rest args) &body body)
   (declare (arglist (&optional stream
-		     &key frame-class command-table own-window background
+		     &key frame-class command-table own-window
+   		          background foreground text-style
 			  exit-boxes resize-frame align-prompts
 			  initially-select-query-identifier modify-initial-query
 			  resynchronize-every-pass (check-overlapping t)
diff --git a/clim/command.lisp b/clim/command.lisp
index 9cb9bce8ae990a05501b6e0e157eed88398b7b68..d52234a8a56664078aa0b20c392c0236af959e52 100644
--- a/clim/command.lisp
+++ b/clim/command.lisp
@@ -1,6 +1,6 @@
 s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: command.lisp,v 1.25 1993/06/04 16:06:20 cer Exp $
+;; $fiHeader: command.lisp,v 1.26 1993/10/26 03:21:30 colin Exp $
 
 (in-package :clim-internals)
 
@@ -140,10 +140,11 @@ s;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10
 	  (dovector (element menu)
 	    (destructuring-bind (string keystroke (type value &rest options)) element
 	      (when (case inherit-menu
-		      (:menu (set keystroke nil) 
+		      (:menu (setq keystroke nil) 
 			     t)
 		      (:keystrokes (setq string nil) 
-				   keystroke))
+				   keystroke)
+		      (otherwise t))
 		(apply #'add-menu-item-to-command-table 
 		       command-table string type value
 		       :keystroke keystroke :errorp nil
diff --git a/clim/cursor.lisp b/clim/cursor.lisp
index 05ca38201893f733f328505d13523ba2a59cce62..234a3360294860223b191bf47445db0770580375 100644
--- a/clim/cursor.lisp
+++ b/clim/cursor.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: cursor.lisp,v 1.24 93/05/13 16:28:35 colin Exp $
+;; $fiHeader: cursor.lisp,v 1.25 1993/07/27 01:38:41 colin Exp $
 
 (in-package :clim-internals)
 
@@ -86,10 +86,10 @@
 	  ;; Turn it off and then turn it on to make it move
 	  (unwind-protect
 	      (progn
-		(setf (cursor-active cursor) nil)
+		(setf (cursor-state cursor) nil)
 		(setf x (coordinate nx)
 		      y (coordinate ny)))
-	    (setf (cursor-active cursor) t)))))))
+	    (setf (cursor-state cursor) t)))))))
   
 (defmethod (setf cursor-state) (new-state (cursor standard-text-cursor))
   (with-slots (flags) cursor
@@ -153,16 +153,11 @@
 	 :off)))
  
 (defmethod (setf cursor-visibility) (visibility (cursor standard-text-cursor))
-  (setf (cursor-state cursor) 
-	(case visibility
-	  (:off nil)
-	  ((nil) nil)
-	  ((t :on) t)))
-  (setf (cursor-active cursor) 
-        (case visibility
-	  (:off t)
-	  ((nil) nil)
-	  ((t :on) t))))
+  (let ((active (member visibility '(t :on :off) :test  #'eq)))
+    (setf (cursor-active cursor) active)
+    (setf (cursor-state cursor)
+      (and active
+	   (not (eq visibility :off))))))
 
 (defmacro with-cursor-state ((stream state) &body body)
   (default-input-stream stream)
diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp
index 4f348673af418fae6c7f9972621879b9d6004a6b..20756615bb995b30a54ecd139f159d8f3aac62de 100644
--- a/clim/db-stream.lisp
+++ b/clim/db-stream.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-stream.lisp,v 1.58 1993/10/25 16:15:24 cer Exp $
+;; $fiHeader: db-stream.lisp,v 1.59 1993/11/18 18:44:14 cer Exp $
 
 (in-package :clim-internals)
 
@@ -507,13 +507,20 @@
 (defmethod (setf window-visibility) (visibility (stream clim-stream-sheet))
   (let ((frame (pane-frame stream)))
     (if frame
-	(if visibility (enable-frame frame) (disable-frame frame))
-	(setf (sheet-enabled-p stream) visibility))))
+	(if visibility
+	    (enable-frame frame)
+	  (disable-frame frame))
+      (setf (sheet-enabled-p stream) visibility))))
 
 (defmethod window-visibility ((stream clim-stream-sheet))
-  (mirror-visible-p (port stream) stream))
+  (let ((frame (pane-frame stream)))
+    (and (if frame 
+	     (eq (frame-state frame) :enabled)
+	   (sheet-enabled-p stream))
+	 (mirror-visible-p (port stream) stream))))
 
 (defmethod window-viewport ((stream clim-stream-sheet))
+  ;;;---why doesn't this return a viewport?? (cim 10/12/94)
   (or (pane-viewport-region stream)
       ;; Not a scrolling pane, so the sheet's region is the viewport
       (sheet-region stream)))
diff --git a/clim/default-frame.lisp b/clim/default-frame.lisp
index e4a709ff057395a7e3c235a93d8219fd2ebac660..109ad55d573326146f656f6494660b1b1160dd3f 100644
--- a/clim/default-frame.lisp
+++ b/clim/default-frame.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: default-frame.lisp,v 1.6 93/03/18 14:36:31 colin Exp $
+;; $fiHeader: default-frame.lisp,v 1.7 1993/07/27 01:38:59 colin Exp $
 
 (in-package :clim-internals)
 
@@ -47,7 +47,8 @@
 		 documentation
 		 (exit-boxes '(:exit :abort :help))
 		 (name title)
-		 text-style)
+		 text-style
+		 &allow-other-keys)
   (declare (ignore style documentation name))
   (let ((stream associated-window))
     (accepting-values (stream :exit-boxes exit-boxes :label title
@@ -70,7 +71,8 @@
 		 directory-list-label
 		 file-list-label
 		 (exit-boxes '(:exit :abort :help))
-		 (name title))
+		 (name title)
+		 &allow-other-keys)
   (declare (ignore style documentation name
 		   file-search-proc directory-list-label file-list-label))
   (let ((stream associated-window))
diff --git a/clim/defresource.lisp b/clim/defresource.lisp
index ec6138121249dfa280af35ef7fe0cc507d665c7e..9d6505b74bea6d5e5bfdb2b4730fb0bb92f3ed9d 100644
--- a/clim/defresource.lisp
+++ b/clim/defresource.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: defresource.lisp,v 1.10 92/09/24 09:38:43 cer Exp $
+;; $fiHeader: defresource.lisp,v 1.11 1993/07/27 01:39:05 colin Exp $
 
 (in-package :clim-internals)
 
@@ -67,7 +67,10 @@
 
 (defun clear-resource (resource)
   (with-resource-rd (resource rd)
-    (setf (fill-pointer (rd-objects rd)) 0))
+    (let ((objects (rd-objects rd)))
+      (dotimes (i (array-total-size objects))
+	(setf (aref objects i) nil))
+      (setf (fill-pointer objects) 0)))
   nil)
 
 (defun lookup-resource-descriptor (name)
diff --git a/clim/dragging-output.lisp b/clim/dragging-output.lisp
index 86fed2ea090ad2cd1cf94cd1798da5fd910f0279..b9a436e76f61fb2bd07d6d287b598de90ff5b4fa 100644
--- a/clim/dragging-output.lisp
+++ b/clim/dragging-output.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: dragging-output.lisp,v 1.11 1993/07/27 01:39:12 colin Exp $
+;; $fiHeader: dragging-output.lisp,v 1.12 1993/09/17 19:05:04 cer Exp $
 
 (in-package :clim-internals)
 
@@ -24,7 +24,7 @@
 
 (defun drag-output-record (stream output-record
 			   &key (repaint t) multiple-window
-				(erase #'erase-output-record) feedback
+				(erase #'erase-output-record erase-sp) feedback
 				(finish-on-release *dragging-output-finish-on-release*))
   (declare (values final-x final-y delta-x delta-y))
   (let (last-x last-y
@@ -33,6 +33,12 @@
 	(parent (output-record-parent output-record))
 	;; Clipping region for repainting the damaged region
 	(region (bounding-rectangle output-record)))
+
+    ;; If the default erase-output-record is used then it is not
+    ;; necessary to repaint because erase-output-record does a replay
+    (unless erase-sp
+      (setq repaint nil))
+    
     (multiple-value-bind (initial-x initial-y)
 	(stream-pointer-position stream)
       (declare (type coordinate initial-x initial-y))
diff --git a/clim/frames.lisp b/clim/frames.lisp
index 4a0bfae6a49ff3b0fe7785e9f3563315c6825945..3cc68b9a4b40f0d29bdee863a32685104f1c9950 100644
--- a/clim/frames.lisp
+++ b/clim/frames.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: frames.lisp,v 1.75 1993/11/18 18:44:17 cer Exp $
+;; $fiHeader: frames.lisp,v 1.76 1993/12/07 05:33:36 colin Exp $
 
 (in-package :clim-internals)
 
@@ -14,6 +14,8 @@
     ((name :initarg :name :accessor frame-name)
      (pretty-name :initarg :pretty-name :accessor frame-pretty-name)
      (background :initform nil :initarg :background :accessor frame-background)
+     (foreground :initform nil :initarg :foreground :accessor frame-foreground)
+     (text-style :initform nil :initarg :text-style :accessor frame-text-style)
      (command-table :initarg :command-table 
 		    :initform (find-command-table 'user-command-table)
 		    :accessor frame-command-table)
@@ -103,6 +105,9 @@
 (defmethod color-stream-p ((stream stream))
   nil)
 
+(defmethod color-stream-p ((stream standard-encapsulating-stream))
+  (color-stream-p (encapsulating-stream-stream stream)))
+
 (defmethod color-stream-p ((stream basic-extended-output-protocol))
   (let* ((frame (pane-frame stream))
 	 (palette (if frame
@@ -133,8 +138,13 @@
     (apply #'define-command-table-1 command-table)))
 )	;eval-when
 
+;; The recoginized options for define-application-frame are
+;; :pane :panes :layouts :top-level :menu-bar :pointer-documentation
+;; :command-definer :command-table :disabled-commands
+;; :default-initargs :icon :geometry. All other options are passed on
+;; as class options to defclass
+
 (defmacro define-application-frame (name superclasses slots &rest options)
-  #+Genera (declare (zwei:indentation 1 25 2 3 3 1))
   (with-warnings-for-definition name define-application-frame
     (let (pane panes layouts top-level menu-bar pointer-documentation
 	  command-definer command-table disabled-commands
@@ -146,7 +156,7 @@
 			    (t
 			     ,@(if pair
 				   `((assert (= (length entry) 2) (entry)
-					     "The length of the option ~S must be 2" entry)
+				       "The length of the option ~S must be 2" entry)
 				     (setq ,name (second entry)
 					   options (delete entry options)))
 				   `((assert (listp (rest entry)) (entry)
@@ -173,10 +183,11 @@
       (check-type layouts list)
       (check-type top-level list)
       (check-type disabled-commands list)
-      (when (and pane panes)
-	(error "You must use either ~S or ~S options" :pane :panes))
-      (when (and panes (null layouts))
-	(error "You must use ~S and ~S together" :panes :layouts))
+      (check-type geometry list)
+      (check-type default-initargs list)
+      (when (and pane (or panes layouts))
+	(error "The ~S option is mutually exclusive with the ~S and ~S options"
+	       :pane :panes :layouts))
       (when (null superclasses)
 	(setq superclasses '(standard-application-frame)))
       (when (eq command-definer 't)
@@ -188,26 +199,25 @@
 	    (t (warn-if-command-table-invalid name command-table)))
       (when (eq (first command-table) 't)
 	(setq command-table (list* name (rest command-table))))
-    #-Silica (warn-if-pane-descriptions-invalid name pane-descriptions)
-    #-Silica (warn-if-layouts-invalid name layouts pane-descriptions)
-    (let ((pane-constructors 
-	    (cond (panes
-		   (compute-pane-constructor-code panes))
-		  (pane
- 		   (compute-pane-constructor-code `((,name ,pane))))))
- 	  (layout-value
-	    `(list ,@(mapcar
+      (let ((pane-constructors 
+	     (cond (panes
+		    (compute-pane-constructor-code panes))
+		   (pane
+		    (compute-pane-constructor-code `((,name ,pane))))))
+	    (layout-value
+	     `(list ,@(mapcar
 		       #'(lambda (layout)
-			   (destructuring-bind (name panes &rest sizes) layout
+			   (destructuring-bind (name pane &rest sizes) layout
 			     (check-type sizes list)
 			     (if sizes
-				 `(list ',name ',panes 
-					,@(mapcar #'(lambda (pane-and-size)
-						      (destructuring-bind (pane &rest sizes) pane-and-size
-							`(list ',pane
-							       ,@sizes)))
-						  sizes))
-				 `',layout)))
+				 `(list ',name ',pane 
+					,@(mapcar
+					   #'(lambda (pane-and-size)
+					       (destructuring-bind (pane &rest sizes)
+						   pane-and-size
+						 `(list ',pane ,@sizes)))
+					   sizes))
+			       `',layout)))
 		       layouts))))
       `(progn
 	 (eval-when (compile)
@@ -325,21 +335,20 @@
 		      The valid keywords are ~S and ~S."
 		     keyword :command-table frame-name :inherit-from :menu))))))) 
 
-(defun compute-generate-panes-code (name code panes layouts)
-  (if layouts
-      (compute-complex-generate-panes-code name panes layouts)
-      (compute-simple-generate-panes-code name code)))
+(defun compute-generate-panes-code (name pane panes layouts)
+  (cond (layouts (compute-complex-generate-panes-code name panes layouts))
+	(panes (compute-default-generate-panes-code name panes))
+	(pane (compute-simple-generate-panes-code name pane))))
 
 (defun compute-simple-generate-panes-code (name code)
-  (and code
-       (let ((frame '#:frame)
-	     (framem '#:framem))
-	 `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
-	     (let ((*application-frame* ,frame))
-	       (setf (frame-panes ,frame)
-		     (frame-wrapper ,framem ,frame
-		       (with-look-and-feel-realization (,framem ,frame)
-			 ,code)))))))))
+  (let ((frame '#:frame)
+	(framem '#:framem))
+    `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
+	(let ((*application-frame* ,frame))
+	  (setf (frame-panes ,frame)
+	    (frame-wrapper ,framem ,frame
+			   (with-look-and-feel-realization (,framem ,frame)
+			     ,code))))))))
 
 (defun compute-complex-generate-panes-code (name panes layouts)
   (check-type layouts list)
@@ -348,8 +357,8 @@
     `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
 	(symbol-macrolet
 	  ,(mapcar #'(lambda (pane-spec)
-		       (destructuring-bind (name code &rest ignore) pane-spec
-			 (declare (ignore code ignore))
+		       (destructuring-bind (name &rest ignore) pane-spec
+			 (declare (ignore ignore))
 			 `(,name (find-or-make-pane-named ,frame ',name))))
 		   panes)
 	  (let ((*application-frame* ,frame))
@@ -359,156 +368,25 @@
 		      (ecase (frame-current-layout ,frame)
 			,@(mapcar 
 			    #'(lambda (layout-spec)
-				(destructuring-bind (name panes &rest ignore) layout-spec
+				(destructuring-bind (name pane &rest ignore) layout-spec
 				  (declare (ignore ignore))
-				  `(,name ,panes)))
+				  `(,name ,pane)))
 			    layouts)))))))))))
 
-(defun compute-pane-constructor-code (panes)
-  (check-type panes list)
-  `(list ,@(mapcar #'(lambda (pane-spec)
-		       (destructuring-bind (name code &rest options) pane-spec
-			 (setq code (canonicalize-pane-spec name code options))
-			 `(list ',name
-				#'(lambda (frame framem)
-				    (with-look-and-feel-realization (framem frame)
-				      ,code)))))
-		   panes)))
-   
-(defun canonicalize-pane-spec (name code rest)
-  (cond ((symbolp code)
-	 (unless (getf rest :name)
-	   (setf (getf rest :name) `',name))
-	 (apply #'find-pane-class-constructor code rest))
-	((null rest) code)
-	(t
-	 (error "Invalid pane specification: ~S"
-		(list* name code rest)))))
-
-(defmethod find-pane-class-constructor ((type t) &rest options)
-  (declare (dynamic-extent options))
-  (error "Unknown pane type ~S with options ~S" type options))
-
-
-;;--- Extend this to default the options from the lambda list
-(defmacro define-pane-type (type lambda-list &body body)
-  `(defmethod find-pane-class-constructor ((type (eql ',type)) ,@lambda-list)
-     ,@body))
-
-(define-pane-type :title (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-clim-stream-pane
-     :type 'title-pane
-     ,@options
-     :display-function 'display-title
-     :display-after-commands nil
-     :text-style (parse-text-style '(:sans-serif :bold :large))
-     :scroll-bars nil
-     :width :compute :height :compute
-     :max-height :compute
-     :end-of-page-action :allow 
-     :end-of-line-action :allow))
-
-(define-pane-type :command-menu (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-clim-stream-pane
-     :type 'command-menu-pane
-     ,@options
-     :display-function `(display-command-menu :command-table ,(frame-command-table frame))
-     :incremental-redisplay t
-     :display-after-commands t
-     :text-style *command-table-menu-text-style*
-     :scroll-bars nil
-     :width :compute :height :compute
-     :end-of-page-action :allow 
-     :end-of-line-action :allow))
-
-
-(define-pane-type :interactor (&rest options &key (scroll-bars :vertical))
-  (declare (non-dynamic-extent options))
-  `(make-clim-interactor-pane
-     ,@options
-     :scroll-bars ,scroll-bars))
-
-(define-pane-type :application (&rest options &key (scroll-bars :both))
-  (declare (non-dynamic-extent options))
-  `(make-clim-application-pane 
-     ,@options
-     :scroll-bars ,scroll-bars))
-
-(define-pane-type :accept-values (&rest options &key (scroll-bars :vertical))
-  (declare (non-dynamic-extent options))
-  `(make-clim-stream-pane 
-     :type 'accept-values-pane
-     ,@options
-     :display-after-commands :no-clear
-     :scroll-bars ,scroll-bars
-     :width :compute :height :compute
-     :end-of-page-action :allow
-     :end-of-line-action :allow))
-
-(define-pane-type :pointer-documentation (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-clim-stream-pane
-     :type 'pointer-documentation-pane
-     ,@options
-     :display-after-commands nil
-     :text-style (parse-text-style '(:sans-serif :bold :normal))
-     :scroll-bars nil
-     :end-of-page-action :allow
-     :end-of-line-action :allow))
-
-(define-pane-type scroll-bar (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'scroll-bar ,@options))
-
-(define-pane-type slider (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'slider ,@options))
-
-(define-pane-type push-button (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'push-button ,@options))
-
-(define-pane-type label-pane (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'label-pane ,@options))
-
-(define-pane-type text-field (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'text-field ,@options))
-
-(define-pane-type text-editor (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'text-editor ,@options))
-
-(define-pane-type toggle-button (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'toggle-button ,@options))
-
-(define-pane-type radio-box (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'radio-box ,@options))
-
-(define-pane-type check-box (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'check-box ,@options))
-
-(define-pane-type list-pane (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'list-pane ,@options))
-
-(define-pane-type option-pane (&rest options)
-  (declare (non-dynamic-extent options))
-  `(make-pane 'option-pane ,@options))
-
-(define-pane-type :menu-bar (&rest options &key command-table)
-  (declare (non-dynamic-extent options))
-  (with-keywords-removed (options options '(:command-table))
-    `(make-pane 'menu-bar 
-		,@options
-		:command-table ,(or command-table
-				    `(frame-command-table frame)))))
+(defun compute-default-generate-panes-code (name panes)
+  (let ((frame '#:frame)
+	(framem '#:framem))
+    `((defmethod generate-panes ((,framem standard-frame-manager) (,frame ,name))
+	(let ((*application-frame* ,frame))
+	  (setf (frame-panes ,frame)
+	    (frame-wrapper ,framem ,frame
+	      (with-look-and-feel-realization (,framem ,frame)
+		(vertically ()
+		  ,@(mapcar #'(lambda (pane-spec)
+				(destructuring-bind (name &rest ignore) pane-spec
+				  (declare (ignore ignore))
+				  `(find-or-make-pane-named ,frame ',name)))
+			    panes))))))))))
 
 
 (defmethod find-or-make-pane-named ((frame standard-application-frame) name)
@@ -644,13 +522,11 @@
   (let ((geometry (getf options :geometry)))
     (when (and (eq user-specified-position-p :unspecified)
 	       (or (and (getf geometry :left)
-			(getf geometry :top))
-		   (and left top)))
+			(getf geometry :top))))
       (setf user-specified-position-p t))
     (when (and (eq user-specified-size-p :unspecified)
 	       (or (and (getf geometry :width)
-			(getf geometry :height))
-		   (and width height)))
+			(getf geometry :height))))
       (setf user-specified-size-p t)))
   (with-keywords-removed (options options 
 			  '(:frame-class :pretty-name :enable :save-under
@@ -720,9 +596,7 @@
 	 (multiple-value-bind (width height)
 	     (ecase old-state
 	       (:disowned 
-		(if (and width height)
-		    (values width height)
-		  (values)))
+		(values width height))
 	       (:disabled
 		(bounding-rectangle-size
 		 (frame-top-level-sheet frame))))  
@@ -908,8 +782,8 @@
 
 (defmethod default-frame-top-level ((frame standard-application-frame)
 				    &key command-parser command-unparser
-				    partial-command-parser
-				    (prompt "Command: "))
+					 partial-command-parser
+					 (prompt "Command: "))
   ;; Enable the frame now
   (unless (eq (frame-state frame) :enabled)
     (enable-frame frame))
@@ -948,7 +822,8 @@
 		(output-protocol-mixin si)
 		(t (frame-top-level-sheet frame))))))
       ;; The read-eval-print loop for applications...
-      (letf-globally (((frame-actual-pointer-documentation-pane frame) *pointer-documentation-output*))
+      (letf-globally (((frame-actual-pointer-documentation-pane frame)
+		       *pointer-documentation-output*))
 	(loop
 	  ;; Redisplay all the panes
 	  (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
@@ -1077,6 +952,7 @@
 
 ;; The contract of GET-FRAME-PANE is to get a pane upon which we can do normal
 ;; I/O operations, that is, a CLIM stream pane
+
 (defmethod get-frame-pane ((frame standard-application-frame) pane-name &key (errorp t))
   (with-slots (all-panes) frame
     (let ((pane (assoc pane-name all-panes)))
@@ -1145,31 +1021,38 @@
 	      (push pane (slot-value frame 'initialized-panes))))
 	  (return
 	    (cond (display-function
-		   (cond (redisplay-p
-			  (let ((redisplay-record
-				 (let ((history (stream-output-history pane)))
-				   (when history
-				     #+compulsive-redisplay
-				     (when (> (output-record-count history :fastp t) 1)
-				       (cerror "Clear the output history and proceed"
-					       "There is more than one element in this redisplay pane")
-				       (window-clear pane))
-				     (unless (zerop (output-record-count history :fastp t))
-				       (output-record-element history 0))))))
-			    (cond ((or (null redisplay-record) force-p)
-				   (when force-p
-				     (window-clear pane))
-				   (invoke-pane-redisplay-function frame pane))
-				  (t 
-				   (redisplay redisplay-record pane 
-					      :check-overlapping check-overlapping)))))
-			 ((or force-p (progn (multiple-value-setq (needs-display clear)
-					       (pane-needs-redisplay pane))
-					     needs-display))
-			  (when (or force-p clear)
-			    (window-clear pane))
-			  (invoke-pane-display-function frame pane)))
+		   (cond 
+
+		    ;; display function with incremental redisplay
+		    (redisplay-p
+		     (let ((redisplay-record
+			    (let ((history (stream-output-history pane)))
+			      (when history
+				#+compulsive-redisplay
+				(when (> (output-record-count history :fastp t) 1)
+				  (cerror "Clear the output history and proceed"
+					  "There is more than one element in this redisplay pane")
+				  (window-clear pane))
+				(unless (zerop (output-record-count history :fastp t))
+				  (output-record-element history 0))))))
+		       (cond ((or (null redisplay-record) force-p)
+			      (when force-p
+				(window-clear pane))
+			      (invoke-pane-redisplay-function frame pane))
+			     (t 
+			      (redisplay redisplay-record pane 
+					 :check-overlapping check-overlapping)))))
+
+		    ;; display function without incremental redisplay
+		    ((or force-p (progn (multiple-value-setq (needs-display clear)
+					  (pane-needs-redisplay pane))
+					needs-display))
+		     (when (or force-p clear)
+		       (window-clear pane))
+		     (invoke-pane-display-function frame pane)))
 		   (force-output pane))
+		  
+		  ;; no display function
 		  (force-p
 		   ;; If refilling from scratch, give the application a chance
 		   ;; to draw stuff
diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp
index 11d1cdfce931bff3d04ce9f340ccaca43d0beded..2022cd5502a1e0b28a83f4cbcf97acdd63dd7b97 100644
--- a/clim/gadget-output.lisp
+++ b/clim/gadget-output.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadget-output.lisp,v 1.55 1993/11/18 18:44:20 cer Exp $
+;; $fiHeader: gadget-output.lisp,v 1.56 1993/12/07 05:33:40 colin Exp $
 
 (in-package :clim-internals)
 
@@ -273,6 +273,13 @@
 	    (cdr *with-deferred-gadget-updates*))
       (setf (sheet-enabled-p (output-record-gadget record)) state)))
 
+(define-presentation-method gadget-includes-prompt-p :around 
+  ((type t) (stream t) (view actual-gadget-view))
+  (let ((initargs (view-gadget-initargs view)))
+    (or (getf initargs :label)
+	(not (getf initargs :prompt t))
+	(call-next-method))))
+
 
 ;;; Completion gadget
 
@@ -285,20 +292,11 @@
       (call-next-method)
     +radio-box-view+))
 
-(define-presentation-method gadget-includes-prompt-p 
-    ((type completion) (stream t) (view radio-box-view))
-  (not (null (getf (view-gadget-initargs view) :label))))
-
-(define-presentation-method gadget-includes-prompt-p :around 
-  ((type t) (stream t) (view actual-gadget-view))
-  (or (not (getf (view-gadget-initargs view) :prompt t))
-      (call-next-method)))
-
 (define-presentation-method accept-present-default 
 			    ((type completion) stream (view radio-box-view)
 			     default default-supplied-p present-p query-identifier
 			     &key (prompt t) (active-p t))
-  (declare (ignore present-p))
+  (declare (ignore present-p prompt))
   (move-cursor-to-view-position stream view)
   (let ((current-selection nil))
     (flet ((update-gadget (record gadget radio-box)
@@ -344,20 +342,16 @@
 			    button))
 		      sequence))
 	       (radio-box
-		 (apply #'make-pane 'radio-box
-			(append
-			  (remove-keywords (view-gadget-initargs view)
-					   '(:toggle-button-options))
-			  (list :label (and (stringp prompt) prompt)
-				:choices buttons 
-				:current-selection current-selection 
-				:client stream
-				:id query-identifier 
-				:value-changed-callback
-				  (make-accept-values-value-changed-callback
-				    stream query-identifier)
-				:active active-p
-				:help-callback (make-gadget-help type))))))
+		(make-pane-from-view 'radio-box view 
+				     '(:toggle-button-options :label)
+		  :choices buttons 
+		  :current-selection current-selection 
+		  :client stream
+		  :id query-identifier 
+		  :value-changed-callback (make-accept-values-value-changed-callback
+					   stream query-identifier)
+		  :active active-p
+		  :help-callback (make-gadget-help type))))
 	  (values (if radio-box-label
 		      (outlining ()
 			(vertically ()
@@ -376,15 +370,11 @@
       (call-next-method)
       +check-box-view+))
 
-(define-presentation-method gadget-includes-prompt-p 
-    ((type subset-completion) (stream t) (view check-box-view))
-  (not (null (getf (view-gadget-initargs view) :label))))
-
 (define-presentation-method accept-present-default 
 			    ((type subset-completion) stream (view check-box-view)
 			     default default-supplied-p present-p query-identifier
 			     &key (prompt t) (active-p t))
-  (declare (ignore present-p))
+  (declare (ignore present-p prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget check-box)
 	   (declare (ignore record gadget))
@@ -434,20 +424,17 @@
 			  (when actual-value (push button current-selection))
 			  button))
 		    sequence))
-	     (check-box (apply #'make-pane 'check-box
-			       (append
-				 (remove-keywords (view-gadget-initargs view)
-						  '(:toggle-button-options))
-				 (list :label (and (stringp prompt) prompt)
-				       :choices buttons
-				       :current-selection current-selection
-				       :client stream 
-				       :id query-identifier
-				       :value-changed-callback
-				         (make-accept-values-value-changed-callback
-					   stream query-identifier)
-				       :active active-p
-				       :help-callback (make-gadget-help type))))))
+	     (check-box
+	      (make-pane-from-view 'check-box view 
+				   '(:toggle-button-options :label)
+		:choices buttons
+		:current-selection current-selection
+		:client stream 
+		:id query-identifier
+		:value-changed-callback (make-accept-values-value-changed-callback
+					 stream query-identifier)
+		:active active-p
+		:help-callback (make-gadget-help type))))
 	(values (if check-box-label
 		    (outlining ()
 		      (vertically ()
@@ -466,15 +453,11 @@
       (call-next-method)
       +toggle-button-view+))
 
-(define-presentation-method gadget-includes-prompt-p 
-    ((type boolean) (stream t) (view toggle-button-view))
-  t)
-
 (define-presentation-method accept-present-default 
 			    ((type boolean) stream (view toggle-button-view)
 			     default default-supplied-p present-p query-identifier
 			     &key (prompt t) (active-p t))
-  (declare (ignore default-supplied-p present-p))
+  (declare (ignore default-supplied-p present-p prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget button)
  	   (declare (ignore record gadget))
@@ -485,7 +468,6 @@
  	   (setf (gadget-value button) default)))
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
       (let ((button (make-pane-from-view 'toggle-button view ()
-		      :label (and (stringp prompt) prompt)
 		      :value default
 		      :client stream :id query-identifier
 		      :value-changed-callback
@@ -498,10 +480,6 @@
 
 ;;; Numeric gadgets
 
-(define-presentation-method gadget-includes-prompt-p
-			    ((type real) (stream t) (view slider-view))
-  t)
-
 (define-presentation-method accept-present-default 
 			    ((type real) stream (view slider-view)
 			     default default-supplied-p present-p query-identifier
@@ -523,6 +501,7 @@
 					 type prompt query-identifier
 					 low high default-supplied-p
 					 &optional (editable-p t))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (let ((min-value (if (eq low '*) 0 low))
 	(max-value (if (eq high '*) 100 high)))
@@ -538,7 +517,6 @@
 	(let ((slider 
 		;;--- What other initargs do we pass along from the view?
 		(make-pane-from-view 'slider view ()
-		  :label (and (stringp prompt) prompt)
 		  :value (if default-supplied-p default min-value)
 		  :min-value min-value :max-value max-value
 		  :orientation (gadget-orientation view)
@@ -575,6 +553,7 @@
 					    type prompt query-identifier
 					    low high default-supplied-p
 					    &optional (editable-p t))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (let ((min-value (if (eq low '*) 0 low))
 	(max-value (if (eq high '*) 100 high)))
@@ -590,7 +569,6 @@
 	(let ((slider
 		;;--- What other initargs do we pass along from the view?
 		(make-pane-from-view 'slider view ()
-		  :label (and (stringp prompt) prompt)
 		  :value (if default-supplied-p default min-value)
 		  :min-value min-value :max-value max-value
 		  :orientation (gadget-orientation view)
@@ -653,6 +631,7 @@
 					default-supplied-p type
 					prompt query-identifier
 					&key (editable-p t))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget text-field)
  	   (declare (ignore record gadget))	     ;;-- This sucks
@@ -666,7 +645,6 @@
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
       (let ((text-field (make-pane-from-view 
 			  'text-field view ()
-			  :label (and (stringp prompt) prompt)
 			  :value (if default-supplied-p
 				     (present-to-string default type)
 				   "")
@@ -679,6 +657,10 @@
 			    ;;--- Why do we check for editable-p?  If it
 			    ;;--- is read-only, won't this callback never be
 			    ;;--- called? (cim) 
+			    (and editable-p
+				 `(accept-values-string-field-changed-callback
+				   ,stream ,query-identifier))
+			    :activate-callback
 			    (and editable-p
 				 `(accept-values-string-field-changed-callback
 				    ,stream ,query-identifier))
@@ -705,7 +687,8 @@
 	      ;; accept multi-line strings in text-editors (cim)
 	    (accept-from-string (accept-values-query-type query)
 				new-value
-				:activation-gestures nil)
+				:activation-gestures nil
+				:delimiter-gestures nil)
 	  (declare (ignore type))
 	  (assert (= index (length new-value)))
 	  object)
@@ -738,6 +721,7 @@
 				    default-supplied-p type
 				    prompt query-identifier
 				    &key (editable-p t))
+  (declare (ignore prompt))
   (move-cursor-to-view-position stream view)
   (flet ((update-gadget (record gadget button)
  	   (declare (ignore record gadget))
@@ -750,7 +734,6 @@
 	       ""))))
     (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget)
       (let ((text-field (make-pane-from-view 'text-editor view '(:scroll-bars)
-			  :label (and (stringp prompt) prompt)
 			  :value (if default-supplied-p
 				     default
 				   "")
@@ -763,6 +746,11 @@
 			    ;;--- Why do we check for editable-p?  If it
 			    ;;--- is read-only, won't this callback never be
 			    ;;--- called? (cim) 
+			    (and editable-p
+				 `(accept-values-string-field-changed-callback
+				    ,stream ,query-identifier))
+
+			    :activate-callback
 			    (and editable-p
 				 `(accept-values-string-field-changed-callback
 				    ,stream ,query-identifier))
diff --git a/clim/gestures.lisp b/clim/gestures.lisp
index 448e9f7b5d33c73a0674f8d610541ad0a96eab08..f1dfcbe7702ac0bfeb77163782ea302a512af6bf 100644
--- a/clim/gestures.lisp
+++ b/clim/gestures.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gestures.lisp,v 1.21 93/05/13 16:23:10 cer Exp $
+;; $fiHeader: gestures.lisp,v 1.22 1993/07/27 01:39:37 colin Exp $
 
 (in-package :clim-internals)
 
@@ -169,7 +169,9 @@
 	  (unless port
 	    ;; This is the best we can do...
 	    (setq port (port *application-frame*)))
-	  (values event 0))
+	  (values event (if (upper-case-p event)
+			    (make-modifier-state :shift)
+			  0)))
 	(keyboard-event			;--- KEY-PRESS-EVENT?
 	  (unless port
 	    (setq port (port (event-sheet event))))
@@ -232,7 +234,10 @@
   (declare (values keysym modifier-state))
   (when (atom gesture-spec)
     (return-from parse-gesture-spec
-      (values gesture-spec 0)))
+      (if (and (characterp gesture-spec)
+	       (upper-case-p gesture-spec))
+	  (values gesture-spec (make-modifier-state :shift))
+	(values gesture-spec 0))))
   (when (and (consp gesture-spec)
 	     (integerp (cdr gesture-spec)))
     (return-from parse-gesture-spec
@@ -243,7 +248,10 @@
       (if (find x *modifier-keys*)
 	  (let ((bit (modifier-key-index x)))
 	    (setf modifier-state (dpb 1 (byte 1 bit) modifier-state)))
-	  (setq keysym (or keysym x))))
+	(setq keysym (or keysym x))))
+    (when (and (characterp keysym)
+	       (upper-case-p keysym))
+      (setq modifier-state (logior modifier-state (make-modifier-state :shift))))
     (values keysym modifier-state)))
 
 ;; A slower, more careful version of the above that gets used to
diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp
index 454670e73f7c7d914835f2d890f6d09778eb2d38..e24cf8142e554e3df7884d7c17885618731acc71 100644
--- a/clim/graphics-recording.lisp
+++ b/clim/graphics-recording.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: graphics-recording.lisp,v 1.25 1993/10/25 16:15:32 cer Exp $
+;; $fiHeader: graphics-recording.lisp,v 1.26 1993/11/18 18:44:22 cer Exp $
 
 (in-package :clim-internals)
 
@@ -284,11 +284,19 @@
      (let* ((position-seq (slot-value record 'position-seq))
 	    (line-style (slot-value record 'line-style))
 	    (thickness (line-style-thickness line-style)))
-       (map-endpoint-sequence
-	 #'(lambda (x1 y1 x2 y2)
-	     (when (point-close-to-line-p x y x1 y1 x2 y2 thickness)
-	       (return-from refined-position-test t)))
-	 position-seq)))
+       (with-half-thickness (lthickness rthickness) line-style
+         (map-endpoint-sequence
+	  #'(lambda (x1 y1 x2 y2)
+	      (when (point-close-to-line-p x y x1 y1 x2 y2 thickness)
+		(when (> x1 x2) (rotatef x1 x2))
+		(when (> y1 y2) (rotatef y1 y2))
+		(when (ltrb-contains-position-p (- x1 lthickness)
+						(- y1 lthickness)
+						(+ x2 rthickness)
+						(+ y2 rthickness)
+						x y)
+		(return-from refined-position-test t))))
+	  position-seq))))
   :highlighting-function
     ((stream state)
      (declare (ignore state))			;for now.
diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp
index 43427a1c72186b58da08d969e7b55997e9470e32..cdaa733dea7aade7d97c9cf6d9b924d7e6a036f2 100644
--- a/clim/input-defs.lisp
+++ b/clim/input-defs.lisp
@@ -1,6 +1,6 @@
 M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-defs.lisp,v 1.18 1993/05/05 01:38:30 cer Exp $
+;; $fiHeader: input-defs.lisp,v 1.19 1993/05/25 20:40:52 cer Exp $
 
 (in-package :clim-internals)
 
@@ -185,8 +185,13 @@ M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10
 	;;--- it's hours before AAAI.  Note that this can cause blowouts
 	;;--- in multi-processing systems if the function that does the
 	;;--- unhighlighting depends on application state.
+	;;---	
+	;;--- let's go the whole hog and make a stab at binding
+	;;--- *application-frame* (cim 1/31/94)
 	(when (output-recording-stream-p sheet)
-	  (set-highlighted-presentation sheet nil nil))))))
+	  (let ((*application-frame* (or (pane-frame sheet)
+					 *application-frame*)))
+	    (set-highlighted-presentation sheet nil nil)))))))
 
 (defmethod pointer-decache ((pointer standard-pointer))
   ;;-- If the (sheet-transformation (pointer-sheet .)) has changed
diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp
index 982bf70edfe2dd9a23155d051b06c497190caab6..17e99db5dd34509bd227adc86d5d4bd96da482cb 100644
--- a/clim/input-protocol.lisp
+++ b/clim/input-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: input-protocol.lisp,v 1.44 1993/07/27 01:39:55 colin Exp $
+;; $fiHeader: input-protocol.lisp,v 1.45 1993/08/12 16:03:07 cer Exp $
 
 (in-package :clim-internals)
 
@@ -128,7 +128,8 @@
 		(with-sheet-medium (medium stream)
 		  (with-medium-clipping-region (medium region)
 		    (declare (ignore medium))
-		    (note-cursor-change cursor 'cursor-active nil t)))))))))))
+		    ;; this forces the cursor to be redrawn
+		    (note-cursor-change cursor 'cursor-state nil t)))))))))))
 
 (defmethod pointer-motion-pending ((stream input-protocol-mixin)
 				   &optional
@@ -573,7 +574,7 @@
 			  (> (get-internal-real-time) end-time))
 		 (setq flag :timeout))
 	       flag))
-	(declare (dynamic-extent #'waiter))
+	#-Allegro (declare (dynamic-extent #'waiter))
 	(port-event-wait (port stream) #'waiter :timeout timeout)
 	(return-from stream-input-wait
 	  (values (when (eq flag ':input-buffer) t)
@@ -663,7 +664,7 @@
     old-focus))
 
 (defmethod stream-restore-input-focus ((stream input-protocol-mixin) old-focus)
-  (setf (port-keyboard-input-focus (port stream)) old-focus))
+  (setf (port-keyboard-input-focus (port (graft stream))) old-focus))
 
 (defmethod note-sheet-gain-focus ((sheet input-protocol-mixin))
   (let ((text-cursor (stream-text-cursor sheet)))
diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp
index 5a54b0014ddfa9050d6b35a4aac5a94b7fb7f167..4c1c0fbc5b083f38ae8d9466bd53ed3dc3c16f8e 100644
--- a/clim/interactive-protocol.lisp
+++ b/clim/interactive-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: interactive-protocol.lisp,v 1.31 1993/11/18 18:44:24 cer Exp $
+;; $fiHeader: interactive-protocol.lisp,v 1.32 1993/11/23 19:58:38 cer Exp $
 
 (in-package :clim-internals)
 
@@ -1043,23 +1043,27 @@
   (values (apply #'accept ptype
 		 :stream stream
 		 :prompt-mode :raw
-		 :prompt (apply #'format nil format-string args)
+		 :prompt (if format-string
+			     (apply #'format nil format-string args)
+			   "")
 		 accept-args)))
 
-(defmethod stream-yes-or-no-p ((stream input-protocol-mixin) &optional (format-string "") &rest args)
+(defmethod stream:stream-yes-or-no-p ((stream input-protocol-mixin)
+				      &optional format-string &rest args)
   (stream-yay-or-nay-p stream
 		       '(member-alist (("Yes" :value t) ("No" :value nil)))
 		       format-string args))
 
 
-(defmethod stream-y-or-n-p ((stream input-protocol-mixin) &optional (format-string "") &rest args)
+(defmethod stream:stream-y-or-n-p ((stream input-protocol-mixin)
+				   &optional format-string &rest args)
   (stream-yay-or-nay-p stream
 		       '(member-alist (("Y" :value t) ("N" :value nil)))
 		       format-string args))
 
 
-(defmethod stream-y-or-n-or-newline-p ((stream input-protocol-mixin) 
-				       &optional (format-string "") &rest args)
+(defmethod excl::stream-y-or-n-or-newline-p ((stream input-protocol-mixin) 
+					     &optional format-string &rest args)
   (stream-yay-or-nay-p stream
 		       '(member-alist (("Y" :value t) ("N" :value nil)))
 		       format-string args
diff --git a/clim/menus.lisp b/clim/menus.lisp
index e9a9cd049587eb77c47093ededbfdac4f27416af..20e3b47c21f839cff60e1761f6698a01c384d3bd 100644
--- a/clim/menus.lisp
+++ b/clim/menus.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: menus.lisp,v 1.45 1993/05/25 20:40:58 cer Exp $
+;; $fiHeader: menus.lisp,v 1.46 1993/10/25 16:15:35 cer Exp $
 
 (in-package :clim-internals)
 
@@ -68,7 +68,9 @@
 			   (eq (not label) (not (menu-frame-label (pane-frame menu))))
 			   (eq (frame-manager menu) (frame-manager root)))
 	       
-	     :deinitializer (window-clear menu)
+	     :deinitializer (progn
+			      (setf (window-visibility menu) nil)
+			      (window-clear menu))
 	     :initializer (initialize-menu (port menu) menu :label label))
 
 (defmethod initialize-menu ((port basic-port) menu &key label)
@@ -241,32 +243,36 @@
      (drawer-args :initarg :drawer-args)))
 
 (defgeneric menu-choose (items &rest keys
-			 &key associated-window text-style default-item
+			 &key associated-window text-style
+			      default-item foreground background
 			      label scroll-bars printer presentation-type
 			      cache unique-id id-test cache-value cache-test
 			      max-width max-height n-rows n-columns
 			      x-spacing y-spacing
 			      cell-align-x cell-align-y
-			      pointer-documentation menu-type))
+			      pointer-documentation menu-type
+			      x-position y-position))
 
 ;; Are these reasonable defaults for UNIQUE-ID, CACHE-VALUE, ID-TEST, and CACHE-TEST?
 (defmethod menu-choose ((items t) &rest keys
 			&key (associated-window (frame-top-level-sheet *application-frame*))
-			     text-style default-item
+			     text-style default-item foreground background
 			     label (scroll-bars t) printer presentation-type
 			     (cache nil) (unique-id items) (id-test #'equal)
 			     (cache-value items) (cache-test #'equal)
 			     max-width max-height n-rows n-columns
 			     x-spacing y-spacing (row-wise nil)
 			     (cell-align-x ':left) (cell-align-y ':top)
-			     pointer-documentation menu-type gesture)
+			     pointer-documentation menu-type gesture
+			     x-position y-position)
   (declare (values value chosen-item gesture))
-  (declare (ignore text-style default-item
+  (declare (ignore text-style default-item foreground background
 		   label scroll-bars printer presentation-type
 		   cache unique-id id-test cache-value cache-test
 		   max-width max-height n-rows n-columns
 		   x-spacing y-spacing row-wise cell-align-x cell-align-y
-		   pointer-documentation menu-type gesture))
+		   pointer-documentation menu-type gesture
+		   x-position y-position))
   (declare (dynamic-extent keys))
   (unless (zerop (length items))
     (apply #'frame-manager-menu-choose (frame-manager associated-window) items keys)))
@@ -352,7 +358,7 @@
 	   (frame-manager ,w) ,w #'with-menu-as-popup-body)))))
 
 (defmethod invoke-with-menu-as-popup 
-	   ((framem standard-frame-manager) (window t) continuation)
+	   ((framem standard-frame-manager) (sheet basic-sheet) continuation)
   (funcall continuation))
 
 ;; The drawer gets called with (stream presentation-type &rest drawer-args).
@@ -373,90 +379,93 @@
   (flet (#+Allegro
 	 (abort-menu-handler () 
 	   (return-from menu-choose-from-drawer nil)))
-   #+Allegro (declare (dynamic-extent #'abort-menu-handler))
-   (with-clim-state-reset (:all t
-			   :additional-bindings
-			     #+Allegro ((*click-outside-menu-handler* #'abort-menu-handler))
-			     #-Allegro nil)
-     ;; We could make the drawer a lexical closure, but that would then
-     ;; partially defeat the purpose of the uid and cache-value because we'd cons the closure
-     ;; whether or not we ran it.
-     (let* ((cached-output-history-info
+    #+Allegro (declare (dynamic-extent #'abort-menu-handler))
+    (with-clim-state-reset (:all t
+				 :additional-bindings
+				 #+Allegro ((*click-outside-menu-handler* #'abort-menu-handler))
+				 #-Allegro nil)
+      ;; We could make the drawer a lexical closure, but that would then
+      ;; partially defeat the purpose of the uid and cache-value
+      ;; because we'd cons the closure whether or not we ran it.
+      (let* ((cached-output-history-info
 	      (when cache
 		(if (typep cache 'static-menu)
 		    cache-value
-		    (get-from-output-history-cache unique-id id-test))))
-	    (cached-menu-contents
+		  (get-from-output-history-cache unique-id id-test))))
+	     (cached-menu-contents
 	      (when cached-output-history-info
 		(if (typep cache 'static-menu)
 		    cached-output-history-info
-		    (let* ((contents (pop cached-output-history-info))
-			   (value cached-output-history-info))
-		      (when (funcall cache-test value cache-value)
-			contents))))))
-       (cond (cached-menu-contents
-	      (stream-add-output-record menu cached-menu-contents))
-	     (t
-	      ;; "Draw" into deexposed menu for sizing only
-	      (with-output-recording-options (menu :draw nil :record t)
-		(let ((menu-contents
+		  (let* ((contents (pop cached-output-history-info))
+			 (value cached-output-history-info))
+		    (when (funcall cache-test value cache-value)
+		      contents))))))
+	(cond (cached-menu-contents
+	       (stream-add-output-record menu cached-menu-contents))
+	      (t
+	       ;; "Draw" into deexposed menu for sizing only
+	       (with-output-recording-options (menu :draw nil :record t)
+		 (let ((menu-contents
 			(with-new-output-record (menu)
 			  (setq default-presentation 
-				(funcall drawer menu presentation-type)))))
-		  (when cache
-		    (setf (get-from-output-history-cache unique-id id-test)
-			  (cons menu-contents cache-value))))))))
-     (size-frame-from-contents menu)
-     (unwind-protect
-	 (with-menu-as-popup (menu)
-	   (position-sheet-near-pointer
-	     (frame-top-level-sheet (pane-frame menu)) x-position y-position)
-	   (setf (window-visibility menu) t)
-	   ;;--- If we have windows with backing store then we dont get
-	   ;;--- exposure event and so nothing appears
-	   #+Allegro (replay (stream-output-history menu) menu)
-	   (stream-set-input-focus menu)
-	   (when default-presentation
-	     (with-bounding-rectangle* (left top right bottom) default-presentation
-	       (stream-set-pointer-position
-		 menu (floor (+ left right) 2) (floor (+ top bottom) 2))))
-	   ;; Pointer documentation usually adds no information, and slows things
-	   ;; down in a big way, which is why we defaultly disable it.
-	   (let ((*pointer-documentation-output* pointer-documentation))
-	     (with-input-context (presentation-type :override T)
-				 (object type gesture)
-		  (labels ((input-wait-test (menu)
-			     ;; Wake up if the menu becomes buried, or if highlighting
-			     ;; is needed.
-			     ;;--- This screws up in Allegro because querying the server
-			     ;;--- in the wait function screws event handling.
-			     (or #-Allegro 
-				 (and *abort-menus-when-buried*
+			    (funcall drawer menu presentation-type)))))
+		   (when cache
+		     (setf (get-from-output-history-cache unique-id id-test)
+		       (cons menu-contents cache-value))))))))
+      (size-frame-from-contents menu)
+      (unwind-protect
+	  (with-menu-as-popup (menu)
+	    (let ((top-level-sheet (frame-top-level-sheet (pane-frame menu))))
+	      (position-sheet-near-pointer
+	       top-level-sheet x-position y-position)
+	      (setf (sheet-pointer-cursor top-level-sheet) :menu
+		    (window-visibility menu) t))
+	    ;;--- If we have windows with backing store then we dont get
+	    ;;--- exposure event and so nothing appears
+	    #+Allegro (replay (stream-output-history menu) menu)
+	    (stream-set-input-focus menu)
+	    (when default-presentation
+	      (with-bounding-rectangle* (left top right bottom) default-presentation
+					(stream-set-pointer-position
+					 menu (floor (+ left right) 2) (floor (+ top bottom) 2))))
+	    ;; Pointer documentation usually adds no information, and slows things
+	    ;; down in a big way, which is why we defaultly disable it.
+	    (let ((*pointer-documentation-output* pointer-documentation))
+	      (with-input-context (presentation-type :override T)
+		(object type gesture)
+		(labels ((input-wait-test (menu)
+			   ;; Wake up if the menu becomes buried, or if highlighting
+			   ;; is needed.
+			   ;;--- This screws up in Allegro because querying the server
+			   ;;--- in the wait function screws event handling.
+			   (or #-Allegro 
+			       (and *abort-menus-when-buried*
+				    (not (window-visibility menu)))
+			       (pointer-motion-pending menu)))
+			 (input-wait-handler (menu)
+			   ;; Abort if the menu becomes buried
+			   #-Allegro
+			   (when (and *abort-menus-when-buried*
 				      (not (window-visibility menu)))
-				 (pointer-motion-pending menu)))
-			   (input-wait-handler (menu)
-			     ;; Abort if the menu becomes buried
-			     #-Allegro
-			     (when (and *abort-menus-when-buried*
-					(not (window-visibility menu)))
-			       (return-from menu-choose-from-drawer nil))
-			     ;; Take care of highlighting
-			     (highlight-presentation-of-context-type menu)))
-		    (declare (dynamic-extent #'input-wait-test #'input-wait-handler))
-		    ;; Await exposure before going any further, since X can get
-		    ;; to the call to READ-GESTURE before the menu is visible.
-		    (when *abort-menus-when-buried*
-		      #-Silica (wait-for-window-exposed menu))
-		    (with-mouse-grabbed-in-window (menu)
-		      (loop
-			(read-gesture :stream menu
-				      :input-wait-test #'input-wait-test
-				      :input-wait-handler #'input-wait-handler)
-			(beep menu))))
+			     (return-from menu-choose-from-drawer nil))
+			   ;; Take care of highlighting
+			   (highlight-presentation-of-context-type menu)))
+		  #-Allegro  
+		  (declare (dynamic-extent #'input-wait-test #'input-wait-handler))
+		  ;; Await exposure before going any further, since X can get
+		  ;; to the call to READ-GESTURE before the menu is visible.
+		  (when *abort-menus-when-buried*
+		    #-Silica (wait-for-window-exposed menu))
+		  (with-mouse-grabbed-in-window (menu)
+		    (loop
+		      (read-gesture :stream menu
+				    :input-wait-test #'input-wait-test
+				    :input-wait-handler #'input-wait-handler)
+		      (beep menu))))
 		(t (values object gesture)))))
-       (unless leave-menu-visible
-	 (setf (window-visibility menu) nil))
-       (force-output menu)))))
+	(unless leave-menu-visible
+	  (setf (window-visibility menu) nil))
+	(force-output menu)))))
 
 (defun hierarchical-menu-choose (items
 				 &key (associated-window
@@ -633,16 +642,23 @@
   ((type :initarg :type)
    (scroll-bars :initarg :scroll-bars) 
    (borders :initarg :borders)
+   (background :initarg :background)
+   (foreground :initarg :foreground)
+   (text-style :initarg :text-style)
    stream
    pane)
   (:command-definer nil)
   (:menu-bar nil)
   (:pane
-   (with-slots (pane stream type scroll-bars borders) *application-frame*
+   (with-slots (pane stream type scroll-bars borders background
+		foreground text-style) *application-frame*
      (multiple-value-setq (pane stream)
        (make-clim-stream-pane
 	:type type
 	:scroll-bars scroll-bars
+	:background background
+	:foreground foreground
+	:text-style text-style
 	:borders borders))
      pane)))
 
@@ -651,8 +667,9 @@
 				(right nil rightp)
 				(bottom nil bottomp) 
 				width height
-				(foreground +black+) (background +white+)
-				text-style default-text-style
+				foreground 
+				background
+				text-style
 				(vertical-spacing 2)
 				(end-of-line-action :allow)
 				(end-of-page-action :allow)
@@ -681,6 +698,9 @@
 					:scroll-bars scroll-bars
 					:borders  borders
 					:input-buffer input-buffer
+					:background background
+					:foreground foreground
+					:text-style text-style
 					:frame-manager
 					(etypecase parent
 					  ((or pane standard-application-frame) 
@@ -688,11 +708,7 @@
 					  (frame-manager parent)
 					  (null (find-frame-manager)))))
 	 (stream (slot-value frame 'stream)))
-    (setf (medium-foreground stream) foreground
-	  (medium-background stream) background
-	  (medium-default-text-style stream) (or default-text-style *default-text-style*)
-	  (medium-text-style stream) (or text-style *default-text-style*)
-	  (stream-vertical-spacing stream) vertical-spacing
+    (setf (stream-vertical-spacing stream) vertical-spacing
 	  (stream-end-of-line-action stream) end-of-line-action
 	  (stream-end-of-page-action stream) end-of-page-action
 	  (stream-recording-p stream) record
diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp
index ebc449b3552fc5a38593581339e703e71026b490..e0ae59af96630510979cc7c36f7eaf1579de5062 100644
--- a/clim/noting-progress.lisp
+++ b/clim/noting-progress.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: noting-progress.lisp,v 1.7 1993/07/22 15:38:05 cer Exp $
+;; $fiHeader: noting-progress.lisp,v 1.8 1993/08/12 16:03:09 cer Exp $
 
 (in-package :clim-internals)
 
@@ -105,7 +105,7 @@
 	 (dolist (,var ,list-var)
 	   ,@body
 	   (incf ,count-var)
-	   (note-progress ,count-var ,total-var))))))
+	   (note-progress ,count-var ,total-var ,note-var))))))
 
 (defmacro dotimes-noting-progress ((var countform name
 				    &optional stream (note-var '*current-progress-note*))
@@ -117,7 +117,7 @@
 	   ,@body
 	   ;; We want the progress bar to advance after the first iteration
 	   ;; even though DOTIMES is zero-based, so add one to the numerator.
-	   (note-progress (1+ ,var) ,count-var))))))
+	   (note-progress (1+ ,var) ,count-var ,note-var))))))
 
 (defmethod frame-manager-display-progress-note
     ((framem standard-frame-manager) (note progress-note))
@@ -133,3 +133,4 @@
 (defmethod frame-manager-display-progress-note
     ((framem null) (note progress-note))
   nil)
+
diff --git a/clim/panes.lisp b/clim/panes.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..d899f1bee5495ef7073fd6f7a7039e24fbfca2db
--- /dev/null
+++ b/clim/panes.lisp
@@ -0,0 +1,155 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader$
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1991, 1992 Franz, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+(defun compute-pane-constructor-code (panes)
+  (check-type panes list)
+  `(list ,@(mapcar #'(lambda (pane-spec)
+		       (destructuring-bind (name code &rest options) pane-spec
+			 (setq code (canonicalize-pane-spec name code options))
+			 `(list ',name
+				#'(lambda (frame framem)
+				    (with-look-and-feel-realization (framem frame)
+				      ,code)))))
+		   panes)))
+   
+(defun canonicalize-pane-spec (name code rest)
+  (cond ((symbolp code)
+	 (unless (getf rest :name)
+	   (setf (getf rest :name) `',name))
+	 (apply #'find-pane-class-constructor code rest))
+	((null rest) code)
+	(t
+	 (error "Invalid pane specification: ~S"
+		(list* name code rest)))))
+
+(defmethod find-pane-class-constructor ((type t) &rest options)
+  (declare (dynamic-extent options))
+  (error "Unknown pane type ~S with options ~S" type options))
+
+
+;;--- Extend this to default the options from the lambda list
+(defmacro define-pane-type (type lambda-list &body body)
+  `(defmethod find-pane-class-constructor ((type (eql ',type)) ,@lambda-list)
+     ,@body))
+
+(define-pane-type :title (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-clim-stream-pane
+     :type 'title-pane
+     ,@options
+     :display-function 'display-title
+     :display-after-commands nil
+     :text-style (parse-text-style '(:sans-serif :bold :large))
+     :scroll-bars nil
+     :width :compute :height :compute
+     :max-height :compute
+     :end-of-page-action :allow 
+     :end-of-line-action :allow))
+
+(define-pane-type :command-menu (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-clim-stream-pane
+     :type 'command-menu-pane
+     ,@options
+     :display-function `(display-command-menu :command-table ,(frame-command-table frame))
+     :incremental-redisplay t
+     :display-after-commands t
+     :text-style *command-table-menu-text-style*
+     :scroll-bars nil
+     :width :compute :height :compute
+     :end-of-page-action :allow 
+     :end-of-line-action :allow))
+
+
+(define-pane-type :interactor (&rest options &key (scroll-bars :vertical))
+  (declare (non-dynamic-extent options))
+  `(make-clim-interactor-pane
+     ,@options
+     :scroll-bars ,scroll-bars))
+
+(define-pane-type :application (&rest options &key (scroll-bars :both))
+  (declare (non-dynamic-extent options))
+  `(make-clim-application-pane 
+     ,@options
+     :scroll-bars ,scroll-bars))
+
+(define-pane-type :accept-values (&rest options &key (scroll-bars :vertical))
+  (declare (non-dynamic-extent options))
+  `(make-clim-stream-pane 
+     :type 'accept-values-pane
+     ,@options
+     :display-after-commands :no-clear
+     :scroll-bars ,scroll-bars
+     :width :compute :height :compute
+     :end-of-page-action :allow
+     :end-of-line-action :allow))
+
+(define-pane-type :pointer-documentation (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-clim-stream-pane
+     :type 'pointer-documentation-pane
+     ,@options
+     :display-after-commands nil
+     :text-style (parse-text-style '(:sans-serif :bold :normal))
+     :scroll-bars nil
+     :end-of-page-action :allow
+     :end-of-line-action :allow))
+
+(define-pane-type scroll-bar (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'scroll-bar ,@options))
+
+(define-pane-type slider (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'slider ,@options))
+
+(define-pane-type push-button (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'push-button ,@options))
+
+(define-pane-type label-pane (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'label-pane ,@options))
+
+(define-pane-type text-field (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'text-field ,@options))
+
+(define-pane-type text-editor (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'text-editor ,@options))
+
+(define-pane-type toggle-button (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'toggle-button ,@options))
+
+(define-pane-type radio-box (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'radio-box ,@options))
+
+(define-pane-type check-box (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'check-box ,@options))
+
+(define-pane-type list-pane (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'list-pane ,@options))
+
+(define-pane-type option-pane (&rest options)
+  (declare (non-dynamic-extent options))
+  `(make-pane 'option-pane ,@options))
+
+(define-pane-type :menu-bar (&rest options &key command-table)
+  (declare (non-dynamic-extent options))
+  (with-keywords-removed (options options '(:command-table))
+    `(make-pane 'menu-bar 
+		,@options
+		:command-table ,(or command-table
+				    `(frame-command-table frame)))))
diff --git a/clim/presentations.lisp b/clim/presentations.lisp
index d535a71bf330acb72d55413c1ac385d6f60d7f98..8ff76bbe354263ff89f5eb3a96b4ebb944f8eae7 100644
--- a/clim/presentations.lisp
+++ b/clim/presentations.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: presentations.lisp,v 1.20 92/12/03 10:27:35 cer Exp $
+;; $fiHeader: presentations.lisp,v 1.21 1993/06/21 20:50:12 cer Exp $
 
 (in-package :clim-internals)
 
@@ -182,7 +182,7 @@
 		     ;; This is more like the pointer moving than anything else.
 		     (/= old-state
 			 (setf old-state (window-modifier-state stream)))))))
-	  (declare (dynamic-extent #'pointer-motion-pending))
+	  #-Allegro (declare (dynamic-extent #'pointer-motion-pending))
 	  (let ((*input-wait-handler* #'highlight-presentation-of-context-type)
 		(*input-wait-test* #'pointer-motion-pending)
 		(*pointer-button-press-handler* #'input-context-button-press-handler))
diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp
index 445a0bab42e154a5529a67d08d2bb460e77dd994..2bafd92fa48d044304671ae27b008886c2d6fd1b 100644
--- a/clim/recording-protocol.lisp
+++ b/clim/recording-protocol.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: recording-protocol.lisp,v 1.37 1993/10/25 16:15:37 cer Exp $
+;; $fiHeader: recording-protocol.lisp,v 1.38 1993/10/26 03:21:36 colin Exp $
 
 (in-package :clim-internals)
 
@@ -969,31 +969,33 @@
 	  (setf (svref elements 1) child))))))
 
 (defmethod delete-output-record 
-	   (child (record standard-sequence-output-record) &optional (errorp t))
-  (with-slots (elements fill-pointer) record
-    (typecase elements
-      (null (error "The output record ~S was not found in ~S" child record))
-      (array
-	(let ((index (position child elements :end fill-pointer)))
-	  (cond (index
-		 (let ((new-fp (the fixnum (1- fill-pointer)))
-		       (vector elements))
-		   (declare (type simple-vector vector) (fixnum new-fp))
-		   (unless (= (the fixnum index) new-fp)
-		     ;; Shift the whole vector downward
-		     (do ((i (the fixnum index) (1+ i)))
-			 ((= i new-fp))
-		       (declare (type fixnum i)
-				(optimize (speed 3) (safety 0)))
-		       (setf (svref vector i) (svref vector (1+ i)))))
-		   (setf fill-pointer new-fp)))
-		(errorp
-		 (error "The output record ~S was not found in ~S" child record)))))
-      ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD
-      (otherwise
-	(unless (eq elements child)
-	  (error "The output record ~S was not found in ~S" child record))
-	(setf elements nil))))
+    (child (record standard-sequence-output-record) &optional (errorp t))
+  (flet ((not-found ()
+	   (when errorp
+	     (error "The output record ~S was not found in ~S" child record))))
+    (with-slots (elements fill-pointer) record
+      (typecase elements
+	(null (not-found))
+	(array
+	 (let ((index (position child elements :end fill-pointer)))
+	   (if index
+	       (let ((new-fp (the fixnum (1- fill-pointer)))
+			(vector elements))
+		 (declare (type simple-vector vector) (fixnum new-fp))
+		 (unless (= (the fixnum index) new-fp)
+		   ;; Shift the whole vector downward
+		   (do ((i (the fixnum index) (1+ i)))
+		       ((= i new-fp))
+		     (declare (type fixnum i)
+			      (optimize (speed 3) (safety 0)))
+		     (setf (svref vector i) (svref vector (1+ i)))))
+		 (setf fill-pointer new-fp))
+	     (not-found))))
+	;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD
+	(otherwise
+	 (if (eq elements child)
+	     (setf elements nil)
+	   (not-found))))))
   t)
 
 (defmethod map-over-output-records-overlapping-region
@@ -1151,7 +1153,7 @@
     (with-slots (output-record text-output-record record-p) stream
       (when (or output-record text-output-record)
 	(setq region (normalize-replay-region region stream))
-	(clim-utils::with-drawing-options (stream :clipping-region region)
+	(with-drawing-options (stream :clipping-region region)
 	  (letf-globally ((record-p nil))
 	    (when output-record
 	      (replay output-record stream region))
diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp
index 687e15cfe5a02adba466db977faab75598ba8ab7..62d052214f24ac9e39ae240c2d839958eeca376e 100644
--- a/clim/standard-types.lisp
+++ b/clim/standard-types.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: standard-types.lisp,v 1.30 1993/09/17 19:05:26 cer Exp $
+;; $fiHeader: standard-types.lisp,v 1.31 1993/12/07 05:33:44 colin Exp $
 
 (in-package :clim-internals)
 
@@ -1459,7 +1459,7 @@
   (let ((*read-recursive-objects* nil))
     (with-temporary-string (string)
       (with-activation-gestures ('(:end))
-	(read-recursive stream string nil :auto-activate auto-activate))
+	(read-recursive stream string nil auto-activate))
       (when (input-editing-stream-p stream)
 	(rescan-if-necessary stream))
       (multiple-value-bind (expression index)
@@ -1515,31 +1515,25 @@
 			      (#\| . #\|)))
 
 ;;; Ignore issues like comments for now.
-(defun read-recursive (stream input-buffer desired-delimiter &key auto-activate)
+
+(defun read-recursive (stream input-buffer desired-delimiter auto-activate)
   (let ((top-level (not desired-delimiter)))
-    (loop
-      (with-input-context ('expression)
-	(object type)
-	(let ((char (read-char stream nil :eof)))
-	  (cond ((eq char :eof)
-		 (return))
+    (flet ((read-recursive-1 ()
+	     (let ((char (read-char stream nil :eof)))
+	       (cond 
+		((eq char :eof)
+		 (return-from read-recursive))
 		
 		;; ignore leading space
 		((and (zerop (fill-pointer input-buffer))
 		      (whitespace-char-p char)))
-
-		;; terminate with white space when at top level with auto-activate
-		((and top-level
-		      auto-activate
-		      (whitespace-char-p char))
-		 (unread-char char stream)
-		 (return))
 		
-		;; ALWAYS terminate with delimiter or activation gesture
+		;; ALWAYS terminate with activation gesture or delimiter
+		;; gesture at top level
 		((or (activation-gesture-p char)
-		     (delimiter-gesture-p char))
+		     (and top-level (delimiter-gesture-p char)))
 		 (unread-char char stream)
-		 (return))
+		 (return-from read-recursive))
 		
 		((not (or (ordinary-char-p char)
 			  (diacritic-char-p char)))
@@ -1556,27 +1550,34 @@
 		 
 		 (if (and desired-delimiter 
 			  (char-equal char desired-delimiter))
-		     (return)
+		     (return-from read-recursive)
 		   (let ((other-delimiter (cdr (assoc char *char-associations*))))
 		     (when other-delimiter
 		       (read-recursive stream input-buffer other-delimiter
-				       :auto-activate auto-activate)
+				       auto-activate)
 		       (when (and top-level
 				  auto-activate)
-			 (return))))))))
-	(t
-	 ;; Put this thing into the input editor's buffer
-	 (when (input-editing-stream-p stream)
-	   (presentation-replace-input stream object type +textual-view+))
-	 ;; And into the buffer we ourselves are maintaining
-	 (let ((n (length *read-recursive-objects*)))
-	   (setq *read-recursive-objects* (nconc *read-recursive-objects* (list object)))
-	   (doseq (char (format nil " #.(~S ~D ~S) "
-				'nth n '*read-recursive-objects*))
-		  (vector-push-extend char input-buffer)))
-	 (when (and top-level
-		    auto-activate)
-	   (return)))))))
+			 (return-from read-recursive))))))))))
+      (if top-level
+	  (loop
+	    (read-recursive-1))
+	(loop
+	  (with-input-context ('expression)
+	    (object type)
+	    (read-recursive-1)
+	    (t
+	     ;; Put this thing into the input editor's buffer
+	     (when (input-editing-stream-p stream)
+	       (presentation-replace-input stream object
+					   type +textual-view+))
+	     ;; And into the buffer we ourselves are maintaining
+	     (let ((n (length *read-recursive-objects*)))
+	       (setq *read-recursive-objects*
+		 (nconc *read-recursive-objects* (list object)))
+	       (doseq (char (format nil " #.(~S ~D ~S) "
+				    'nth n '*read-recursive-objects*))
+		      (vector-push-extend char input-buffer))))))))))
+
 
 (defun print-recursive (object stream
 			&key (make-presentation t)
diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp
index 845212ec66a6be78f054888fe1e6a0d4e72d73e3..380d32d859623cdc3cff76ccb6d78ae1409717ff 100644
--- a/clim/text-formatting.lisp
+++ b/clim/text-formatting.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-formatting.lisp,v 1.13 1993/07/27 01:41:30 colin Exp $
+;; $fiHeader: text-formatting.lisp,v 1.14 1993/10/26 03:21:42 colin Exp $
 
 (in-package :clim-internals)
 
@@ -201,7 +201,8 @@
       (setf (slot-value filling-stream 'prefix) prefix)
       (setf (slot-value filling-stream 'prefix-width) prefix-width)
       (setf (fill-pointer (slot-value filling-stream 'buffer)) 0)
-      (setf (slot-value filling-stream 'current-width) 0)))
+      (setf (slot-value filling-stream 'current-width)
+	(stream-cursor-position stream))))
 
 (defun invoke-filling-output (stream continuation
 			      &key (fill-width '(80 :character))
diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp
index 8255971451b532be35f408b3acab26657b11b749..b0a3c3a652957d513bb505f3cccb3ede1ab7ed14 100644
--- a/clim/tracking-pointer.lisp
+++ b/clim/tracking-pointer.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: tracking-pointer.lisp,v 1.17 93/05/05 01:39:05 cer Exp $
+;; $fiHeader: tracking-pointer.lisp,v 1.18 1993/07/27 01:41:43 colin Exp $
 
 (in-package :clim-internals)
 
@@ -195,7 +195,7 @@
 			   (multiple-value-setq (moved-p last-window last-x last-y)
 			     (pointer-state-changed pointer last-window last-x last-y))
 			   (and moved-p last-window))))
-		  (declare (dynamic-extent #'pointer-motion-pending))
+		  #-Allegro (declare (dynamic-extent #'pointer-motion-pending))
 		  ;; It's OK to do the input wait on STREAM instead of on
 		  ;; CURRENT-WINDOW, because multiple-window mode only works
 		  ;; when all the windows share the same I/O buffer.  Same
@@ -352,45 +352,55 @@
 (defun pointer-input-rectangle* (&key left top right bottom
 				      (stream *standard-input*)
 				      (pointer (stream-primary-pointer stream))
-				      multiple-window)
+				      multiple-window
+				      finish-on-release)
   (let ((rectangle-drawn nil))
-    (with-output-recording-options (stream :draw t :record nil)
-      (tracking-pointer (stream :pointer pointer :multiple-window multiple-window)
-	(:pointer-motion (window x y)
-	 (when rectangle-drawn
-	   (draw-rectangle* stream left top right bottom
-			    :filled nil :ink +flipping-ink+)
-	   (setq rectangle-drawn nil))
-	 (when left
-	   (when (eq window stream)
-	     (setq right x bottom y)
-	     (draw-rectangle* stream left top right bottom
-			      :filled nil :ink +flipping-ink+)
-	     (setq rectangle-drawn t))))
-	(:pointer-button-press (event)
-	 (if (eq (event-sheet event) stream)
-	     (cond ((null left)
-		    (setq left (pointer-event-x event))
-		    (setq top (pointer-event-y event)))
-		   (t
-		    (when rectangle-drawn
-		      (draw-rectangle* stream left top right bottom
-				       :filled nil :ink +flipping-ink+)
-		      (setq rectangle-drawn nil))
-		    (return-from pointer-input-rectangle*
-		      (values left top
-			      (pointer-event-x event) (pointer-event-y event)))))
-	     (beep stream)))))))
+    (flet ((finish (event)
+	     (when rectangle-drawn
+	       (draw-rectangle* stream left top right bottom
+				:filled nil :ink +flipping-ink+)
+	       (setq rectangle-drawn nil))
+	     (return-from pointer-input-rectangle*
+	       (values left top
+		       (pointer-event-x event) (pointer-event-y event)))))
+      (with-output-recording-options (stream :draw t :record nil)
+	(tracking-pointer (stream :pointer pointer :multiple-window multiple-window)
+	  (:pointer-motion (window x y)
+	    (when rectangle-drawn
+	      (draw-rectangle* stream left top right bottom
+			       :filled nil :ink +flipping-ink+)
+	      (setq rectangle-drawn nil))
+	    (when left
+	      (when (eq window stream)
+		(setq right x bottom y)
+		(draw-rectangle* stream left top right bottom
+				 :filled nil :ink +flipping-ink+)
+		(setq rectangle-drawn t))))
+	  (:pointer-button-press (event)
+	    (if (eq (event-sheet event) stream)
+		(if (null left)
+		    (setq left (pointer-event-x event)
+			  top (pointer-event-y event))
+		  (when (not finish-on-release)
+		    (finish event)))
+	      (beep stream)))
+	  (:pointer-button-release (event)
+	    (if (eq (event-sheet event) stream)
+		(when (and left
+			   finish-on-release)
+		  (finish event))
+	      (beep stream))))))))
 
-(defun pointer-input-rectangle (&key rectangle
-				     (stream *standard-input*)
-				     (pointer (stream-primary-pointer stream)))
+(defun pointer-input-rectangle (&rest keys &key rectangle &allow-other-keys)
+  (declare (dynamic-extent keys))
   (let (left top right bottom)
     (when rectangle
       (multiple-value-setq (left top right bottom)
 	(bounding-rectangle* rectangle)))
     (multiple-value-call #'make-bounding-rectangle
-      (pointer-input-rectangle* :left left :top top
-				:right right :bottom bottom
-				:stream stream
-				:pointer pointer))))
+      (with-keywords-removed (keys keys '(:rectangle))
+	(apply #'pointer-input-rectangle*
+	       :left left :top top
+	       :right right :bottom bottom
+	       keys)))))
+
diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp
index cc649682aa5582102d910990df985c39b7267839..721cfe8361688745d9bd3d2cf724a7c6bf215a78 100644
--- a/clim/view-defs.lisp
+++ b/clim/view-defs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: view-defs.lisp,v 1.14 1993/09/17 19:05:29 cer Exp $
+;; $fiHeader: view-defs.lisp,v 1.15 1993/10/25 16:15:39 cer Exp $
 
 (in-package :clim-internals)
 
@@ -93,6 +93,7 @@
 
 
 (defmacro make-pane-from-view (class view ignore &body initargs)
-  `(apply #'make-pane ,class (append (remove-keywords (view-gadget-initargs ,view) ,ignore)
-				     (list ,@initargs))))
+  `(apply #'make-pane ,class
+	  (append (remove-keywords (view-gadget-initargs ,view) ,ignore)
+		  (list ,@initargs))))
 
diff --git a/demo/README b/demo/README
new file mode 100644
index 0000000000000000000000000000000000000000..e479dd93f99428ba2bf1b0371acfc5f9c18b7a50
--- /dev/null
+++ b/demo/README
@@ -0,0 +1,15 @@
+
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA  All rights reserved.
+
+;; $fiHeader$
+
+To run the CLIM demos.
+
+1. Load the demos with:
+
+	(require :clim-demoxm) for Motif 
+	(require :clim-demool) for OpenLook
+
+2. Evaluate (clim-demo:start-demo)
+
diff --git a/demo/default-frame-top-level.lisp b/demo/default-frame-top-level.lisp
index f75344723c482730fa6348e25c00d79042f94a66..5d743eb46218be2c5b94a378e53973ea750dfcb4 100644
--- a/demo/default-frame-top-level.lisp
+++ b/demo/default-frame-top-level.lisp
@@ -32,51 +32,53 @@
     (enable-frame frame))
   (loop
     (let* ((*standard-output*
-	     (or (frame-standard-output frame) *standard-output*))
+	    (or (frame-standard-output frame) *standard-output*))
 	   (*standard-input* 
-	     (or (frame-standard-input frame) *standard-output*))
+	    (or (frame-standard-input frame) *standard-output*))
 	   (*query-io* 
-	     (or (frame-query-io frame) *standard-input*))
+	    (or (frame-query-io frame) *standard-input*))
 	   (*error-output* 
-	     (or (frame-error-output frame) *standard-output*))
+	    (or (frame-error-output frame) *standard-output*))
 	   (*pointer-documentation-output*
-	     (frame-pointer-documentation-output frame))
+	    (frame-pointer-documentation-output frame))
 	   (interactor
-	     (not (null (find-frame-pane-of-type frame 'interactor-pane))))
+	    (not (null (find-frame-pane-of-type frame 'interactor-pane))))
 	   (*command-parser*
-	     (or command-parser
-		 (if interactor
-		     #'command-line-command-parser
-		     #'menu-command-parser)))
+	    (or command-parser
+		(if interactor
+		    #'command-line-command-parser
+		  #'menu-command-parser)))
 	   (*command-unparser*
-	     (or command-unparser 
-		 #'command-line-command-unparser))
+	    (or command-unparser 
+		#'command-line-command-unparser))
 	   (*partial-command-parser* 
-	     (or partial-command-parser
-		 (if interactor
-		     #'command-line-read-remaining-arguments-for-partial-command
-		     #'menu-read-remaining-arguments-for-partial-command)))
+	    (or partial-command-parser
+		(if interactor
+		    #'command-line-read-remaining-arguments-for-partial-command
+		  #'menu-read-remaining-arguments-for-partial-command)))
 	   (command-stream
-	     ;;--- We have to ask the frame since we do not want to
-	     ;;--- just pick up a stream from the dynamic environment
-	     (let ((si (or (frame-standard-input frame)
-			   (frame-standard-output frame))))
-	       (typecase si
-		 (output-protocol-mixin si)
-		 (t (frame-top-level-sheet frame))))))
+	    ;;--- We have to ask the frame since we do not want to
+	    ;;--- just pick up a stream from the dynamic environment
+	    (let ((si (or (frame-standard-input frame)
+			  (frame-standard-output frame))))
+	      (typecase si
+		(output-protocol-mixin si)
+		(t (frame-top-level-sheet frame))))))
       ;; The read-eval-print loop for applications...
-      (loop
-	;; Redisplay all the panes
-	(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
-	  (redisplay-frame-panes frame)
-	  (when interactor
-	    (fresh-line *standard-input*)
-	    (if (stringp prompt)
-		(write-string prompt *standard-input*)
-		(funcall prompt *standard-input* frame)))
-	  (let ((command (read-frame-command frame :stream command-stream)))
+      (letf-globally (((frame-actual-pointer-documentation-pane frame)
+		       *pointer-documentation-output*))
+	(loop
+	  ;; Redisplay all the panes
+	  (catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
+	    (redisplay-frame-panes frame)
 	    (when interactor
-	      (terpri *standard-input*))
-	    ;; Need this check in case the user aborted out of a command menu
-	    (when command
-	      (execute-frame-command frame command))))))))
+	      (fresh-line *standard-input*)
+	      (if (stringp prompt)
+		  (write-string prompt *standard-input*)
+		(funcall prompt *standard-input* frame)))
+	    (let ((command (read-frame-command frame :stream command-stream)))
+	      (when interactor
+		(terpri *standard-input*))
+	      ;; Need this check in case the user aborted out of a command menu
+	      (when command
+		(execute-frame-command frame command)))))))))
diff --git a/demo/demo-last.lisp b/demo/demo-last.lisp
index 9bb1d6991d4108fb59f22c0e7e24d7bdc80e0e9f..c94ec654d172e9e81986337e6964f22658787c06 100644
--- a/demo/demo-last.lisp
+++ b/demo/demo-last.lisp
@@ -20,12 +20,16 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader$
+;; $fiHeader: demo-last.lisp,v 1.1 1993/08/12 16:03:34 cer Exp $
 
 
 (in-package :user)
 
+(provide :climdemo)
+
 (cond ((excl::featurep :clim-motif)
+       (provide :climdemoxm)
        (load "clim2demoxm-preload.fasl" :if-does-not-exist nil))
       ((excl::featurep :clim-openlook)
+       (provide :climdemool)
        (load "clim2demool-preload.fasl" :if-does-not-exist nil)))
diff --git a/demo/plot.lisp b/demo/plot.lisp
index 32d35e9fb55e272e152a108a8dab16e4da657d42..42638102e9a2931fb7e5abb969825a4379412f45 100644
--- a/demo/plot.lisp
+++ b/demo/plot.lisp
@@ -1,33 +1,19 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
-;; $fiHeader: plot.lisp,v 1.30 1993/09/22 21:21:17 cer Exp $
+;; $fiHeader: plot.lisp,v 1.31 1993/10/25 16:15:56 cer Exp $
 
 (in-package :clim-demo)
 
-
 ;;; CLIM based plotting package
 
-(defmacro plotting-data ((stream &rest  options) &body body)
-  ;; For each X value we want to specify the Y values
-  ;; Specify labels for each X value
-  ;; Specify label for each set of Y values
-  ;; Specify the size of the graph we want draw.
-  ;; Range of values for the axiss
-  (let ((point-plotting-continuation (gensym))
-	(plot-data-continuation (gensym)))
-    `(flet ((plotting-data-body (,point-plotting-continuation ,plot-data-continuation) 
-	      ;; Perhaps we can also have a way of
-	      ;; specify all the points in one go
-	      (flet ((plot-point (x &rest ys)
-		       (declare (dynamic-extent ys))
-		       (apply ,point-plotting-continuation x ys))
-		     (plot-data (array)
-		       (funcall ,plot-data-continuation array)))
-		(declare (dynamic-extent #'plot-point #'plot-data))
-		#'plot-point #'plot-data
-		,@body)))
-       (declare (dynamic-extent #'plotting-data-body))
-       (invoke-plotting-data ,stream #'plotting-data-body ,@options))))
-
+(defmacro plotting-points ((stream &rest options) &body body)
+  (let ((points (gensym)))
+    `(let ((,points nil))
+       (flet ((plot-point (x &rest ys)
+		(declare (dynamic-extent ys))
+		(push (list* x ys) ,points)))
+	 ,@body)
+       (plot-points ,stream ,points ,@options))))
+  
 ;; We should make presentations of these types
 
 (define-presentation-type graph-plot ())
@@ -116,62 +102,52 @@
 
 (define-presentation-type graph-axis ())
 
-(defun invoke-plotting-data (stream continuation 
-			     &key x-labels y-labels 
-				  y-labelling
-				  x-min y-min
-				  x-max y-max 
-				  width height
-				  (type :plot))
-  (let ((points nil))
-    (flet ((point-collector (x &rest ys)
-	     (declare (non-dynamic-extent ys))
-	     (push (list* x ys) points))
-	   (plot-data-collector (data)
-	     (setq points data)))
-      (declare (dynamic-extent #'point-collector #'plot-data-collector))
-      (funcall continuation #'point-collector #'plot-data-collector))
-
-    (etypecase points
-      ((array t (* *)) nil)
-      (list
-       (setq points (make-array (list (length points) (length (car points)))
-				:initial-contents (nreverse points)))))
-
-    (multiple-value-setq  (width height)
-      (default-width-and-height stream type points width height))
+(defun plot-points (stream points &key x-labels y-labels 
+				       y-labelling
+				       x-min y-min
+				       x-max y-max 
+				       width height
+				       (type :plot))
+  (etypecase points
+    ((array t (* *)) nil)
+    (list
+     (setq points (make-array (list (length points) (length (car points)))
+			      :initial-contents (nreverse points)))))
+
+  (multiple-value-setq  (width height)
+    (default-width-and-height stream type points width height))
     
-    (multiple-value-setq (x-min y-min x-max y-max y-labelling)
-      (default-graph-axis type points x-min y-min x-max y-max y-labelling))
-
-    (let ((transform
-	   (and (not (eq type :pie))
-		(let ((scaling-transform
-		       (make-scaling-transformation
-			(/ width (- x-max x-min))
-			(/ height (- y-max y-min)))))
-		  (multiple-value-bind (ox oy)
-		      (transform-position scaling-transform x-min y-min)
-		    (compose-transformations
-		     (make-translation-transformation (- ox) (- oy))
-		     scaling-transform))))))
-      (with-output-as-presentation (stream nil 'graph-plot :single-box :position)
-	(formatting-item-list (stream :n-columns 2)
-	  (updating-output (stream :unique-id :data-and-axis)
-	    (formatting-cell (stream)
-	      (with-room-for-graphics (stream)
-		(draw-axis stream type
-			   width height
-			   x-min y-min x-max y-max
-			   x-labels y-labels
-			   points transform
-			   y-labelling)
-		(draw-data stream type
-			   width height x-min y-min x-max
-			   y-max points transform))))
-	  (updating-output (stream :unique-id :caption)
-	    (formatting-cell (stream)
-	      (draw-caption stream type y-labels))))))))
+  (multiple-value-setq (x-min y-min x-max y-max y-labelling)
+    (default-graph-axis type points x-min y-min x-max y-max y-labelling))
+
+  (let ((transform
+	 (and (not (eq type :pie))
+	      (let ((scaling-transform
+		     (make-scaling-transformation
+		      (/ width (- x-max x-min))
+		      (/ height (- y-max y-min)))))
+		(multiple-value-bind (ox oy)
+		    (transform-position scaling-transform x-min y-min)
+		  (compose-transformations
+		   (make-translation-transformation (- ox) (- oy))
+		   scaling-transform))))))
+    (with-output-as-presentation (stream nil 'graph-plot :single-box :position)
+      (formatting-item-list (stream :n-columns 2)
+	(updating-output (stream :unique-id :data-and-axis)
+	  (formatting-cell (stream)
+	    (with-room-for-graphics (stream)
+	      (draw-axis stream type
+			 width height
+			 x-min y-min x-max y-max
+			 x-labels y-labels
+			 points transform
+			 y-labelling)
+	      (draw-data stream type
+			 width height x-min y-min x-max
+			 y-max points transform))))
+	(updating-output (stream :unique-id :caption)
+	  (formatting-cell (stream)
+	    (draw-caption stream type y-labels)))))))
    
 (defun draw-caption (stream type y-labels)
   (updating-output (stream :unique-id 'captions
@@ -671,10 +647,13 @@
 (define-plot-demo-command (com-edit-data-point :name t :menu t)
     ((point 'data-point :gesture :select))
   (with-application-frame (frame)
-    (destructuring-bind (i j) point
-      (setf (aref (slot-value frame 'plot-data) i j)
-	    (accept 'number
-		    :default (aref (slot-value frame 'plot-data) i j))))))
+    (accepting-values (*standard-input* :own-window t)
+      (destructuring-bind (i j) point
+	(setf (aref (slot-value frame 'plot-data) i j)
+	  (accept 'number
+		  :stream *standard-input*
+		  :default (aref (slot-value frame 'plot-data) i
+				 j)))))))
 
 (define-plot-demo-command (com-quit-plot-demo :menu "Quit" :name "Quit") () 
   (frame-exit *application-frame*))
@@ -682,12 +661,12 @@
 (defmethod display-graph ((frame plot-demo) stream &key &allow-other-keys)
   (with-slots (y-labelling graph-type plot-data x-labels y-labels
 			   x-min y-min x-max y-max) frame
-    (plotting-data (stream :y-labelling y-labelling 
-			   :x-labels x-labels :y-labels y-labels
-			   :x-min x-min :y-min y-min 
-			   :x-max x-max :y-max y-max
-			   :type graph-type)
-		   (plot-data plot-data))))
+    (plot-points stream plot-data
+		 :y-labelling y-labelling 
+		 :x-labels x-labels :y-labels y-labels
+		 :x-min x-min :y-min y-min 
+		 :x-max x-max :y-max y-max
+		 :type graph-type)))
 
 (define-plot-demo-command com-describe-graph-line 
     ((line 'graph-line :gesture :describe))
diff --git a/homegrown/db-button.lisp b/homegrown/db-button.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..56a346958cf5c9b720485ecf16d8532b4c00b02b
--- /dev/null
+++ b/homegrown/db-button.lisp
@@ -0,0 +1,1039 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-button.lisp,v 1.20 1993/07/27 01:50:27 colin Exp $
+
+"Copyright (c) 1991, 1992 by Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1990, 1991 International Lisp Associates."
+
+(in-package :silica)
+
+
+#|
+
+To Do:
+
+Split toggle-button into check-box-button and radio-button classes that share a
+toggle button base. This way they can share the draw code.
+
+|#
+
+
+;;; Shared button functionality
+
+(defclass button-pane-mixin 
+	  (space-requirement-mixin
+	   leaf-pane)
+    ;; ARMED has three states:
+    ;;  NIL ==> the button is not armed
+    ;;  T   ==> the button is armed, waiting for a pointer button press
+    ;;  :ACTIVE ==> the button is armed, waiting for a pointer button release
+    ((armed :initform nil))
+  (:default-initargs :pointer-cursor :button))
+
+;; General highlight-by-inverting method
+(defmethod highlight-button ((pane button-pane-mixin) medium)
+  (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+    (draw-rectangle* medium left top right bottom
+		     :ink +flipping-ink+ :filled t)
+    ;; Do this for the benefit of X displays
+    (medium-force-output medium)))
+
+(defmethod handle-event :around ((pane button-pane-mixin) (event pointer-event))
+  (when (gadget-active-p pane)
+    (call-next-method))
+  (deallocate-event event))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-enter-event))
+  (with-slots (armed) pane
+    (unless armed
+      (cond ((let ((pointer (pointer-event-pointer event)))
+	       (and (pointer-button-state pointer)
+		    (not (zerop (pointer-button-state pointer)))))
+	     (setf armed :active)
+	     (with-sheet-medium (medium pane)
+	       (highlight-button pane medium)))
+	    (t (setf armed t)))
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-exit-event))
+  (with-slots (armed) pane
+    (when armed
+      (when (prog1 (eq armed :active) (setf armed nil))
+	(with-sheet-medium (medium pane)
+	  (highlight-button pane medium)))
+      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-press-event))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed :active)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium)))))
+
+(defmethod handle-event ((pane button-pane-mixin) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (activate-callback pane (gadget-client pane) (gadget-id pane)))))
+
+
+;;; Patterns for push buttons
+
+(defparameter *square-button-pattern*
+	      (make-pattern #2a((0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *circle-button-pattern*
+	      (make-pattern #2a((0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0) 
+				(0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0) 
+				(0 0 1 0 0 0 0 0 0 0 0 0 0 1 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *right-triangle-button-pattern*
+	      (make-pattern #2a((0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 1 0 0 1 1 1 0 0 0 0 0 0 0 0 0) 
+				(0 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0) 
+				(0 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0) 
+				(0 1 0 0 0 0 0 0 0 0 1 1 1 0 0 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 1 1 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 1 1 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 1 1 1 0 0 0) 
+				(0 1 0 0 0 0 0 0 1 1 1 0 0 0 0 0) 
+				(0 1 0 0 0 0 1 1 1 0 0 0 0 0 0 0) 
+				(0 1 0 0 1 1 1 0 0 0 0 0 0 0 0 0) 
+				(0 1 1 1 1 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *left-triangle-button-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0) 
+				(0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0) 
+				(0 0 0 0 0 0 0 0 0 1 1 1 0 0 1 0) 
+				(0 0 0 0 0 0 0 1 1 1 0 0 0 0 1 0) 
+				(0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 0) 
+				(0 0 0 1 1 1 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 1 1 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 1 1 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 0 0 1 1 1 0 0 0 0 0 0 0 0 1 0) 
+				(0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 0) 
+				(0 0 0 0 0 0 0 1 1 1 0 0 0 0 1 0) 
+				(0 0 0 0 0 0 0 0 0 1 1 1 0 0 1 0) 
+				(0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0) 
+				(0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *rounded-button-pattern*
+	      (make-pattern #2a((0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0) 
+				(0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+
+;;; Push buttons
+
+(defparameter *default-button-label-text-style*
+	      (make-text-style :sans-serif :bold :small))
+
+(defclass push-button-pane (push-button button-pane-mixin)
+    ((external-label :initarg :external-label)
+     (depth :initarg :depth)
+     ;; These slots hold the patterns we'll really use...
+     (normal-pattern :initarg :normal-pattern)
+     (depressed-pattern :initarg :depressed-pattern)
+     (x-margin :initarg :x-margin)
+     (y-margin :initarg :y-margin)
+     ;;--- kludge because DRAW-TEXT* :ALIGN-X :CENTER is wrong
+     (internal-label-offset :initform 0))
+  (:default-initargs :label nil
+		     :text-style *default-button-label-text-style*
+		     :show-as-default nil
+		     :external-label nil
+		     :depth 2
+		     :pattern *square-button-pattern*
+		     :icon-pattern nil
+		     :normal-pattern nil
+		     :x-margin 2 :y-margin 0))
+
+(defmethod compose-space ((pane push-button-pane) &key width height)
+  (declare (ignore width height))
+  (with-slots (normal-pattern external-label x-margin y-margin) pane
+    (unless normal-pattern (setup-patterns pane))
+    (let* ((pattern-width (pattern-width normal-pattern))
+	   (pattern-height (pattern-height normal-pattern))
+	   (ext-label-width 0)
+	   (ext-label-height 0))
+      (when external-label
+	(let ((text-style (slot-value pane 'text-style)))
+	  (with-sheet-medium (medium pane)
+	    (multiple-value-bind (w h)
+		(text-size medium external-label :text-style text-style)
+	      (setq ext-label-width (+ w (text-style-width text-style medium))
+		    ext-label-height (+ h (floor
+					    (text-style-height text-style medium) 2)))))))
+      (make-space-requirement
+	:width (+ x-margin ext-label-width pattern-width x-margin)
+	:height (+ y-margin (max ext-label-height pattern-height) y-margin)))))
+
+;; There are 3 cases:
+;;  1) A simple pattern - no label
+;;  2) A simple pattern with internal label
+;;  3) An icon pattern and simple border pattern
+;; We don't do this at INITIALIZE-INSTANCE time since the medium is not
+;; yet set up at that time, meaning we can't compute label sizes, etc.
+(defmethod setup-patterns ((pane push-button-pane))
+  (with-slots (pattern icon-pattern normal-pattern depressed-pattern depth
+	       label internal-label-offset text-style) pane
+    (with-sheet-medium (medium pane)
+      (let ((text-margin (text-style-width text-style medium))
+	    (label-width 0)
+	    (label-height 0)
+	    inside-left inside-top inside-right inside-bottom 
+	    inside-width inside-height)
+	(when (or label icon-pattern)
+	  (multiple-value-setq (inside-left inside-top inside-right inside-bottom)
+	    (inside-extent-button-pattern pattern))
+	  (setq inside-width (- inside-right inside-left)
+		inside-height (- inside-bottom inside-top)))
+	(when icon-pattern
+	  (setq pattern (mount-button-pattern icon-pattern pattern)))
+	(when label
+	  (multiple-value-setq (label-width label-height)
+	    (compute-gadget-label-size pane))
+	  ;; I like a tiny bit more margin
+	  (incf label-width (* 2 text-margin))
+	  (setq label-width (max label-width inside-width)
+		label-height (max label-height inside-height))
+	  (when (or (> label-width inside-width)
+		    (> label-height inside-height))
+	    (setq pattern (grow-button-pattern pattern label-width label-height))))
+	(setq normal-pattern (refit-button-pattern pattern :overhang 4)
+	      depressed-pattern (offset-button-pattern normal-pattern
+						       :x-offset depth :y-offset depth))
+	;;--- Kludge because DRAW-TEXT* :ALIGN-X :CENTER is wrong
+	(when label
+	  (setq internal-label-offset
+		(+ text-margin (floor (- (pattern-width normal-pattern) label-width) 2))))
+	(setq normal-pattern
+	      (shadow-button-pattern normal-pattern :depth depth))))))
+
+(defmethod highlight-button ((pane push-button-pane) medium)
+  (draw-button-pattern pane medium)
+  ;; Do this for the benefit of X displays
+  (medium-force-output medium))
+
+(defmethod handle-event ((pane push-button-pane) (event pointer-button-press-event))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed :active)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      ;; So you can see it even if you let go quickly...
+      (sleep 0.25))))
+
+(defmethod handle-repaint ((pane push-button-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (draw-button-pattern pane medium :draw-external-label-p t)))
+
+(defmethod draw-button-pattern ((pane push-button-pane) medium
+				&key (draw-external-label-p nil))
+  (with-slots (normal-pattern depressed-pattern armed external-label
+	       text-style label depth internal-label-offset
+	       x-margin y-margin) pane
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane) right
+      (let* ((pattern (if (eq armed :active) depressed-pattern normal-pattern))
+	     (pattern-width (pattern-width pattern))
+	     (pattern-height (pattern-height pattern))
+	     (pattern-center-y (floor (+ top bottom) 2))
+	     (pattern-top (- pattern-center-y (floor pattern-height 2) y-margin))
+	     (pattern-left (+ left x-margin)))
+	(draw-pattern* medium pattern pattern-left pattern-top)
+	;; I don't like this - we really need to be able to draw text into patterns
+	(when label
+	  (let ((offset (if (eq armed :active) depth 0)))
+	    (draw-text* medium label
+			;;--- Kludge because DRAW-TEXT* :ALIGN-X :CENTER is wrong
+			(+ left x-margin internal-label-offset offset)
+			(+ pattern-center-y offset)
+			:text-style text-style
+			:align-x :left :align-y :center)))
+	(when draw-external-label-p
+	  (when external-label
+	    (draw-text* medium external-label
+			(+ pattern-left pattern-width x-margin) pattern-center-y
+			:text-style text-style
+			:align-x :left :align-y :center)))))))
+
+
+;;; Utilities for transmogrifying buttons
+
+;; Creates a new pattern which consists of the supplied pattern plus 
+;; a drop shadow
+(defvar *shadow-button-pattern-cache* (make-hash-table :test 'equal))
+(defun shadow-button-pattern (original-pattern &key (depth 2))
+  (multiple-value-bind (result foundp)
+      (gethash (cons original-pattern depth) *shadow-button-pattern-cache*)
+    (when foundp 
+      (return-from shadow-button-pattern result)))
+  (let* ((result-pattern (copy-pattern original-pattern))
+	 (width (pattern-width result-pattern))
+	 (height (pattern-height result-pattern))
+	 (array (decode-pattern result-pattern)))
+    (loop with y = (1- height)
+	  for x from 1 to (1- width)
+	  do (shadow-button-scan array x y width height depth))
+    (loop with x = (1- width)
+	  for y from (- height 2) downto 1
+	  do (shadow-button-scan array x y width height depth))
+    (setf (gethash (cons original-pattern depth) *shadow-button-pattern-cache*)
+	  result-pattern)))
+
+(defun copy-pattern (pattern)
+  (multiple-value-bind (array designs) (decode-pattern pattern)
+    (let* ((pattern-width (pattern-width pattern))
+	   (pattern-height (pattern-height pattern))
+	   (new-array
+	     (make-array (list pattern-height pattern-width)
+			 :element-type `(unsigned-byte ,(integer-length (1- (length designs))))
+			 :initial-element 0)))
+      (loop for x from 0 to (1- pattern-width)
+	    do (loop for y from 0 to (1- pattern-height)
+		     do (setf (aref new-array y x) (aref array y x))))
+      (make-pattern new-array designs))))
+
+(defun shadow-button-scan (array start-x start-y width height depth)
+  (loop with x = start-x
+	with y = start-y
+	with limit = (floor height 2)
+	with done = nil
+	for steps from 0
+	until done
+	do (decf x)
+	   (decf y)
+	   (if (or (<= x 0) (<= y 0) (> steps limit))
+	       (setq done t)
+	       (when (not (= 0 (aref array y x)))
+		 (loop with nx = (1+ x)
+		       with ny = (1+ y)
+		       repeat depth
+		       until (or (>= nx width) (>= ny height))
+		       do (setf (aref array ny nx) 1)
+			  (incf nx) (incf ny))
+		 (setq done t)))))
+
+;; Creates a new pattern which consists of the supplied pattern offset
+;; by the specified amount
+(defvar *offset-button-pattern-cache* (make-hash-table :test 'equal))
+(defun offset-button-pattern (original-pattern &key (x-offset 2) (y-offset 2)
+						    (new-width nil) (new-height nil))
+  (let ((width (pattern-width original-pattern))
+	(height (pattern-height original-pattern)))
+    (unless new-width (setq new-width width))
+    (unless new-height (setq new-height height))
+    (multiple-value-bind (result foundp)
+	(gethash (list original-pattern x-offset y-offset new-width new-height)
+		 *offset-button-pattern-cache*)
+      (when foundp 
+	(return-from offset-button-pattern result)))
+    (multiple-value-bind (array designs) (decode-pattern original-pattern)
+      (let* ((new-array 
+	       (make-array (list new-height new-width)
+			   :element-type `(unsigned-byte ,(integer-length (1- (length designs))))
+			   :initial-element 0))
+	     (result-pattern (make-pattern new-array designs)))
+	(loop for x from 0 to (1- width)
+	      do (loop for y from 0 to (1- height)
+		       for new-x = (+ x x-offset)
+		       for new-y = (+ y y-offset)
+		       unless (or (< new-x 0) (> new-x (1- new-width))
+				  (< new-y 0) (> new-y (1- new-height)))
+			 do (setf (aref new-array (+ y y-offset) (+ x x-offset))
+				  (aref array y x))))
+	(setf (gethash (list original-pattern x-offset y-offset new-width new-height)
+		       *offset-button-pattern-cache*)
+	      result-pattern)))))
+
+;; Creates a new pattern which consists of the supplied pattern plus a drop shadow
+(defvar *refit-button-pattern-cache* (make-hash-table :test 'equal))
+(defun refit-button-pattern (original-pattern &key (overhang 0))
+  (multiple-value-bind (result foundp)
+      (gethash (cons original-pattern overhang) *refit-button-pattern-cache*)
+    (when foundp 
+      (return-from refit-button-pattern result)))
+  (multiple-value-bind (original-array designs)
+      (decode-pattern original-pattern)
+    (multiple-value-bind (left top right bottom)
+	(bounding-extent-button-pattern original-pattern)
+      (let* ((new-width (+ (- right left) 1 (* 2 overhang)))
+	     (new-height (+ (- bottom top) 1 (* 2 overhang)))
+	     (x-offset (- left overhang))
+	     (y-offset (- top overhang))
+	     (new-array 
+	       (make-array (list new-height new-width)
+			   :element-type `(unsigned-byte ,(integer-length (1- (length designs))))
+			   :initial-element 0)))
+	(loop for x from left to right
+	      do (loop for y from top to bottom
+		       do (setf (aref new-array (- y y-offset) (- x x-offset))
+				(aref original-array y x))))
+	(let ((result-pattern (make-pattern new-array designs)))
+	  (setf (gethash (cons original-pattern overhang) *refit-button-pattern-cache*)
+		result-pattern))))))
+
+(defun bounding-extent-button-pattern (pattern)
+  (let ((width (pattern-width pattern))
+	(height (pattern-height pattern))
+	(array (decode-pattern pattern))
+	left bottom right top)
+    (loop with done = nil
+	  for x from 0 to (1- width)
+	  until done
+	  do (loop for y from 0 to (1- height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      left x))))
+    (loop with done = nil
+	  for x from (1- width) downto 0
+	  until done
+	  do (loop for y from 0 to (1- height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      right x))))
+    (loop with done = nil
+	  for y from (1- height) downto 0
+	  until done
+	  do (loop for x from 0 to (1- width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      bottom y))))
+    (loop with done = nil
+	  for y from 0 to (1- height)
+	  until done
+	  do (loop for x from 0 to (1- width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      top y))))
+    (values left top right bottom)))
+
+(defun operate-on-button-patterns (source-1 source-2 destination operation)
+  (let ((source-1-width (pattern-width source-1))
+	(source-2-width (when source-2 (pattern-width source-2)))
+	(destination-width (pattern-width destination))
+	(source-1-height (pattern-height source-1))
+	(source-2-height (when source-2 (pattern-height source-2)))
+	(destination-height (pattern-height destination))
+	(source-1-array (decode-pattern source-1))
+	(source-2-array (when source-2 (decode-pattern source-2)))
+	(destination-array (decode-pattern destination)))
+    (unless (and (= source-1-width destination-width)
+		 (or (null source-2) (= source-2-width source-1-width))
+		 (= source-1-height destination-height)
+		 (or (null source-2) (= source-2-height source-1-height)))
+      (error "Incompatible dimensions"))
+    (loop for x from 0 to (1- source-1-width)
+	  do (loop for y from 0 to (1- source-1-height)
+		   do (if source-2
+			  (setf (aref destination-array y x)
+				(funcall operation
+					 (aref source-1-array y x)
+					 (aref source-2-array y x)))
+			  (setf (aref destination-array y x)
+				(funcall operation
+					 (aref source-1-array y x))))))))
+
+;; Creates an outlined copy of the original pattern in the destination
+;; pattern, clobbering the destination in the process
+(defun outline-button-pattern (original-pattern destination-pattern
+			       &key (space 1) (thickness 2))
+  (assert (not (eq original-pattern destination-pattern))
+	  (original-pattern destination-pattern)
+	  "The original and destination patterns must be different objects")
+  (let ((width (pattern-width original-pattern))
+	(height (pattern-height original-pattern))
+	(array (decode-pattern original-pattern))
+	(dest-array (decode-pattern destination-pattern)))
+    (loop with done = nil
+	  for x from 0 to (1- width)
+	  until done
+	  do (loop for y from 0 to (1- height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(outline-button-pattern-scan dest-array x y -1 0 space thickness)
+			(setq done t))))
+    (loop with done = nil
+	  for x from (1- width) downto 0
+	  until done
+	  do (loop for y from 0 to (1- height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(outline-button-pattern-scan dest-array x y 1 0 space thickness)
+			(setq done t))))
+    (loop with done = nil
+	  for y from (1- height) downto 0
+	  until done
+	  do (loop for x from 0 to (1- width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(outline-button-pattern-scan dest-array x y 0 1 space thickness)
+			(setq done t))))
+    (loop with done = nil
+	  for y from 0 to (1- height)
+	  until done
+	  do (loop for x from 0 to (1- width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(outline-button-pattern-scan dest-array x y 0 1 space thickness)
+			(setq done t))))))
+
+(defun outline-button-pattern-scan (dest-array start-x start-y dx dy space thickness)
+  (loop with x = start-x
+	with y = start-y
+	repeat space
+	do (incf x dx)
+	   (incf y dy))
+  (loop with x = start-x
+	with y = start-y
+	with width-1 = (array-dimension dest-array 1)
+	with height-1 = (array-dimension dest-array 0)
+	repeat thickness
+	until (or (< x 0) (< y 0) (> x width-1) (> y height-1))
+	do (incf x dx)
+	   (incf y dy)
+	   (setf (aref dest-array y x) 1)))
+
+;; Desstructively "grays" the supplied pattern
+(defun gray-button-pattern (original-pattern)
+  (let ((width (pattern-width original-pattern))
+	(height (pattern-height original-pattern))
+	(array (decode-pattern original-pattern)))
+    (loop for x from (1- width) downto 0
+	  do (loop for y from (1- height) downto 0
+		   do (if (oddp x)
+			  (when (evenp y) (setf (aref array y x) 0))
+			  (when (oddp y) (setf (aref array y x) 0)))))
+    original-pattern))
+
+;; Creates a new pattern consisting of the supplied pattern "stretched"
+;; to the new dimensions
+(defvar *grow-button-pattern-cache* (make-hash-table :test 'equal))
+(defun grow-button-pattern (original-pattern new-width new-height)
+  (let ((original-width (pattern-width original-pattern))
+	(original-height (pattern-height original-pattern)))
+    (maxf new-width original-width)
+    (maxf new-height original-height)
+    (multiple-value-bind (result foundp)
+	(gethash (list original-pattern new-width new-height) *grow-button-pattern-cache*)
+      (when foundp 
+	(return-from grow-button-pattern result)))
+    (multiple-value-bind (original-array designs)
+	(decode-pattern original-pattern)
+      (let ((center-x (floor original-width 2))
+	    (center-y (floor original-height 2))
+	    (intermediate-array
+	      (make-array (list original-height new-width)
+			  :element-type `(unsigned-byte ,(integer-length (1- (length designs)))) 
+			  :initial-element 0))
+	    (final-array 
+	      (make-array (list new-height new-width) 
+			  :element-type `(unsigned-byte ,(integer-length (1- (length designs))))
+			  :initial-element 0)))
+	(loop for x from 0 to center-x
+	      do (loop for y from 0 to (1- original-height)
+		       do (setf (aref intermediate-array y x) (aref original-array y x))))
+	(loop for x from (1- new-width) downto (- new-width center-x)
+	      for old-x from (1- original-width) by -1
+	      do (loop for y from 0 to (1- original-height)
+		       do (setf (aref intermediate-array y x) (aref original-array y old-x))))
+	(loop for x from (1+ center-x) to (- new-width center-x 1)
+	      do (loop for y from 0 to (1- original-height)
+		       do (setf (aref intermediate-array y x)
+				(aref original-array y center-x))))
+	;; Now the other direction
+	(loop for y from 0 to center-y
+	      do (loop for x from 0 to (1- new-width)
+		       do (setf (aref final-array y x) (aref intermediate-array y x))))
+	(loop for y from (1- new-height) downto (- new-height center-y)
+	      for old-y from (1- original-height) by -1
+	      do (loop for x from 0 to (1- new-width)
+		       do (setf (aref final-array y x) (aref intermediate-array old-y x))))
+	(loop for y from (1+ center-y) to (- new-height center-y 1)
+	      do (loop for x from 0 to (1- new-width)
+		       do (setf (aref final-array y x) (aref intermediate-array center-y x))))
+	(let ((result-pattern (make-pattern final-array designs)))
+	  (setf (gethash (list original-pattern new-width new-height) 
+			 *grow-button-pattern-cache*)
+		result-pattern))))))
+
+;; Creates a new pattern which consists of the icon pattern mounted within
+;; the appropriately sized button pattern
+(defvar *mount-button-pattern-cache* (make-hash-table :test 'equal))
+(defun mount-button-pattern (icon-pattern button-pattern)
+  (multiple-value-bind (result foundp)
+      (gethash (cons icon-pattern button-pattern) *mount-button-pattern-cache*)
+    (when foundp 
+      (return-from mount-button-pattern result)))
+  (multiple-value-bind (ileft itop iright ibottom)
+      (inside-extent-button-pattern button-pattern)
+    (let* ((icon-width (pattern-width icon-pattern))
+	   (icon-height (pattern-height icon-pattern))
+	   (icon-array (decode-pattern icon-pattern))
+	   (background-width (pattern-width button-pattern))
+	   (background-height (pattern-height button-pattern))
+	   (button-inside-width (- iright ileft))
+	   (button-inside-height (- ibottom itop))
+	   (white-space 2)
+	   (border-width (+ (* 2 white-space) (- background-width button-inside-width)))
+	   (border-height (+ (* 2 white-space) (- background-height button-inside-height)))
+	   result-pattern)
+      (if (or (> icon-width button-inside-width)
+	      (> icon-height button-inside-height))
+	  (setq button-inside-width (+ (max icon-width button-inside-width) border-width)
+		button-inside-height (+ (max icon-height button-inside-height) border-height)
+		result-pattern (grow-button-pattern button-pattern
+						    button-inside-width
+						    button-inside-height))
+	  (setq result-pattern (copy-pattern button-pattern)))
+      (let ((x-offset (floor border-width 2))
+	    (y-offset (floor border-height 2))
+	    (result-array (decode-pattern result-pattern)))
+	(loop for x from 0 to (1- icon-width)
+	      do (loop for y from 0 to (1- icon-height)
+		       do (setf (aref result-array (+ y y-offset) (+ x x-offset))
+				(aref icon-array y x)))))
+      (setf (gethash (cons icon-pattern button-pattern) *mount-button-pattern-cache*)
+	    result-pattern))))
+
+(defun inside-extent-button-pattern (pattern)
+  (let* ((width (pattern-width pattern))
+	 (height (pattern-height pattern))
+	 (array (decode-pattern pattern))
+	 (center-x (floor width 2))
+	 (center-y (floor height 2))
+	 (initial-height 1)
+	 left bottom right top real-width)
+    (loop with done = nil
+	  for x from center-x downto 0
+	  until done
+	  do (loop for y from (- center-y initial-height) to (+ center-y initial-height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      left (1+ x)))))
+    (loop with done = nil
+	  for x from center-x to (1- width)
+	  until done
+	  do (loop for y from (- center-y initial-height) to (+ center-y initial-height)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      right (1- x)))))
+    (setq real-width (floor (- right left) 2))
+    (loop with done = nil
+	  for y from center-y to (1- height)
+	  until done
+	  do (loop for x from (- center-x real-width) to (+ center-x real-width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      bottom (1- y)))))
+    (loop with done = nil
+	  for y from center-y downto 0
+	  until done
+	  do (loop for x from (- center-x real-width) to (+ center-x real-width)
+		   until done
+		   do (unless (= 0 (aref array y x))
+			(setq done t
+			      top (1+ y)))))
+    (values left top right bottom)))
+
+
+;;; Patterns for toggle buttons and check boxes
+
+(defparameter *empty-check-box-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *crossed-check-box-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 0 0 0 0 0 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 1 1 1 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 1 1 1 0 1 1 1 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 1 0 0 0 1 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 0 0 0 0 0 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *checked-check-box-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 1 1) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 1 1 0 0 0 0 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 1 1 0 0 1 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 0 1 1 1 1 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 1 1 1 1 1 1 1 1 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 1 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 1 1 1 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 1 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *grayed-check-box-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0) 
+				(0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *radio-button-off-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0) 
+				(0 0 1 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0) 
+				(0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *radio-button-on-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 1 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 0) 
+				(0 0 1 1 0 0 0 1 1 1 1 1 1 1 0 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 1 1 1 1 1 1 1 1 1 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 0 1 1 1 1 1 1 1 0 0 0 1 1 0 0) 
+				(0 0 1 1 1 0 0 1 1 1 1 1 1 1 0 0 1 1 1 0 0) 
+				(0 0 0 1 1 0 0 0 1 1 1 1 1 0 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 0 0 0 1 0 0 0 0 1 1 1 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *radio-button-grayed-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 1 1 1 0 0 1 0 1 0 1 0 0 1 1 1 0 0 0) 
+				(0 0 0 1 1 0 0 1 0 1 0 1 0 1 0 0 1 1 0 0 0) 
+				(0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0) 
+				(0 0 1 1 0 0 0 1 0 1 0 1 0 1 0 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 1 0 1 0 1 0 1 0 1 0 0 1 1 0 0) 
+				(0 0 1 1 0 0 0 1 0 1 0 1 0 1 0 0 0 1 1 0 0) 
+				(0 0 1 1 1 0 1 0 1 0 1 0 1 0 1 0 1 1 1 0 0) 
+				(0 0 0 1 1 0 0 1 0 1 0 1 0 1 0 0 1 1 0 0 0) 
+				(0 0 0 1 1 1 0 0 1 0 1 0 1 0 0 1 1 1 0 0 0) 
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0) 
+				(0 0 0 0 1 1 1 1 1 0 0 0 1 1 1 1 1 0 0 0 0) 
+				(0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0) 
+				(0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+
+;;; Toggle buttons
+
+;;--- This should only have the 3 pattern slots on, off and unknown (maybe
+;;--- also disabled if its not done with a overlay).  I was hoping that we could
+;;--- split this into separate classes because that would be the most natural
+;;--- implementation - you then just fill the slots with the right patterns
+;;--- using the :DEFAULT-INITARGS list.  I guess we can do the sort of thing
+;;--- at initialize instance time - but I still favor splitting - its easier
+;;--- to add new toggle button classes that way.
+(defclass toggle-button-pane (toggle-button button-pane-mixin)
+    ((empty-check-box-pattern :initarg :empty-check-box-pattern)
+     (checked-check-box-pattern :initarg :checked-check-box-pattern)
+     (grayed-check-box-pattern :initarg :grayed-check-box-pattern)
+     (radio-button-off-pattern :initarg :radio-button-off-pattern)
+     (radio-button-on-pattern :initarg :radio-button-on-pattern)
+     (radio-button-grayed-pattern :initarg :radio-button-grayed-pattern))
+  (:default-initargs :label nil
+		     :indicator-type ':one-of
+		     :empty-check-box-pattern *empty-check-box-pattern*
+		     :checked-check-box-pattern *checked-check-box-pattern*
+		     :grayed-check-box-pattern *grayed-check-box-pattern*
+		     :radio-button-off-pattern *radio-button-off-pattern*
+		     :radio-button-on-pattern *radio-button-on-pattern*
+		     :radio-button-grayed-pattern *radio-button-grayed-pattern*
+		     :text-style *default-button-label-text-style*))
+
+(defmethod compose-space ((pane toggle-button-pane) &key width height)
+  (declare (ignore width height))
+  (multiple-value-bind (width height)
+      (compute-gadget-label-size pane)
+    ;;--- Should either make radio buttons and check boxes different classes
+    ;;--- or generalize this
+    (with-slots (empty-check-box-pattern) pane
+      (let ((pattern-width (pattern-width empty-check-box-pattern))
+	    (pattern-height (pattern-height empty-check-box-pattern)))
+	;; We allow 1/2 pattern width on each side as margin
+	(make-space-requirement :width (+ width (* pattern-width 2))
+				:height (max height (* pattern-height 2)))))))
+
+(defmethod handle-repaint ((pane toggle-button-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    ;;--- This is pretty gross: toggle buttons and check boxes should
+    ;;--- be different classes
+    (cond ((typep (gadget-client pane) 'radio-box)
+	   (draw-radio-button pane medium :draw-label-p t))
+	  (t
+	   (draw-toggle-button-check-box pane medium :draw-label-p t)))))
+
+;; This is done in the (SETF GADGET-VALUE) method because that's where it 
+;; would be done in, say, Motif.  (That is, we'd pass the SET-GADGET-VALUE
+;; off to Motif which would toggle the indicator.)
+(defmethod (setf gadget-value) :after (value (pane toggle-button-pane) &key invoke-callback)
+  (declare (ignore value invoke-callback))
+  (when (port pane)
+    ;; If it's not grafted, don't draw it.
+    (with-sheet-medium (medium pane)
+      ;;--- This is pretty gross: toggle buttons and check boxes should
+      ;;--- be different classes
+      (cond ((typep (gadget-client pane) 'radio-box)
+	     (draw-radio-button pane medium))
+	    (t
+	     (draw-toggle-button-check-box pane medium))))))
+
+(defmethod draw-toggle-button-check-box ((pane toggle-button-pane) medium
+					 &key (draw-label-p nil))
+  (with-slots (empty-check-box-pattern checked-check-box-pattern
+	       grayed-check-box-pattern) pane
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (declare (ignore right))
+      (let* ((pattern-width (pattern-width empty-check-box-pattern))
+	     (pattern-height (pattern-height empty-check-box-pattern))
+	     ;; assume a margin of 1/2 pattern width
+	     (x (+ left (floor pattern-width 2)))
+	     (y (- (floor (+ top bottom) 2) (floor pattern-height 2))))
+	(case (gadget-value pane)
+	  (:unknown (draw-pattern* medium grayed-check-box-pattern x y))
+	  ((nil) (draw-pattern* medium empty-check-box-pattern x y))
+	  (otherwise (draw-pattern* medium checked-check-box-pattern x y)))
+	(when draw-label-p
+	  (draw-gadget-label pane medium
+			     (+ left (* pattern-width 2)) (floor (+ top bottom) 2)
+			     :align-x :left :align-y :center))))))
+
+(defmethod draw-radio-button ((pane toggle-button-pane) medium
+			      &key (draw-label-p nil))
+  (with-slots (radio-button-off-pattern radio-button-on-pattern
+	       radio-button-grayed-pattern) pane
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (declare (ignore right))
+      (let* ((pattern-width (pattern-width radio-button-off-pattern))
+	     (pattern-height (pattern-height radio-button-off-pattern))
+	     ;; assume a margin of 1/2 pattern width
+	     (x (+ left (floor pattern-width 2)))
+	     (y (- (floor (+ top bottom) 2) (floor pattern-height 2))))
+	(case (gadget-value pane)
+	  (:unknown (draw-pattern* medium radio-button-grayed-pattern x y))
+	  ((nil) (draw-pattern* medium radio-button-off-pattern x y))
+	  (otherwise (draw-pattern* medium radio-button-on-pattern x y)))
+	(when draw-label-p
+	  (draw-gadget-label pane medium
+			     (+ left (* pattern-width 2)) (floor (+ top bottom) 2)
+			     :align-x :left :align-y :center))))))
+
+;; Highlighting is a no-op
+(defmethod highlight-button ((pane toggle-button-pane) medium)
+  (declare (ignore medium)))
+
+(defmethod handle-event ((pane toggle-button-pane) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))))
+
+
+;;; Menu buttons
+(defclass menu-button-pane (menu-button button-pane-mixin)
+    ((menu-group :initarg :menu-group :reader menu-button-menu-group)
+     (show-arrow :initarg :show-arrow))
+  (:default-initargs :label nil :label-text-style *default-button-label-text-style*
+		     :menu-group nil :show-arrow t))
+
+
+;;; Radio boxes and check boxes
+
+(defclass radio-box-pane 
+	  (radio-box
+	   wrapping-space-mixin
+	   sheet-permanently-enabled-mixin
+	   sheet-mute-input-mixin
+	   sheet-multiple-child-mixin
+	   space-requirement-mixin
+	   basic-pane)
+    ())
+
+(defmethod initialize-instance :after ((pane radio-box-pane) 
+				       &key choices selection frame-manager frame)
+  (declare (ignore choices))
+  ;; Set the button's client and disown it from the radio box so
+  ;; that we can do layout, below.
+  (let ((buttons (copy-list (sheet-children pane))))
+    (dolist (button buttons)
+      (setf (gadget-client button) pane)
+      (sheet-disown-child pane button))
+    (let ((inferiors
+	    (with-look-and-feel-realization (frame-manager frame)
+	      (make-pane (ecase (gadget-orientation pane)
+			   (:horizontal 'hbox-pane)
+			   (:vertical 'vbox-pane))
+		:spacing 5
+		:contents buttons))))
+      (sheet-adopt-child pane inferiors)))
+  (when selection
+    (setf (gadget-value pane) selection)
+    (setf (gadget-value selection) t)))
+
+(defmethod value-changed-callback :around
+	   ((selection toggle-button) (client radio-box-pane) gadget-id value)
+  (declare (ignore gadget-id value))
+  (let ((old-selection (radio-box-current-selection client)))
+    (when (and old-selection
+	       (not (eq selection old-selection)))
+      (setf (gadget-value old-selection :invoke-callback t) nil)))
+  (call-next-method))
+
+(defmethod handle-event :after ((pane radio-box-pane) (event pointer-event))
+  (deallocate-event event))
+
+
+(defclass check-box-pane 
+	  (check-box
+	   wrapping-space-mixin
+	   sheet-permanently-enabled-mixin
+	   sheet-mute-input-mixin
+	   sheet-multiple-child-mixin
+	   space-requirement-mixin
+	   basic-pane)
+    ())
+
+(defmethod initialize-instance :after ((pane check-box-pane) 
+				       &key choices selection frame-manager frame)
+  (declare (ignore choices))
+  (let ((buttons (copy-list (sheet-children pane))))
+    (dolist (button buttons)
+      (setf (gadget-client button) pane)
+      (sheet-disown-child pane button))
+    (let ((inferiors
+	    (with-look-and-feel-realization (frame-manager frame)
+	      (make-pane (ecase (gadget-orientation pane)
+			   (:horizontal 'hbox-pane)
+			   (:vertical 'vbox-pane))
+		:spacing 5
+		:contents buttons))))
+      (sheet-adopt-child pane inferiors)))
+  (when selection
+    (setf (gadget-value pane) (list selection))
+    (setf (gadget-value selection) t)))
+
+(defmethod handle-event :after ((pane check-box-pane) (event pointer-event))
+  (deallocate-event event))
+
+
diff --git a/homegrown/db-label.lisp b/homegrown/db-label.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..094fc6f737ff7b9a23770ec81c19258f2f438301
--- /dev/null
+++ b/homegrown/db-label.lisp
@@ -0,0 +1,84 @@
+;; -*- mode: common-lisp; package: silica -*-
+;;
+;;				-[Thu Jul 22 17:16:08 1993 by colin]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader: db-label.lisp,v 1.3 1993/07/27 01:50:31 colin Exp $
+
+(in-package :silica)
+
+(defclass generic-label-pane 
+	  (label-pane
+	   space-requirement-mixin
+	   leaf-pane)
+    ()
+  (:default-initargs :align-x :left
+		     :text-style *default-label-text-style*))
+
+(defmethod compose-space ((pane generic-label-pane) &key width height)
+  (declare (ignore width height))
+  (multiple-value-bind (width height)
+      (compute-gadget-label-size pane)
+    (make-space-requirement :width width :height height)))
+  
+(defmethod handle-repaint ((pane generic-label-pane) region)
+  (declare (ignore region))			;not worth checking
+  (with-sheet-medium (medium pane)
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (declare (ignore right bottom))
+      (draw-gadget-label pane medium left top
+			 :align-x (gadget-alignment pane) :align-y :top))))
+
+(defmethod draw-gadget-label ((pane labelled-gadget-mixin) medium x y
+			      &key (align-x (gadget-alignment pane))
+				   (align-y :baseline))
+  (let ((label (gadget-label pane)))
+    (etypecase label
+      (string
+	(let ((text-style (slot-value pane 'text-style)))
+	  (draw-text* medium label x y
+		      :text-style text-style
+		      :align-x align-x :align-y align-y)))
+      (null)      
+      (pattern
+	(let ((width (pattern-width label))
+	      (height (pattern-height label)))
+	  (ecase align-x
+	    (:left)
+	    (:right (decf x width))
+	    (:center (decf x (floor width 2))))
+	  (ecase align-y
+	    ((:top :baseline))
+	    (:bottom (decf x height))
+	    (:center (decf x (floor height 2))))
+	  (draw-pattern* medium label x y)))
+      (pixmap
+	(let ((width (pixmap-width label))
+	      (height (pixmap-height label)))
+	  (ecase align-x
+	    (:left)
+	    (:right (decf x width))
+	    (:center (decf x (floor width 2))))
+	  (ecase align-y
+	    ((:top :baseline))
+	    (:bottom (decf x height))
+	    (:center (decf x (floor height 2))))
+	  (copy-from-pixmap label 0 0 width height
+			    medium x y))))))
diff --git a/homegrown/db-list.lisp b/homegrown/db-list.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..68b82dec118059bd2645002d6d906523e553ea0c
--- /dev/null
+++ b/homegrown/db-list.lisp
@@ -0,0 +1,210 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-list.lisp,v 1.5 1993/07/27 01:38:44 colin Exp $
+
+"Copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :silica)	;yes, this file is in the Silica package
+
+;;; List panes and option panes
+
+
+;; We use "simple" toggle buttons inside of list and option panes
+(defclass simple-toggle-button-pane (toggle-button button-pane-mixin)
+    ()
+  (:default-initargs :label nil 
+		     :text-style *default-button-label-text-style*
+		     :show-as-default nil))
+
+(defparameter *check-mark-pattern*
+	      (make-pattern #2a((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1)
+				(0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1)
+				(0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0)
+				(0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0)
+				(0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0)
+				(0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0)
+				(0 0 1 1 0 0 0 0 1 1 1 0 0 0 0 0)
+				(0 1 1 1 1 0 0 1 1 1 0 0 0 0 0 0)
+				(1 1 1 1 1 0 1 1 1 1 0 0 0 0 0 0)
+				(0 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0)
+				(0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
+				(0 0 0 1 1 1 1 1 0 0 0 0 0 0 0 0)
+				(0 0 0 0 1 1 1 0 0 0 0 0 0 0 0 0)
+				(0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defmethod compose-space ((pane simple-toggle-button-pane) &key width height)
+  (declare (ignore width height))
+  (multiple-value-bind (width height)
+      (compute-gadget-label-size pane)
+    (incf width  (+ (pattern-width *check-mark-pattern*)  2))
+    (maxf height (+ (pattern-height *check-mark-pattern*) 1))
+    (make-space-requirement :width width :height height)))
+
+;; Draw the text, invert the whole button when it's armed.  Add a check
+;; mark when the button is toggled on.
+(defmethod handle-repaint ((pane simple-toggle-button-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (let ((text (gadget-label pane))
+	  (text-style (slot-value pane 'text-style))
+	  (armed (slot-value pane 'armed))
+	  (pattern *check-mark-pattern*))
+      (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+	(if (gadget-value pane)
+	    (draw-pattern* medium pattern (- right (+ (pattern-width pattern) 2)) (+ top 1))
+	    (draw-rectangle* medium 
+			     (- right (+ (pattern-width pattern) 2)) (+ top 1) right bottom
+			     :filled t :ink +background-ink+))
+	(draw-rectangle* medium left top (1- right) (1- bottom)
+			 :filled nil)
+	(draw-text* medium text (+ left 2) (+ top (floor (- bottom top) 2))
+		    :text-style text-style
+		    :align-x :left :align-y :center))
+      (when (eq armed :active)
+	(highlight-button pane medium)))))
+
+(defmethod handle-event ((pane simple-toggle-button-pane) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (setf (gadget-value pane :invoke-callback t) (not (gadget-value pane))))))
+
+;; This is done in the (SETF GADGET-VALUE) method because that's where it 
+;; would be done in, say, Motif.  (That is, we'd pass the SET-GADGET-VALUE
+;; off to Motif which would toggle the indicator.)
+(defmethod (setf gadget-value) :after (value (pane simple-toggle-button-pane)
+				       &key invoke-callback)
+  (declare (ignore value invoke-callback))
+  (when (port pane)
+    (handle-repaint pane +everywhere+)))
+
+
+(defclass generic-list-pane
+	  (list-pane
+	   wrapping-space-mixin
+	   sheet-permanently-enabled-mixin
+	   sheet-mute-input-mixin
+	   sheet-multiple-child-mixin
+	   space-requirement-mixin
+	   basic-pane)
+    ())
+
+(defmethod initialize-instance :after ((pane generic-list-pane) &key)
+  (with-slots (items name-key value-key test mode) pane
+    (let* ((frame (pane-frame pane))
+	   (framem (frame-manager frame)))
+      (assert (and frame framem) ()
+	      "There must be both a frame and frame manager active")
+      (with-look-and-feel-realization (framem frame)
+	(dolist (item items)
+	  (make-pane 'simple-toggle-button-pane
+	    :value (ecase mode
+		     (:exclusive
+		       (funcall test (funcall value-key item) (gadget-value pane)))
+		     (:nonexclusive
+		       (and (member (funcall value-key item) (gadget-value pane) :test test)
+			    t)))
+	    :label (funcall name-key item)
+	    :id item
+	    :parent pane))
+	(let ((buttons (copy-list (sheet-children pane))))
+	  (setq items buttons)			;save them away
+	  (dolist (button buttons)
+	    (setf (gadget-client button) pane) 
+	    (sheet-disown-child pane button))
+	  (let ((inferiors
+		  (make-pane 'vbox-pane
+		    :spacing 3
+		    :contents buttons)))
+	    (sheet-adopt-child pane inferiors)))))))
+
+(defmethod value-changed-callback :around 
+	   ((selection toggle-button) (client generic-list-pane) gadget-id value)
+  (declare (ignore gadget-id))
+  (with-slots (items value-key mode) client
+    (let ((real-value (funcall value-key (gadget-id selection)))
+	  (old-selection nil))
+      (ecase mode
+	(:exclusive
+	  (setq old-selection (gadget-value client))
+	  (setf (gadget-value client) (and value real-value)))
+	(:nonexclusive
+	  (if value
+	      (pushnew real-value (gadget-value client))
+	      (setf (gadget-value client) (delete real-value (gadget-value client))))))
+      (when old-selection
+	(let ((button (find old-selection items :key #'gadget-id)))
+	  (setf (gadget-value button :invoke-callback nil) nil)))
+      (value-changed-callback
+	client (gadget-client client) (gadget-id client) (gadget-value client))))
+  (call-next-method))
+
+(defmethod handle-event :after ((pane generic-list-pane) (event pointer-event))
+  (deallocate-event event))
+
+
+(defclass generic-option-pane (option-pane push-button-pane)
+    ((menu :initform nil))
+  (:default-initargs :pattern *right-triangle-button-pattern*))
+
+;;--- The idea is the the option pane itself is a pushbutton which, when
+;;--- pressed, pops up a menu containing the options.
+(defmethod initialize-instance :after ((pane generic-option-pane) &key)
+  (with-slots (external-label label
+	       items name-key value-key test mode) pane
+    (shiftf external-label label nil)
+    (let* ((frame (pane-frame pane))
+	   (framem (frame-manager frame))
+	   (buttons nil))
+      (assert (and frame framem) ()
+	      "There must be both a frame and frame manager active")
+      (with-look-and-feel-realization (framem frame)
+	(dolist (item items)
+	  (push (make-pane 'simple-toggle-button-pane
+		  :value (ecase mode
+			   (:exclusive
+			     (funcall test (funcall value-key item) (gadget-value pane)))
+			   (:nonexclusive
+			     (and (member (funcall value-key item) (gadget-value pane) :test test)
+				  t)))
+		  :label (funcall name-key item)
+		  :id item
+		  :client pane)
+		buttons))
+	(setq buttons (nreverse buttons))
+	(setq items (copy-list buttons))	;save them away
+	(let ((menu (make-pull-down-menu :port (port frame))))
+	  (initialize-pull-down-menu menu buttons)
+	  (setf (slot-value pane 'menu) menu))))))
+
+(defmethod handle-event ((pane generic-option-pane) (event pointer-button-release-event))
+  (with-slots (armed menu) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (choose-from-pull-down-menu menu pane))))
+
+(defmethod value-changed-callback :around 
+	   ((selection toggle-button) (client generic-option-pane) gadget-id value)
+  (declare (ignore gadget-id))
+  (with-slots (items value-key mode) client
+    (let ((real-value (funcall value-key (gadget-id selection)))
+	  (old-selection nil))
+      (ecase mode
+	(:exclusive
+	  (setq old-selection (gadget-value client))
+	  (setf (gadget-value client) (and value real-value)))
+	(:nonexclusive
+	  (if value
+	      (pushnew real-value (gadget-value client))
+	      (setf (gadget-value client) (delete real-value (gadget-value client))))))
+      (when old-selection
+	(let ((button (find old-selection items :key #'gadget-id)))
+	  (setf (gadget-value button :invoke-callback nil) nil)))
+      (value-changed-callback
+	client (gadget-client client) (gadget-id client) (gadget-value client))))
+  (call-next-method))
diff --git a/homegrown/db-menu.lisp b/homegrown/db-menu.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..ebfc0b11ae6d77da741ef2bf2ecbb06f3c2f2e97
--- /dev/null
+++ b/homegrown/db-menu.lisp
@@ -0,0 +1,344 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-menu.lisp,v 1.8 1993/07/27 01:38:47 colin Exp $
+
+"Copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :silica)	;yes, this file is in the Silica package
+
+;;; Menu bars and buttons
+
+;;--- The main visual problem is that there is just too much whitespace...
+
+
+;;; Menu bar buttons
+
+;; Like push buttons, except that they activate when the pointer button is
+;; down rather than when it is released
+(defclass menu-bar-button (push-button-pane)
+    ((next-menu :initform nil :initarg :next-menu)))
+
+(defmethod handle-event ((pane menu-bar-button) (event pointer-enter-event))
+  (with-slots (armed next-menu) pane
+    (unless armed
+      (cond ((let ((pointer (pointer-event-pointer event)))
+	       (and (pointer-button-state pointer)
+		    (not (zerop (pointer-button-state pointer)))))
+	     (with-sheet-medium (medium pane)
+	       (setf armed :active)
+	       (highlight-button pane medium)
+	       (if (typep next-menu 'pull-down-menu)
+		   (choose-from-pull-down-menu next-menu pane)
+		   (activate-callback pane (gadget-client pane) (gadget-id pane)))
+	       (setf armed t)
+	       (highlight-button pane medium)))
+	    (t (setf armed t)))
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defmethod handle-event ((pane menu-bar-button) (event pointer-button-press-event))
+  (with-slots (armed next-menu) pane
+    (with-sheet-medium (medium pane)
+      (when armed
+	(setf armed :active)
+	(highlight-button pane medium))
+      (if (typep next-menu 'pull-down-menu)
+	  (choose-from-pull-down-menu next-menu pane)
+	  (activate-callback pane (gadget-client pane) (gadget-id pane)))
+      (setf armed t)
+      (highlight-button pane medium))))
+
+(defmethod handle-event ((pane menu-bar-button) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (and (eq armed :active))
+      (with-sheet-medium (medium pane)
+	(setf armed t)
+	(highlight-button pane medium)))))
+
+
+;;; Pull-down menu buttons
+
+(defparameter *cascade-button-pattern*
+	      (make-pattern #2a((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1) 
+				(1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) 
+				(1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1))
+			    (list +background-ink+ +foreground-ink+)))
+
+;; Like push buttons except that the pointer button is assumed to be already down
+(defclass pull-down-menu-button (push-button-pane) 
+    ((next-menu :initform nil :initarg :next-menu)))
+
+(defmethod initialize-instance :after ((pane pull-down-menu-button) &key)
+  (with-slots (next-menu pattern) pane
+    (when next-menu
+      (setq pattern *cascade-button-pattern*))))
+
+(defmethod handle-event ((pane pull-down-menu-button) (event pointer-enter-event))
+  (when (port pane)				;the menu is sometimes disabled...
+    (let* ((pointer (port-pointer (port pane)))
+	   (pointer-button-state (pointer-button-state pointer)))
+      (unless (= pointer-button-state 0)
+	(with-slots (armed) pane
+	  (unless (eq armed :active)
+	    (with-sheet-medium (medium pane)
+	      (setq armed :active)
+	      (highlight-button pane medium))
+	    (armed-callback pane (gadget-client pane) (gadget-id pane))))))))
+
+(defmethod handle-event ((pane pull-down-menu-button) (event pointer-exit-event))
+  (when (port pane)				;the menu is often disabled...
+    (with-slots (armed) pane
+      (when armed
+	(with-sheet-medium (medium pane)
+	  (setq armed nil)
+	  (highlight-button pane medium))
+	(disarmed-callback pane (gadget-client pane) (gadget-id pane))))))
+
+(defmethod handle-event ((pane pull-down-menu-button) (event pointer-motion-event))
+  (with-slots (next-menu x-margin normal-pattern) pane
+    (when next-menu
+      (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+	(declare (ignore top right bottom))
+	(let* ((pattern-width (pattern-width normal-pattern))
+	       (sensitive-region 16)
+	       (x (pointer-event-x event)))
+	  (when (and next-menu (> x (- (+ left x-margin pattern-width) sensitive-region)))
+	    (if (typep next-menu 'pull-down-menu)
+		(choose-from-pull-down-menu next-menu pane :cascade-p t)
+		(funcall next-menu pane))))))))
+
+;; We really shouldn't ever get one of these - the button must have been down
+;; for us to get here.
+(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-press-event))
+  )
+
+(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-release-event))
+  (with-slots (armed) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (with-sheet-medium (medium pane)
+	(highlight-button pane medium))
+      (activate-callback pane (gadget-client pane) (gadget-id pane))
+      ;;--- This modularity is a bit dubious.  Oh well.
+      (throw 'exit-pull-down-menu (values)))))
+
+
+;;; Pull-down menu sheets
+
+(defclass popup-menu-sheet 
+	  (sheet-permanently-enabled-mixin
+	   sheet-single-child-mixin
+	   wrapping-space-mixin
+	   space-requirement-mixin
+	   basic-pane)
+    ()
+  (:default-initargs :medium t))
+
+(defclass pull-down-menu (popup-menu-sheet)
+    ((current-button :initform nil)
+     (buttons :initarg :buttons :accessor pull-down-menu-buttons)
+     (entered :initarg nil :accessor pull-down-menu-entered))
+  (:default-initargs :buttons nil))
+
+(defmethod handle-repaint :after ((pane pull-down-menu) region)
+  (dolist (button (slot-value pane 'buttons))
+    (handle-repaint button region)))
+
+(defmethod handle-event ((pane pull-down-menu) (event pointer-motion-event))
+  (when (and (plusp (pointer-event-x event))
+	     (plusp (pointer-event-y event)))
+    (setf (pull-down-menu-entered pane) t)))
+
+(defmethod handle-event ((pane pull-down-menu) (event pointer-button-press-event))
+  )
+
+(defmethod handle-event ((pane pull-down-menu) (event pointer-button-release-event))
+  )
+
+(defmethod handle-event ((pane pull-down-menu) (event pointer-enter-event))
+  (when (and (plusp (pointer-event-x event))
+	     (plusp (pointer-event-y event)))
+    (setf (pull-down-menu-entered pane) t)))
+
+(defmethod handle-event ((pane pull-down-menu) (event pointer-exit-event))
+  ;; Don't punt if we've never entered the menu, or if we are entering
+  ;; one of the buttons within the menu
+  (when (and (pull-down-menu-entered pane)
+	     (not (eq (pointer-boundary-event-kind event) :inferior)))
+    (throw 'exit-pull-down-menu (values))))
+
+(defmethod handle-event :after ((pane pull-down-menu) (event pointer-event))
+  (deallocate-event event))
+
+
+;;; Interface to pull-down menus 
+
+(define-application-frame pull-down-menu-frame ()
+    (menu)
+  (:pane
+    (with-slots (menu) *application-frame*
+      (outlining ()
+	(setq menu (make-pane 'pull-down-menu
+		     :width 100 :height 100)))))
+  (:menu-bar nil))
+
+(defun make-pull-down-menu (&key port)
+  (let ((frame (make-application-frame 'pull-down-menu-frame
+				       :frame-manager (find-frame-manager :port port)
+				       :save-under t)))
+    (values (slot-value frame 'menu) frame)))
+
+;; Pull-down menus share their event queue with the owning application
+(defresource pull-down-menu (port)
+  :constructor (make-pull-down-menu :port port)
+  :matcher (eq (port pull-down-menu) port)
+  :deinitializer 
+    (progn
+      (setf (pull-down-menu-buttons pull-down-menu) nil)
+      (setf (pull-down-menu-entered pull-down-menu) nil)
+      (dolist (child (sheet-children pull-down-menu))
+	(sheet-disown-child pull-down-menu child))))
+
+(defmacro initialize-pull-down-menu (menu &body buttons)
+  (assert (= (length buttons) 1))
+  `(with-look-and-feel-realization ()
+     (setf (pull-down-menu-buttons ,menu) ,@buttons)
+     (sheet-adopt-child ,menu (make-pane 'vbox-pane
+				:contents (pull-down-menu-buttons ,menu)
+				:spacing 0))
+     (layout-frame (pane-frame ,menu))
+     ,menu))
+
+(defvar *subsidiary-pull-down-menu* nil)
+(defun choose-from-pull-down-menu (menu &optional button &key cascade-p)
+  (let ((menu-frame (pane-frame menu))
+	(event-queue (sheet-event-queue menu)))
+    (when button
+      (with-bounding-rectangle* (bleft btop bright bbottom)
+	  (sheet-device-region button)
+	(declare (ignore bright))
+	(multiple-value-bind (fleft ftop fright fbottom)
+	    (let ((tls (get-top-level-sheet button)))
+	      (mirror-region* (port tls) tls))
+	  (declare (ignore fright fbottom))
+	  (if cascade-p
+	      (let ((pattern-width (pattern-width (slot-value button 'normal-pattern)))
+		    (button-x-margin (slot-value button 'x-margin)))
+		(move-sheet (frame-top-level-sheet menu-frame)
+			    (+ bleft fleft pattern-width button-x-margin -16)
+			    (+ btop ftop)))
+	      (move-sheet (frame-top-level-sheet menu-frame)
+			  (+ bleft fleft 10)
+			  (+ bbottom ftop -10))))))
+    (enable-frame menu-frame)
+    ;; Share the event queue with the application frame
+    (setf (sheet-event-queue (frame-top-level-sheet (pane-frame menu)))
+	  (sheet-event-queue (frame-top-level-sheet *application-frame*)))
+    ;; Ensure no surprise exit events
+    (setf (pull-down-menu-entered menu) nil)
+    ;; Wait for an event and then handle it
+    (unwind-protect
+	(flet ((waiter ()
+		 (not (queue-empty-p event-queue))))
+	  #-Allegro (declare (dynamic-extent #'waiter))
+	  (catch (if *subsidiary-pull-down-menu* 
+		     '|Not exit-pull-down-menu|
+		     'exit-pull-down-menu)
+	    (let ((*subsidiary-pull-down-menu* t))
+	      (loop
+		(port-event-wait (port menu) #'waiter)
+		(let ((event (queue-get event-queue)))
+		  (handle-event (event-sheet event) event))))))
+      (disable-frame menu-frame))))
+
+;;--- Kludge alert
+(defun get-top-level-sheet (pane)
+  (if (typep pane 'top-level-sheet)
+      pane
+      (get-top-level-sheet (sheet-parent pane))))
+
+
+;;; Menu bars
+
+(defclass menu-bar-pane (menu-bar)
+    ())
+
+;;--- What about when the command menu tick changes?
+;;--- What about graying of disabled commands?
+(defun compute-menu-bar-pane (frame command-table)
+  (let* ((text-style (and (listp command-table)
+			 (getf (cdr command-table) :text-style)
+			 `(:text-style ,(getf (cdr command-table) :text-style))))
+	 (command-table (if (listp command-table) (car command-table) command-table)))
+    (when (eq command-table 't)
+      (setq command-table (frame-command-table frame)))
+    (with-look-and-feel-realization ((frame-manager frame) frame)
+      (labels
+	((make-command-table-buttons (command-table top-level)
+	   (let ((buttons nil))
+	     (map-over-command-table-menu-items
+	       #'(lambda (menu keystroke item)
+		   (let ((type (command-menu-item-type item))
+			 (value (command-menu-item-value item)))
+		     (case type
+		       (:command 
+			 (push (apply #'make-pane
+				      (if top-level 'push-button 'pull-down-menu-button)
+				      :label menu
+				      :activate-callback
+					#'(lambda (button)
+					    (menu-bar-command-callback
+					      button command-table value))
+				      text-style)
+			       buttons))
+		       (:function
+			 ;;--- Do something about this
+			 )
+		       (:menu
+			 (push (apply #'make-pane
+				      (if top-level 'menu-bar-button 'pull-down-menu-button)
+				      :label menu
+				      :next-menu (make-command-table-menu value nil)
+				      :activate-callback nil
+				      text-style)
+			       buttons))
+		       (:divider
+			 (unless top-level
+			   ;;--- Do something about this
+			   )))))
+	       command-table)
+	     (nreverse buttons)))
+	 (make-command-table-menu (command-table top-level)
+	   (let ((buttons (make-command-table-buttons command-table top-level)))
+	     (if top-level
+		 (outlining ()
+		   (make-pane 'hbox-pane :contents buttons))
+		 (let ((menu (make-pull-down-menu :port (port frame))))
+		   (initialize-pull-down-menu menu buttons)
+		   menu)))))
+	(declare (dynamic-extent #'make-command-table-buttons #'make-command-table-menu))
+	(make-command-table-menu command-table t)))))
+
+(defun menu-bar-command-callback (button command-table command)
+  (let ((frame (pane-frame button)))
+    (distribute-event
+      (port button)
+      (allocate-event 'presentation-event
+	:frame frame
+	:sheet (frame-top-level-sheet frame)
+	:presentation-type `(command :command-table ,command-table)
+	:value command))))
diff --git a/homegrown/db-slider.lisp b/homegrown/db-slider.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..59f38e2ac2d9c785f0623bdc44fc54a20fea6eaa
--- /dev/null
+++ b/homegrown/db-slider.lisp
@@ -0,0 +1,472 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-slider.lisp,v 1.18 1993/07/27 01:50:34 colin Exp $
+
+"Copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :silica)
+
+;;; Sliders
+
+;; To Do:
+;; 
+;; We should somehow support mini-sliders that conveniently fit on one
+;; line.  This is certainly easy to do and I think I know how I'd like
+;; them to look - but we should wait till some of the other gadgets are
+;; done so we can give all the mini-gadgets the same look and feel.
+;; 
+;; We should do a multipane implementation of this where the slider rail
+;; and end stops are in different panes. This would make it easier to add
+;; a type-in current value field.
+;; 
+;; We should make disable/graying work
+;; 
+;; We should make indeterminate state work
+
+(defparameter *default-horizontal-slider-pattern*
+	      (make-pattern #2A((0 0 0 0 0 0 0 0 0 0 0 0)
+				(0 1 1 1 1 1 1 1 1 1 0 0)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 0 0 0 0 1 0 0 0 0 1 1)
+				(1 1 0 0 0 1 0 0 0 1 1 1)
+				(0 1 1 1 1 1 1 1 1 1 1 1)
+				(0 1 1 1 1 1 1 1 1 1 1 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *default-vertical-slider-pattern*
+	      (make-pattern #2a((0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0) 
+				(0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1) 
+				(0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1) 
+				(0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) 
+				(0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0))
+			    (list +background-ink+ +foreground-ink+)))
+
+(defparameter *slider-rail-thickness* 6)
+(defparameter *slider-rail-ink* (make-gray-color 2/3))
+(defparameter *slider-tick-mark-height* 4)
+(defparameter *slider-tick-mark-offset* 4)
+(defparameter *slider-range-label-offset* 2)
+
+
+(defclass slider-pane 
+	  (slider
+	   space-requirement-mixin
+	   leaf-pane)
+    ((label-width :initform 0)
+     (label-height :initform 0)
+     (visible-value-width :initform 0)
+     (visible-value-height :initform 0)
+     (margin :initform 8)
+     (slider-button-pattern :initarg :slider-button-pattern :initform nil)
+     ;; ARMED has three states:
+     ;;  NIL ==> the slider is not armed
+     ;;  T   ==> the slider is armed, waiting for a pointer button press
+     ;;  :ACTIVE ==> the slider is armed, waiting for a pointer button release
+     (armed :initform nil)
+     (background-saved-p :initform nil)
+     (saved-background :initform nil))
+  (:default-initargs :value 0
+		     :text-style *default-slider-label-text-style*))
+
+(defmethod initialize-instance :after ((pane slider-pane) &key &allow-other-keys)
+  (with-slots (slider-button-pattern) pane
+    (unless slider-button-pattern
+      (ecase (gadget-orientation pane)
+	(:vertical
+	  (setq slider-button-pattern *default-vertical-slider-pattern*)
+	  (setf (slot-value pane 'pointer-cursor) :vertical-thumb))
+	(:horizontal
+	  (setq slider-button-pattern *default-horizontal-slider-pattern*)
+	  (setf (slot-value pane 'pointer-cursor) :horizontal-thumb))))))
+
+(defmethod compose-space ((pane slider-pane) &key width height)
+  (declare (ignore width height))
+  (with-sheet-medium (medium pane)
+    (with-slots (slider-button-pattern label min-label max-label 
+		 text-style range-label-text-style label-width label-height 
+		 visible-value-width visible-value-height
+		 show-value-p number-of-tick-marks) pane
+      (let* ((pattern-width (pattern-width slider-button-pattern))
+	     (pattern-height (pattern-height slider-button-pattern))
+	     (margin (slot-value pane 'margin))
+	     (tick-dist (if (> number-of-tick-marks 0)
+			    (+ *slider-tick-mark-offset* *slider-tick-mark-height*)
+			    0))
+	     ;; Value width and height may one day have different text-styles from
+	     ;; the label text style
+	     (vwidth (* 10 (text-style-width text-style medium)))
+	     (vheight (text-style-height text-style medium)))
+	(multiple-value-bind (lwidth lheight)
+	    (compute-gadget-label-size pane)
+	  (setq label-width lwidth)
+	  (setq label-height lheight)
+	  (setq visible-value-width (if show-value-p vwidth 0))
+	  (setq visible-value-height (if show-value-p vheight 0))
+	  (ecase (gadget-orientation pane)
+	    (:vertical
+	      (let* ((max-length 
+		       (max (if min-label (length min-label) 0)
+			    (if max-label (length max-label) 0)))
+		     (range-label-width
+		       (if (or min-label max-label)
+			   (+ *slider-range-label-offset*
+			      (* max-length
+				 (text-style-width range-label-text-style medium))
+			      *slider-range-label-offset*)
+			   0))
+		     (rail-width (+ (ceiling *slider-rail-thickness* 2)
+				    (* 2 (+ 4 tick-dist range-label-width)))))
+		(make-space-requirement
+		  :width (max label-width visible-value-width
+			      (+ margin (max pattern-width rail-width) margin))
+		  :height (+ (+ label-height visible-value-height (* 3 pattern-height)) 100)
+		  :min-height (+ label-height visible-value-height (* 3 pattern-height))
+		  :max-height +fill+)))
+	    (:horizontal
+	      (let* ((range-label-height
+		       (if (or min-label max-label)
+			   (+ *slider-range-label-offset*
+			      (text-style-height range-label-text-style medium)
+			      *slider-range-label-offset*)
+			   0))
+		     (rail-height
+		       (+ (ceiling *slider-rail-thickness* 2) 4
+			  tick-dist range-label-height)))
+		(make-space-requirement
+		  :width (+ (+ label-width visible-value-width (* 3 pattern-width)) 100)
+		  :min-width (+ label-width visible-value-width (* 3 pattern-width))
+		  :max-width +fill+
+		  :height (+ margin (max pattern-height rail-height lheight) margin))))))))))
+
+
+(defmethod handle-repaint ((pane slider-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (draw-slider-rail pane medium)
+    (draw-slider-indicator pane medium :draw)
+    (draw-slider-label pane medium)
+    (when (slot-value pane 'show-value-p)
+      (draw-visible-value pane medium))))
+
+(defmethod draw-slider-rail ((pane slider-pane) medium)
+  (with-slots (label-width label-height text-style min-label max-label
+	       number-of-tick-marks margin visible-value-width visible-value-height) pane
+    (let ((region (sheet-region pane))
+	  (half-thickness (floor *slider-rail-thickness* 2)))
+      (with-bounding-rectangle* (left top right bottom) region
+	(let* ((center-x (floor (+ right left) 2))
+	       (center-y (floor (+ bottom top) 2))
+	       (offset 2)
+	       (tick-offset 
+		 (if (> number-of-tick-marks 0)
+		     (+ *slider-tick-mark-offset* *slider-tick-mark-height*)
+		     0))
+	       (label-offset
+		 (+ half-thickness tick-offset *slider-range-label-offset*)))
+	  (decf right) (decf bottom)
+	  (incf left margin) (incf top margin) (decf right margin) (decf bottom margin)
+	  (ecase (gadget-orientation pane)
+	    (:vertical
+	      (incf top (+ label-height visible-value-height))
+	      (draw-rectangle* medium
+			       (- center-x half-thickness) top
+			       (+ center-x half-thickness) bottom
+			       :filled t :ink *slider-rail-ink*)
+	      (draw-rectangle* medium
+			       (- center-x half-thickness) top
+			       (+ center-x half-thickness) bottom
+			       :filled nil)
+	      (draw-rectangle* medium
+			       (- center-x half-thickness offset) (- top offset)
+			       (+ center-x half-thickness offset) (+ bottom offset)
+			       :filled nil))
+	    (:horizontal
+	      (incf left (+ label-width visible-value-width))
+	      (draw-rectangle* medium
+			       left (- center-y half-thickness)
+			       right (+ center-y half-thickness)
+			       :filled t :ink *slider-rail-ink*)
+	      (draw-rectangle* medium
+			       left (- center-y half-thickness)
+			       right (+ center-y half-thickness)
+			       :filled nil)
+	      (draw-rectangle* medium
+			       (- left offset) (- center-y half-thickness offset) 
+			       (+ right offset) (+ center-y half-thickness offset)
+			       :filled nil)))
+	  ;; Must be after the ecase because of adjustments to left etc...
+	  (when (> number-of-tick-marks 0)
+	    (draw-slider-tick-marks
+	      pane medium center-x center-y tick-offset left top right bottom))
+	  (draw-slider-range-labels
+	    pane medium center-x center-y label-offset left top right bottom))))))
+
+(defmethod draw-slider-tick-marks ((pane slider-pane)
+				   medium center-x center-y tick-offset
+				   left top right bottom)
+  (with-slots (number-of-tick-marks) pane
+    (let ((half-thickness (floor *slider-rail-thickness* 2)))
+      (ecase (gadget-orientation pane)
+	(:vertical
+	  (dotimes (i number-of-tick-marks)
+	    (let ((y (compute-symmetric-value 0 number-of-tick-marks i top bottom)))
+	      (draw-line* medium
+			  (+ center-x half-thickness *slider-tick-mark-offset*) y
+			  (+ center-x half-thickness tick-offset) y
+			  :ink +foreground-ink+))))
+	(:horizontal
+	  (dotimes (i number-of-tick-marks)
+	    (let ((x (compute-symmetric-value 0 number-of-tick-marks i left right)))
+	      (draw-line* medium
+			  x (+ center-y half-thickness *slider-tick-mark-offset*)
+			  x (+ center-y half-thickness tick-offset)
+			  :ink +foreground-ink+))))))))
+
+(defmethod draw-slider-range-labels ((pane slider-pane)
+				     medium center-x center-y label-offset
+				     left top right bottom)
+  (with-slots (min-label max-label range-label-text-style) pane
+    (ecase (gadget-orientation pane)
+      (:vertical
+	(when max-label
+	  (draw-text* medium max-label (+ center-x label-offset) bottom
+		      :text-style range-label-text-style
+		      :align-x ':left :align-y ':bottom))
+	(when min-label
+	  (draw-text* medium min-label (+ center-x label-offset) top
+		      :text-style range-label-text-style
+		      :align-x ':left :align-y ':top)))
+      (:horizontal
+	(when min-label
+	  (draw-text* medium min-label left (+ center-y label-offset)
+		      :text-style range-label-text-style
+		      :align-x ':left :align-y ':top))
+	(when max-label
+	  (draw-text* medium max-label right (+ center-y label-offset)
+		      :text-style range-label-text-style
+		      :align-x ':right :align-y ':top))))))
+
+(defmethod draw-slider-indicator ((pane slider-pane) medium action)
+  (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+    (with-slots (min-value max-value label-width margin slider-button-pattern
+		 visible-value-width background-saved-p saved-background
+		 label-height visible-value-height) pane
+      (let* ((value (gadget-value pane))
+	     (normal-value (compute-symmetric-value min-value max-value value 0 1))
+	     (pattern-width (pattern-width slider-button-pattern))
+	     (pattern-height (pattern-height slider-button-pattern))
+	     width height x y)
+	(ecase (gadget-orientation pane)
+	  (:vertical
+	    (setq width (- right left)
+		  height (- bottom top label-height visible-value-height margin margin)
+		  x (- (floor width 2) (floor pattern-width 2))
+		  y (- (+ top margin label-height visible-value-height (* height normal-value))
+		       (floor pattern-height 2))))
+	  (:horizontal
+	    (setq width (- right left label-width visible-value-width margin margin)
+		  height (- bottom top)
+		  y (- (floor height 2) (floor pattern-height 2))
+		  x (- (+ left label-width visible-value-width margin (* width normal-value))
+		       (floor pattern-width 2)))))
+	(ecase action
+	  (:draw
+	    (when (null saved-background)
+	      (setq saved-background 
+		    (allocate-pixmap medium pattern-width pattern-height)))
+	    (copy-to-pixmap medium x y pattern-width pattern-height
+			    saved-background)
+	    (setq background-saved-p t)
+	    (draw-pattern* medium slider-button-pattern x y))
+	  (:erase
+	    (if background-saved-p
+		(progn
+		  (copy-from-pixmap saved-background 0 0 pattern-width pattern-height
+				    medium x y)
+		  (setq background-saved-p nil))
+		(draw-slider-rail pane medium))))))))
+
+(defmethod draw-slider-label ((pane slider-pane) medium)
+  (with-slots (label-height margin) pane
+    (let ((region (sheet-region pane)))
+      (with-bounding-rectangle* (left top right bottom) region
+	right
+	(ecase (gadget-orientation pane)
+	  (:vertical
+	    (draw-gadget-label pane medium
+			       (floor (+ left right) 2) (+ top label-height)
+			       :align-x ':center :align-y ':bottom))
+	  (:horizontal
+	    (draw-gadget-label pane medium
+			       (+ left margin) (floor (+ bottom top) 2)
+			       :align-x ':left :align-y ':center)))))))
+
+(defmethod draw-visible-value ((pane slider-pane) medium)
+  (with-slots (text-style margin label-width label-height
+	       visible-value-width visible-value-height 
+	       slider-button-pattern decimal-places) pane
+    (let* ((region (sheet-region pane))
+	   (pattern-width (pattern-width slider-button-pattern))
+	   (pattern-height (pattern-height slider-button-pattern))
+	   (x-offset (- (floor pattern-width 2)))
+	   (y-offset (- (floor pattern-height 2)))
+	   (value (gadget-value pane))
+	   (places (expt 10 decimal-places)))
+      ;; Float it so that it looks better in the display
+      (setq value (float (/ (round (* value places)) places)))
+      (with-bounding-rectangle* (left top right bottom) region
+	(ecase (gadget-orientation pane)
+	  (:vertical
+	    (medium-clear-area 
+	      medium
+	      left (+ top label-height)
+	      right (+ top margin label-height visible-value-height y-offset))
+	    (draw-text* medium (format nil "~A" value)
+			(floor (+ left right) 2) (+ top label-height visible-value-height)
+			:text-style text-style
+			:align-x ':center :align-y ':bottom))
+	  (:horizontal
+	    (medium-clear-area
+	      medium 
+	      (+ left margin label-width) top
+	      (+ left margin label-width visible-value-width x-offset) bottom)
+	    (draw-text* medium (format nil "~A" value)
+			(+ left margin label-width) (+ top (floor (- bottom top) 2))
+			:text-style text-style
+			:align-x ':left :align-y ':center)))))))
+
+
+(defmethod handle-event :around ((pane slider-pane) (event pointer-event))
+  (when (gadget-active-p pane)
+    (call-next-method))
+  (deallocate-event event))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-enter-event))
+  (declare (special *pointer-documentation-output*))
+  (with-slots (armed) pane
+    (unless armed
+      (setf armed t)
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))
+    (frame-manager-display-pointer-documentation-string
+      (frame-manager pane) (pane-frame pane) *pointer-documentation-output*
+      "L,M,R: Move the slider indicator.")))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-exit-event))
+  (declare (special *pointer-documentation-output*))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed nil)
+      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))
+    (frame-manager-display-pointer-documentation-string
+      (frame-manager pane) (pane-frame pane) *pointer-documentation-output* nil)))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-button-press-event))
+  (with-slots (armed margin visible-value-width visible-value-height
+	       show-value-p label-width label-height) pane
+    (when armed
+      (setf armed :active)
+      (let ((x (pointer-event-x event))
+	    (y (pointer-event-y event)))
+	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+	  (ecase (gadget-orientation pane)
+	    (:vertical
+	      (update-slider-value pane y
+				   (+ top margin label-height visible-value-height)
+				   (- bottom margin)))
+	    (:horizontal
+	      (update-slider-value pane x
+				   (+ left margin label-width visible-value-width)
+				   (- right margin))))))
+      (when show-value-p
+	(with-sheet-medium (medium pane)
+	  (draw-visible-value pane medium))))))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-button-release-event))
+  (with-slots (armed margin visible-value-width visible-value-height
+	       show-value-p label-width label-height) pane
+    (when (eq armed :active)
+      (setf armed t)
+      (let ((x (pointer-event-x event))
+	    (y (pointer-event-y event)))
+	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+	  (ecase (gadget-orientation pane)
+	    (:vertical
+	      (update-slider-value pane y 
+				   (+ top margin label-height visible-value-height)
+				   (- bottom margin)))
+	    (:horizontal
+	      (update-slider-value pane x
+				   (+ left margin label-width visible-value-width)
+				   (- right margin))))))
+      (when show-value-p
+	(with-sheet-medium (medium pane)
+	  (draw-visible-value pane medium)))
+      (value-changed-callback
+	pane (gadget-client pane) (gadget-id pane) (gadget-value pane)))))
+
+(defmethod handle-event ((pane slider-pane) (event pointer-motion-event))
+  (with-slots (armed margin visible-value-width visible-value-height
+	       show-value-p label-width label-height) pane
+    (when (eq armed :active)
+      (let ((old-value (gadget-value pane))
+	    (x (pointer-event-x event))
+	    (y (pointer-event-y event)))
+	(with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+	  (ecase (gadget-orientation pane)
+	    (:vertical
+	      (update-slider-value pane y 
+				   (+ top margin label-height visible-value-height)
+				   (- bottom margin)))
+	    (:horizontal
+	      (update-slider-value pane x
+				   (+ left margin label-width visible-value-width)
+				   (- right margin)))))
+	(unless (eq old-value (gadget-value pane))
+	  (when show-value-p
+	    (with-sheet-medium (medium pane)
+	      (draw-visible-value pane medium)))
+	  (drag-callback
+	    pane (gadget-client pane) (gadget-id pane) (gadget-value pane)))))))
+
+(defmethod update-slider-value ((pane slider-pane) coord min max)
+  (with-slots (min-value max-value number-of-quanta) pane
+    (let* ((value (max min-value
+		       (min max-value
+			    (compute-symmetric-value min max coord min-value max-value)))))
+      (when number-of-quanta
+	(let ((quanta-size (/ (abs (- max-value min-value)) number-of-quanta)))
+	  (setq value (* quanta-size (round (/ value (float quanta-size)))))))
+      (setf (gadget-value pane) value))))
+
+(defmethod (setf gadget-value) :around (value (pane slider-pane) &key invoke-callback)
+  (declare (ignore value invoke-callback))
+  (if (port pane)
+      (with-sheet-medium (medium pane)
+	(draw-slider-indicator pane medium :erase)
+	(call-next-method)
+	(draw-slider-indicator pane medium :draw)
+	(when (slot-value pane 'show-value-p)
+	  (draw-visible-value pane medium)))
+      (call-next-method)))
+
diff --git a/homegrown/db-text.lisp b/homegrown/db-text.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..b8c19a87985cba0ea0943ee70f2713dddf06a52c
--- /dev/null
+++ b/homegrown/db-text.lisp
@@ -0,0 +1,128 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: db-text.lisp,v 1.8 1993/07/27 01:38:56 colin Exp $
+
+"Copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :clim-internals)
+
+(defun pop-up-text-editor (&key initial-contents prompt
+				(exit-gesture '(:end))
+				(width '(60 :character)) (height '(10 :line)))
+  (with-menu (stream)
+    ;; First set up the pop-up window the way we want to see it
+    (setf (cursor-visibility (stream-text-cursor stream)) :off)
+    (when prompt
+      (with-text-face (stream :italic)
+	(write-string prompt stream))
+      (fresh-line stream))
+    (let ((width (process-spacing-arg stream width 'pop-up-text-editor :width))
+	  (height (process-spacing-arg stream height 'pop-up-text-editor :height)))
+      (window-set-inside-size stream width height))
+    (setf (stream-text-margin stream) (bounding-rectangle-width (window-viewport stream)))
+    (setf (window-visibility stream) t)
+    ;; Now edit the text
+    (unwind-protect
+	(do-text-editing stream 
+			 :initial-contents initial-contents :exit-gesture exit-gesture)
+      (setf (window-visibility stream) nil)
+      (setf (cursor-visibility (stream-text-cursor stream)) nil))))
+
+(defun do-text-editing (stream &key initial-contents clear (exit-gesture '(:end)))
+  (with-clim-state-reset (:all t
+			  :encapsulating-streams nil)
+    (when clear
+      (window-clear stream))
+    (with-input-focus (stream)
+      (with-input-editing (stream :initial-contents initial-contents)
+	(with-activation-gestures (exit-gesture :override t)
+	  (unwind-protect
+	      (read-token stream)
+	    ;; Eat the activation character
+	    (read-gesture :stream stream :timeout 0)))))))
+
+
+;;; Text field and text editor gadgets
+
+;; Requires TEXT-FIELD-PANE or TEXT-EDITOR-PANE
+(defclass text-editor-mixin 
+	  ;;--- It's awful that we need these to be CLIM streams
+	  (clim-stream-pane) 
+    ()
+  (:default-initargs :draw-p t :record-p nil
+		     :pointer-cursor :prompt))
+
+(defmethod handle-repaint :around ((pane text-editor-mixin) region)
+  (declare (ignore region))
+  (call-next-method)
+  (stream-set-cursor-position pane 0 0)
+  (write-string (gadget-value pane) pane))
+
+;;--- Grotesque kludge to subvert RECEIVE-GESTURE mechanism
+(defmethod receive-gesture :around ((pane text-editor-mixin) (event event))
+  (process-event-locally pane event)
+  nil)
+
+(defmethod handle-event :around ((pane text-editor-mixin) (event pointer-event))
+  (when (gadget-active-p pane)
+    (call-next-method))
+  (deallocate-event event))
+
+(defmethod handle-event ((pane text-editor-mixin) (event pointer-enter-event))
+  (with-slots (armed) pane
+    (unless armed
+      (setf armed t)
+      (armed-callback pane (gadget-client pane) (gadget-id pane)))
+    (when (eq (port-input-focus-selection (port pane)) :sheet-under-pointer)
+      (edit-text-field pane))))
+
+(defmethod handle-event ((pane text-editor-mixin) (event pointer-exit-event))
+  (with-slots (armed) pane
+    (when armed
+      (setf armed nil)
+      (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))
+
+(defun edit-text-field (pane)
+  (let ((string
+	  (do-text-editing pane :initial-contents (gadget-value pane) :clear t)))
+    (setf (gadget-value pane :invoke-callback t) string)))
+
+
+(defclass text-field-pane (text-field
+			   text-editor-mixin)
+    ())
+
+(defmethod compose-space ((pane text-field-pane) &key width height)
+  (declare (ignore width height))
+  (with-sheet-medium (medium pane)
+    (let* ((style (medium-default-text-style medium))
+	   (style-width (text-style-width style medium))
+	   (style-height (text-style-height style medium))
+	   (string (gadget-value pane)))
+      (multiple-value-bind (width height)
+	  (if string 
+	      (text-size pane string :text-style style)
+	      (values (* style-width 20) style-height))
+	(make-space-requirement :width width :height height)))))
+
+(defmethod handle-event ((pane text-field-pane) (event pointer-button-press-event))
+  (edit-text-field pane))
+
+
+(defclass text-editor-pane (text-editor
+			    text-editor-mixin)
+    ())
+
+(defmethod compose-space ((pane text-editor-pane) &key width height)
+  (declare (ignore width height))
+  (with-sheet-medium (medium pane)
+    (let* ((style (medium-default-text-style medium))
+	   (style-width (text-style-width style medium))
+	   (style-height (text-style-height style medium)))
+      (make-space-requirement
+	:width (* style-width (gadget-columns pane))
+	:height (* style-height (gadget-lines pane))))))
+
+(defmethod handle-event ((pane text-editor-pane) (event pointer-button-press-event))
+  (when (gadget-editable-p pane)
+    (edit-text-field pane)))
diff --git a/homegrown/last.lisp b/homegrown/last.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..f410d4b01770a75ff4f0c3989098ce0635881ebd
--- /dev/null
+++ b/homegrown/last.lisp
@@ -0,0 +1,29 @@
+;; -*- mode: common-lisp; package: silica -*-
+;;
+;;				-[Thu Jul 22 17:16:08 1993 by colin]-
+;; 
+;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA  All rights reserved.
+;; copyright (c) 1986-1992 Franz Inc, Berkeley, CA  All rights reserved.
+;;
+;; The software, data and information contained herein are proprietary
+;; to, and comprise valuable trade secrets of, Franz, Inc.  They are
+;; given in confidence by Franz, Inc. pursuant to a written license
+;; agreement, and may be stored and used only in accordance with the terms
+;; of such license.
+;;
+;; Restricted Rights Legend
+;; ------------------------
+;; Use, duplication, and disclosure of the software, data and information
+;; contained herein by any agency, department or entity of the U.S.
+;; Government are subject to restrictions of Restricted Rights for
+;; Commercial Software developed at private expense as specified in FAR
+;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
+;; applicable.
+;;
+;; $fiHeader:$
+
+(in-package :silica)
+
+(provide :climgg)
+
+
diff --git a/homegrown/scroll-pane.lisp b/homegrown/scroll-pane.lisp
new file mode 100644
index 0000000000000000000000000000000000000000..170ed25365637f31244c17f2fd9d317bd4e1d2dd
--- /dev/null
+++ b/homegrown/scroll-pane.lisp
@@ -0,0 +1,657 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: scroll-pane.lisp,v 1.6 1993/07/27 01:51:08 colin Exp $
+
+"Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
+ Portions copyright(c) 1991, 1992 International Lisp Associates.
+ Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
+
+(in-package :silica)
+
+
+;; An implementation of a scroller pane
+(defclass generic-scroller-pane ( 
+				 wrapping-space-mixin
+				 permanent-medium-sheet-output-mixin
+				 pane-repaint-background-mixin
+				 layout-pane
+				 scroller-pane)
+    ())
+
+(defmethod handle-event :after ((pane generic-scroller-pane) (event pointer-motion-event))
+  (deallocate-event event))
+
+(defmethod allocate-space :before ((scroller generic-scroller-pane) width height)
+  (declare (ignore width height))
+  ;; Adjust the status of the scrollbars
+  (multiple-value-bind (changedp 
+			hscroll-bar hscroll-bar-enabled-p
+			vscroll-bar vscroll-bar-enabled-p)
+      (compute-dynamic-scroll-bar-values scroller)
+    (when changedp
+      (update-dynamic-scroll-bars scroller changedp
+				  hscroll-bar hscroll-bar-enabled-p
+				  vscroll-bar vscroll-bar-enabled-p))))
+
+(defmethod compose-space ((scroller generic-scroller-pane) &key width height)
+  (declare (ignore width height))
+  (let ((sr (call-next-method)))
+    (multiple-value-bind (width min-width max-width
+			  height min-height max-height)
+	(space-requirement-components sr)
+      (if (or (< width 50) (< height 50))
+	  ;; Make sure the scroller pane is big enough to hold something
+	  (make-space-requirement
+	    :width (max width 50)
+	    :min-width (max min-width 50)
+	    :max-width (max max-width 50)
+	    :height (max height 50)
+	    :min-height (max min-height 50)
+	    :max-height (max max-height 50))
+	  sr))))
+
+;;--- Ideally we should use a toolkit scrolling window. This will look
+;;--- exactly right and will deal with user specified placement of scroll-bars.
+;;--- However the geometry management problems are quite huge.
+(defmethod initialize-instance :after ((pane generic-scroller-pane) 
+				       &key contents frame-manager frame
+					    scroll-bars)
+  (let ((scroller (gadget-supplied-scrolling frame-manager frame contents
+					     :scroll-bars scroll-bars)))
+    (if scroller
+	(progn
+	  (sheet-adopt-child pane scroller)
+	  (setf (slot-value pane 'scrolling-supplied-by-gadget) t)
+	  scroller)
+	(progn
+	  (check-type scroll-bars
+		      (member t :both :dynamic :vertical :horizontal))
+	  (with-slots (vertical-scroll-bar horizontal-scroll-bar
+		       (c contents) viewport foreground background) pane
+	    (with-look-and-feel-realization (frame-manager frame)
+	      (let ((verticalp
+		      (member scroll-bars '(t :both :dynamic :vertical)))
+		    (horizontalp
+		      (member scroll-bars '(t :both :dynamic :horizontal))))
+		(setf vertical-scroll-bar 
+		      (and verticalp
+			   (make-pane 'scroll-bar 
+			     :orientation :vertical
+			     :id :vertical
+			     :client pane
+			     :background background
+ 			     :foreground foreground
+			     :shared-medium-sheet pane))
+		      horizontal-scroll-bar 	    
+		      (and horizontalp
+			   (make-pane 'scroll-bar 
+			     :orientation :horizontal
+			     :id :horizontal
+			     :background background
+ 			     :foreground foreground
+			     :client pane
+			     :shared-medium-sheet pane))
+		      c contents
+		      viewport (make-pane 'viewport :scroller-pane pane))
+		(sheet-adopt-child
+		  pane
+		  (cond ((and horizontalp verticalp)
+			 (tabling ()
+			   (viewport vertical-scroll-bar)
+			   (horizontal-scroll-bar nil)))
+			(verticalp
+			 (horizontally ()
+			   viewport
+			   vertical-scroll-bar))
+			(horizontalp
+			 (vertically ()
+			   viewport
+			   horizontal-scroll-bar))
+			(t (error "Internal error laying out scroll bars"))))
+		(sheet-adopt-child viewport c)
+		;;--- Add callbacks
+		)))))))
+
+
+;;; Home-grown scroll bars
+
+(defparameter *scroll-shaft-thickness-ink* 12)
+
+;;--- unit-increment, page-increment.
+(defclass scroll-bar-pane
+	  (scroll-bar
+	   sheet-permanently-enabled-mixin
+	   wrapping-space-mixin
+	   immediate-sheet-input-mixin
+	   sheet-multiple-child-mixin
+	   space-requirement-mixin
+	   shared-medium-sheet-output-mixin
+	   basic-pane)
+    ((shaft-thickness :initarg :shaft-thickness)
+     (min-target-pane :initform nil)
+     (max-target-pane :initform nil)
+     (shaft-pane :initform nil))
+  (:default-initargs :value 0
+		     :shaft-thickness *scroll-shaft-thickness-ink*))
+
+(defmethod initialize-instance :after ((pane scroll-bar-pane)
+				       &key orientation shaft-thickness
+					    frame-manager frame)
+  (with-slots (min-target-pane max-target-pane shaft-pane
+	       shared-medium-sheet foreground background) pane
+    (with-look-and-feel-realization (frame-manager frame)
+      (let ((inferiors
+	      (ecase orientation
+		(:vertical
+		  (spacing (:thickness 1)
+		    (vertically ()
+		      (setq min-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :less-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq shaft-pane 
+			    (make-pane 'scroll-bar-shaft-pane 
+			      :scroll-bar pane
+			      :width shaft-thickness
+			      :height 0
+			      :max-height +fill+
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq max-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :greater-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet)))))
+		(:horizontal
+		  (spacing (:thickness 1)
+		    (horizontally ()
+		      (setq min-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :less-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq shaft-pane 
+			    (make-pane 'scroll-bar-shaft-pane
+			      :scroll-bar pane
+			      :width 0
+			      :max-width +fill+
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))
+		      (setq max-target-pane
+			    (make-pane 'scroll-bar-target-pane
+			      :scroll-bar pane
+			      :end :greater-than
+			      :width shaft-thickness
+			      :height shaft-thickness
+			      :background background
+			      :foreground foreground
+			      :shared-medium-sheet shared-medium-sheet))))))))
+	(sheet-adopt-child pane inferiors)))))
+
+(defmethod handle-event :after ((pane scroll-bar-pane) (event pointer-event))
+  (deallocate-event event))
+
+
+(defmethod contents-range ((scroller generic-scroller-pane) orientation)
+  (with-slots (viewport) scroller
+    (with-bounding-rectangle* (left top right bottom) 
+	(viewport-contents-extent viewport)
+      (ecase orientation
+	(:horizontal (- right left))
+	(:vertical (- bottom top))))))
+
+(defmethod viewport-range ((scroller generic-scroller-pane) orientation)
+  (with-slots (viewport) scroller
+    (with-bounding-rectangle* (left top right bottom) 
+	(viewport-viewport-region viewport)
+      (ecase orientation
+	(:horizontal (- right left))
+	(:vertical (- bottom top))))))
+
+(defmethod scroll-up-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value port) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (line-value (if (= contents-range 0)
+			     0
+			     (the single-float
+			       (/ (line-scroll-amount scroller-pane orientation :up)
+				  (float contents-range  0.0s0)))))
+	     (new-value (max 0.0 (- current-value line-value))))	
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-down-line-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value port) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (line-value (if (= contents-range 0)
+			     0
+			     (the single-float
+			       (/ (line-scroll-amount scroller-pane orientation :down)
+				  (float contents-range  0.0s0)))))
+	     (new-value (+ current-value line-value)))
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-up-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (viewport-range (bounding-rectangle-max-y viewport))
+	     new-value)
+	(if (zerop contents-range)
+	    (setq new-value current-value)
+	    (let ((page-value (the single-float 
+				(/ viewport-range (float contents-range 0.0s0)))))
+	      (setq new-value (max 0.0 (- current-value page-value)))))
+	(scroll-bar-value-changed-callback
+	  scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-down-page-callback ((scroll-bar scroll-bar-pane) scroller-pane orientation)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      (let* ((contents-range (contents-range scroller-pane orientation))
+	     (viewport-range (bounding-rectangle-max-y viewport))
+	     new-value)
+      (if (zerop contents-range)
+	  (setq new-value current-value)
+	  (let ((page-value (the single-float 
+			      (/ viewport-range (float contents-range 0.0s0)))))
+	    (setq new-value (+ current-value page-value))))
+      (scroll-bar-value-changed-callback
+	scroll-bar scroller-pane orientation new-value current-size)))))
+
+(defmethod scroll-to-top-callback ((scroll-bar scroll-bar-pane) client id)
+  (with-slots (current-size current-value) scroll-bar
+    (scroll-bar-value-changed-callback scroll-bar client id 0 current-size)))
+
+(defmethod scroll-to-bottom-callback ((scroll-bar scroll-bar-pane) client id)
+  (with-slots (current-size current-value) scroll-bar
+    (scroll-bar-value-changed-callback
+      scroll-bar client id 1.0 current-size)))
+
+(defmethod scroll-line-to-top-callback ((scroll-bar scroll-bar-pane)
+					scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if it's not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(with-bounding-rectangle* (vleft vtop vright vbottom)
+	    (viewport-viewport-region viewport) 
+	  (declare (ignore vright vbottom))
+	  (with-bounding-rectangle* (cleft ctop cright cbottom)
+	      (viewport-contents-extent viewport) 
+	    (declare (ignore cright cbottom))
+	    (let ((contents-range (contents-range scroller-pane orientation)))
+	      (unless (zerop contents-range)
+		(let* ((viewport-range (viewport-range scroller-pane orientation))
+		       (contents-min
+			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
+		       (viewport-min
+			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
+		       (mouse-offset
+			 (ecase orientation
+			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
+		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
+				  contents-min)
+			       contents-range)))
+		  (scroll-bar-value-changed-callback
+		    scroll-bar scroller-pane id
+		    pos current-size))))))))))
+
+(defmethod scroll-line-to-bottom-callback ((scroll-bar scroll-bar-pane)
+					   scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if its not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(with-bounding-rectangle* (vleft vtop vright vbottom)
+	    (viewport-viewport-region viewport) 
+	  (declare (ignore vright vbottom))
+	  (with-bounding-rectangle* (cleft ctop cright cbottom)
+	      (viewport-contents-extent viewport) 
+	    (declare (ignore cright cbottom))
+	    (let ((contents-range (contents-range scroller-pane orientation)))
+	      (unless (zerop contents-range)
+		(let* ((viewport-range (viewport-range scroller-pane orientation))
+		       (contents-min
+			 (ecase orientation (:horizontal cleft) (:vertical ctop)))
+		       (viewport-min
+			 (ecase orientation (:horizontal vleft) (:vertical vtop)))
+		       (mouse-offset
+			 (ecase orientation
+			   (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+			   (:horizontal (/ (- x left) (float (- right left) 0.0s0)))))
+		       (pos (/ (- (+ viewport-min (* viewport-range mouse-offset))
+				  viewport-range contents-min)
+			       contents-range)))
+		  (scroll-bar-value-changed-callback
+		    scroll-bar scroller-pane id (max 0 pos) current-size))))))))))
+
+(defmethod scroll-elevator-callback ((scroll-bar scroll-bar-pane)
+				     scroller-pane id orientation x y)
+  (with-slots (current-size current-value) scroll-bar
+    (with-slots (viewport contents) scroller-pane
+      ;; --- scroll-bar may not be the right thing if its not the same
+      ;; size as the contents pane - Davo 6/30/92.
+      (with-bounding-rectangle* (left top right bottom)
+	  (sheet-region scroll-bar)
+	(let* ((mouse-offset
+		 (- (ecase orientation
+		      (:vertical (/ (- y top) (float (- bottom top) 0.0s0)))
+		      (:horizontal (/ (- x left) (float (- right left) 0.0s0))))
+		    (/ current-size 2.0s0))))
+	  (scroll-bar-value-changed-callback
+	    scroll-bar scroller-pane id (min 1.0s0 (max 0.0s0 mouse-offset)) current-size))))))
+
+;;; Set the indicator to the proper size and location (size and value are between 0 and 1)
+(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane)
+				     &key slider-size value line-increment)
+  (declare (ignore line-increment))
+  (setf (gadget-value scroll-bar :invoke-callback nil) value)
+  (setf (scroll-bar-current-size scroll-bar) slider-size)
+  (let* ((scroller (gadget-client scroll-bar))
+	 (contents (pane-contents scroller)))
+    ;;--- Hmm, if two "linked" panes have callbacks that cause the other
+    ;;--- pane to be scrolled, this will go into a loop...
+    (value-changed-callback scroll-bar contents (gadget-id scroll-bar) value)))
+
+
+(defclass scroll-bar-target-pane 
+	  (immediate-sheet-input-mixin
+	   space-requirement-mixin
+	   sheet-single-child-mixin
+	   shared-medium-sheet-output-mixin
+	   sheet-with-resources-mixin
+	   pane-repaint-background-mixin
+	   leaf-pane)
+    ((end :initarg :end)
+     (scroll-bar :initarg :scroll-bar)
+     (coord-cache :initform nil)))
+
+
+(defmethod initialize-instance :after ((pane scroll-bar-target-pane) &key end)
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (setf (slot-value pane 'pointer-cursor)
+	  (ecase end
+	    (:less-than 
+	      (ecase orientation
+		(:horizontal :scroll-left)
+		(:vertical :scroll-up)))
+	    (:greater-than
+	      (ecase orientation
+		(:horizontal :scroll-right)
+		(:vertical :scroll-down)))))))
+
+(defmethod note-sheet-region-changed :after ((pane scroll-bar-target-pane)
+					     &key &allow-other-keys)
+  (setf (slot-value pane 'coord-cache) nil))
+
+(defmethod handle-repaint ((pane scroll-bar-target-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (draw-rectangle* medium left top (1- right) (1- bottom)
+		       :filled nil :ink (medium-foreground medium)))
+    (draw-target pane medium)))
+
+;;; You can pass :FILLED T to this in order to highlight the target when clicked on...
+(defmethod draw-target ((pane scroll-bar-target-pane) medium
+			&key filled (ink +foreground-ink+))
+  (let ((coord-cache (slot-value pane 'coord-cache)))
+    (unless coord-cache
+      (let ((identity (sheet-pointer-cursor pane)))
+	(setq coord-cache
+	      (setf (slot-value pane 'coord-cache)
+		    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+		      ;; This seems to be a kludge to deal with roundoff?
+		      (decf right) (decf bottom)
+		      ;; Indent the target arrows a little for aesthetic purposes
+		      (incf left 2) (decf right 2)
+		      (incf top 2)  (decf bottom 2)
+		      (ecase identity
+			(:scroll-up
+			  (list left bottom
+				(+ left (/ (- right left) 2)) top
+				right bottom))
+			(:scroll-down
+			  (list left top
+				(+ left (/ (- right left) 2)) bottom
+				right top))
+			(:scroll-left
+			  (list right top
+				left (/ (+ top bottom) 2)
+				right bottom))
+			(:scroll-right
+			  (list left top
+				right (/ (+ top bottom) 2)
+				left bottom))))))))
+    (draw-polygon* medium coord-cache :filled filled :ink ink)))
+
+(defclass scroll-bar-shaft-pane
+	  (immediate-sheet-input-mixin
+	   space-requirement-mixin
+	   sheet-single-child-mixin
+	   shared-medium-sheet-output-mixin
+	   sheet-with-resources-mixin
+	   pane-repaint-background-mixin
+	   leaf-pane)
+    ((scroll-bar :initarg :scroll-bar)
+     (needs-erase :initform nil)))
+
+
+
+(defmethod initialize-instance :after ((pane scroll-bar-shaft-pane) &key)
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (setf (slot-value pane 'pointer-cursor)
+	  (ecase orientation
+	    (:horizontal :horizontal-scroll)
+	    (:vertical :vertical-scroll)))))
+
+(defmethod handle-repaint ((pane scroll-bar-shaft-pane) region)
+  (declare (ignore region))
+  (with-sheet-medium (medium pane)
+    (with-bounding-rectangle* (left top right bottom) (sheet-region pane)
+      (draw-rectangle* medium left top (1- right) (1- bottom)
+		       :filled nil :ink (medium-foreground medium)))
+    (draw-thumb pane medium)))
+
+(defparameter *scroll-bar-thumb-ink* (make-gray-color 2/3))
+
+(defmethod draw-thumb ((pane scroll-bar-shaft-pane) medium
+		       &key (ink +foreground-ink+))
+  (let ((needs-erase (slot-value pane 'needs-erase)))
+    (setf (slot-value pane 'needs-erase) (not (eq ink +background-ink+)))
+    (when (and (not needs-erase)
+	       (eq ink +background-ink+))
+      (return-from draw-thumb (values))))
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (scroll-value (gadget-value scroll-bar))
+	 (min-value (gadget-min-value scroll-bar))
+	 (max-value (gadget-max-value scroll-bar))
+	 (gadget-size (or (scroll-bar-current-size scroll-bar) 0))
+	 (gadget-range (abs (- max-value min-value)))
+	 (identity (sheet-pointer-cursor pane)))
+    (flet ((draw-car (medium left top right bottom which)
+	     (decf right) (decf bottom)
+	     (draw-rectangle* medium left top right bottom
+			      :filled t
+			      :ink (if (eq ink +foreground-ink+) *scroll-bar-thumb-ink* ink))
+	     (case which
+	       (:vertical-scroll
+		 (draw-line* medium left top right top :ink ink)
+		 (draw-line* medium left bottom right bottom :ink ink))
+	       (:horizontal-scroll
+		 (draw-line* medium left bottom left top :ink ink)
+		 (draw-line* medium right bottom right top :ink ink)))))
+      (declare (dynamic-extent #'draw-car))
+      (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane)
+	(let* ((height (- y2 y1))
+	       (width (- x2 x1))
+	       (scroll-range (ecase identity
+			       (:vertical-scroll height)
+			       (:horizontal-scroll width)))
+	       (car-size (max 10 (* scroll-range (/ gadget-size gadget-range))))
+	       (elevator-top (compute-symmetric-value 
+			       min-value max-value scroll-value 0
+			       scroll-range))
+	       (elevator-bottom (+ elevator-top car-size)))
+	  (ecase identity
+	    (:vertical-scroll
+	      (draw-car medium
+			(+ x1 1)           (+ y1 elevator-top)
+			(+ x1 width -1) (+ y1 elevator-bottom)
+			identity))
+	    (:horizontal-scroll
+	      (draw-car medium
+			elevator-top      (+ y1 1)
+			elevator-bottom   (+ y1 height -1)
+			identity))))))))
+
+
+(defmethod handle-event :around ((pane scroll-bar-target-pane) 
+				 (event pointer-button-press-event))
+  (with-sheet-medium (medium pane)
+    (draw-target pane medium :filled t :ink +foreground-ink+)
+    (call-next-method)
+    (draw-target pane medium :filled t :ink +background-ink+)
+    (draw-target pane medium :filled nil)))
+
+;;; This implements genera style scroll bars.
+;;; Vertical Scroll bars
+;;;    Top Target
+;;;       Left: Next Line   Middle: First Page   Right: Previous Line
+;;;    Bottom Target
+;;;       Left: Next Page   Middle: Last Page    Right: Previous Page
+(defmethod handle-event ((pane scroll-bar-target-pane) 
+			 (event pointer-button-press-event))
+  (let* ((scroll-bar (slot-value pane 'scroll-bar))
+	 (client (gadget-client scroll-bar))
+	 (id (gadget-id scroll-bar)))
+    (case (pointer-event-button event)
+      (#.+pointer-left-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-down-page-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-down-line-callback scroll-bar client id))))
+      (#.+pointer-middle-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-to-bottom-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-to-top-callback scroll-bar client id))))
+      (#.+pointer-right-button+
+       (ecase (slot-value pane 'end)
+	 (:greater-than
+	   (scroll-up-page-callback scroll-bar client id))
+	 (:less-than
+	   (scroll-up-line-callback scroll-bar client id)))))))
+
+(defmethod handle-event ((pane scroll-bar-shaft-pane) 
+			 (event pointer-button-press-event))
+  (let* ((x (pointer-event-x event))
+	 (y (pointer-event-y event))
+	 (scroll-bar (slot-value pane 'scroll-bar))
+	 (client (gadget-client scroll-bar))
+	 (id (gadget-id scroll-bar))
+	 (orientation (gadget-orientation scroll-bar)))
+    (case (pointer-event-button event)
+      (#.+pointer-left-button+
+       (scroll-line-to-top-callback
+	 scroll-bar client id orientation x y))
+      (#.+pointer-right-button+
+       (scroll-line-to-bottom-callback
+	 scroll-bar client id orientation x (- (bounding-rectangle-height scroll-bar) y)))
+      (#.+pointer-middle-button+
+       (scroll-elevator-callback
+	 scroll-bar client id orientation x y)))))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-enter-event))
+  (declare (special *pointer-documentation-output*))
+  (frame-manager-display-pointer-documentation-string
+    (frame-manager pane) (pane-frame pane) *pointer-documentation-output*
+    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
+      (:vertical
+	"L: This line to top; M: Proportional scrolling; R: Top line to here.")
+      (:horizontal
+	"L: This column to left edge; M: Proportional scrolling; R: Left edge to here."))))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-enter-event))
+  (declare (special *pointer-documentation-output*))
+  (frame-manager-display-pointer-documentation-string
+    (frame-manager pane) (pane-frame pane) *pointer-documentation-output*
+    (ecase (gadget-orientation (slot-value pane 'scroll-bar))
+      (:vertical
+	(ecase (slot-value pane 'end)
+	  (:greater-than
+	    "L: Next screenful; M: Last screenful; R: previous screenful.")
+	  (:less-than
+	    "L: Next line; M: First screenful; R: Previous line.")))
+      (:horizontal
+	(ecase (slot-value pane 'end)
+	  (:greater-than
+	    "L: Next screenful; M: Last screenful; R: previous screenful.")
+	  (:less-than
+	    "L: Next column; M: First screenful; R: Previous column."))))))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-exit-event))
+  (declare (special *pointer-documentation-output*))
+  (frame-manager-display-pointer-documentation-string 
+    (frame-manager pane) (pane-frame pane) *pointer-documentation-output* nil))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-exit-event))
+  (declare (special *pointer-documentation-output*))
+  (frame-manager-display-pointer-documentation-string 
+    (frame-manager pane) (pane-frame pane) *pointer-documentation-output* nil))
+
+(defmethod handle-event :after ((pane scroll-bar-shaft-pane) (event pointer-event))
+  (deallocate-event event))
+
+(defmethod handle-event :after ((pane scroll-bar-target-pane) (event pointer-event))
+  (deallocate-event event))
+
+(defmethod update-scroll-bar-value ((pane scroll-bar-shaft-pane) scroll-bar coord min max)
+  (let* ((min-value (gadget-min-value scroll-bar))
+	 (max-value (gadget-max-value scroll-bar))
+	 (value (compute-symmetric-value min max coord min-value max-value)))
+    (setf (gadget-value scroll-bar) value)))
+
+(defmethod (setf gadget-value) (value (pane scroll-bar-pane) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (setf (slot-value pane 'value) value))
+
+(defmethod (setf gadget-value) :around (value (pane scroll-bar-pane) &key invoke-callback)
+  (declare (ignore value invoke-callback))
+  (if (port pane)
+      (let ((shaft-pane (slot-value pane 'shaft-pane)))
+	(with-sheet-medium (medium shaft-pane)
+	  (draw-thumb shaft-pane medium :ink +background-ink+)
+	  (call-next-method)
+	  (draw-thumb shaft-pane medium :ink +foreground-ink+)))
+      (call-next-method)))
+
diff --git a/make-symbolic-links.sh b/make-symbolic-links.sh
new file mode 100644
index 0000000000000000000000000000000000000000..7e7be42289fe9e9494f2be448f11c8fb88e1fe73
--- /dev/null
+++ b/make-symbolic-links.sh
@@ -0,0 +1,41 @@
+#!/bin/sh
+#
+# $fiHeader$
+#
+# make a tree of links
+#
+
+original=$1
+linkdir=$2
+
+# remove any existing links
+
+if test -d $linkdir; then
+  echo "$linkdir already exists - removing old links"
+  find $linkdir -type l -print | xargs /bin/rm -f
+else
+  echo "creating $linkdir"
+  mkdir $linkdir
+fi
+
+# create the directory tree
+
+for dir in `(cd $original; 
+	     find * -type d -a ! -name CVS -print)` ; do
+	if test ! -d $linkdir/$dir; then 
+	  echo "creating $linkdir/$dir"
+	  mkdir $linkdir/$dir
+	fi
+done
+
+# and now do the links
+
+echo "creating new links"
+
+for file in `(cd $original;
+	      find * -type f ! -name .\* ! -name \*~ ! -name \#\*\# \
+		     -print \
+		      -o -name CVS -prune)` ; do
+	ln -s $original/$file $linkdir/$file
+done
+
diff --git a/misc/climgccursor.c b/misc/climgccursor.c
index e0663915018c7fc239a012a90819b61ffcf54d32..7072b3efb80818813e90335980e141dbb8b8c1db 100644
--- a/misc/climgccursor.c
+++ b/misc/climgccursor.c
@@ -42,11 +42,7 @@ Cursor cursor;
 
     if (gc_widget && (window = XtWindow(gc_widget))) {
 	Display *display = XtDisplayOfObject(gc_widget);
-
-	if (cursor)
-	    XDefineCursor(display, window, cursor);
-	else
-	    XUndefineCursor(display, window);
+	XDefineCursor(display, window, cursor);
 	XFlush(display);
     }
 }
diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp
index 401925de286bbf376a3195e61e965fdc0ddc9cb0..1b33c59e36aad7e37979c5f4cabb97e12c342e72 100644
--- a/misc/compile-1.lisp
+++ b/misc/compile-1.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: compile-1.lisp,v 1.23 1993/05/25 20:41:40 cer Exp $
+;; $fiHeader: compile-1.lisp,v 1.26 1994/11/23 23:28:48 smh Exp $
 
 (in-package :user)
 
@@ -32,28 +32,20 @@
 
 (set-case-mode :case-insensitive-lower)
 
-#+ignore
-(progn
-  (compile-file "~/stuff/misc/new-slot-opt.cl")
-  (load "~/stuff/misc/new-slot-opt.fasl")
-  )
-
-#+ignore
-(progn
-  (setf (sys:gsgc-switch :print) t)
-  (setf (sys:gsgc-switch :stats) t))
-
 (setq comp:generate-call-count-code-switch
   (named-function |(> debug 1)|
 		  (lambda (safety size speed debug)
 		    (declare (ignore safety size speed))
 		    (> debug 1))))
+
 (setq comp:declared-fixnums-remain-fixnums-switch
   (named-function |(> speed 2)|
 		  (lambda (safety size speed debug)
 		    (declare (ignore safety size debug))
 		    (> speed 2))))
 
+(setf (sys:gsgc-parameter :print) nil)
+
 ;(unless (find-package 'clim-defsystem)
 ;  (compile-file-if-needed "sys/defsystem")
 ;  (let ((*enable-package-locked-errors* nil))
@@ -67,6 +59,8 @@
     (tenuring
      (excl:load-system sys))
 
+    (excl:compile-system 'clim-homegrown)
+    
     (load "clim2:;postscript;sysdcl")
     (excl:compile-system 'postscript-clim :include-components t)
     (excl:load-system 'postscript-clim)
diff --git a/misc/dump.lisp b/misc/dump.lisp
index ae07a67fcc9ff7772ba935f4eab459046914ad4f..aaa65a06e1679e172217d86d20b26ab0c08d7366 100644
--- a/misc/dump.lisp
+++ b/misc/dump.lisp
@@ -20,12 +20,14 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: dump.lisp,v 1.5 93/01/11 15:45:06 colin Exp $
+;; $fiHeader: dump.lisp,v 1.6 1993/07/27 01:47:54 colin Exp $
 
 ;; Assuming CLIM is loaded, dump it into /usr/tmp/clim.temp_$USER.
 (room t)
 (sys:resize-areas :global-gc t :old 1000000 :new 500000)
 (room t)
 
+#+ignore (setq tpl::*user-top-level* nil) ;; workaround for bug3225
+
 (dumplisp :name sys::*clim-dump-name* :checkpoint nil)
 
diff --git a/misc/train.lisp b/misc/train.lisp
index c5dc205c1444ec75cd8ff19907d7936bf0af2293..50024351f4dfdd52bb0050226b1dd160d6556c35 100644
--- a/misc/train.lisp
+++ b/misc/train.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: train.lisp,v 1.15 1993/11/18 18:44:44 cer Exp $
+;; $fiHeader: train.lisp,v 1.16 1993/11/23 19:58:44 cer Exp $
 
 (defun train-clim (&key (train-times 2) 
 			(psview nil)
@@ -30,17 +30,14 @@
 			(compile t)
 			(profilep t)
 			(benchmarkp t))
-  
-  ;;(setq *global-gc-behavior* nil)
+
   (load "test/test.lisp")
   
-  #-svr4 (excl:shell "ps vaxg")
-  
   (room t)
   
   (clim-test:with-test-reporting (:file (if (excl::featurep :clim-motif) 
-					     "test-suite-reportxm.lisp"
-					   "test-suite-reportol.lisp"))
+					     "notes/test-suite-reportxm.lisp"
+					   "notes/test-suite-reportol.lisp"))
     (when compile
       (compile-file-if-needed "test/test-suite" :print nil :verbose t))
     (load "test/test-suite.fasl")
@@ -90,8 +87,8 @@
   
   (when (fboundp 'generate-coverage-report)
     (with-open-file (*standard-output* (if (excl::featurep :clim-motif) 
-					   "coverage-reportxm.lisp"
-					 "coverage-reportol.lisp")
+					   "notes/coverage-reportxm.lisp"
+					 "notes/coverage-reportol.lisp")
 		     :if-exists :supersede :direction :output)
       (generate-coverage-report :files (known-clim2-files))))
 
@@ -106,6 +103,7 @@
 
   ;; delete the preload fasls for the type of clim we are testing, so that
   ;; make-dist cat use the one we will make.
+
   (let ((xx (if* (excl::featurep :clim-motif) 
 	       then "xm"
 	       else "ol")))
@@ -116,13 +114,18 @@
       (handler-case (delete-file (format nil file-format xx))
 	(error () nil))))
 
-  (compile-file (if* (probe-file "../src/clos-preload.cl")
-		   thenret
-		   else "misc/clos-preload.cl")
-		:output-file 
-		(if (excl::featurep :clim-motif) 
-		    "climxm-preload.fasl" 
-		  "climol-preload.fasl")))
+
+  (let ((comp::*new-closure-style* nil)
+	(tpl::*zoom-print-circle* t)
+	(tpl::*zoom-print-length* 3)
+	(tpl::*zoom-print-level* 3))
+    (compile-file (if* (probe-file "../src/clos-preload.cl")
+		     thenret
+		     else "misc/clos-preload.cl")
+		  :output-file 
+		  (if (excl::featurep :clim-motif) 
+		      "climxm-preload.fasl" 
+		    "climol-preload.fasl"))))
 
 
 
diff --git a/misc/undefinedsymbols.motif b/misc/undefinedsymbols.motif
index 3b22ca45f77b9b37463b4e4cc2019d502aa2ca24..378be88f58bd93948867a8ab7eea987a21aeb3d6 100644
--- a/misc/undefinedsymbols.motif
+++ b/misc/undefinedsymbols.motif
@@ -6,7 +6,9 @@ XmFontListInitFontContext
 XmFontListFreeFontContext
 XmFontListGetNextFont
 XmFontListCreate
+XmFontListFree
 XmFontListEntryCreate
+XmFontListEntryFree
 XmFontListAppendEntry
 XmFontListEntryGetFont
 XmAddProtocolCallback
diff --git a/misc/undefinedsymbols.xt b/misc/undefinedsymbols.xt
index 06297f0372e7b2490bb0251d5029ae2ceeda9c17..e0ed349813ee77ca497c50d2b51864ab1ccc3740 100644
--- a/misc/undefinedsymbols.xt
+++ b/misc/undefinedsymbols.xt
@@ -42,3 +42,6 @@ XtWindow
 XtParseTranslationTable
 XtParseAcceleratorTable
 XtAppSetFallbackResources
+XtCloseDisplay
+XtDestroyApplicationContext
+XtIsRealized
diff --git a/misc/xtsupport.c b/misc/xtsupport.c
index c5c966c1305f897492732662c1dbcf4da46adf5c..7890af77bcc57de68329d7fccecf66e7d815c5ec 100644
--- a/misc/xtsupport.c
+++ b/misc/xtsupport.c
@@ -1,4 +1,4 @@
-/* $fiHeader: xtsupport.c,v 1.7 1993/07/27 01:48:11 colin Exp $ */
+/* $fiHeader: xtsupport.c,v 1.9 1993/12/04 00:32:10 duane Exp $ */
 
 #include <X11/Intrinsic.h>
 
@@ -6,21 +6,9 @@
 #include <stdio.h>
 #include <X11/IntrinsicP.h>
 #include <X11/CoreP.h>
-
-#ifdef sparc
 #include "IntrinsicI.h"
-#endif
-
-#ifndef sparc
-
-unsigned long XtAppIntervalNextTimer(app)
-{
-    return (1000);
-    }
 
-#endif
 
-#ifdef sparc
 
 /* Some systems running NTP daemons are known to return strange usec
  * values from gettimeofday.  At present (3/90) this has only been
@@ -98,17 +86,12 @@ unsigned long XtAppIntervalNextTimer(app)
     if(app->timerQueue != NULL && IS_AFTER(cur_time, app->timerQueue->te_timer_value))
     {
 	TIMEDELTA (wait_time, app->timerQueue->te_timer_value, cur_time);
-	/*
-	 * We add an extra 1 to ensure that events due to happen in less than
-	 * 1000us are not lost by the rounding error of the integer divide
-	 */
-	return (1+wait_time.tv_sec*1000+wait_time.tv_usec/1000);
+	return (wait_time.tv_sec*1000+wait_time.tv_usec/1000);
     }
     else 
-	return 0;
-	}
+	return -1;
+}
 
-#endif
 
 xt_widget_num_popups (w)
 Widget w;
diff --git a/notes/times/clim2-beta2.n b/notes/times/clim2-beta2.n
new file mode 100644
index 0000000000000000000000000000000000000000..eca09789e2a6d73194954d2b971e841e1c29d015
--- /dev/null
+++ b/notes/times/clim2-beta2.n
@@ -0,0 +1,34 @@
+;Speed of Allegro CL 4.2.beta2.0 [SPARC; R1] (6/1/93 20:11)
+;on SPARC id: #x4210456.
+;on vapor
+
+((CLIM-USER::LINE-DRAWING 0.8233333)
+ (CLIM-USER::UNRECORDED-LINE-DRAWING 0.17208333)
+ (CLIM-USER::TRANSFORMED-LINE-DRAWING 1.5366665)
+ (CLIM-USER::THICK-LINE-DRAWING 0.8383333)
+ (CLIM-USER::CLIPPED-LINE-DRAWING 1.0366668)
+ (CLIM-USER::SHAPE-DRAWING 0.33666667)
+ (CLIM-USER::UNRECORDED-SHAPE-DRAWING 0.080625)
+ (CLIM-USER::TRANSFORMED-SHAPE-DRAWING 0.685)
+ (CLIM-USER::THICK-SHAPE-DRAWING 0.3125)
+ (CLIM-USER::FILLED-SHAPE-DRAWING 0.29416665)
+ (CLIM-USER::STIPPLED-SHAPE-DRAWING 0.35833335)
+ (CLIM-USER::CLIPPED-SHAPE-DRAWING 0.4775) (CLIM-USER::TEXT-OUTPUT 1.9699999)
+ (CLIM-USER::UNRECORDED-TEXT-OUTPUT 1.57)
+ (CLIM-USER::STYLISH-TEXT-OUTPUT 3.55) (CLIM-USER::CLIPPED-TEXT-OUTPUT 1.625)
+ (CLIM-USER::TEXT-SCROLLING 3.7966664) (CLIM-USER::GRAPHICS-SCROLLING 2.25)
+ (CLIM-USER::TEXT-REFRESH 1.255) (CLIM-USER::GRAPHICS-REFRESH 0.40750003)
+ (CLIM-USER::FIND-SHAPE-PRESENTATIONS 1.24)
+ (CLIM-USER::HIGHLIGHT-SHAPE-PRESENTATIONS 1.1533333)
+ (CLIM-USER::FIND-TEXTUAL-PRESENTATIONS 1.9166666)
+ (CLIM-USER::HIGHLIGHT-TEXTUAL-PRESENTATIONS 1.6966667)
+ (CLIM-USER::HIGHLIGHT-MENU-ITEMS 1.025)
+ (CLIM-USER::SIMPLE-TABLE-FORMATTING 1.3933333)
+ (CLIM-USER::COMPOUND-TABLE-FORMATTING 0.91499996)
+ (CLIM-USER::GRAPHIC-TABLE-FORMATTING 0.38208333)
+ (CLIM-USER::SIMPLE-GRAPH-FORMATTING 0.94)
+ (CLIM-USER::BASIC-REDISPLAY 4.436667) (CLIM-USER::GRAPHIC-REDISPLAY 1.86)
+ (CLIM-USER::COMPOUND-REDISPLAY 6.616667) (CLIM-USER::SIMPLE-MENU-CHOOSE 1.0)
+ (CLIM-USER::CACHED-MENU-CHOOSE 1.0016667)
+ (CLIM-USER::SIMPLE-DIALOG 1.1416668) (CLIM-USER::WINDOW-DIALOG 1.4466667)
+ (CLIM-USER::COMPOUND-DIALOG 1.6550001)) 
\ No newline at end of file
diff --git a/notes/times/clim2-final.n b/notes/times/clim2-final.n
new file mode 100644
index 0000000000000000000000000000000000000000..45dea18dc927151e76ff5515c7cdce633d4769ae
--- /dev/null
+++ b/notes/times/clim2-final.n
@@ -0,0 +1,38 @@
+;Speed of Allegro CL 4.2 [SPARC; R1] (1/12/94 14:12)
+;on SPARC id: #x4210456.
+;on vapor
+
+((CLIM-USER::LINE-DRAWING 1.0366668)
+ (CLIM-USER::UNRECORDED-LINE-DRAWING 0.38583335)
+ (CLIM-USER::TRANSFORMED-LINE-DRAWING 1.8466667)
+ (CLIM-USER::THICK-LINE-DRAWING 1.1066667)
+ (CLIM-USER::CLIPPED-LINE-DRAWING 1.03) (CLIM-USER::SHAPE-DRAWING 0.3375)
+ (CLIM-USER::UNRECORDED-SHAPE-DRAWING 0.19708334)
+ (CLIM-USER::TRANSFORMED-SHAPE-DRAWING 0.45166668)
+ (CLIM-USER::THICK-SHAPE-DRAWING 0.5691667)
+ (CLIM-USER::FILLED-SHAPE-DRAWING 0.32166666)
+ (CLIM-USER::STIPPLED-SHAPE-DRAWING 0.4983333)
+ (CLIM-USER::CLIPPED-SHAPE-DRAWING 0.37833333)
+ (CLIM-USER::TEXT-OUTPUT 2.0266666)
+ (CLIM-USER::UNRECORDED-TEXT-OUTPUT 1.8266667)
+ (CLIM-USER::STYLISH-TEXT-OUTPUT 3.92)
+ (CLIM-USER::CLIPPED-TEXT-OUTPUT 1.2783333)
+ (CLIM-USER::TEXT-SCROLLING 4.7033334)
+ (CLIM-USER::GRAPHICS-SCROLLING 2.9966667) (CLIM-USER::TEXT-REFRESH 1.09)
+ (CLIM-USER::GRAPHICS-REFRESH 0.45333335)
+ (CLIM-USER::FIND-SHAPE-PRESENTATIONS 1.2433333)
+ (CLIM-USER::HIGHLIGHT-SHAPE-PRESENTATIONS 1.1766666)
+ (CLIM-USER::FIND-TEXTUAL-PRESENTATIONS 1.8033333)
+ (CLIM-USER::HIGHLIGHT-TEXTUAL-PRESENTATIONS 1.7266668)
+ (CLIM-USER::HIGHLIGHT-MENU-ITEMS 1.0233332)
+ (CLIM-USER::SIMPLE-TABLE-FORMATTING 1.3866667)
+ (CLIM-USER::COMPOUND-TABLE-FORMATTING 0.98)
+ (CLIM-USER::GRAPHIC-TABLE-FORMATTING 0.28166667)
+ (CLIM-USER::SIMPLE-GRAPH-FORMATTING 1.015)
+ (CLIM-USER::BASIC-REDISPLAY 3.8133335)
+ (CLIM-USER::GRAPHIC-REDISPLAY 2.3633335)
+ (CLIM-USER::COMPOUND-REDISPLAY 5.9366665)
+ (CLIM-USER::SIMPLE-MENU-CHOOSE 1.0033334)
+ (CLIM-USER::CACHED-MENU-CHOOSE 1.0066667)
+ (CLIM-USER::SIMPLE-DIALOG 5.6999993) (CLIM-USER::WINDOW-DIALOG 5.863333)
+ (CLIM-USER::COMPOUND-DIALOG 4.713333)) 
\ No newline at end of file
diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp
index 357011450f7b1a6cefae3e29b5b3ccbc9c149922..7730924f2808bb0e1fce11b506da8c4fda5b3921 100644
--- a/postscript/postscript-medium.lisp
+++ b/postscript/postscript-medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: postscript-medium.lisp,v 1.15 93/04/23 09:18:07 cer Exp $
+;; $fiHeader: postscript-medium.lisp,v 1.16 1993/06/21 20:50:48 cer Exp $
 
 (in-package :postscript-clim)
 
@@ -43,7 +43,10 @@
     (with-slots (current-line-style) medium
       (unless (equalp current-line-style new-line-style)
 	(setq current-line-style new-line-style)
-	(format printer-stream " ~D setlinewidth~%" (round thickness))
+	(format printer-stream " ~D setlinewidth~%"
+		(if (< thickness 2)
+		    0
+		  (the fixnum (round thickness))))
 	(if dashes
 	    (progn
 	      (when (eq dashes t)
@@ -57,6 +60,25 @@
 	      (format printer-stream "0 setdash~%"))
 	  (format printer-stream "[] 0 setdash~%"))))))
 
+(defun use-clip-region (medium clip-region)
+  (let ((printer-stream (slot-value medium 'printer-stream))
+	(transform (sheet-device-transformation (medium-sheet medium))))
+    (with-slots (current-clip-region) medium
+      (unless (eq current-clip-region clip-region)
+	(setq current-clip-region clip-region)
+	(if (eq clip-region +everywhere+)
+	    (format printer-stream " initclip ")
+	  (with-bounding-rectangle* (left top right bottom)
+	      clip-region
+	    (convert-to-postscript-coordinates transform
+	       left top right bottom)
+	    (format printer-stream " newpath ")
+	    (ps-pos-op medium "m" left top)
+	    (ps-pos-op medium "lineto" right top)
+	    (ps-pos-op medium "lineto" right bottom)
+	    (ps-pos-op medium "lineto" left bottom)
+	    (format printer-stream " closepath clip "))))))) ;no cr
+
 (defun color-equal (c1 c2)
   (or (eq c1 c2)
       (and (colorp c1)
@@ -98,7 +120,9 @@
   (maybe-set-color medium (make-color-for-contrasting-ink ink)))
 
 (defmacro with-postscript-drawing-options ((medium printer-stream-var
-					    &key ink (filled nil filled-p) line-style
+					    &key ink (filled nil
+						      filled-p) line-style 
+						 clip-region
 						 epilogue (newpath t))
 					   &body body)
   (let ((printer-stream (or printer-stream-var (make-symbol (symbol-name 'printer-stream)))))
@@ -106,6 +130,7 @@
        (when (and ,@(and filled-p `((not ,filled))) ,line-style)
 	 (use-line-style ,medium ,line-style))
        (maybe-set-color ,medium ,ink)
+       (use-clip-region ,medium ,clip-region)
        ,@(when newpath `((format ,printer-stream " newpath~%")))
        ,@body
        ,@(case epilogue
@@ -118,11 +143,13 @@
 (defmethod medium-draw-point* ((medium postscript-medium) x y)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform x y)
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :stroke
-				      :ink ink :line-style line-style)
+				      :ink ink :line-style line-style
+				      :clip-region clip-region)
       (ps-pos-op medium "m" x y)
       (ps-rel-pos-op medium "rlineto" 0 0))
     (annotating-postscript (medium printer-stream)
@@ -132,10 +159,12 @@
 (defmethod medium-draw-points* ((medium postscript-medium) position-seq)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :stroke
-				      :ink ink :line-style line-style)
+				      :ink ink :line-style line-style
+				      :clip-region clip-region)
       (map-position-sequence
 	#'(lambda (x y)
 	    (convert-to-postscript-coordinates transform x y)
@@ -146,11 +175,13 @@
 (defmethod medium-draw-line* ((medium postscript-medium) x1 y1 x2 y2)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform x1 y1 x2 y2)
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :stroke
-				      :ink ink :line-style line-style)
+				      :ink ink :line-style line-style
+				      :clip-region clip-region)
       (ps-pos-op medium "m" x1 y1)
       (ps-pos-op medium "lineto" x2 y2))
     (annotating-postscript (medium printer-stream)
@@ -160,10 +191,12 @@
 (defmethod medium-draw-lines* ((medium postscript-medium) position-seq)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :stroke
-				      :ink ink :line-style line-style)
+				      :ink ink :line-style line-style
+				      :clip-region clip-region)
       (map-endpoint-sequence
 	#'(lambda (x1 y1 x2 y2)
 	    (convert-to-postscript-coordinates transform x1 y1 x2 y2)
@@ -175,12 +208,15 @@
 				   left top right bottom filled)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform
       left top right bottom)
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :default
-				      :ink ink :filled filled :line-style line-style)
+				      :ink ink :filled filled
+				      :line-style line-style
+				      :clip-region clip-region)
       (ps-pos-op medium "m" left top)
       (ps-pos-op medium "lineto" right top)
       (ps-pos-op medium "lineto" right bottom)
@@ -193,10 +229,13 @@
 (defmethod medium-draw-rectangles* ((medium postscript-medium) position-seq filled)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (with-postscript-drawing-options (medium printer-stream
 				      :epilogue :default
-				      :ink ink :filled filled :line-style line-style)
+				      :ink ink :filled filled
+				      :line-style line-style
+				      :clip-region clip-region)
       (map-endpoint-sequence
 	#'(lambda (left top right bottom)
 	    (convert-to-postscript-coordinates transform
@@ -212,6 +251,7 @@
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
 	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium))
 	 (minx most-positive-fixnum)
 	 (miny most-positive-fixnum)
 	 (length (length position-seq)))
@@ -228,7 +268,9 @@
 	  (if (< y miny) (setq miny y))))
       (with-postscript-drawing-options (medium printer-stream
 					:epilogue :default
-					:ink ink :filled filled :line-style line-style)
+					:ink ink :filled filled
+					:line-style line-style
+					:clip-region clip-region)
 	(let ((start-x (svref points 0))
 	      (start-y (svref points 1)))
 	  (ps-pos-op medium "m" start-x start-y)
@@ -250,7 +292,8 @@
   (maybe-send-feature medium 'ellipse *ps-ellipse-code*)
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (line-style (medium-line-style medium)))
+	 (line-style (medium-line-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform center-x center-y)
     (convert-to-postscript-distances transform 
       radius-1-dx radius-1-dy radius-2-dx radius-2-dy)
@@ -271,7 +314,9 @@
 		     (* (cos a) y-radius))))
 	(with-postscript-drawing-options (medium printer-stream
 					  :epilogue :default
-					  :ink ink :filled filled :line-style line-style)
+					  :ink ink :filled filled
+					  :line-style line-style
+					  :clip-region clip-region)
 	  (ps-pos-op medium "ellipse" center-x center-y
 		     x-radius y-radius
 		     ;; Don't allow the common full-circle case to be
@@ -302,7 +347,8 @@
     (setq end (length string)))
   (let* ((transform (sheet-device-transformation (medium-sheet medium)))
 	 (ink (medium-ink medium))
-	 (text-style (medium-merged-text-style medium)))
+	 (text-style (medium-merged-text-style medium))
+	 (clip-region (medium-clipping-region medium)))
     (convert-to-postscript-coordinates transform x y)
     (when towards-x
       (convert-to-postscript-coordinates transform towards-x towards-y))
@@ -325,7 +371,8 @@
       (ps-pos-op medium "m" x y)
       (with-postscript-drawing-options (medium printer-stream
 					       :epilogue nil :newpath nil
-					       :ink ink)
+					       :ink ink
+					       :clip-region clip-region)
 	(if towards-x
 	    (with-postscript-gsave medium 
 	      (format printer-stream " currentpoint translate ~D rotate "
diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp
index a30a03adcb5fcd2c579bbbac84ffcf70196a171c..f3b4dfa55b71d45cddfa175f06c66f5c0b9cf31c 100644
--- a/postscript/postscript-port.lisp
+++ b/postscript/postscript-port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: postscript-port.lisp,v 1.22 1993/08/12 16:04:02 cer Exp $
+;; $fiHeader: postscript-port.lisp,v 1.23 1993/11/18 18:44:51 cer Exp $
 
 (provide :climps)
 
@@ -260,7 +260,8 @@
    (curfont :initform nil)	;a psfck structure
    (ch1buf :initform (make-array 1 :element-type #+ANSI-90 'character
 				 #-ANSI-90 'string-char))
-   (current-line-style :initform nil)))
+   (current-line-style :initform nil)
+   (current-clip-region :initform nil)))
 
 (defmethod implementation-pixels-per-point ((medium postscript-medium))
   (float (/ *1-pixel=points*) 0f0))
@@ -312,19 +313,12 @@
 
 (defmethod ps-pos-op ((medium postscript-medium) op x y &rest args)
   (declare (dynamic-extent args))
-  (let ((printer-stream (slot-value medium 'printer-stream))
-	(port (port medium)))
+  (let ((printer-stream (slot-value medium 'printer-stream)))
     (pixels-to-points x y)
     (write-char #\space printer-stream)
-    (ps-optimal-flonize
-      (+ (* (slot-value port 'page-indent)
-	    (slot-value port 'device-units-per-inch)) x)
-      printer-stream)
+    (ps-optimal-flonize x printer-stream)
     (write-char #\space printer-stream)
-    (ps-optimal-flonize
-      (- (* (+ (slot-value port 'page-height) (slot-value port 'page-indent))
-	    (slot-value port 'device-units-per-inch)) y)
-      printer-stream)
+    (ps-optimal-flonize (- y) printer-stream)
     (dolist (arg args)
       (write-char #\space printer-stream)
       (if (numberp arg)
@@ -542,18 +536,24 @@ end } def
     (format printer-stream "%%DocumentFonts: (atend)~%")
     (format printer-stream "%%EndComments~%")
     (format printer-stream *postscript-prologue* (length (slot-value (port medium) 'font-map)))
-    (ecase orientation
-      (:portrait
-        (format printer-stream
-            "/format-rotation 0 def ~%/format-y-translation 0 def~%"))
-      (:landscape
-        (format printer-stream
-            "/format-rotation -90 def ~%/format-y-translation ~D def~%" 
-          (float (* (+ (slot-value port 'page-height) (slot-value port 'page-indent))
-		    (slot-value port 'device-units-per-inch))))))
+    (with-slots (page-indent page-height page-width device-units-per-inch) 
+	port
+      (flet ((device-units (x)
+	       (float (* x device-units-per-inch))))
+	(ecase orientation
+	  (:portrait
+	   (format printer-stream
+		   "/format-rotation 0 def ~%/format-translation {~D ~D} def~%"
+		   (device-units page-indent)
+		   (device-units (+ page-indent page-height))))
+	  (:landscape
+	   (format printer-stream
+		   "/format-rotation -90 def ~%/format-translation {~D ~D} def~%" 
+		   (device-units (+ page-indent page-height))
+		   (device-units (+ page-indent page-width)))))))
     (format printer-stream "/format-scale ~D def~%" (float (or scale-factor 1)))
     (format printer-stream
-        "/new-matrix {0 format-y-translation translate
+        "/new-matrix {format-translation translate
 		      format-rotation rotate
 		      format-scale format-scale scale} def
 	 /new-page {showpage new-matrix} def~%")
@@ -813,20 +813,21 @@ end } def
 
 
 (defclass apple-laser-writer (postscript-port)
-    ((x-resolution :initform 300)	;pixels per inch
-     (y-resolution :initform 300)
-     (page-indent :initform  0.5)	;in inches
-     (page-width  :initform  7.5)
-     (page-height :initform 10)))
+  ;; x-resolution and y-resolution should *never* appear in any
+  ;; calculations - they have no relevance whatsoever as postscript is
+  ;; co-ordinates are given in user space *not* device space. 
+  ((x-resolution :initform 300)		;pixels per inch
+   (y-resolution :initform 300)
+   (page-indent :initform  0.5)		;in inches
+   (page-width  :initform  7.5)
+   (page-height :initform 10)))
 
 (defmethod normal-line-thickness ((port postscript-port) thickness)
   thickness)
 
 (defmethod normal-line-thickness ((port apple-laser-writer) thickness)
-  (if (= thickness 1)
-      0
-      (* thickness (/ (slot-value port 'device-units-per-inch)
-		      (slot-value port 'x-resolution)))))
+  (* thickness *1-pixel=points*))
+
 
 (defmethod initialize-instance :after ((port apple-laser-writer) &key server-path)
   (declare (ignore server-path))
@@ -908,39 +909,39 @@ end } def
 		       (not (eq region +everywhere+)))
 		  (not multi-page))
 	      (replay output-record stream (or region +everywhere+))
-	      (with-bounding-rectangle* (left top right bottom) output-record
-		(let* ((page-width
-			 (floor (* (slot-value port 'page-width)
-				   (slot-value port 'device-units-per-inch))
-				*1-pixel=points*))
-		       (page-height
-			 (floor (* (slot-value port 'page-height)
-				   (slot-value port 'device-units-per-inch))
-				*1-pixel=points*))
-		       (first-page t))
-		  (setq viewport-x 0 viewport-y 0)
-		  ;; Draw each chunk of output on its own page
-		  (unwind-protect
-		      (do ((y top (+ y page-height)))
-			  ((> y bottom))
-			(do ((x left (+ x page-width)))
-			    ((> x right))
-			  (if first-page
-			      (setq first-page nil)
-			      (format printer-stream "gsave new-page grestore~%"))
-			  (let ((region (make-bounding-rectangle
-					  x y (+ x page-width) (+ y page-height))))
-			    (setf (sheet-device-transformation stream)
-				  (make-translation-transformation
-				   (- viewport-x) (- viewport-y)))
-			    (let ((*annotate-postscript* t))
-			      (annotating-postscript (medium printer-stream)
-						     (format printer-stream  "%%%%%----- Multi-page ~D,~D" viewport-x viewport-y)))
-			    (replay output-record stream region))
-			  (incf viewport-x page-width))
-			(setf viewport-x 0)
-			(incf viewport-y page-height))
-		    (setq viewport-x 0 viewport-y 0))))))))))
+	    (with-bounding-rectangle* (left top right bottom) output-record
+	      (let* ((page-width
+		      (floor (* (slot-value port 'page-width)
+				(slot-value port 'device-units-per-inch))
+			     *1-pixel=points*))
+		     (page-height
+		      (floor (* (slot-value port 'page-height)
+				(slot-value port 'device-units-per-inch))
+			     *1-pixel=points*))
+		     (first-page t))
+		(setq viewport-x 0 viewport-y 0)
+		;; Draw each chunk of output on its own page
+		(unwind-protect
+		    (do ((y top (+ y page-height)))
+			((> y bottom))
+		      (do ((x left (+ x page-width)))
+			  ((> x right))
+			(if first-page
+			    (setq first-page nil)
+			  (format printer-stream "gsave new-page grestore~%"))
+			(let ((region (make-bounding-rectangle
+				       x y (+ x page-width) (+ y page-height))))
+			  (setf (sheet-device-transformation stream)
+			    (make-translation-transformation
+			     (- viewport-x) (- viewport-y)))
+			  (let ((*annotate-postscript* t))
+			    (annotating-postscript (medium printer-stream)
+						   (format printer-stream  "%%%%%----- Multi-page ~D,~D" viewport-x viewport-y)))
+			  (replay output-record stream region))
+			(incf viewport-x page-width))
+		      (setf viewport-x 0)
+		      (incf viewport-y page-height))
+		  (setq viewport-x 0 viewport-y 0))))))))))
 
 (defmethod invoke-with-output-recording-options :before 
 	   ((stream postscript-stream) continuation record draw)
@@ -977,6 +978,9 @@ end } def
 	 (stream (make-instance 'postscript-stream
 				:multi-page multi-page))
 	 (abort-p t))
+    (when (eq orientation :landscape)
+      (rotatef (slot-value port 'page-width)
+	       (slot-value port 'page-height)))
     (setf (port stream :graft (find-graft :port port)) port)
     (let ((medium (sheet-medium stream)))
       (setf (slot-value medium 'printer-stream) file-stream)
@@ -986,38 +990,39 @@ end } def
 		(letf-globally (((stream-generating-postscript stream) nil))
 		  (funcall continuation stream)))
 	    (force-output stream)
-	    (multiple-value-bind (width height) 
-		(bounding-rectangle-size (stream-output-history stream))
-	      (let* ((page-width
-		      (floor (* (slot-value port 'page-width)
-				(slot-value port 'device-units-per-inch))
-			     *1-pixel=points*))
-		     (page-height
-		      (floor (* (slot-value port 'page-height)
-				(slot-value port 'device-units-per-inch))
-			     *1-pixel=points*))
-		     (scale-factor
-		      (progn
-			(when (eq orientation :landscape)
-			  (rotatef page-width page-height))
+	    (let ((record  (stream-output-history stream)))
+	      (when (or scale-to-fit multi-page)
+		(bounding-rectangle-set-position record 0 0))
+	      (multiple-value-bind (width height) 
+		  (bounding-rectangle-size record)
+		(let* ((page-width
+			(floor (* (slot-value port 'page-width)
+				  (slot-value port 'device-units-per-inch))
+			       *1-pixel=points*))
+		       (page-height
+			(floor (* (slot-value port 'page-height)
+				  (slot-value port 'device-units-per-inch))
+			       *1-pixel=points*))
+		       (scale-factor
 			(if (or (not scale-to-fit)
 				(and (< width page-width)
 				     (< height page-height)))
 			    1
 			  (min (/ page-width width)
-			       (/ page-height height))))))
-		;; Now do the output to the printer, breaking up the output into
-		;; multiple pages if that was requested
-		(let ((string
-		       (with-output-to-string (string-stream)
-			 (letf-globally (((slot-value medium 'printer-stream) string-stream))
-			   (with-output-recording-options (stream :record nil :draw t)
-			     (stream-replay stream nil))))))
-		  (postscript-prologue medium
-				       :scale-factor scale-factor
-				       :orientation orientation
-				       :header-comments header-comments)
-		  (write-string string (slot-value medium 'printer-stream)))))
+			       (/ page-height height)))))
+		  ;; Now do the output to the printer, breaking up the output into
+		  ;; multiple pages if that was requested
+		  (let ((string
+			 (with-output-to-string (string-stream)
+			   (letf-globally (((slot-value medium 'printer-stream) string-stream))
+			     (with-output-recording-options (stream :record nil :draw t)
+			       (stream-replay stream nil))))))
+		    (postscript-prologue medium
+					 :scale-factor scale-factor
+					 :orientation orientation
+					 :header-comments header-comments)
+
+		    (write-string string (slot-value medium 'printer-stream))))))
 	    (setq abort-p nil))
 	(close stream :abort abort-p)
 	(destroy-port port)))))
diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp
index a32d4ccd28b02863cfcfe6c8f62de0a23ada70bc..16a479c193d9faf2a8a9b828a7827cf537a4312a 100644
--- a/silica/db-scroll.lisp
+++ b/silica/db-scroll.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: db-scroll.lisp,v 1.50 1993/10/26 03:22:09 colin Exp $
+;; $fiHeader: db-scroll.lisp,v 1.51 1993/11/23 19:58:50 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright(c) 1991, 1992 International Lisp Associates.
@@ -16,6 +16,8 @@
 			 pane)
     ((scroll-bars :initarg :scroll-bars
 		  :reader scroller-pane-scroll-bar-policy)
+     (drag-scroll :initarg :drag-scroll 
+		  :accessor scroller-pane-drag-scroll)
      viewport
      (contents :initarg :contents :accessor pane-contents)
      (vertical-scroll-bar :initform nil 
@@ -30,8 +32,7 @@
 				  :vertical-line-scroll-amount)
      (horizontal-line-scroll-amount :initform nil 
 				    :initarg :horizontal-line-scroll-amount))
-  (:default-initargs :scroll-bars :both))
-
+    (:default-initargs :scroll-bars :both :drag-scroll t))
 
 ;; Returns the viewport of the pane, if there is one
 (defmethod pane-viewport ((sheet sheet))
@@ -81,6 +82,7 @@
   (unless *inhibit-updating-scroll-bars*
     ;;--- This is not the most efficient thing in the world
     (let ((scroller (viewport-scroller-pane viewport)))
+
       #+ignore
       (multiple-value-bind (changedp
 			    hscroll-bar hscroll-bar-enabled-p
@@ -90,6 +92,7 @@
 	  scroller changedp
 	  hscroll-bar hscroll-bar-enabled-p 
 	  vscroll-bar vscroll-bar-enabled-p t))
+      
       (with-bounding-rectangle* (left top right bottom) 
 	  (viewport-contents-extent viewport)
 	(with-bounding-rectangle* (vleft vtop vright vbottom)
@@ -111,9 +114,6 @@
 				 vleft vright
 				 :horizontal))))))))
 
-(defmethod note-sheet-grafted :before ((sheet scroll-bar))
-  (setf (scroll-bar-current-size sheet) nil))
-
 ;;--- In the case where the viewport is bigger than the window this
 ;;--- code gets things wrong.  Check out the thinkadot demo.  It's
 ;;--- because (- (--) (- vmin)) is negative.
@@ -124,15 +124,13 @@
   ;;window is large enough no one changes the viewport but we cannot scroll-either
   (maxf max vmax)
   (minf min vmin)
-  (let ((current-size (scroll-bar-current-size scroll-bar))
-	(current-value (scroll-bar-current-value scroll-bar)))
+  (let ((current-size (scroll-bar-size scroll-bar))
+	(current-value (gadget-value scroll-bar)))
     ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size
     ;; before, and the viewport is bigger than the extent, don't bother with
     ;; the fancy math.
-    (let* ((gmin (float (gadget-min-value scroll-bar) 0s0))
-	   (gmax (float (gadget-max-value scroll-bar) 0s0))
-	   (range (- gmax gmin)))
-      (declare (type single-float range gmin gmax))
+    (let ((range (float (gadget-range scroll-bar) 0s0)))
+      (declare (type single-float range))
       (when (and (and current-size (= (the single-float current-size) range))
 		 (> (- vmax vmin) (- max min)))
 	(return-from update-scroll-bar))
@@ -146,34 +144,41 @@
 			      1.0
 			    (min 1.0 (the single-float
 				       (/ viewport-range contents-range))))))))
-	     ;;-- This does not scale by the range
 	     (pos (the single-float
-		    (min 1.0s0 (max 0.0s0
-				    (if (<= contents-range viewport-range)
-					0.0
-				      (/ (float (- vmin min) 0.0s0) 
-					 ;;--- Uh-oh, the home-grown scroll bars
-					 ;;--- seem to have a different contract
-					 ;;--- from Motif/OpenLook.  Fix them!
-					 #+Allegro (- contents-range viewport-range)
-					 #-Allegro contents-range)))))))
+		    (* range
+		       (min 1.0s0 (max 0.0s0
+				       (if (<= contents-range viewport-range)
+					   0.0
+					 (/ (float (- vmin min) 0.0s0) 
+					    contents-range))))))))
 	(declare (type single-float pos size))
 	(unless (and current-size
 		     current-value
 		     (= current-size size)
 		     (= current-value pos))
-	  (setf (scroll-bar-current-value scroll-bar) pos)
-	  (setf (scroll-bar-current-size scroll-bar) size)
 	  ;;-- It would be nice if we could do this at the point of scrolling
-	  (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client) orientation nil))
+	  (let* ((line-scroll (line-scroll-amount (slot-value scroll-bar 'client)
+						  orientation
+						  nil))
 		 (line-scroll (if (zerop contents-range)
-				  0 ;-- Who knows
+				  0	;-- Who knows
 				(* range (/ line-scroll contents-range)))))
 	    (change-scroll-bar-values scroll-bar 
 				      :slider-size size
 				      :value pos
 				      :line-increment line-scroll)))))))
 
+(defmethod value-changed-callback 
+    ((sheet scroll-bar) (client scroller-pane) id value)
+  (scroll-bar-value-changed-callback sheet client id value
+				     (scroll-bar-size sheet)))
+
+(defmethod drag-callback 
+    ((sheet scroll-bar) (client scroller-pane) id value)
+  (when (scroller-pane-drag-scroll client)
+      (scroll-bar-value-changed-callback sheet client id value
+				     (scroll-bar-size sheet))))
+
 (defmethod scroll-bar-value-changed-callback
 	   (sheet (client scroller-pane) id value size)
   (with-slots (viewport contents) client
@@ -185,8 +190,7 @@
 	    contents
 	     (bounding-rectangle-min-x region)
 	     (+ (bounding-rectangle-min-y extent)
-		  (* (max 0 (- (bounding-rectangle-height extent)
-			       (bounding-rectangle-height region)))
+		  (* (bounding-rectangle-height extent)
 		     (if (= size (gadget-range sheet))
 			 0
 			 (/ (- value (gadget-min-value sheet))
@@ -195,20 +199,23 @@
 	  (scroll-extent
 	    contents
 	    (+ (bounding-rectangle-min-x extent)
-		  (* (max 0 (- (bounding-rectangle-width extent)
-			       (bounding-rectangle-width region)))
+		  (* (bounding-rectangle-width extent)
 		     (if (= size (gadget-range sheet))
 			 0
 			 (/ (- value (gadget-min-value sheet))
 			    (gadget-range sheet)))))
 	    (bounding-rectangle-min-y region))))
       ;;-- Yuck
-      (clim-internals::maybe-redraw-input-editor-stream contents (pane-viewport-region contents)))))
+      (clim-internals::maybe-redraw-input-editor-stream 
+       contents (pane-viewport-region contents)))))
 
 (defmethod update-region ((sheet basic-sheet) nleft ntop nright nbottom &key no-repaint)
   (declare (ignore nleft ntop nright nbottom no-repaint))
   nil)
 
+(defmethod mirror-region-updated :after ((port basic-port) (viewport viewport))
+  (update-scroll-bars viewport))
+
 (defmethod scroll-extent ((sheet basic-sheet) x y)
   ;;--- CER says that this really isn't right...
   (fix-coordinates x y)
@@ -270,7 +277,9 @@
 (defun compute-symmetric-value (min1 max1 value1 min2 max2)
   (declare (values value2))
   (let* ((distance1 (- max1 min1))
-	 (fraction1 (if (zerop distance1) 0 (/ (- value1 min1) distance1))))
+	 (fraction1 (if (zerop distance1)
+			0
+		      (/ (- value1 min1) distance1))))
     (let ((x (+ min2 (* (- max2 min2) fraction1))))
       (if (integerp x) x (float x)))))
 
diff --git a/silica/event.lisp b/silica/event.lisp
index 9d612ffde73963cfc65efb7752fce56ee58516fc..5094ee8de1877320ac4961af95983c7c061787d7 100644
--- a/silica/event.lisp
+++ b/silica/event.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: event.lisp,v 1.37 1993/06/02 18:41:50 cer Exp $
+;; $fiHeader: event.lisp,v 1.38 1993/08/12 16:04:13 cer Exp $
 
 (in-package :silica)
 
@@ -56,7 +56,9 @@
 
 (defgeneric queue-event (client event))
 (defmethod queue-event ((sheet sheet-with-event-queue-mixin) event)
-  (queue-put (sheet-event-queue sheet) event))
+  (let ((queue (sheet-event-queue sheet)))
+    (when queue
+      (queue-put queue event))))
 
 (defgeneric event-read (client))
 (defmethod event-read ((sheet sheet-with-event-queue-mixin))
@@ -134,6 +136,12 @@
   (queue-event sheet repaint-event))
 
 (defgeneric repaint-sheet (sheet region))
+
+(defmethod repaint-sheet :around ((sheet basic-sheet) region)
+  (declare (ignore region))
+  (when (port sheet)
+    (call-next-method)))
+
 (defmethod repaint-sheet ((sheet basic-sheet) region)
   (handle-repaint sheet (or region +everywhere+)))	;--- kludge for null region
 
@@ -170,6 +178,7 @@
   nil)
 
 
+
 ;;; Crossing events
 
 ;; We have fun here to generate enter/exit events for unmirrored sheets
@@ -542,7 +551,30 @@
 
 (defmethod distribute-event-1 :around ((port basic-port) (event pointer-event))
   (let ((sheet (port-grabbing-sheet port)))
-    (if sheet (dispatch-pointer-event-to-sheet port event sheet)
+    (if sheet 
+	(let ((event-sheet (event-sheet event))
+	      (grab-sheet (sheet-mirrored-ancestor sheet)))
+	  ;; If the grabbing sheet is different from the sheet the
+	  ;; event was reported on it is necessary to transfer the
+	  ;; co-ordinates. (cim 10/14/94 - see clim2bug688)
+	  (unless (eq event-sheet grab-sheet)
+	    (let ((x (pointer-event-native-x event))
+		  (y (pointer-event-native-y event)))
+	      (loop
+		(unless event-sheet
+		  (return))
+		(multiple-value-setq (x y)
+		  (transform-position (sheet-transformation event-sheet) x y))
+		(setq event-sheet (sheet-parent event-sheet)))
+	      (loop
+		(unless grab-sheet
+		  (return))
+		(multiple-value-setq (x y)
+		  (untransform-position (sheet-transformation grab-sheet) x y))
+		(setq grab-sheet (sheet-parent grab-sheet)))
+	      (with-slots (native-x native-y) event
+		(setf native-x x native-y y))))
+	  (dispatch-pointer-event-to-sheet port event sheet))
       (call-next-method))))
 
 (defmethod distribute-event-1 ((port basic-port) (event pointer-event))
diff --git a/silica/framem.lisp b/silica/framem.lisp
index efc1524082980dfc457f00f2b04f1c97c9e91c07..2f07dc14769a3e08a0b312ab36ba3f3c18e56764 100644
--- a/silica/framem.lisp
+++ b/silica/framem.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: framem.lisp,v 1.30 1993/07/27 01:50:43 colin Exp $
+;; $fiHeader: framem.lisp,v 1.31 1993/09/17 19:06:15 cer Exp $
 
 (in-package :silica)
 
@@ -111,7 +111,9 @@
 			       :region (multiple-value-bind (width height)
 					   (bounding-rectangle-size top-pane)
 					 (make-bounding-rectangle 0 0 width height))
-			       :background (frame-background frame)))))
+			       :background (frame-background frame)
+			       :foreground (frame-foreground frame)
+			       :text-style (frame-text-style frame)))))
       (sheet-adopt-child (find-graft :port (port frame)) sheet)
       (setf (frame-top-level-sheet frame) sheet
 	    (frame-shell frame) (sheet-shell sheet))
@@ -172,12 +174,14 @@
 (defgeneric frame-manager-notify-user
 	    (framem message-string &rest options
 	     &key frame associated-window title documentation
-		  exit-boxes name style text-style))
+		  exit-boxes name style text-style background
+		  foreground x-position y-position))
 
 (defgeneric frame-manager-select-file 
 	    (framem &rest options 
 	     &key frame associated-window title documentation exit-boxes name
-		 file-search-proc directory-list-label file-list-label))
+		  file-search-proc directory-list-label file-list-label
+		  text-style foreground background x-position y-position))
 
 
 (defmethod make-pane-class ((framem standard-frame-manager) class &rest options)
diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp
index d7ecf84d8f0ef78c1c6182839263208cf224bb70..ea34ba17b2474ec80c3f2ca4b3e8b64ab52379d6 100644
--- a/silica/gadgets.lisp
+++ b/silica/gadgets.lisp
@@ -1,6 +1,6 @@
 ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: gadgets.lisp,v 1.57 1993/09/07 21:46:41 colin Exp $
+;; $fiHeader: gadgets.lisp,v 1.58 1993/11/18 18:44:55 cer Exp $
 
 "Copyright (c) 1991, 1992 by Franz, Inc.  All rights reserved.
  Portions copyright (c) 1992 by Symbolics, Inc.  All rights reserved."
@@ -29,13 +29,13 @@
   (declare (dynamic-extent args))
   (if (consp function)
       (apply (car function) (append args (cdr function)))
-      (apply function args)))
+    (apply function args)))
 
 (defmethod armed-callback :around ((gadget basic-gadget) (client t) (id t))
   (let ((callback (gadget-armed-callback gadget)))
     (if callback
 	(invoke-callback-function callback gadget)
-        (call-next-method))))
+      (call-next-method))))
 
 (defmethod armed-callback ((gadget basic-gadget) (client t) (id t))
   nil)
@@ -44,7 +44,7 @@
   (let ((callback (gadget-disarmed-callback gadget)))
     (if callback
 	(invoke-callback-function callback gadget)
-        (call-next-method))))
+      (call-next-method))))
 
 (defmethod disarmed-callback ((gadget basic-gadget) (client t) (id t))
   nil)
@@ -68,11 +68,17 @@
   nil)
 
 
+;;; Value Gadgets
+
 (defclass value-gadget (basic-gadget) 
-    ((value :initarg :value :initform nil
-	    :reader gadget-initial-value)
-     (value-changed-callback :initarg :value-changed-callback :initform nil
-			     :reader gadget-value-changed-callback)))
+  ((value
+    :initarg :value :initform nil)	; no accessor defined - see below
+   (value-changed-callback 
+    :initarg :value-changed-callback :initform nil
+    :reader gadget-value-changed-callback)))
+
+;; we explicitly define our own gadget-value accessor so that the
+;; writer can include the invoke-callback keyword argument
 
 (defgeneric gadget-value (gadget))
 
@@ -81,40 +87,48 @@
 
 (defgeneric (setf gadget-value) (value gadget &key invoke-callback))
 
-(defmethod (setf gadget-value) (value (gadget value-gadget) &key invoke-callback)
-  (declare (ignore value invoke-callback)))
+(defmethod (setf gadget-value)
+    (value (gadget value-gadget) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (setf (slot-value gadget 'value) value))
 
-;;--- What is the correct default for INVOKE-CALLBACK?
-(defmethod (setf gadget-value) :after (value (gadget value-gadget) &key invoke-callback)
-  (setf (slot-value gadget 'value) value)
+(defmethod (setf gadget-value) :after
+    (value (gadget value-gadget) &key invoke-callback)
   (when invoke-callback
-    (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) value)))
+    (value-changed-callback gadget
+			    (gadget-client gadget) (gadget-id gadget) value)))
 
-(defmethod value-changed-callback :around ((gadget value-gadget) (client t) (id t) value)
+(defmethod value-changed-callback :around 
+    ((gadget value-gadget) (client t) (id t) value)
   (setf (slot-value gadget 'value) value)
   (let ((callback (gadget-value-changed-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget value)
-        (call-next-method))))
+    (when callback
+      (invoke-callback-function callback gadget value))
+    (call-next-method)))
 
-(defmethod value-changed-callback ((gadget value-gadget) (client t) (id t) value)
+(defmethod value-changed-callback
+    ((gadget value-gadget) (client t) (id t) value)
   (declare (ignore value))
   nil)
 
+;;; Action Gadgets
 
 (defclass action-gadget (basic-gadget)
     ((activate-callback :initarg :activate-callback :initform nil
 			:reader gadget-activate-callback)))  
 
-(defmethod activate-callback :around ((gadget action-gadget) (client t) (id t))
+(defmethod activate-callback :around
+    ((gadget action-gadget) (client t) (id t))
   (let ((callback (gadget-activate-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget)
-        (call-next-method))))
+    (when callback
+      (invoke-callback-function callback gadget))
+    (call-next-method)))
 
-(defmethod activate-callback ((gadget action-gadget) (client t) (id t))
+(defmethod activate-callback 
+    ((gadget action-gadget) (client t) (id t))
   nil)
 
+;;; Focus Gadgets
 
 (defclass focus-gadget (basic-gadget)
     ((focus-out-callback :initarg :focus-out-callback :initform nil
@@ -122,25 +136,28 @@
      (focus-in-callback :initarg :focus-in-callback :initform nil
 			:reader gadget-focus-in-callback)))
 
-(defmethod focus-out-callback :around ((gadget focus-gadget) (client t) (id t)) 
+(defmethod focus-out-callback :around
+    ((gadget focus-gadget) (client t) (id t)) 
   (let ((callback (gadget-focus-out-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget)
-	(call-next-method))))
+    (when callback
+      (invoke-callback-function callback gadget))
+    (call-next-method)))
 
-(defmethod focus-out-callback ((gadget focus-gadget) (client t) (id t))
+(defmethod focus-out-callback
+    ((gadget focus-gadget) (client t) (id t))
   nil)
 
-(defmethod focus-in-callback :around ((gadget focus-gadget) (client t) (id t)) 
+(defmethod focus-in-callback :around
+    ((gadget focus-gadget) (client t) (id t)) 
   (let ((callback (gadget-focus-in-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget)
-	(call-next-method))))
+    (when callback
+      (invoke-callback-function callback gadget))
+    (call-next-method)))
 
-(defmethod focus-in-callback ((gadget focus-gadget) (client t) (id t))
+(defmethod focus-in-callback 
+    ((gadget focus-gadget) (client t) (id t))
   nil)
 
-
 ;;; Basic gadgets-mixins
 
 (defclass oriented-gadget-mixin ()
@@ -220,14 +237,14 @@
      (number-of-tick-marks :initarg :number-of-tick-marks)
      (number-of-quanta :initarg :number-of-quanta)
      (editable-p :initarg :editable-p :accessor gadget-editable-p))
-  (:default-initargs :decimal-places 0
-		     :show-value-p nil
-		     :min-label nil
-		     :max-label nil
-		     :range-label-text-style *default-slider-range-label-text-style*
-		     :number-of-tick-marks 0
-		     :number-of-quanta nil
-		     :editable-p t))
+    (:default-initargs :value 0.0
+                       :show-value-p nil
+		       :min-label nil
+		       :max-label nil
+		       :range-label-text-style *default-slider-range-label-text-style*
+		       :number-of-tick-marks 0
+		       :number-of-quanta nil
+		       :editable-p t))
 
 (defmethod initialize-instance :after ((pane slider) 
 				       &key (decimal-places 0 places-p)
@@ -242,9 +259,9 @@
 
 (defmethod drag-callback :around ((gadget slider) (client t) (id t) value)
   (let ((callback (slider-drag-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget value)
-        (call-next-method))))
+    (when callback
+      (invoke-callback-function callback gadget value))
+    (call-next-method)))
 
 (defmethod drag-callback ((gadget slider) (client t) (id t) value)
   (declare (ignore value))
@@ -254,25 +271,37 @@
 ;;; Scroll bar
 (defclass scroll-bar
 	  (value-gadget range-gadget-mixin oriented-gadget-mixin)
-    ((current-value :initform nil :accessor scroll-bar-current-value)
-     (current-size :initform nil :accessor scroll-bar-current-size)
+    ((size :initform nil :initarg :size :accessor scroll-bar-size)
      (drag-callback :initarg :drag-callback :initform nil
 		    :reader scroll-bar-drag-callback)))
 
-(defmethod destroy-mirror :after  ((port basic-port) (sheet scroll-bar))
-  ;; This invalidates any caching that is going on
-  (setf (scroll-bar-current-size sheet) nil))
-
 (defmethod drag-callback :around ((gadget scroll-bar) (client t) (id t) value)
   (let ((callback (scroll-bar-drag-callback gadget)))
-    (if callback
-	(invoke-callback-function callback gadget value)
-        (call-next-method))))
+    (when callback
+	(invoke-callback-function callback gadget value))
+    (call-next-method)))
 
 (defmethod drag-callback ((gadget scroll-bar) (client t) (id t) value)
   (declare (ignore value))
   nil)
 
+(defmethod (setf scroll-bar-size) :around (size (gadget scroll-bar))
+  (assert (and (<= (+ size (gadget-value gadget))
+		   (gadget-max-value gadget))
+	       (> size 0)) 
+      (size)
+    "Scroll bar size ~A out of range" size)
+  (call-next-method size gadget))
+
+(defmethod (setf gadget-value) :around 
+	   (value (gadget scroll-bar) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (assert (and (<= (+ value (scroll-bar-size gadget))
+		   (gadget-max-value gadget))
+	       (>= value (gadget-min-value gadget))) 
+      (value)
+    "Scroll bar value ~A out of range" value)
+  (call-next-method value gadget))
 
 ;;; Push-button
 (defclass push-button 
@@ -325,20 +354,26 @@
  	    :initarg :current-selection
  	    :accessor radio-box-current-selection)))
 
-(defmethod (setf gadget-value) (new-value (gadget radio-box) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (new-value (gadget radio-box) &key invoke-callback)
   (declare (ignore invoke-callback))
   (unless (eq new-value (radio-box-current-selection gadget))
     (dolist (toggle (radio-box-selections gadget))
       (setf (gadget-value toggle)
-	(eq new-value toggle))))
-  (call-next-method))
+	(eq new-value toggle)))))
 
 (defmethod initialize-instance :after ((rb radio-box) &key choices)
   (let* ((frame (pane-frame rb))
 	 (framem (frame-manager frame))
-	 (selections nil))
+	 (selections nil)
+	 (current-selection (radio-box-current-selection rb)))
     (assert (and frame framem) ()
       "There must be both a frame and frame manager active")
+    (when current-selection
+      (assert (member current-selection choices :test #'equal) 
+	  ()
+	"Radio box current-selection: ~S must be one of choices: ~S"
+	current-selection choices))
     (with-look-and-feel-realization (framem frame)
       (dolist (choice choices)
 	(etypecase choice
@@ -348,10 +383,10 @@
 	   (unless (sheet-parent choice)
 	     (sheet-adopt-child rb choice))
 	   (push choice selections)
-	   (setf (gadget-value choice) (eq choice (radio-box-current-selection rb))))
+	   (setf (gadget-value choice) (eq choice current-selection)))
 	  (string
 	   ;; Create a button if the user supplied an abbreviation
-	   (let* ((value (equal (radio-box-current-selection rb) choice))
+	   (let* ((value (equal current-selection choice))
 		  (button (make-pane 'toggle-button 
 				     :value value
 				     :label choice
@@ -362,8 +397,7 @@
 	     (push button selections)
 	     (when value
 	       (setf (radio-box-current-selection rb) button)))))))
-    (setf (slot-value rb 'selections) (nreverse selections))
-    (check-type (radio-box-current-selection rb) (or null pane))))
+    (setf (slot-value rb 'selections) (nreverse selections))))
 
 (defmethod value-changed-callback :around 
 	   ((selection basic-gadget) (client radio-box) gadget-id value)
@@ -390,20 +424,26 @@
  	    :initarg :current-selection
  	    :accessor check-box-current-selection)))
 
-(defmethod (setf gadget-value) (new-value (gadget check-box) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (new-value (gadget check-box) &key invoke-callback)
   (declare (ignore invoke-callback))
   (unless (equal new-value (check-box-current-selection gadget))
     (dolist (toggle (check-box-selections gadget))
       (setf (gadget-value toggle)
-	(member toggle new-value))))
-  (call-next-method))
+	(member toggle new-value)))))
 
 (defmethod initialize-instance :after ((cb check-box) &key choices)
   (let* ((frame (pane-frame cb))
 	 (framem (frame-manager frame))
-	 (selections nil))
+	 (selections nil)
+	 (current-selection (check-box-current-selection cb)))
     (assert (and frame framem) ()
       "There must be both a frame and frame manager active")
+    (assert (every #'(lambda (x) (member x choices :test #'equal))
+		   current-selection)
+	()
+      "Each element of check box current-selection: ~S must be one of choices: ~S"
+      current-selection choices)
     (with-look-and-feel-realization (framem frame)
       (dolist (choice choices)
 	(etypecase choice
@@ -413,10 +453,10 @@
 	   (push choice selections)
 	   (unless (sheet-parent choice)
 	     (sheet-adopt-child cb choice))
-	   (setf (gadget-value choice) (member choice (check-box-current-selection cb))))
+	   (setf (gadget-value choice) (member choice current-selection)))
 	  (string
 	   ;; Create a button if the user supplied an abbreviation
-	   (let* ((value (member choice (check-box-current-selection cb) :test #'equal))
+	   (let* ((value (member choice current-selection :test #'equal))
 		  (button (make-pane 'toggle-button 
 				     :value (and value t)
 				     :label choice
@@ -427,8 +467,7 @@
 	     (push button selections)
 	     (when value
 	       (setf (car value) button)))))))
-    (setf (slot-value cb 'selections) (nreverse selections))
-    (assert (every #'panep (check-box-current-selection cb)) () "Current selection must be a list of panes")))
+    (setf (slot-value cb 'selections) (nreverse selections))))
 
 (defmethod value-changed-callback :around 
 	   ((selection basic-gadget) (client check-box) gadget-id value)
diff --git a/silica/layout.lisp b/silica/layout.lisp
index dd1fd8240b578048e873780acec10b13a82fe718..0c13845afa558039a203b73b15213f1ce3dcd820 100644
--- a/silica/layout.lisp
+++ b/silica/layout.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: layout.lisp,v 1.32 1993/06/21 20:51:19 cer Exp $
+;; $fiHeader: layout.lisp,v 1.33 1993/12/07 05:34:01 colin Exp $
 
 (in-package :silica)
 
@@ -15,7 +15,7 @@
   (print-unreadable-object (object stream :type t)
     (multiple-value-bind (width min-width max-width height min-height max-height) 
 	(space-requirement-components object)
-      (format stream "~D,~D,~D ~D,~D,~D"
+      (format stream "~D<w=~D<~D ~D<h=~D<~D"
 	min-width width max-width 
 	min-height height max-height))))
 
diff --git a/silica/medium.lisp b/silica/medium.lisp
index 3b2003d95df7ea879892f300c92369f2cc3d1a5d..2c1e91587372edb1d623d0687f7aab22db1e01bf 100644
--- a/silica/medium.lisp
+++ b/silica/medium.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: medium.lisp,v 1.38 1993/09/07 21:46:44 colin Exp $
+;; $fiHeader: medium.lisp,v 1.39 1993/09/17 19:06:17 cer Exp $
 
 (in-package :silica)
 
@@ -129,7 +129,8 @@
 		   `(let ((,c ,color))
 		      (etypecase ,c
 			(color ,c)
-			(string (find-named-color ,c palette))))))
+			(string (find-named-color ,c palette))
+			(integer (make-device-color palette ,c))))))
 	       (get-resource (resource default)
 		 `(or (getf initargs ,resource)
 		      (get-parent-initarg sheet ,resource)
diff --git a/silica/port.lisp b/silica/port.lisp
index ff916f0a452cfcc4b9c6b519b7e1154f16f07a2c..21b31e39f23f5d674a6bd0810191b6c949f39d88 100644
--- a/silica/port.lisp
+++ b/silica/port.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: port.lisp,v 1.31 1993/07/22 15:38:59 cer Exp $
+;; $fiHeader: port.lisp,v 1.32 1993/09/07 21:46:48 colin Exp $
 
 (in-package :silica)
 
@@ -72,8 +72,8 @@
 (defmethod initialize-instance :around ((port basic-port) &key server-path)
   (setf (slot-value port 'server-path) (copy-list server-path))
   (call-next-method)
-  (setq *ports* (nconc *ports* (list port)))
-  (restart-port port))
+  (restart-port port)
+  (setq *ports* (nconc *ports* (list port))))
 
 
 (defmethod find-named-color (name (port basic-port) &key (errorp t))
diff --git a/silica/sheet.lisp b/silica/sheet.lisp
index 13bc9ed20c7bb2628a1dccb73e919effefc2efaa..864900de6777ef8b581d55e88e55444f2b222b38 100644
--- a/silica/sheet.lisp
+++ b/silica/sheet.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sheet.lisp,v 1.37 1993/05/25 20:41:59 cer Exp $
+;; $fiHeader: sheet.lisp,v 1.38 1993/07/27 01:51:13 colin Exp $
 
 (in-package :silica)
 
@@ -48,6 +48,9 @@
 (defclass sheet-single-child-mixin (sheet-parent-mixin)
     ((children :initform nil :accessor sheet-children)))
 
+(define-dynamic-extent-args map-over-sheets (function sheet)
+  function)
+
 (defun map-over-sheets (function sheet)
   (declare (dynamic-extent function))
   (funcall function sheet)
diff --git a/silica/text-style.lisp b/silica/text-style.lisp
index 6ff66ee69250c03c03a2fff2c866c61a4707bf89..c4cdb98874774781e8d152e41866d3deed6767b4 100644
--- a/silica/text-style.lisp
+++ b/silica/text-style.lisp
@@ -1,10 +1,11 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: text-style.lisp,v 1.19 1993/05/13 16:29:57 colin Exp $
+;; $fiHeader: text-style.lisp,v 1.21 1993/08/19 20:10:16 smh Exp $
 
 (in-package :silica)
 
 "Copyright (c) 1990, 1991, 1992 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1991, 1992 Franz, Inc.  All rights reserved.
  Portions copyright (c) 1989, 1990 International Lisp Associates."
 
 ;;; To consider: how to merge Genera styles with styles.
@@ -28,10 +29,6 @@
   (with-slots (family face size) style
     (values family (face-code->face face) size)))
 
-(defmethod fully-merged-text-style-p ((style standard-text-style))
-  (with-slots (family face size) style
-    (and family face size)))
-
 (defmethod make-load-form ((object standard-text-style) &optional environment)
   (declare (ignore environment))
   (with-slots (family face size) object
@@ -692,16 +689,17 @@
     (standardize-text-style-error style))
   style)
 
-(defun standardize-text-style-error (style)
-  (if (fully-merged-text-style-p style)
-      (cerror "Use the undefined text style stand-in instead"
-	      "The size component of ~S is not numeric.  This port does not know ~
+(defmethod standardize-text-style-error ((style standard-text-style))
+  (with-slots (family face size) style
+    (if (and family face size)
+	(cerror "Use the undefined text style stand-in instead"
+		"The size component of ~S is not numeric.  This port does not know ~
 	       how to map logical text style sizes"
-	      style)
+		style)
       (cerror "Use the undefined text style stand-in instead"
 	      "The text style ~S must be a fully merged text style"
 	      style))
-  *undefined-text-style*)
+    *undefined-text-style*))
 
 ;; For use by more specific STANDARDIZE-TEXT-STYLE methods
 (defun-inline standardize-text-style-1 (port style character-set size-alist)
diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp
index b728c503df32193004ed5d5a7f3247a169073834..b17586a4968ab5f773b9c150fce3f6f2952ac2c6 100644
--- a/sys/sysdcl.lisp
+++ b/sys/sysdcl.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: sysdcl.lisp,v 1.41 93/05/13 17:31:55 colin Exp $
+;; $fiHeader: sysdcl.lisp,v 1.43 1994/11/23 23:29:01 smh Exp $
 
 (in-package #-ANSI-90 :user #+ANSI-90 :cl-user)
 
@@ -176,7 +176,7 @@
    "std-sheet"
 
    ;; "Windshield", aka "DashBoard"
-  ;; First the layout gadgets
+   ;; First the layout gadgets
    "layout"
    "db-layout"
    "db-box"
@@ -186,10 +186,6 @@
    "gadgets"
    "db-border"
    "db-scroll"
-   "scroll-pane"
-   "db-button"
-   ("db-label" (:load-before-compile "db-border"))
-   "db-slider"
    ))
 
 (defsystem clim-standalone
@@ -268,11 +264,9 @@
    ("command-processor" (:load-before-compile "clim-defs" "command"))
    ("basic-translators" (:load-before-compile "ptypes2" "command"))
    ("frames" (:load-before-compile "clim-defs" "command-processor"))
+   ("panes" (:load-before-compile "frames"))
    ("default-frame" (:load-before-compile "frames"))
    ("activities" (:load-before-compile "frames"))
-   ("db-menu" (:load-before-compile "frames"))
-   ("db-list" (:load-before-compile "db-menu"))
-   ("db-text" (:load-before-compile "frames"))
    ("noting-progress" (:load-before-compile "frames"))
    ("menus" (:load-before-compile "defresource" "clim-defs"))
    ("accept-values" (:load-before-compile "clim-defs" "incremental-redisplay" "frames"))
@@ -285,6 +279,20 @@
    #+(or Genera Cloe-Runtime) "prefill"
    ))
 
+(defsystem clim-homegrown
+    (:default-pathname "clim2:;homegrown;")
+  (:serial
+   clim-standalone 
+   clim-silica)
+  "scroll-pane"
+  "db-button"
+  "db-label"
+  "db-slider"
+  "db-menu"
+  ("db-list" (:load-before-compile "db-menu"))
+  "db-text"
+  "last")
+
 
 #+Allegro
 (defsystem xlib
diff --git a/test/test-driver.lisp b/test/test-driver.lisp
index 3bcaf37e9d6e0d16fda3d1a19fd5d76fd6c6dffc..c31a3855ddc7d67fe09fa45c6ea2b7a49fddc182 100644
--- a/test/test-driver.lisp
+++ b/test/test-driver.lisp
@@ -685,17 +685,14 @@
 		 (declare (ignore second minute hour))
 		 (format nil "notes/times/~D.~D.~D.n" month date year)))))
 
-(defun test-it (&optional filename (errorp *catch-errors-in-tests*))
-  (let* ((file (pathname (or filename (format nil "/tmp/foofile~A" (gensym))))))
-    (exercise-frame 'test-it
-		    'clim-user::clim-tests
-		    '(:width 600 :height 400 :left 0 :top 0)
-		    `(((clim-user::run-benchmarks-to-dummy-file :file ,file) :timeout 1800))
-		    `(clim-user::exit-clim-tests)
-		    :error errorp)
-    (unless filename 
-      (when (probe-file file)
-	(delete-file file)))))
+(defun test-it (&optional (pathname "/dev/null") (errorp *catch-errors-in-tests*))
+  (exercise-frame 'test-it
+		  'clim-user::clim-tests
+		  '(:width 600 :height 400 :left 0 :top 0)
+		  `(((clim-user::run-benchmarks 
+		      :pathname ,pathname) :timeout 1800))
+		  `(clim-user::exit-clim-tests)
+		  :error errorp))
 
 (defun fill-in-partial-command-1 (command-name command-table stream
 				  partial-command accept-function send-it)
diff --git a/test/test-suite.lisp b/test/test-suite.lisp
index c4858a22459299a761b2a2083f401edd3373d488..b31fa14ca064f41652bb90f1b16dfe7cf56c7975 100644
--- a/test/test-suite.lisp
+++ b/test/test-suite.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: test-suite.lisp,v 1.73 1993/10/25 16:16:15 cer Exp $
+;; $fiHeader: test-suite.lisp,v 1.74 1993/11/18 18:45:15 cer Exp $
 
 (in-package :clim-user)
 
@@ -2232,7 +2232,10 @@ Luke Luck licks the lakes Luke's duck likes."))
 					 (terpri stream))))
 				accepts))))
 	(accepts 
-	 (d (float 0 1) :view '(slider-view :show-value-p t :decimal-places 2))
+	 (d (float 0 1) :view '(slider-view :show-value-p t
+				:decimal-places 2 
+				:min-label "min"
+				:max-label "max"))
 	 (e (integer 0 10) :view +slider-view+)
 	 (f (float 0 100) :view '(slider-view :orientation :vertical :show-value-p t))
 	 (g (integer 0 10) :view '(slider-view :orientation :vertical)))
@@ -2362,6 +2365,70 @@ Luke Luck licks the lakes Luke's duck likes."))
     (fresh-line stream)
     (accept 'string :stream stream)))
 
+(define-application-frame list-pane-frame ()
+  ()
+  (:panes
+   (list-pane1
+    (make-pane 'clim::list-pane
+	       :items '("no scrolling" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0))
+   (list-pane2
+    (make-pane 'clim::list-pane
+	       :items '("nil" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0))
+   (list-pane3
+    (make-pane 'clim::list-pane
+	       :items '(":dynamic" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0))
+   (list-pane4
+    (make-pane 'clim::list-pane
+	       :items '(":horizontal" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0))
+   (list-pane5
+    (make-pane 'clim::list-pane
+	       :items '(":vertical" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0))
+   (list-pane6
+    (make-pane 'clim::list-pane
+	       :items '(":both" "a very long item to show" "short")
+	       :min-height 10
+	       :max-height +fill+
+	       :min-width 0)))
+  (:layouts
+   (default
+       (vertically ()
+	 list-pane1
+	 (scrolling (:scroll-bars nil)
+	   list-pane2)
+	 (scrolling (:scroll-bars :dynamic)
+	   list-pane3)
+	 (scrolling (:scroll-bars :horizontal)
+	   list-pane4)
+	 (scrolling (:scroll-bars :vertical)
+	   list-pane5)
+	 (scrolling (:scroll-bars :both)
+	   list-pane6)))))
+
+(define-list-pane-frame-command (com-quit-list-pane :menu "Quit") ()
+  (clim::frame-exit clim::*application-frame*))
+
+(define-test (scrolled-list-pane-tests menus-and-dialogs) (stream)
+  "Resize the window and check things work ok"
+  (run-frame-top-level 
+   (make-application-frame 'list-pane-frame 
+			   :input-buffer (stream-input-buffer stream))))
+
+
 
 ;;;; Benchmarks
 
@@ -2486,22 +2553,19 @@ Luke Luck licks the lakes Luke's duck likes."))
    compound-dialog)))
 
 (define-command (run-benchmarks :command-table benchmarks :menu t)
-    ()
-  (multiple-value-bind (pathname comment)
-      (let ((stream (get-frame-pane *application-frame* 'display-pane)))
-	(window-clear stream)
-	(accepting-values (stream)
-	  (values (progn
-		    (terpri stream)
-		    (accept 'pathname :prompt "Pathname for results" :stream stream))
-		  (progn
-		    (terpri stream)
-		    (accept 'string :prompt "Comment describing this run" :stream stream)))))
-    (run-benchmarks-internal pathname comment)))
-
-(define-command (run-benchmarks-to-dummy-file :command-table benchmarks :menu t)
-    (&key (file '(null-or-type pathname) :default nil))
-  (run-benchmarks-internal file "no comment"))
+    (&key (pathname '(null-or-type pathname))
+	  (comment 'string :default "no comment"))
+  (unless (and pathname comment)
+    (let ((stream (get-frame-pane *application-frame* 'display-pane)))
+      (window-clear stream)
+      (accepting-values (stream :align-prompts t)
+	(setq pathname
+	  (accept 'pathname :prompt "Pathname for results" 
+		  :stream stream :default pathname))
+	(setq comment
+	  (accept 'string :prompt "Comment describing this run"
+		  :stream stream :default comment)))))
+  (run-benchmarks-internal pathname comment))
 
 (defun run-benchmarks-internal (pathname comment)
   (let ((data nil))
diff --git a/tk-silica/gc-cursor.lisp b/tk-silica/gc-cursor.lisp
index 7bd5edba07707907eece2b720a65949e62e0a75c..3577cdfa42ee7017cdeed5966b7270194df4e96d 100644
--- a/tk-silica/gc-cursor.lisp
+++ b/tk-silica/gc-cursor.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: gc-cursor.lisp,v 1.1 93/05/13 16:24:48 cer Exp $
+;; $fiHeader: gc-cursor.lisp,v 1.3 1994/11/23 23:29:23 smh Exp $
 
 
 (in-package :xm-silica)
@@ -47,10 +47,9 @@
       (if mirror
 	  (tk::set_clim_gc_cursor_widget 
 	   mirror
-	   (let ((cursor (sheet-pointer-cursor sheet)))
-	     (if cursor
-		 (realize-cursor (port sheet) sheet cursor)
-	       0)))
+	   (realize-cursor (port sheet) 
+			   sheet
+			   (sheet-pointer-cursor sheet)))
 	(tk::set_clim_gc_cursor_widget 0 0)))))
 
 (defmethod (setf sheet-pointer-cursor) :after (cursor (sheet xt-top-level-sheet))
diff --git a/tk-silica/image.lisp b/tk-silica/image.lisp
index 7611bbbd299790d22e6356a75d7b1447722e15bb..ff3d29425da30ad71165651b9d9eb468157f287d 100644
--- a/tk-silica/image.lisp
+++ b/tk-silica/image.lisp
@@ -20,20 +20,20 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: image.lisp,v 1.16 1993/09/17 19:06:57 cer Exp $
+;; $fiHeader: image.lisp,v 1.17 1993/11/18 18:45:30 cer Exp $
 
 (in-package :xm-silica)
 
 
 (defun make-pattern-from-bitmap-file (file &rest args &key ((:designs supplied-designs)) format)
-  (multiple-value-bind
-      (array designs)
+  (multiple-value-bind (array designs)
       (with-keywords-removed (args args '(:designs))
 	(apply #'read-bitmap-file file args))
     (make-pattern array 
 		  (or designs 
 		      supplied-designs 
-		      (error "Designs must be specified for this format: ~A" format)))))
+		      (error "Designs must be specified for this format: ~A"
+			     format)))))
 
 ;;; 
 
@@ -66,13 +66,22 @@
 (defmethod read-image-file ((format t) pathname palette)
   (multiple-value-bind (format filter)
       (compute-filter-for-bitmap-format format)
-    (with-open-stream (fstream (excl:run-shell-command
-				(format nil "cat ~A | ~A"
-					(truename pathname) filter)
-				:wait nil
-				:error-output :stream
-				:output :stream))
-      (read-image-file format fstream palette))))
+    (let* ((truename (truename pathname))
+	   (command (format nil "cat ~A | ~A" truename filter)))
+      (unwind-protect
+	  (with-open-stream (fstream (excl:run-shell-command
+				      command
+				      :wait nil
+				      ;;:error-output :stream
+				      :output :stream))
+	    (handler-case (read-image-file format fstream palette)
+	      (error (c)
+		(error "Unable to read image file: (~s ~s ~s) signalled \"~a\" ~
+			while executing ~s. ~
+			Make sure programs like xpm are executable in your path."
+		       'read-image-file format pathname palette command)
+		)))
+	(sys:os-wait)))))
 
 (defmethod compute-filter-for-bitmap-format (format)
   (error "Dont know how to convert from the format ~A" format))
@@ -136,7 +145,6 @@
 			chars-per-pixel line)
       (get-bitmap-file-properties fstream)
     (declare (ignore line depth left-pad))
-    (assert (= chars-per-pixel 1))
     (assert (= format 1))
     (flet ((read-strings ()
 	     (let ((strings nil))
@@ -153,7 +161,7 @@
       (let ((colors (do ((colors (read-strings) (cddr colors))
 			 (r nil))
 			((null colors) r)
-		      (push (cons (coerce (first colors) 'character) 
+		      (push (cons (first colors) 
 				  (convert-color (second colors))) r)))
 	    (pixels (read-strings))
 	    (array (make-array (list height width)))
@@ -163,8 +171,11 @@
 	(excl::fast
 	 (dolist (row pixels)
 	   (dotimes (j width)
-	     (setf (aref array i j)
-	       (position (schar row j) colors :key #'car)))
+	     (let ((index (* j chars-per-pixel)))
+	       (setf (aref array i j)
+		 (position
+		  (subseq row index (+ index chars-per-pixel))
+		  colors :key #'car :test #'equal))))
 	   (incf i)))
 	(values array (mapcar #'cdr colors))))))
 
@@ -229,7 +240,7 @@
 
 
 
-;; Support for the xpm stuff.
+;; Support for the xpm version 3 format
 
 (defmethod read-image-file ((format (eql :pixmap-3)) pathname palette)
   (if (streamp pathname)
diff --git a/tk-silica/last.lisp b/tk-silica/last.lisp
index 07278917bbe6b476cac2a02af64ae42890af7239..1308c33c30085235a9654b11a91f8975b3f10f70 100644
--- a/tk-silica/last.lisp
+++ b/tk-silica/last.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: last.lisp,v 1.4 1993/07/27 01:54:56 colin Exp $
+;; $fiHeader: last.lisp,v 1.5 1993/09/17 19:06:58 cer Exp $
 
 
 (in-package :system)
@@ -35,3 +35,7 @@
 		    excl::*library-pathname*)))
  :devel (locally (declare (special system::*devel*)) system::*devel*))
 
+(provide
+ (cond ((excl::featurep :clim-motif) :climxm)
+       ((excl::featurep :clim-openlook) :climol)
+       (t (error "Unknown Xt backend"))))
diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp
index 64b762002594d502caa9053e20fd41e272315998..3b2427cbdb7de6c447f7e1433f6de1bef7895dc1 100644
--- a/tk-silica/ol-gadgets.lisp
+++ b/tk-silica/ol-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-gadgets.lisp,v 1.63 1993/11/18 18:45:32 cer Exp $
+;; $fiHeader: ol-gadgets.lisp,v 1.64 1993/12/07 05:34:15 colin Exp $
 
 
 (in-package :xm-silica)
@@ -58,67 +58,69 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-scroll-bar))
-  (values 'tk::scrollbar '(:slider-max 0 :slider-max 1000)))
-
-(defmethod (setf scroll-bar-size) (nv (sb openlook-scroll-bar))
-  ;; (tk::set-values (sheet-direct-mirror sb) :slider-size nv)
-  nv)
-
-(defmethod (setf scroll-bar-value) (nv (sb openlook-scroll-bar))
-  (tk::set-values (sheet-direct-mirror sb) :slider-value nv)
-  nv)
+  (let ((size (scroll-bar-size sheet)))
+    (values 'tk::scrollbar
+	    (append '(:slider-min 0 :slider-max 1000)
+		    (when size
+		      `(:proportion-length 
+			,(convert-scroll-bar-value-out sheet
+						       size)))))))
 
 (defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &key
-							      slider-size value line-increment)
+							      slider-size 
+							      value line-increment)
   (let ((mirror (sheet-direct-mirror sb)))
-    (multiple-value-bind
-	(mmin mmax) (tk::get-values mirror :slider-min :slider-max)
+    (when mirror
       (multiple-value-bind
-	  (real-value real-size line-increment)
-	  (compute-new-scroll-bar-values sb mmin mmax value
-					 slider-size line-increment)
-	(tk::set-values
-	 mirror
-	 :granularity line-increment
-	 :proportion-length  real-size
-	 :slider-value real-value)))))
+	(real-value real-size line-increment)
+	  (compute-new-scroll-bar-values sb value slider-size line-increment)
+      (tk::set-values mirror
+		      :granularity line-increment
+		      :proportion-length  real-size
+		      :slider-value real-value)))))
 
-;;-- This method is ((gadget motif-range-pane))
+(defmethod add-sheet-callbacks :after  ((port openlook-port) (sheet openlook-scroll-bar) (widget t))
+  (tk::add-callback widget
+		    :slider-moved
+		    'ol-scroll-bar-callback
+		    sheet))
+
+(defun ol-scroll-bar-callback (widget value sheet)
+  (declare (ignore widget))
+  (value-changed-callback
+   sheet
+   (gadget-client sheet)
+   (gadget-id sheet)
+   (convert-scroll-bar-value-in sheet value)))
 
 (defmethod gadget-value ((gadget openlook-scroll-bar))
-  ;;--- We should use the scale functions to get the value
   (let ((mirror (sheet-direct-mirror gadget)))
-    (if mirror 
-        (multiple-value-bind
-            (smin smax) (gadget-range* gadget)
-          (multiple-value-bind
-              (value mmin mmax proportion-length)
-              (tk::get-values mirror :slider-value :slider-min
-			      :slider-max :proportion-length)
-            (compute-symmetric-value
-             mmin (- mmax proportion-length) value smin smax)))
+    (if mirror
+	(convert-scroll-bar-value-in gadget
+				     (tk::get-values mirror :slider-value))
       (call-next-method))))
 
-(defmethod add-sheet-callbacks :after  ((port openlook-port) (sheet openlook-scroll-bar) (widget t))
-  (tk::add-callback widget
-		    :slider-moved
-		    'scroll-bar-changed-callback-1
-		    sheet))
+(defmethod (setf gadget-value) :after 
+	   (nv (gadget openlook-scroll-bar) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (let ((mirror (sheet-direct-mirror gadget)))
+    (when mirror
+      (tk::set-values mirror
+		      :slider-value (convert-scroll-bar-value-out gadget nv)))))
+
+(defmethod scroll-bar-size ((sheet openlook-scroll-bar))
+  (let ((mirror (sheet-direct-mirror sheet)))
+    (if mirror
+	(convert-scroll-bar-value-in sheet
+				     (tk::get-values mirror :proportion-length))
+      (call-next-method))))
 
-(defmethod scroll-bar-changed-callback-1 ((widget t) value (sheet openlook-scroll-bar))
-  (multiple-value-bind
-      (smin smax) (gadget-range* sheet)
-    (multiple-value-bind
-	(size mmin mmax)
-	(tk::get-values widget :proportion-length :slider-min :slider-max)
-      (scroll-bar-value-changed-callback
-       sheet
-       (gadget-client sheet)
-       (gadget-id sheet)
-       (compute-symmetric-value
-	mmin (- mmax size) value smin smax)
-       (compute-symmetric-value
-	mmin mmax size smin smax)))))
+(defmethod (setf scroll-bar-size) :after (nv (sheet openlook-scroll-bar))
+  (let ((mirror (sheet-direct-mirror sheet)))
+    (when mirror
+      (tk::set-values mirror
+		      :proportion-length
+		      (convert-scroll-bar-value-out sheet nv)))))
 
 (defmethod compose-space ((m openlook-scroll-bar) &key width height)
   (declare (ignore width height))
@@ -522,10 +524,15 @@
 (defmethod compose-space ((sheet openlook-label-pane) &key width height)
   (declare (ignore width height))
   (let ((label (gadget-label sheet)))
-    (if (typep label 'xt::pixmap)
-	(make-space-requirement :width (xt::pixmap-width label)
-				:height (xt::pixmap-height label))
-      (call-next-method))))
+    (cond
+     ((typep label 'xt::pixmap)
+      (make-space-requirement :width (xt::pixmap-width label)
+			      :height (xt::pixmap-height label)))
+     ((typep label 'pattern)
+      (make-space-requirement :width (pattern-width label)
+			      :height (pattern-height label)))
+     (t
+      (call-next-method)))))
 
 (defun make-label-initarg (label initarg)
   (etypecase label
@@ -628,6 +635,15 @@
 (defun openlook-text-field-edit-widget (tf &optional (mirror (sheet-direct-mirror tf)))
   (tk::get-values mirror :text-edit-widget))
 
+;; we can't rely on OpenLook to genarate focus-out events in any
+;; consistent manner. So instead we queue a losing focus event each
+;; time the value changes. This is merly to  ensure that the
+;; accepting-values field is kept up to date (cim 3/17/94)
+
+(defun ol-text-field-value-changed (widget sheet)
+  (queue-value-changed-event widget sheet)
+  (queue-losing-focus-event widget sheet))
+
 (defmethod add-sheet-callbacks :after ((port openlook-port) 
 				       (sheet openlook-text-field) 
 				       (widget t))
@@ -635,14 +651,17 @@
     (let ((edit-widget (openlook-text-field-edit-widget sheet widget))) 
       (tk::add-callback edit-widget
 			:post-modify-notification
-			'queue-value-changed-event
+			'ol-text-field-value-changed
 			sheet)
+      #+ignore
       (tk::add-event-handler edit-widget
 			     '(:focus-change)
 			     1
 			     'openlook-text-field-event-handler
 			     sheet))))
 
+
+#+ignore
 (defun openlook-text-field-event-handler (widget event sheet)
   (case (tk::event-type event)
     (:focus-in (queue-gaining-focus-event widget sheet))
@@ -687,21 +706,26 @@
   (multiple-value-bind
       (class initargs)
       (call-next-method)
-    (with-accessors ((alignment gadget-alignment)
-		     (label gadget-label)) sheet
-      (typecase label
-	(string
-	 (unless (getf initargs :label)
-	   (setf (getf initargs :label) label))
-	 (unless (getf initargs :label-justify)
-	   (setf (getf initargs :label-justify) 
-	     (ecase alignment
-	       (:center :left)
-	       ((:left :right)  alignment)))))
-	(xt::pixmap
-	 (unless (getf initargs :label-image)
-	   (setf (getf initargs :label-image) (tk::image-from-pixmap label)
-		 (getf initargs :label-type) :image)))))
+    (unless *in-find-widget-name-and-class-hack*
+      (with-accessors ((alignment gadget-alignment)
+		       (label gadget-label)) sheet
+	(etypecase label
+	  ((or null string)
+	   (unless (getf initargs :label)
+	     (setf (getf initargs :label) label))
+	   (unless (getf initargs :label-justify)
+	     (setf (getf initargs :label-justify) 
+	       (ecase alignment
+		 (:center :left)
+		 ((:left :right)  alignment)))))
+	  ((or tk::pixmap pattern)
+	   (unless (getf initargs :label-image)
+	     (when (typep label 'pattern)
+	       (with-sheet-medium (medium sheet)
+		 (setq label
+		   (pixmap-from-pattern label medium :pixmap))))
+	     (setf (getf initargs :label-image) (tk::image-from-pixmap label)
+		   (getf initargs :label-type) :image))))))
     (values class initargs)))
 
 (defmethod (setf gadget-label) :after (nv (sheet openlook-labelled-gadget))
@@ -718,26 +742,29 @@
 ;; Toggle button
 
 (defclass openlook-toggle-button (toggle-button
-				openlook-labelled-gadget
-				xt-leaf-pane)
+				  openlook-labelled-gadget
+				  xt-leaf-pane)
 	  ())
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
 						     (parent t)
 						     (sheet openlook-toggle-button))
   (with-accessors ((set gadget-value)
-		   (indicator-type gadget-indicator-type)) sheet
+		   (indicator-type gadget-indicator-type)
+		   (label gadget-label)) sheet
     (values (typecase (sheet-parent sheet)
 	      (openlook-radio-box 'xt::rect-button)
 	      (openlook-check-box 'xt::rect-button)
 	      (t 'xt::check-box))
-	    (append (list :set set)
+	    (append `(:set ,set
+		      :position :right)
 		    #+dunno
 		    (list :indicator-type 
 			  (ecase indicator-type
 			    (:one-of :one-of-many)
 			    (:some-of :n-of-many)))))))
 
+
 ;; check-box, rect  select, unselect callback, :set resource
 
 (defmethod add-sheet-callbacks :after ((port openlook-port) 
@@ -964,26 +991,31 @@
 		   (show-value-p gadget-show-value-p)
 		   (value gadget-value)
 		   (editablep gadget-editable-p)) sheet
-    (multiple-value-bind
-	(smin smax) (gadget-range* sheet)
-      (let ((mmin 0) 
-	    (mmax 1000))
-	(values 
-	 'tk::control
-	 (append
-	  (list :slider-class (if editablep 'tk::slider 'tk::gauge))
-	  (list :show-value-p show-value-p)
-	  (list :drag-c-b-type :release)
-	  ;;-- icon label
-	  (make-label-initarg label :label)
-	  (list :slider-min mmin
-		:slider-max mmax)
-	  (and value 
-	       (list :slider-value 
-		     (fix-coordinate 
-		      (compute-symmetric-value
-		       smin smax value mmin
-		       mmax))))))))))
+    (with-slots (silica::min-label silica::max-label) sheet
+      (multiple-value-bind
+	  (smin smax) (gadget-range* sheet)
+	(let ((mmin 0) 
+	      (mmax 1000))
+	  (values 
+	   'tk::control
+	   (append
+	    (list :slider-class (if editablep 'tk::slider 'tk::gauge))
+	    (list :show-value-p show-value-p)
+	    (list :drag-c-b-type :release)
+	    ;;-- icon label
+	    (make-label-initarg label :label)
+	    (list :slider-min mmin
+		  :slider-max mmax)
+	    (and silica::min-label
+		 (list :min-label silica::min-label))
+	    (and silica::max-label
+		 (list :max-label silica::max-label))
+	    (and value 
+		 (list :slider-value 
+		       (fix-coordinate 
+			(compute-symmetric-value
+			 smin smax value mmin
+			 mmax)))))))))))
 
 (defmethod realize-mirror :around ((port openlook-port) (sheet openlook-slider))
   (let ((control-area (call-next-method))
@@ -1281,8 +1313,9 @@
     (setf (text-editor-text widget) nv)))
 
 (defmethod (setf text-editor-text) (nv (widget tk::text-edit))
-  (assert (not (zerop (tk::ol_text_edit_clear_buffer widget))))
-  (assert (not (zerop (tk::ol_text_edit_insert widget nv (length nv))))))
+  (unless (equal nv (text-editor-text widget))
+    (assert (not (zerop (tk::ol_text_edit_clear_buffer widget))))
+    (assert (not (zerop (tk::ol_text_edit_insert widget nv (length nv)))))))
 
 
 (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port)
@@ -1338,8 +1371,15 @@
 				       (widget t))
   (tk::add-callback widget
 		    :post-modify-notification
-		    'queue-value-changed-event
-		    sheet))
+		    'ol-text-field-value-changed
+		    sheet)
+
+  #+ignore
+  (tk::add-event-handler edit-widget
+			 '(:focus-change)
+			 1
+			 'openlook-text-field-event-handler
+			 sheet))
 
 (defmethod compose-space ((te openlook-text-editor) &key width height)
   (declare (ignore width height))
@@ -1437,12 +1477,17 @@
       (sheet-adopt-child (slot-value sp 'viewport) contents))))
 
 (defmethod realize-widget-mirror ((port openlook-port) (parent-sheet openlook-scrolling-window)
-						       (parent-widget t)
-						       (sheet openlook-scroll-bar))
-  (tk::get-values parent-widget
-   (ecase (gadget-orientation sheet)
-     (:horizontal :h-scrollbar)
-     (:vertical  :v-scrollbar))))
+				  (parent-widget t)
+				  (sheet openlook-scroll-bar))
+  (multiple-value-bind (class initargs)
+      (find-widget-class-and-initargs-for-sheet port parent-widget sheet)
+    (declare (ignore class))
+    (let ((widget (tk::get-values parent-widget
+				  (ecase (gadget-orientation sheet)
+				    (:horizontal :h-scrollbar)
+				    (:vertical  :v-scrollbar)))))
+      (apply #'tk::set-values widget initargs)
+      widget)))
 
 (defmethod gadget-supplies-scrolling-p ((contents t))
   nil)
@@ -1717,7 +1762,8 @@
 (defun find-list-pane-item-from-token (token)
   (tk::ol_list_item_pointer token))
 
-(defmethod compose-space ((sheet openlook-list-pane) &key width height)
+(defmethod compose-space ((sheet openlook-list-pane) &key width
+							  height)
   (declare (ignore width height))
   ;;-- Fudge alert!
   (with-accessors ((items set-gadget-items)
@@ -1880,33 +1926,51 @@
 					 :help))
 				      (name title))
 
-  (let* ((shell (make-instance 
-		 'tk::notice-shell 
-		 :parent (sheet-shell associated-window))))
-    (multiple-value-bind (text-area control-area)
-	(tk::get-values shell :text-area :control-area)
-      (tk::set-values text-area :string message-string)
-      (let ((done nil))
-	(flet ((done (widget value)
-		 (declare (ignore widget))
-		 (setq done (list value))))
-	  (dolist (exit-box exit-boxes)
-	    (multiple-value-bind (name label)
-		(if (consp exit-box) (values (first exit-box)
-					     (second exit-box)) exit-box)
-	      (let ((button (make-instance 'xt::oblong-button 
-					   :parent control-area
-					   :label (or label (string name)))))
-		(case name
-		  (:exit (tk::add-callback button :select #'done t))
-		  (:abort (tk::add-callback button :select #'done nil))))))
-	  (unwind-protect
-	      (progn
-		(tk::popup shell)
-		(wait-for-callback-invocation (port framem) #'(lambda () done))
-		(car done))
-	    (unless done
-	      (tk::popdown shell))))))))
+  (loop
+    (let* ((shell (make-instance 
+		      'tk::notice-shell 
+		    :parent (sheet-shell associated-window))))
+      (multiple-value-bind (text-area control-area)
+	  (tk::get-values shell :text-area :control-area)
+	(tk::set-values text-area :string message-string)
+	(let ((done nil))
+	  (flet ((done (widget value)
+		   (declare (ignore widget))
+		   (setq done (list value)))
+		 (display-help (widget)
+		   (declare (ignore widget))
+		   (frame-manager-notify-user 
+		    framem
+		    documentation
+		    :associated-window associated-window)
+		   (setq done (list :help))))
+	    (dolist (exit-box exit-boxes)
+	      (multiple-value-bind (name label)
+		  (if (consp exit-box) (values (first exit-box)
+					       (second exit-box)) exit-box)
+		(let ((button (make-instance 'xt::oblong-button 
+				:parent control-area
+				:label (or label (string name)))))
+		  (case name
+		    (:exit (tk::add-callback button :select #'done t))
+		    (:abort (tk::add-callback button :select #'done nil))
+		    (:help 
+		     (if documentation
+			 (tk::add-callback button :select #'display-help)
+		       (xt::set-sensitive button nil)))))))
+
+	    (let ((result
+		   (unwind-protect
+		       (progn
+			 (tk::popup shell)
+			 (wait-for-callback-invocation
+			  (port framem) #'(lambda () done))
+			 (car done))
+		     (unless done
+		       (tk::popdown shell)))))
+	      (unless (eq result :help)
+		(return-from frame-manager-notify-user result)))))))))
+  
 
 ;;--- We could export this to handle the default case.
 ;;--- It definitely needs work though. 
diff --git a/tk-silica/pkg.lisp b/tk-silica/pkg.lisp
index 44127308b58d35ae51803b837be17ec825273d80..338c52188bb04c7e3b736a9efd507a8f940b32ed 100644
--- a/tk-silica/pkg.lisp
+++ b/tk-silica/pkg.lisp
@@ -18,7 +18,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: pkg.lisp,v 1.11 1993/08/31 04:54:59 layer Exp $
+;; $fiHeader: pkg.lisp,v 1.12 1993/09/17 19:07:05 cer Exp $
+
+;;; --- the motif v openlook definitions should be in separate package
+;;; definition files
 
 (defpackage :tk-silica
   (:nicknames :xm-silica :xt-silica)
diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp
index f5f180e94544f69acad7ef34473eb958914f04b4..e15246cfeed4a08f48115ac7356fade14190f71b 100644
--- a/tk-silica/xm-frames.lisp
+++ b/tk-silica/xm-frames.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-frames.lisp,v 1.65 1993/11/18 18:45:35 cer Exp $
+;; $fiHeader: xm-frames.lisp,v 1.66 1993/12/07 05:34:21 colin Exp $
 
 (in-package :xm-silica)
 
@@ -116,6 +116,14 @@
 ;;; If would be nice if we could abstract this and use it for the OLIT
 ;;; port
 
+(defun update-menu-item-sensitivity (widget frame commands)
+  (declare (ignore widget))
+  (dolist (cbs commands)
+    (tk::set-sensitive (second cbs)
+		       (command-enabled
+			(car (second (car cbs)))
+			frame))))
+
 (defmethod realize-mirror :around ((port motif-port) (sheet motif-menu-bar))
 
   ;; This code fills the menu-bar. If top level items do not have
@@ -129,172 +137,128 @@
 	 (ct (menu-bar-command-table sheet))
 	 (flatp (flat-command-table-menu-p ct))
 	 (frame (pane-frame sheet)))
-    (labels ((compute-options (item)
-	       (let ((item-text-style (getf (command-menu-item-options item)
-					    :text-style)))
-		 (list* :font-list
-			(text-style-mapping
-			 port
-			 (if item-text-style
-			     (merge-text-styles item-text-style menu-text-style)
-			   menu-text-style))
-			initargs)))
-	     (update-menu-item-sensitivity (widget frame commands)
-	       (declare (ignore widget))
-	       (dolist (cbs commands)
-		 (tk::set-sensitive (second cbs)
-				    (command-enabled
-				     (car (second (car cbs)))
-				     frame))))
-	     (make-menu-for-command-table (command-table parent top)
-	       (if top
-		   (make-menu-for-command-table-1 command-table parent
-						  top)
-		 (let ((commands-and-buttons
-			(make-menu-for-command-table-1 command-table parent top)))
-		   ;; We might have add-callbacks for a different set
-		   ;; of children which are now destroyed
-		   (tk::remove-all-callbacks parent :map-callback)
-		   (tk::add-callback parent :map-callback
-				     #'update-menu-item-sensitivity 
-				     frame
-				     commands-and-buttons))))
-	     (make-submenu (parent menu item)
-	       (let* ((options (compute-options item))
-		      (shell (apply #'make-instance 'xt::xm-menu-shell 
-				    :width 5 ; This widget is
-				; realized when
-				; it is created
-				; so we have to
-				; specify a size!
-				    :height 5
-				    :allow-shell-resize t
-				    :override-redirect t
-				    :parent parent
-				    options))
-
-		      (submenu (apply #'make-instance 'xt::xm-row-column
-				      :managed nil
-				      :parent shell
-				      :row-column-type :menu-pulldown
-				      options))
-		      (cb (apply #'make-instance 'xt::xm-cascade-button
-					 :parent parent
-					 :label-string menu
-					 :sub-menu-id submenu
-					 options)))
-		 (unless flatp
-		   (set-button-mnemonic sheet
-					cb (getf
-					    (command-menu-item-options
-					     item) :mnemonic)))
-
-		 (add-documentation-callbacks 
-		  frame cb (getf (command-menu-item-options item) :documentation))
+    (labels 
+	((compute-options (item)
+	   (let ((item-text-style (getf (command-menu-item-options item)
+					:text-style)))
+	     (list* :font-list
+		    (text-style-mapping
+		     port
+		     (if item-text-style
+			 (merge-text-styles item-text-style menu-text-style)
+		       menu-text-style))
+		    initargs)))
+
+	 (make-command-button (parent menu item keystroke command-table)
+	   (let ((options (compute-options item))
+		 (command-name (car (command-menu-item-value item))))
+	     (let ((button 
+		    (apply #'make-instance 'xt::xm-push-button
+			   :label-string menu
+			   :managed t
+			   :parent parent
+			   :sensitive (command-enabled command-name frame)
+			   options)))
+	       
+	       (when (or (equalp menu "exit")
+			 (eq (getf (command-menu-item-options item) :button-type)
+			     :help))
+		 (tk::set-values mirror :menu-help-widget button))
+
+	       (add-documentation-callbacks 
+		frame button (getf (command-menu-item-options item) :documentation))
+
+	       (push (cons command-name button)
+		     (menu-bar-command-name-to-button-table sheet))
+			       
+	       (unless flatp
+		 (set-button-accelerator-from-keystroke 
+		  sheet
+		  button keystroke)
+			
+		 (set-button-mnemonic
+		  sheet
+		  button (getf
+			  (command-menu-item-options
+			   item) :mnemonic)))
+	       
+	       (tk::add-callback button
+				 :activate-callback
+				 'command-button-callback
+				 frame
+				 command-table
+				 item))))
+	 
+	 (make-submenu (parent menu item)
+	   (let* ((options (compute-options item))
+		  (submenu (apply #'make-instance
+				  'tk::xm-pulldown-menu
+				  :managed nil
+				  :parent parent
+				  options))
+		  (cb (apply #'make-instance 'xt::xm-cascade-button
+			     :parent parent
+			     :label-string menu
+			     :sub-menu-id submenu
+			     options)))
+
+	     (set-button-mnemonic sheet
+				  cb
+				  (getf (command-menu-item-options item)
+					:mnemonic))
+	     #+ignore
+	     (when (equalp menu "help")
+	       (tk::set-values mirror :menu-help-widget cb))
+
+	     (add-documentation-callbacks 
+	      frame cb (getf (command-menu-item-options item) :documentation))
 		 
-		 (let* ((ct (find-command-table (second item)))
-			(tick (slot-value ct 'clim-internals::menu-tick)))
-		   (make-menu-for-command-table ct submenu nil)
-		   (xt::add-callback shell :popup-callback
-		    #'(lambda (shell)
-			(declare (ignore shell))
-			(let ((children
-			       (tk::widget-children submenu)))
-			  (when (or (null children)
-				    (/= tick
-					(setq tick
-					  (slot-value ct
-						      'clim-internals::menu-tick))))
-			    (tk::unmanage-children children)
-			    (make-menu-for-command-table
-			     ct submenu nil)
-			    (mapc #'tk::destroy-widget children))))))))
-	     (make-menu-for-command-table-1 (command-table parent top)
-	       ;; Unless we are at the top level we want to have a
-	       ;; map-before callback that sets the sensitivity of
-	       ;; each item. Also we might want to regenerate the menu
-	       ;; if it has got out of date wrt to the command table.
-	       (let ((commands-and-buttons nil))
-		 (map-over-command-table-menu-items
-		  #'(lambda (menu keystroke item)
-		      (let ((type (command-menu-item-type item))
-			    (options (compute-options item)))
-			(case type
-			  (:divider
-			   (ecase (command-menu-item-value item)
-			     (:label 
-			      (apply #'make-instance 'tk::xm-label
-				     :label-string menu
-				     :parent parent
-				     options))
-			     ((nil :line)
-			      (apply #'make-instance 'tk::xm-separator
-				     :parent parent
-				     options))))
-			  (:function
-			   ;;--- Do this sometime
-			   )
-			  (:menu
-			   (make-submenu parent menu item))
-			  (t
-			   (let ((parent parent))
-			     (when top
+	     (make-menu-for-command-table (find-command-table
+					   (command-menu-item-value item))
+					  submenu nil)))
+
+	 (make-menu-for-command-table (command-table parent top)
+	   (map-over-command-table-menu-items
+	    #'(lambda (menu keystroke item)
+		(ecase (command-menu-item-type item)
+		  (:divider
+		   (ecase (command-menu-item-value item)
+		     (:label 
+		      (apply #'make-instance 'tk::xm-label
+			     :label-string menu
+			     :parent parent
+			     (compute-options item)))
+		     ((nil :line)
+		      (apply #'make-instance 'tk::xm-separator
+			     :parent parent
+			     (compute-options item)))))
+		  (:function
+		   ;;--- Do this sometime
+		   )
+		  (:menu
+		   (make-submenu parent menu item))
+		  (:command
+		   (let* ((button-parent
+			   (if top
 			       (let* ((submenu (apply #'make-instance
 						      'tk::xm-pulldown-menu
 						      :managed nil
 						      :parent parent
-						      options))
+						      (compute-options item)))
 				      (cb (apply #'make-instance 'xt::xm-cascade-button
 						 :parent parent
 						 :label-string menu
 						 :sub-menu-id
 						 submenu
-						 options)))
+						 (compute-options item))))
 				 (declare (ignore cb))
-				 (setq parent submenu)))
-			     (let ((button 
-				    (apply #'make-instance 'xt::xm-push-button
-					   :label-string menu
-					   :managed t
-					   :parent parent
-					   :sensitive (command-enabled
-						       (car (command-menu-item-value item))
-						       (slot-value sheet 'silica::frame))
-					   options)))
-			       (push (list item button)
-				     commands-and-buttons)
-			       
-			       (add-documentation-callbacks 
-				frame button (getf (command-menu-item-options item) :documentation))
-
-			       (when flatp 
-				 (push (cons (car (command-menu-item-value item))
-					     button)
-				       (menu-bar-command-name-to-button-table sheet)))
-			       
-			       (unless flatp
-				 (set-button-accelerator-from-keystroke 
-				  sheet
-				  button keystroke)
-			
-				 (set-button-mnemonic
-				  sheet
-				  button (getf
-					  (command-menu-item-options
-					   item) :mnemonic)))
-			       
-			       (tk::add-callback
-				button
-				:activate-callback
-				'command-button-callback
-				(slot-value sheet 'silica::frame)
-				command-table
-				item)))))))
-			  
-		  command-table)
-		 commands-and-buttons)))
-      (make-menu-for-command-table
-	 ct mirror (not flatp)))
+				 submenu) 
+			     parent))
+			     (button (make-command-button
+				      button-parent menu item
+				      keystroke command-table)))))))
+	    command-table)))
+      (make-menu-for-command-table ct mirror (not flatp)))
     mirror))
 
 (defmethod set-button-accelerator-from-keystroke ((menubar motif-menu-bar) button keystroke)
@@ -347,6 +311,8 @@
 	    presentation-type 
 	    associated-window
 	    text-style
+	    foreground
+	    background
 	    label
 	    gesture
 	    row-wise
@@ -359,19 +325,14 @@
 	 (simplep (and (null printer)
 		       (null presentation-type)))
 	 (port (port framem))
+	 ;; we treat text-style specially as individual menu items can
+	 ;; have their own text-style which must be merged (cim 10/3/94)
 	 (initargs (remove-keywords 
-		    (if (and associated-window
-			     (typep associated-window 'sheet-with-resources-mixin))
-			(find-widget-resource-initargs-for-sheet port
-								 associated-window)
-		      (find-application-resource-initargs port))
+		    (find-widget-resource-initargs-for-sheet 
+		     port associated-window
+		     :foreground foreground :background background)
 		    '(:font-list)))
-	 (default-text-style 
-	     (or (and associated-window
-		      (typep associated-window 'sheet-with-resources-mixin)
-		      (pane-text-style associated-window))
-		 (getf (get-application-resources port) :text-style)
-		 *default-text-style*))
+	 (default-text-style (sheet-text-style port associated-window))
 	 (menu-text-style (if text-style
 			      (merge-text-styles text-style
 						 default-text-style)
@@ -593,7 +554,7 @@
       (let ((slider
 	     (make-instance 'xt::xm-scale 
 			    :show-value t
-			    :managed nil
+			    :managed t
 			    :sensitive nil
 			    :parent dialog
 			    :orientation :horizontal)))
@@ -670,6 +631,13 @@
      'pointer-documentation-callback-function
      frame documentation nil)))
 
+(defmethod add-documentation-callbacks (frame (button tk::xm-cascade-button) documentation)
+  (when documentation
+    (tk::add-callback
+     button :cascading-callback 
+     'pointer-documentation-callback-function
+     frame documentation t)))
+
 (defmethod add-documentation-callbacks :after (frame (button t) documentation)
   (when documentation
     (tk::add-callback button 
diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp
index a5d822e0df1dc7e45ce0aa2ab6f29bc8bcbc7195..a0420ec431937813a081a32080b29666c9702071 100644
--- a/tk-silica/xm-gadgets.lisp
+++ b/tk-silica/xm-gadgets.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-gadgets.lisp,v 1.85 1993/11/18 18:45:37 cer Exp $
+;; $fiHeader: xm-gadgets.lisp,v 1.86 1993/12/07 05:34:24 colin Exp $
 
 (in-package :xm-silica)
 
@@ -52,11 +52,13 @@
 (defclass motif-value-pane () ())
 
 (defmethod gadget-value ((gadget motif-value-pane))
-  (if (sheet-direct-mirror gadget)
-      (tk::get-values (sheet-mirror gadget) :value)
-    (call-next-method)))
+  (let ((mirror (sheet-direct-mirror gadget)))
+    (if mirror
+	(tk::get-values mirror :value)
+      (call-next-method))))
 
-(defmethod (setf gadget-value) (nv (gadget motif-value-pane) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (nv (gadget motif-value-pane) &key invoke-callback)
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (tk::get-values m :value))))
@@ -65,7 +67,7 @@
 
 ;;; Motif widgets that support the value-changed callback
 
-(defclass motif-value-changed-callback-pane (motif-value-pane) ())
+(defclass motif-value-changed-callback-pane () ())
 
 (defmethod add-sheet-callbacks :after 
            ((port motif-port) (sheet motif-value-changed-callback-pane) (widget t))
@@ -76,7 +78,7 @@
 
 ;;; Motif widgets that support the losing-focus callback
 
-(defclass motif-losing-focus-callback-pane (motif-value-pane) ())
+(defclass motif-losing-focus-callback-pane () ())
 
 (defmethod add-sheet-callbacks :after 
            ((port motif-port) (sheet motif-losing-focus-callback-pane) (widget t))
@@ -96,28 +98,30 @@
   (multiple-value-bind
       (class initargs)
       (call-next-method)
-    (with-accessors ((alignment gadget-alignment)
-                     (label gadget-label)) sheet
-      (cond 
-       ((stringp label)
-        (unless (getf initargs :label-string)
-          (setf (getf initargs :label-string) label)))
-       ((typep label 'tk::pixmap)
-        (unless (getf initargs :label-pixmap)
-          (setf (getf initargs :label-pixmap) label)
-          ;;-- Perhaps we need to stipple this?
-          (setf (getf initargs :label-insensitive-pixmap) label)
-          (setf (getf initargs :label-type) :pixmap)))
-       (t (unless (getf initargs :label-string)
-	    (setf (getf initargs :label-string) ""))))
-
-      (unless (getf initargs :alignment)
-        (setf (getf initargs :alignment) 
-          (ecase alignment
-            ((:left nil) :beginning)
-            (:center :center)
-            (:right :end))))
-      (setf (getf initargs :recompute-size) nil))
+    (unless *in-find-widget-name-and-class-hack*
+      (with-accessors ((alignment gadget-alignment)
+		       (label gadget-label)) sheet
+	(etypecase label
+	  ((or null string)
+	   (unless (getf initargs :label-string)
+	     (setf (getf initargs :label-string) (or label ""))))
+	  ((or tk::pixmap pattern)
+	   (unless (getf initargs :label-pixmap)
+	     (when (typep label 'pattern)
+	       (with-sheet-medium (medium sheet)
+		 (setq label
+		   (pixmap-from-pattern label medium :pixmap))))
+	     (setf (getf initargs :label-pixmap) label)
+	     ;;-- Perhaps we need to stipple this?
+	     (setf (getf initargs :label-insensitive-pixmap) label)
+	     (setf (getf initargs :label-type) :pixmap))))
+	(unless (getf initargs :alignment)
+	  (setf (getf initargs :alignment) 
+	    (ecase alignment
+	      ((:left nil) :beginning)
+	      (:center :center)
+	      (:right :end))))
+	(setf (getf initargs :recompute-size) nil)))
     (values class initargs)))
 
 (defmethod (setf gadget-label) :after (nv (sheet motif-labelled-gadget))
@@ -167,16 +171,23 @@
   (compute-space-requirement-for-push-button-or-label sheet))
 
 (defun compute-space-requirement-for-push-button-or-label (sheet)
-  (let ((label (gadget-label sheet)))
+  (let ((label (gadget-label sheet))
+	width
+	height)
     (etypecase label
       ((or null string)
-       (make-space-requirement
-	:width (process-width-specification sheet `(,(max 1 (length label)) :character))
-	:height (process-height-specification sheet `(1 :line))))
+       (with-sheet-medium (medium sheet)
+	 (multiple-value-setq (width height)
+	   (text-size medium label :text-style (pane-text-style sheet)))))
       (tk::pixmap
-       (make-space-requirement
-	:width (+ (xt::pixmap-width label) (text-gadget-margin-width sheet))
-	:height (+ (xt::pixmap-height label) (text-gadget-margin-height sheet)))))))
+       (setq width (xt::pixmap-width label)
+	     height (xt::pixmap-height label)))
+      (pattern
+       (setq width (pattern-width label)
+	     height (pattern-height label))))
+    (make-space-requirement
+     :width (+ width (text-gadget-margin-width sheet))
+     :height (+ height (text-gadget-margin-height sheet)))))
 
 ;;; Push button
 
@@ -191,7 +202,11 @@
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
                                                      (parent t)
                                                      (sheet motif-push-button))
-  (values 'tk::xm-push-button nil))
+  (values 'tk::xm-push-button 
+	  #-ignore nil
+	  #+ignore '(:margin-width 8 :margin-height 8) ;1
+	  #+ignore '(:margin-width 10 :margin-height 10))) 
+
 
 (defmethod add-sheet-callbacks
     ((port motif-port) (sheet t) (widget tk::xm-my-drawing-area))
@@ -222,9 +237,76 @@
 
 ;;-- This is identical to the method for label
 
+;;; How we deal with the default button in bulletin boards...
+;;;
+;;; The problem is that as soon as motif sees a default button in a
+;;; bulletin board it makes all buttons use the default button
+;;; shadowing. This messes things up visually if you don't take this
+;;; into account in the space allocation. Unfortunately looking at the
+;;; resource :default-button-shadow-thickness isn't good enough
+;;; because this returns 0 for any buttons created *before* any
+;;; default is set and 1 for buttons created *after*. However, the
+;;; bulletin board uses the default-button shadowing for *all* buttons
+;;; if any are set as the default.
+;;; 
+;;; What we do therefore is to allocate more space (by a fudge factor)
+;;; for all push buttons which are part of bb's to allow for extra
+;;; the extra space needed for the default shadowing.
+;;; 
+;;; This works well as long as there is at least one default button in
+;;; a bb so that the shadowing is used. However if there are none then
+;;; no shadowing occurs and the buttons look stupidly big. So as a
+;;; hack we set the default-button for a bb to be the bb itself
+;;; forcing motif to do the default shadowing for any
+;;; buttons. Fortunately this doesn't appear to break anything
+;;;
+;;; cim (8/29/94)
+
+
+
+(defun find-bulletin-board (widget)
+  (and widget
+       (if (typep widget 'tk::xm-bulletin-board)
+	   widget
+	 (find-bulletin-board (tk::widget-parent widget)))))
+
 (defmethod compose-space ((sheet motif-push-button) &key width height)
   (declare (ignore width height))
-  (compute-space-requirement-for-push-button-or-label sheet))
+  (let ((sr (compute-space-requirement-for-push-button-or-label sheet)))
+    (if (find-bulletin-board (sheet-mirror sheet))
+	(multiple-value-bind (width min-width max-width
+			      height min-height max-height)
+	    (space-requirement-components sr)
+	  (declare (ignore min-width max-width min-height max-height))
+	  (let* ((shadow-thickness (tk::get-values (sheet-direct-mirror sheet)
+						   :shadow-thickness))
+		 (fudge (+ 4 (* 4 shadow-thickness))))
+	    (make-space-requirement
+	     :width (+ width fudge)
+	     :height (+ height fudge))))
+      sr)))
+
+(defmethod initialize-mirror :after ((port motif-port)
+				     parent
+				     parent-widget
+				     (sheet motif-push-button)
+				     widget)
+  (declare (ignore parent))
+  (when (silica::push-button-show-as-default sheet)
+    (let ((bb (find-bulletin-board parent-widget)))
+      (when bb
+	(tk::set-values bb :default-button widget)))))
+
+
+(defmethod initialize-mirror :after ((port motif-port)
+				     parent
+				     parent-widget
+				     (sheet top-level-sheet)
+				     (widget tk::xm-bulletin-board))
+  (declare (ignore parent parent-widget))
+  (tk::set-values widget :default-button widget))
+
+  
 
 ;;; range pane mixin
 
@@ -246,7 +328,8 @@
       (call-next-method))))
 
 
-(defmethod (setf gadget-value) (nv (gadget motif-range-pane) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (nv (gadget motif-range-pane) &key invoke-callback)
   (declare (ignore invoke-callback))
   (let ((mirror (sheet-mirror gadget)))
     (when mirror
@@ -257,7 +340,8 @@
             (tk::get-values mirror :minimum :maximum)
           (with-no-value-changed-callbacks
               (tk::set-values mirror
-                              :value (fix-coordinate 
+                              :value 
+			      (fix-coordinate 
                                       (compute-symmetric-value
                                        smin smax nv mmin mmax)))))))))
 
@@ -321,8 +405,8 @@
               (t
                (setq smin (float smin) smax (float smax))
                (let ((scaling (expt 10 decimal-places)))
-                 (setq mmin (round (* scaling smin))
-                       mmax (round (* scaling smax))
+                 (setq mmin (fix-coordinate (* scaling smin))
+                       mmax (fix-coordinate (* scaling smax))
                        decimal-points decimal-places))))
 
         (assert (and (typep mmin '(signed-byte 32))
@@ -367,7 +451,7 @@
                                  :min-width fudge
                                  :width (max (* 2 fudge) swidth)
                                  :max-width +fill+))))))
-         
+
 ;;; Scroll-Bar
 
 
@@ -376,19 +460,17 @@
                             xt-leaf-pane)
           ())
 
+
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
                                                      (parent t)
                                                      (sheet motif-scroll-bar))
-  (values 'tk::xm-scroll-bar '(:minimum 0 :maximum 1000 )))
-
-
-(defmethod (setf scroll-bar-size) (nv (sb motif-scroll-bar))
-  (tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv))
-  nv)
-
-(defmethod (setf scroll-bar-value) (nv (sb motif-scroll-bar))
-  (tk::set-values (sheet-direct-mirror sb) :value nv)
-  nv)
+  (let ((size (scroll-bar-size sheet)))
+    (values 'tk::xm-scroll-bar
+	    (append '(:minimum 0 :maximum 1000)
+		    (when size
+		      `(:slider-size 
+			,(convert-scroll-bar-value-out sheet
+						       size)))))))
 
 ;;;--- We should use the motif functions for getting and changing the
 ;;;--- values
@@ -399,58 +481,60 @@
   (let ((mirror (sheet-direct-mirror sb)))
     (when mirror
       (multiple-value-bind
-          (mmin mmax) (tk::get-values mirror :minimum :maximum)
-        (multiple-value-bind
-            (real-value real-size line-increment) (compute-new-scroll-bar-values sb
-								  mmin
-								  mmax
-								  value slider-size
-								  line-increment)
-          (tk::set-values
-           mirror
-	   :increment line-increment
-	   :page-increment real-size
-           :slider-size real-size
-           :value real-value))))))
-
+	  (real-value real-size line-increment) 
+	  (compute-new-scroll-bar-values sb value slider-size line-increment)
+	(tk::set-values mirror
+			:increment line-increment :page-increment real-size
+			:slider-size real-size :value real-value)))))
 
 (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-scroll-bar) (widget t))
   (tk::add-callback widget
                     :value-changed-callback
-                    'scroll-bar-changed-callback-1
-                    sheet)
+                    'xm-scroll-bar-callback
+                    sheet
+		    'value-changed-callback)
   (tk::add-callback widget
 		    :drag-callback
-		    'scroll-bar-changed-callback-1
-		    sheet))
-
-(defmethod scroll-bar-changed-callback-1 ((widget t) (sheet motif-scroll-bar))
-  (multiple-value-bind
-      (smin smax) (gadget-range* sheet)
-    (multiple-value-bind
-        (value size mmin mmax)
-        (tk::get-values widget :value :slider-size :minimum :maximum)
-      (scroll-bar-value-changed-callback
-       sheet
-       (gadget-client sheet)
-       (gadget-id sheet)
-       (compute-symmetric-value
-        mmin (- mmax size) value smin smax)
-       (compute-symmetric-value
-        mmin mmax size smin smax)))))
+		    'xm-scroll-bar-callback
+		    sheet
+		    'drag-callback))
+
+(defun xm-scroll-bar-callback (widget sheet callback-fn)
+  (funcall callback-fn
+	   sheet
+	   (gadget-client sheet)
+	   (gadget-id sheet)
+	   (convert-scroll-bar-value-in sheet
+					(tk::get-values widget :value))))
 
 (defmethod gadget-value ((gadget motif-scroll-bar))
   (let ((mirror (sheet-direct-mirror gadget)))
     (if mirror 
-        (multiple-value-bind
-            (smin smax) (gadget-range* gadget)
-          (multiple-value-bind
-              (value mmin mmax size)
-	      (tk::get-values mirror :value :minimum :maximum  :slider-size)
-            (compute-symmetric-value
-             mmin (- mmax size) value smin smax)))
+	(convert-scroll-bar-value-in gadget
+				     (tk::get-values mirror :value))
+      (call-next-method))))
+
+(defmethod (setf gadget-value) :after 
+	   (nv (gadget motif-scroll-bar) &key invoke-callback)
+  (declare (ignore invoke-callback))
+  (let ((mirror (sheet-direct-mirror gadget)))
+    (when mirror
+      (tk::set-values mirror
+		      :value (convert-scroll-bar-value-out gadget nv)))))
+
+(defmethod scroll-bar-size ((sheet motif-scroll-bar))
+  (let ((mirror (sheet-direct-mirror sheet)))
+    (if mirror
+	(convert-scroll-bar-value-in sheet
+				     (tk::get-values mirror :slider-size))
       (call-next-method))))
 
+(defmethod (setf scroll-bar-size) :after (nv (sheet motif-scroll-bar))
+  (let ((mirror (sheet-direct-mirror sheet)))
+    (when mirror
+      (tk::set-values mirror
+		      :slider-size (convert-scroll-bar-value-out sheet nv)))))
+
 (defmethod compose-space ((m motif-scroll-bar) &key width height)
   (declare (ignore width height))
   ;;-- We should probably ask the widget
@@ -488,6 +572,9 @@
                     :resize-callback 'sheet-mirror-resized-callback
                     sheet))
 
+(defparameter *xm-dialog-style*
+    :primary-application-modal)
+
 (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port)
                                                      (parent t)
                                                      (sheet top-level-sheet))
@@ -495,38 +582,31 @@
   (let* ((frame (pane-frame sheet))
 	 (name (and frame
 		    (frame-name frame))))
-    (cond 
-     ;;--- hack alert
-     ;; Seems that we need to use a bulletin board so that everything
-     ;; comes up in the right place.
-     ((popup-frame-p sheet)
-      (values 'tk::xm-bulletin-board
-	      (list :margin-width 0 :margin-height 0
-		    ;; We specify NIL for accelerators otherwise the
-		    ;; bulletin board messes with the event handling of
-		    ;; its drawing area children
-		    :accelerators nil
-		    ;; Prevents buttons from deactivating dialog
-		    :dialog-style :primary-application-modal
-		    :auto-unmanage nil
-		    :resize-policy :none
-		    :name name)))
-     (t
+    (if (popup-frame-p sheet)
+	;;--- hack alert
+	;; Seems that we need to use a bulletin board so that everything
+	;; comes up in the right place.
+	(values 'tk::xm-bulletin-board
+		(list :margin-width 0 :margin-height 0
+		      ;; We specify NIL for accelerators otherwise the
+		      ;; bulletin board messes with the event handling of
+		      ;; its drawing area children
+		      :accelerators nil
+		      ;; Prevents buttons from deactivating dialog
+		      :dialog-style *xm-dialog-style*
+		      :auto-unmanage nil
+		      :resize-policy :none
+		      :name name))
       (values 'tk::xm-my-drawing-area 
 	      (list :resize-policy :none
 		    :name name
-		    :margin-width 0 :margin-height 0))))))
+		    :margin-width 0 :margin-height 0)))))
 
 ;;;;;;;;;;;;;;;;
 
-(defvar *map-callback-function* (ff:register-function 'mapped-proc-callback))
-
 (defmethod add-sheet-callbacks :after ((port motif-port) (sheet t) 
                                        (widget tk::xm-bulletin-board))
-  (tk::add-callback widget 
-		    :map-callback
-		    'map-callback-function)
-  (tk::add-event-handler widget
+    (tk::add-event-handler widget
                          '(:enter-window 
                            :leave-window
                            :pointer-motion-hint
@@ -553,6 +633,7 @@
 
 (defclass motif-text-field (motif-losing-focus-callback-pane
 			    motif-value-changed-callback-pane
+			    motif-value-pane
                             motif-action-pane
                             text-field
                             xt-leaf-pane)
@@ -619,7 +700,7 @@
 (defun text-gadget-margin-width (sheet)
   (multiple-value-bind (margin highlight shadow)
       (tk::get-values (sheet-direct-mirror sheet) :margin-width :highlight-thickness :shadow-thickness)
-    (+ (* 2 (+ margin highlight shadow)))))
+    (* 2 (+ margin highlight shadow))))
 
 (defun font-list-max-width-and-height (font-list)
   (let* ((max-width most-negative-fixnum)
@@ -650,7 +731,7 @@
 (defun text-gadget-margin-height (sheet)
   (multiple-value-bind (margin highlight shadow)
       (tk::get-values (sheet-direct-mirror sheet) :margin-height :highlight-thickness :shadow-thickness)
-    (+ (* 2 (+ margin highlight shadow)))))
+    (* 2 (+ margin highlight shadow))))
 
 
 #+ignore
@@ -671,6 +752,7 @@
 
 (defclass motif-text-editor (motif-losing-focus-callback-pane
 			     motif-value-changed-callback-pane
+			     motif-value-pane
                              motif-action-pane
                              text-editor
                              xt-leaf-pane)
@@ -780,7 +862,8 @@
 	(plusp (tk::xm_toggle_button_get_state m))
       (call-next-method))))
 
-(defmethod (setf gadget-value) (nv (gadget motif-toggle-button) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (nv (gadget motif-toggle-button) &key invoke-callback)
   (declare (ignore invoke-callback))
   (let ((m (sheet-direct-mirror gadget)))
     (when (and m (not (equal nv (plusp (tk::xm_toggle_button_get_state m)))))
@@ -800,7 +883,10 @@
                     'sheet-mirror-resized-callback
                     sheet))
 
+;; ignoring the following function - what does it do - no-one appears
+;; to call it (cim 6/21/94)
 
+#+ignore 
 (defun scroll-bar-changed-callback (widget which scroller)
   (let* ((vp (sheet-child scroller))
          (viewport (viewport-viewport-region vp))
@@ -1089,11 +1175,20 @@
 		  (silica::scroller-pane-scroll-bar-policy p)))))
       (values 'xt::xm-list 
               `(
-		:list-size-policy :constant
+		:list-size-policy 
+		#-ignore 
+		,(case scroll-mode
+		   (:vertical :variable)
+		   (t :constant))
+		#+ignore ;; this one required for buggy pre motif-1.2.4
+		,(case scroll-mode
+		   ((:horizontal t :both) :constant)
+		   (t :variable))
 		:scroll-bar-display-policy 
 		,(case scroll-mode
-		   ((:vertical t :both) :static)
-		   (t :as-needed))
+		   ((:horizontal :vertical t :both) :static)
+		   (t :as-needed)
+		   :as-needed)
                 ,@(and selected-items
                        `(:selected-item-count ,(length selected-items)
                          :selected-items ,selected-items))
@@ -1110,7 +1205,16 @@
   (let ((m (sheet-direct-mirror gadget)))
     (when m
       (with-accessors ((name-key set-gadget-name-key)) gadget
-	(tk::set-values m :items (mapcar name-key items) :item-count (length items))))))
+	(tk::set-values m :items (mapcar name-key items) :item-count
+			(length items))))))
+
+(defmethod (setf list-pane-mode) :after (mode (gadget motif-list-pane))
+  (let ((m (sheet-direct-mirror gadget)))
+    (when m
+      (tk::set-values m :selection-policy
+		      (ecase mode
+			(:exclusive :browse-select)
+			(:nonexclusive :multiple-select))))))
 
 (defun list-pane-single-selection-callback (widget item-position sheet)
   (declare (ignore item-count))
@@ -1134,16 +1238,15 @@
      widget sheet items)))
 
 
-(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-list-pane) (widget xt::xm-list))
-  (ecase (list-pane-mode sheet)
-      (:exclusive
-       (tk::add-callback widget :browse-selection-callback
-                         'list-pane-single-selection-callback sheet))
-      (:nonexclusive
-       (tk::add-callback widget :multiple-selection-callback 
-                         'list-pane-multiple-selection-callback sheet))))
-
-(defmethod (setf gadget-value) :after (nv (l motif-list-pane) &key invoke-callback)
+(defmethod add-sheet-callbacks
+    ((port motif-port) (sheet motif-list-pane) (widget xt::xm-list))
+  (tk::add-callback widget :browse-selection-callback
+		    'list-pane-single-selection-callback sheet)
+  (tk::add-callback widget :multiple-selection-callback 
+		    'list-pane-multiple-selection-callback sheet))
+
+(defmethod (setf gadget-value) :after
+    (nv (l motif-list-pane) &key invoke-callback)
   (declare (ignore invoke-callback))
   (when (sheet-direct-mirror l)
     (let ((selected-items
@@ -1162,38 +1265,41 @@
                                                      (parent t)
                                                      (sheet motif-option-pane))
   (let ((pdm (make-instance 'xt::xm-pulldown-menu :managed nil :parent parent)))
-    (update-option-menu-buttons sheet pdm)
+    (update-option-menu-buttons port sheet pdm)
     (values 'xt::xm-option-menu
 	    `(:sub-menu-id ,pdm :margin-height 0))))
 
-(defun update-option-menu-buttons (sheet pdm)
-  (with-accessors ((items set-gadget-items)
-                   (printer silica::option-pane-printer)
-                   (name-key set-gadget-name-key)
-                   (value-key set-gadget-value-key)) sheet
-    (setf (motif-option-menu-buttons sheet)
-      (mapcar #'(lambda (item)
-		  (let* ((name (funcall name-key item))
-			 (pixmap (unless (or (null printer) (eq printer #'write-token))
-				   (pixmap-from-menu-item 
-				    sheet name printer nil)))
-			 (button 
-			  (if (null pixmap)
-			      (make-instance 'tk::xm-push-button 
-					     :label-string name
-					     :parent pdm)
-			    (make-instance 'tk::xm-push-button 
-					   :label-pixmap pixmap
-					   :label-type :pixmap
-					   :parent pdm))))
-		    (tk::add-callback  
-		     button
-		     :activate-callback
-		     'option-menu-callback-function
-		     (funcall value-key item)
-		     sheet)
-		    button))
-	      items))))
+(defun update-option-menu-buttons (port sheet pdm)
+  (let ((initargs (find-widget-resource-initargs-for-sheet port sheet)))
+    (with-accessors ((items set-gadget-items)
+		     (printer silica::option-pane-printer)
+		     (name-key set-gadget-name-key)
+		     (value-key set-gadget-value-key)) sheet
+      (setf (motif-option-menu-buttons sheet)
+	(mapcar #'(lambda (item)
+		    (let* ((name (funcall name-key item))
+			   (pixmap (unless (or (null printer) (eq printer #'write-token))
+				     (pixmap-from-menu-item 
+				      sheet name printer nil)))
+			   (button 
+			    (if (null pixmap)
+				(apply #'make-instance 'tk::xm-push-button 
+				  :label-string name
+				  :parent pdm
+				  initargs)
+			      (apply #'make-instance 'tk::xm-push-button 
+				:label-pixmap pixmap
+				:label-type :pixmap
+				:parent pdm
+				initargs))))
+		      (tk::add-callback  
+		       button
+		       :activate-callback
+		       'option-menu-callback-function
+		       (funcall value-key item)
+		       sheet)
+		      button))
+		items)))))
 
 (defmethod (setf set-gadget-items) :after (items (gadget motif-option-pane))
   (declare (ignore items))
@@ -1203,20 +1309,26 @@
       (let ((pdm (tk::get-values m :sub-menu-id)))
 	(tk::unmanage-children (tk::widget-children pdm))
 	(mapc #'tk::destroy-widget (tk::widget-children pdm))
-	(update-option-menu-buttons gadget pdm)))))
+	(update-option-menu-buttons (port gadget) gadget pdm)))))
 
 (defun option-menu-callback-function (widget count value sheet)
   (declare (ignore count))
   (queue-value-changed-event widget sheet value))
 
-(defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback)
+(defmethod (setf gadget-value) :after
+    (nv (gadget motif-option-pane) &key invoke-callback)
   (declare (ignore invoke-callback)) 
   (with-no-value-changed-callbacks
       (set-option-menu-value gadget nv)))
 
 (defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane))
-  (prog1 (call-next-method)
-    (set-option-menu-value pane (gadget-value pane))))
+  (let ((mirror (call-next-method)))
+    (set-option-menu-value pane (gadget-value pane))
+    (tk::set-values (tk::intern-widget (tk::xm_option_label_gadget mirror))
+		    :font-list
+		    (getf (find-widget-resource-initargs-for-sheet port pane)
+			  :font-list))
+    mirror))
 
 (defun set-option-menu-value (gadget nv)
   (with-accessors ((items set-gadget-items)
@@ -1242,6 +1354,8 @@
                                       message-string 
                                       &key 
                                       text-style
+				      background
+				      foreground
                                       (style :inform)
                                       (frame nil frame-p)
                                       (associated-window
@@ -1254,13 +1368,24 @@
 				       '(:exit
 					 :abort
 					 :help))
-                                      (name :notify-user))
-  (let ((dialog (apply #'make-instance (ecase style
+                                      (name :notify-user)
+				      x-position 
+				      y-position)
+  (let* ((initargs (find-widget-resource-initargs-for-sheet 
+		    (port framem) associated-window
+		    :foreground foreground :background background
+		    :text-style text-style))
+	 (font-list (getf initargs :font-list))
+	 (pixmap (when (typep style '(or string pixmap))
+		   (prog1 style 
+		     (setq style :message))))
+	 (dialog (apply #'make-instance (ecase style
 					 (:inform 'tk::xm-information-dialog)
 					 (:error 'tk::xm-error-dialog)
 					 (:question 'tk::xm-question-dialog)
-					 (:warning 'tk::xm-warning-dialog))
-		       :dialog-style :primary-application-modal
+					 (:warning 'tk::xm-warning-dialog)
+					 (:message 'tk::xm-message-dialog))
+		       :dialog-style *xm-dialog-style*
 		       :managed nil
 		       :parent (if (typep associated-window 'xt::xt-root-class)
 				   associated-window
@@ -1268,10 +1393,13 @@
 		       :name name
 		       :dialog-title title
 		       :message-string message-string
-		       (and text-style
-			    (let ((fonts (list (text-style-mapping (port framem) text-style))))
-			      `(:label-font-list ,fonts :button-font-list ,fonts :text-font-list ,fonts)))))
-        (result nil))
+		       :label-font-list font-list
+		       :button-font-list font-list
+		       :text-font-list font-list
+		       (append 
+			(and pixmap `(:symbol-pixmap ,pixmap))
+			initargs)))
+	 (result nil))
     (multiple-value-bind
         (ok-button cancel-button help-button)
         (get-message-box-child dialog :ok :cancel :help)
@@ -1280,17 +1408,20 @@
                (setq result (list r))))
         (tk::add-callback dialog :ok-callback #'set-it t)
         (tk::add-callback dialog :cancel-callback #'set-it nil)
-
         
 	(process-exit-boxes framem 
 			    associated-window
 			    documentation exit-boxes ok-button cancel-button
-			    help-button)
+			    help-button dialog)
         
         (catch 'notify-user
 	  (unwind-protect
 	      (progn
+		(tk::set-values (tk::widget-parent dialog) :mapped-when-managed nil)
 		(tk::manage-child dialog)
+		(when (and x-position y-position)
+		  (tk::set-values dialog :x x-position :y y-position))
+		(tk::set-values (tk::widget-parent dialog) :mapped-when-managed t)
 		(with-toolkit-dialog-component (notify-user (list message-string :style))
 		  (wait-for-callback-invocation
 		   (port framem)
@@ -1302,7 +1433,7 @@
 (defun process-exit-boxes (framem 
 			   associated-window
 			   documentation exit-boxes ok-button cancel-button
-			   help-button)
+			   help-button &optional dialog)
   
   (flet ((display-help (widget ignore)
 	   (declare (ignore widget ignore))
@@ -1310,17 +1441,21 @@
 	    framem
 	    documentation
 	    :associated-window associated-window))
-	 (set-button-state (name button)
-	   (unless (dolist (x exit-boxes nil)
-		     (cond ((eq x name) (return t))
-			   ((atom x))
-			   ((eq (car x) name)
-			    (tk::set-values button :label-string (second x))
-			    (return t))))
-	     (tk::unmanage-child button))))
-    (set-button-state :exit ok-button)
-    (set-button-state :abort cancel-button)
-    (set-button-state :help help-button)
+	 (set-button-state (name button type)
+	   (let ((box (dolist (x exit-boxes nil)
+			(cond ((eq x name) (return x))
+			      ((atom x))
+			      ((eq (car x) name)
+			       (tk::set-values button :label-string (second x))
+			       (return x))))))
+	     (cond ((null box)
+		    (tk::unmanage-child button))
+		   ((and dialog
+			 (eq box (car exit-boxes)))
+		    (tk::set-values dialog :default-button-type type))))))
+    (set-button-state :exit ok-button :ok)
+    (set-button-state :abort cancel-button :cancel)
+    (set-button-state :help help-button :help)
           
     (if documentation
 	(tk::add-callback help-button :activate-callback #'display-help)
@@ -1334,7 +1469,7 @@
                 'tk::widget
                 (tk::xm-message-box-get-child 
                  widget
-                 (encode-box-child child))))
+                 (tk::encode-box-child child))))
            children)))
 
 (defun get-selection-box-child (widget &rest children)
@@ -1345,42 +1480,9 @@
                 'tk::widget
                 (tk::xm-selection-box-get-child 
                  widget
-                 (encode-box-child child))))
+                 (tk::encode-box-child child))))
            children)))
 
-(defun encode-box-child (child)
-  (let ((x (getf '(
-                   :none                  0 
-                   :apply         1
-                   :cancel    2
-                   :default   3
-                   :ok        4
-                   :filter-label     5
-                   :filter-text      6
-                   :help      7
-                   :list                  8
-                   :history-list     :list
-                   :list-label    9
-                   :message-label    10
-                   :selection-label  11
-                   :prompt-label     :selection-label
-                   :symbol-label     12
-                   :text                  13
-                   :value-text       :text
-                   :command-text     :text
-                   :separator             14
-                   :dir-list         15
-                   :dir-list-label   16
-                   :file-list        :list
-                   :file-list-label  :list-label
-                   ) 
-                 child)))
-    (cond ((null x)
-           (error "cannot encode child ~S" child))
-          ((symbolp x)
-           (encode-box-child x))
-          (t x))))
-
 ;;;; Working
 
 ;;; File Selection
@@ -1400,19 +1502,29 @@
 				  (name :select-file)
 				  directory
 				  pattern
-				  text-style)
+				  background
+				  foreground
+				  text-style
+				  x-position
+				  y-position)
                                   
-  (let ((dialog (apply #'make-instance 
+  (let* ((initargs (find-widget-resource-initargs-for-sheet 
+		    (port framem) associated-window
+		    :foreground foreground :background background
+		    :text-style text-style))
+	 (font-list (getf initargs :font-list))
+	 (dialog (apply #'make-instance 
 		       'tk::xm-file-selection-dialog
-		       :dialog-style :primary-application-modal
+		       :dialog-style *xm-dialog-style*
 		       :managed nil
 		       :parent (sheet-mirror associated-window)
 		       :name name
 		       :dialog-title title
-		       (and text-style
-			    (let ((fonts (list (text-style-mapping (port framem) text-style))))
-			      `(:label-font-list ,fonts :button-font-list ,fonts :text-font-list ,fonts)))))
-        (result nil))
+		       :label-font-list font-list
+		       :button-font-list font-list
+		       :text-font-list font-list
+		       initargs))
+	 (result nil))
 
     (multiple-value-bind
         (ok-button cancel-button help-button)
@@ -1453,7 +1565,11 @@
 
 	(unwind-protect
 	    (progn
+	      (tk::set-values (tk::widget-parent dialog) :mapped-when-managed nil)
 	      (tk::manage-child dialog)
+	      (when (and x-position y-position)
+		(tk::set-values dialog :x x-position :y y-position))
+	      (tk::set-values (tk::widget-parent dialog) :mapped-when-managed t)
 	      (wait-for-callback-invocation
 	       (port associated-window)
 	       #'(lambda () (or result (not (tk::is-managed-p dialog))))
@@ -1803,20 +1919,21 @@
   (when (typep m 'xt::xt-root-class)
     (tk::set-values m :font-list (text-style-mapping port text-style))))
 
-(defmethod find-widget-resource-initargs-for-sheet :around
-    ((port motif-port) (sheet sheet-with-resources-mixin))
-  (let ((initargs (call-next-method))
-	(text-style (pane-text-style sheet)))
-    (if text-style
-	`(:font-list ,(text-style-mapping port text-style) ,@initargs)
-      initargs)))
+(defmethod sheet-text-style :around ((port motif-port) (sheet t))
+   (or (call-next-method)
+       *default-text-style*))
 
-(defmethod find-application-resource-initargs :around 
-	   ((port motif-port))
-  (let ((initargs (call-next-method))
-	(text-style (or (getf (get-application-resources port) :text-style)
-			*default-text-style*)))
-    `(:font-list ,(text-style-mapping port text-style) ,@initargs)))
-			      
+(defmethod sheet-text-style ((port motif-port) (sheet sheet-with-resources-mixin))
+  (pane-text-style sheet))
+  
+(defmethod sheet-text-style ((port motif-port) (sheet t))
+  (getf (get-application-resources port) :text-style))
 
+(defmethod find-widget-resource-initargs-for-sheet :around
+    ((port motif-port) (sheet t) &key text-style)
+  (let ((initargs (call-next-method))
+	(text-style (or text-style
+			(sheet-text-style port sheet))))
+    `(:font-list ,(text-style-mapping port text-style)
+		 ,@initargs)))
 
diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp
index fbb8cf61fa76aa3372d4a214a2a97379c9687626..bbcb45fc1ae2b9e8fe5fcd268546d4ef3668c10d 100644
--- a/tk-silica/xm-silica.lisp
+++ b/tk-silica/xm-silica.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-silica.lisp,v 1.41 1993/11/23 19:59:07 cer Exp $
+;; $fiHeader: xm-silica.lisp,v 1.42 1993/12/07 05:34:27 colin Exp $
 
 (in-package :xm-silica)
 
@@ -187,6 +187,9 @@
     (when m (tk::xm_process_traversal m 0))))
 
 
+;; why is this only defined in motif - shouldn't this be in
+;; xt-silica.lisp (cim) 1/7/94
+
 (defmethod destroy-mirror :around ((port xt-port) (sheet top-level-sheet))
   (let* ((m (sheet-direct-mirror sheet))
 	 (shell (and m (tk::widget-parent m))))
@@ -196,27 +199,11 @@
 	       (zerop (tk::xt_widget_num_popups shell)))
       (tk::destroy-widget shell))))
 
-
 (defmethod port-move-frame :after ((port motif-port) frame x y)
   (fix-coordinates x y)
   (check-type x (signed-byte 16))
   (check-type y (signed-byte 16))
-  ;;--what is the right thing to do?
   (let ((m (sheet-direct-mirror (frame-top-level-sheet frame))))
-    (when (and (typep m 'xt::xm-bulletin-board)
-	       (not (xt::is-managed-p m)))
-      (let ((z (or (assoc 'when-mapped-callback (xt::widget-callback-data m))
-		   (car (push (cons 'when-mapped-callback nil)
-			      (xt::widget-callback-data m))))))
-	(setf (cdr z) (list :x x :y y))))))
-
-
-(defun map-callback-function (bb)
-  (let ((z (assoc 'when-mapped-callback (xt::widget-callback-data bb))))
-    (when z
-      (destructuring-bind (&key x y) (cdr z)
-	(tk::set-values bb :default-position nil :x x :y y))
-      (setf (xt::widget-callback-data bb) 
-	(delete z (xt::widget-callback-data bb))))))
-
+    (when (typep m 'xt::xm-bulletin-board)
+      (tk::set-values m :default-position nil :x x :y y))))
 
diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp
index 81d37bb93e9a2fea7158125162c02d922972e739..19b815f957b36b15d6f6692f372bb7f2cb492c93 100644
--- a/tk-silica/xt-frames.lisp
+++ b/tk-silica/xt-frames.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-frames.lisp,v 1.42 1993/10/25 16:16:44 cer Exp $
+;; $fiHeader: xt-frames.lisp,v 1.43 1993/11/23 19:59:09 cer Exp $
 
 
 (in-package :xm-silica)
@@ -91,8 +91,9 @@
      :sheet (frame-top-level-sheet frame))))
 
 (defmethod handle-event (sheet (event window-manager-delete-event))
-  (and (pane-frame sheet)
-       (frame-exit (pane-frame sheet))))
+  (let ((frame (pane-frame sheet)))
+    (and frame
+	 (frame-exit frame))))
 
 ;;; Menu code
 
@@ -102,6 +103,7 @@
 	  presentation-type 
 	  (associated-window (frame-top-level-sheet *application-frame*))
 	  text-style label
+	  foreground background
 	  cache
 	  (unique-id items)
 	  (id-test 'equal)
@@ -110,53 +112,65 @@
 	  (gesture :select)
 	  row-wise
 	  n-columns
-	  n-rows)
-  (declare (ignore keys))      
+	  n-rows
+	  x-position
+	  y-position
+	  scroll-bars)
   (declare (values value chosen-item gesture))
-  (let ((port (port framem))
-	menu closure)
-    (setq cache (and cache (frame-manager-allows-menu-caching framem)))
-    (when cache
-      (let ((x (assoc unique-id
-		      (frame-manager-menu-cache framem)
-		      :test id-test)))
-	(when x
-	  (destructuring-bind
-	      (menu-cache-value amenu aclosure) (cdr x)
-	    (if (funcall cache-test cache-value menu-cache-value)
-		(setq menu amenu closure aclosure)
-	      (progn
-		(setf (frame-manager-menu-cache framem)
-		  (delete x (frame-manager-menu-cache framem)))
-		(framem-destroy-menu framem amenu)))))))
-      
-    (unless menu
-      (multiple-value-setq
-	  (menu closure)
-	(frame-manager-construct-menu framem 
-				      items 
-				      printer 
-				      presentation-type 
-				      associated-window
-				      text-style
-				      label
-				      gesture
-				      row-wise
-				      n-columns
-				      n-rows))
+  ;; let's degrade to CLIM 1 style menus if we need scroll-bars
+  (if scroll-bars
+      (call-next-method)
+    (let ((port (port framem))
+	  menu closure)
+      (setq cache (and cache (frame-manager-allows-menu-caching framem)))
       (when cache
-	(push (list unique-id cache-value menu closure) 
-	      (frame-manager-menu-cache framem))))
+	(let ((x (assoc unique-id
+			(frame-manager-menu-cache framem)
+			:test id-test)))
+	  (when x
+	    (destructuring-bind
+		(menu-cache-value amenu aclosure) (cdr x)
+	      (if (funcall cache-test cache-value menu-cache-value)
+		  (setq menu amenu closure aclosure)
+		(progn
+		  (setf (frame-manager-menu-cache framem)
+		    (delete x (frame-manager-menu-cache framem)))
+		  (framem-destroy-menu framem amenu)))))))
+      
+      (unless menu
+	(multiple-value-setq
+	    (menu closure)
+	  (frame-manager-construct-menu framem 
+					items 
+					printer 
+					presentation-type 
+					associated-window
+					text-style
+					foreground
+					background
+					label
+					gesture
+					row-wise
+					n-columns
+					n-rows))
+	(when cache
+	  (push (list unique-id cache-value menu closure) 
+		(frame-manager-menu-cache framem))))
 	  
-    ;; initialize the closure
-    (funcall closure t)
-    ;;
-    (multiple-value-bind
-	(ignore win1 win2 x y root-x root-y)
-	(tk::query-pointer (tk::display-root-window
-			    (port-display port)))
-      (declare (ignore ignore win1 win2 x y))
-      (tk::set-values menu :x root-x :y root-y)
+      ;; initialize the closure
+      (funcall closure t)
+      ;;
+
+      (unless (and x-position y-position)
+	(multiple-value-bind
+	    (ignore win1 win2 x y root-x root-y)
+	    (tk::query-pointer (tk::display-root-window
+				(port-display port)))
+	  (declare (ignore ignore win1 win2 x y))
+	  (setq x-position root-x
+		y-position root-y)))
+
+      (tk::set-values menu :x x-position :y y-position)
       (let ((aborted t))
 	(catch 'menu-choose
 	  (unwind-protect
@@ -195,7 +209,7 @@
 
 (defmethod frame-manager-exit-box-labels ((framem xt-frame-manager) frame view)
   (declare (ignore frame view))
-  '((:exit  "OK" :documentation "Exit from dialog")
+  '((:exit  "OK" :documentation "Exit from dialog" :show-as-default t)
     (:abort  "Cancel" :documentation "Cancel dialog")))
 
 (defmethod frame-manager-default-exit-boxes ((framem xt-frame-manager))
@@ -212,10 +226,6 @@
 
 ;;; 
 
-(defmethod invoke-with-menu-as-popup ((framem xt-frame-manager) (window t) continuation)
-  (funcall continuation))
-
-
 (defmethod invoke-with-mouse-grabbed-in-window ((framem xt-frame-manager) (window t) continuation &key)
   (invoke-with-pointer-grabbed window continuation))
 
diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp
index 62ea30b37854961b365771f8088c91627a033372..9d818049d8ba846e077e93f84863cafbd29fff38 100644
--- a/tk-silica/xt-gadgets.lisp
+++ b/tk-silica/xt-gadgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-gadgets.lisp,v 1.38 1993/09/07 21:47:17 colin Exp $
+;; $fiHeader: xt-gadgets.lisp,v 1.39 1993/10/26 03:22:54 colin Exp $
 
 (in-package :xm-silica)
 
@@ -59,32 +59,53 @@
 (defmethod find-widget-class-and-initargs-for-sheet :around
     ((port xt-port) (parent t)
      (sheet sheet-with-resources-mixin))
-  (multiple-value-bind
-      (class initargs)
+  (multiple-value-bind (class initargs)
       (call-next-method)
     (let ((other-initargs (find-widget-resource-initargs-for-sheet port sheet)))
       (values class (append initargs other-initargs)))))
 
+(defun ensure-color (c palette)
+  (etypecase c
+    (color c)
+    (string (find-named-color c palette))
+    (integer (make-device-color palette c))))
+
 (defmethod find-widget-resource-initargs-for-sheet
-    ((port xt-port) (sheet sheet-with-resources-mixin))
+    ((port xt-port) (sheet sheet-with-resources-mixin) &key)
   (let ((background (pane-background sheet))
 	(foreground (pane-foreground sheet)))
     (with-sheet-medium (medium sheet)
-      `(,@(when background (decode-gadget-background medium sheet background))
-	,@(when foreground (decode-gadget-foreground medium sheet foreground))))))
+      (let ((palette (medium-palette medium)))
+	`(,@(when background
+	      (decode-gadget-background medium sheet
+					(ensure-color background palette)))
+	  ,@(when foreground
+	      (decode-gadget-foreground medium sheet 
+					(ensure-color foreground palette))))))))
 
-(defmethod find-application-resource-initargs ((port xt-port))
+(defmethod find-widget-resource-initargs-for-sheet
+    ((port xt-port) (sheet t) &key)
   (let* ((resources (get-application-resources port))
 	 (background (or (getf resources :background) *default-pane-background*))
 	 (foreground (or (getf resources :foreground) *default-pane-foreground*))
 	 (palette (port-default-palette port)))
-    (macrolet ((ensure-color (c)
-		 `(etypecase ,c
-		    (color ,c)
-		    (string (find-named-color ,c palette)))))
-      `(:background ,(decode-color-in-palette (ensure-color background) palette)
-        :foreground ,(decode-color-in-palette (ensure-color foreground) palette)))))
+    `(:background ,(decode-color-in-palette (ensure-color background palette)
+					    palette)
+      :foreground ,(decode-color-in-palette (ensure-color foreground palette)
+					    palette))))
     
+(defmethod find-widget-resource-initargs-for-sheet :around
+    ((port xt-port) (sheet t) &key foreground background)
+  (let ((initargs (call-next-method))
+	(palette (port-default-palette port)))
+    (when foreground
+      (setf (getf initargs :foreground)
+	(decode-color-in-palette (ensure-color foreground palette) palette)))
+    (when background
+      (setf (getf initargs :background)
+	(decode-color-in-palette (ensure-color background palette) palette)))
+    initargs))
+
 (defmethod decode-gadget-background (medium sheet ink)
   (declare (ignore sheet))
   (let ((pixel (decode-color ink medium)))
@@ -183,28 +204,39 @@
       ((typep w '(or tk::shell null))
        w)))
 
+(defmethod add-sheet-callbacks :after
+    ((port xt-port) (sheet xt-top-level-sheet) widget)
+  (tk::add-event-handler (tk::widget-parent widget)
+			 '(:structure-notify)
+			 1
+			 'sheet-mirror-event-handler
+			 sheet))
+			 
 
-(defun compute-new-scroll-bar-values (scroll-bar mmin mmax value
-				      slider-size line-increment)
-  (multiple-value-bind
+;;; scroll bar utilities
+
+(defun convert-scroll-bar-value-out (scroll-bar value)
+  (multiple-value-bind 
       (smin smax) (gadget-range* scroll-bar)
-    (let ((value
-	   (fix-coordinate
-	    (compute-symmetric-value
-	     smin smax (* value (- 1 slider-size)) mmin mmax)))
-	  (size
-	   (max 1
-		(fix-coordinate
-		 (compute-symmetric-value
-		  smin smax slider-size mmin mmax)))))
-      (values 
-       (min value (- mmax size))
-       size
-       (min (- mmax mmin)
-	    (max 1
-		 (fix-coordinate
-		  (compute-symmetric-value
-		   smin smax line-increment mmin mmax))))))))
+    (fix-coordinate
+     (compute-symmetric-value
+      smin smax value 0 1000))))
+
+(defun convert-scroll-bar-value-in (scroll-bar value)
+  (multiple-value-bind 
+      (smin smax) (gadget-range* scroll-bar)
+    (compute-symmetric-value
+     0 1000 value smin smax )))
+
+(defun compute-new-scroll-bar-values (scroll-bar value slider-size line-increment)
+  (values 
+   (and value
+	(convert-scroll-bar-value-out scroll-bar value))
+   (and slider-size
+	(max 1 (convert-scroll-bar-value-out scroll-bar slider-size)))
+   (and line-increment
+	(max 1 (convert-scroll-bar-value-out scroll-bar line-increment)))))
+
 
 (defun wait-for-callback-invocation (port predicate &optional (whostate "Waiting for callback"))
   (if (eq mp:*current-process* (port-process port))
diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp
index f4398343a758e2df0d90049cccc93d54f137ecd8..e50d5238577a2ca4694212a7daa772ff63dad33b 100644
--- a/tk-silica/xt-graphics.lisp
+++ b/tk-silica/xt-graphics.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-graphics.lisp,v 1.82 1993/10/25 16:16:47 cer Exp $
+;; $fiHeader: xt-graphics.lisp,v 1.84 1994/11/23 23:29:26 smh Exp $
 
 (in-package :tk-silica)
 
@@ -89,11 +89,13 @@
 			sheet
 			(sheet-mirror sheet))))))
 
-;;; Palette handling stuff
+;;; Palette handling
 
 (defclass xt-palette (basic-palette)
   ((colormap :reader palette-colormap :initarg :colormap)
    (xcolor-cache :initform (make-hash-table) :reader palette-xcolor-cache)
+   (device-color-cache :initform (make-hash-table) 
+		       :reader palette-device-color-cache)
    (named-color-cache :initform (make-hash-table :test #'equalp) 
 		      :reader palette-named-color-cache)
    (white-pixel :initarg :white-pixel)
@@ -122,15 +124,21 @@
 	(frame-palette frame)
       (port-default-palette (port medium)))))
 
-#+ignore
 (defmethod (setf frame-manager-palette) :after 
 	   ((palette xt-palette) (framem standard-frame-manager))
   (let ((colormap (palette-colormap palette)))
     (dolist (frame (frame-manager-frames framem))
-      (let ((window (tk::widget-window 
-		     (sheet-direct-mirror (frame-top-level-sheet
-					   frame)))))
-	(setf (tk::window-colormap window) colormap)))))
+      (tk::set-values (frame-shell frame) :colormap colormap)
+      (map-over-sheets 
+       #'(lambda (sheet)
+	   (let ((medium (and (typep sheet
+				     'silica::sheet-with-medium-mixin)
+			      (sheet-medium sheet))))
+	     (when medium
+	       (with-slots (ink-table) medium
+		 (clrhash ink-table))
+	       (repaint-sheet sheet +everywhere+))))
+       (frame-top-level-sheet frame)))))
 
 (defun get-xcolor (color palette)
   (let ((xcolor-cache (palette-xcolor-cache palette)))
@@ -151,7 +159,11 @@
     (setq name (substitute #\space #\- (string name)))
     (or (gethash name named-color-cache)
 	(setf (gethash name named-color-cache)
-	  (let ((xcolor (tk::lookup-color (palette-colormap palette) name))
+	  
+	  ;; put this back from lookup-color to parse-color because
+	  ;; openlook version still uses R4 (cim) 1/13/94
+	  
+	  (let ((xcolor (tk::parse-color (palette-colormap palette) name))
 		(x #.(1- (ash 1 16))))
 	    (if xcolor
 		(make-rgb-color (/ (x11:xcolor-red xcolor) x)
@@ -171,22 +183,22 @@
 
 (defmethod update-palette-entries ((palette xt-palette) updates)
   (with-slots (colormap) palette
-    (let* ((n (ash (length updates) -1))
-	   (xcolors (tk::get-xcolor-array n))
-	   (j 0))
-      (dotimes (i n)
-	(let ((pixel (aref updates j))
-	      (color (aref updates (1+ j))))
-	  (let ((xcolor (get-xcolor color palette)))
-	    (declare (ignore ignore))
-	    (setf (x11:xcolor-array-red xcolors i) (x11:xcolor-red xcolor)
-		  (x11:xcolor-array-green xcolors i) (x11:xcolor-green xcolor)
-		  (x11:xcolor-array-blue xcolors i) (x11:xcolor-blue xcolor)
-		  (x11:xcolor-array-pixel xcolors i) pixel
-		  (x11:xcolor-array-flags xcolors i)
-		  #.(logior x11:dored x11:dogreen x11:doblue))))
-	(incf j 2))
-      (tk::store-colors colormap xcolors n))))
+    (let ((n (ash (length updates) -1))
+	  (j 0))
+      (tk::with-xcolor-array (xcolors n)
+	(dotimes (i n)
+	  (let ((pixel (aref updates j))
+		(color (aref updates (1+ j))))
+	    (let ((xcolor (get-xcolor color palette)))
+	      (declare (ignore ignore))
+	      (setf (x11:xcolor-array-red xcolors i) (x11:xcolor-red xcolor)
+		    (x11:xcolor-array-green xcolors i) (x11:xcolor-green xcolor)
+		    (x11:xcolor-array-blue xcolors i) (x11:xcolor-blue xcolor)
+		    (x11:xcolor-array-pixel xcolors i) pixel
+		    (x11:xcolor-array-flags xcolors i)
+		    #.(logior x11:dored x11:dogreen x11:doblue))))
+	  (incf j 2))
+	(tk::store-colors colormap xcolors n)))))
 
 ;;; things we can install in a palette
 ;;; 1 - color (rgb etc)
@@ -254,6 +266,39 @@
 		 layered-color-cache)
 	(remhash set layered-color-cache)))))
 
+;;; Device colors
+
+(defclass xt-device-color (device-color)
+  ((color-cache :initform nil :accessor device-color-color-cache)))
+
+(defmethod make-device-color ((palette xt-palette) pixel)
+  (let ((device-color-cache (palette-device-color-cache palette)))
+    (or (gethash pixel device-color-cache)
+	(setf (gethash pixel device-color-cache)
+	  (make-instance 'xt-device-color
+	    :palette palette 
+	    :pixel pixel)))))
+
+(defmethod device-color-color ((color xt-device-color))
+  (let ((pixel (device-color-pixel color))
+	(palette (device-color-palette color))
+	(cache (device-color-color-cache color)))
+    (multiple-value-bind (r g b)
+	(tk::query-color (palette-colormap palette) pixel)
+      (let* ((x #.(1- (ash 1 16)))
+	     (red (/ r x))
+	     (green (/ g x))
+	     (blue (/ b x)))
+	(if (and cache
+		 (multiple-value-bind (cached-red cached-green cached-blue)
+		     (color-rgb cache)
+		   (and (= red cached-red)
+			(= green cached-green)
+			(= blue cached-blue))))
+	    cache
+	  (setf (device-color-color-cache color)
+	    (make-rgb-color red green blue)))))))
+
 
 ;;
 ;; medium's device clip region is invalidated when:
@@ -390,7 +435,7 @@
 (defvar *default-dashes* '(4 4))
 
 (defun adjust-ink (gc medium x-origin y-origin)
-  
+  (declare (optimize (speed 3) (safety 0)))  
   ;; line style
   (let ((line-style (medium-line-style medium)))
     (unless (eq (ink-gcontext-last-line-style gc) 
@@ -611,10 +656,12 @@
 
       (let ((bitmap
 	     (case format
-	       (:bitmap (or (eql n-designs 2)
-			    (error "Can't make a bitmap from pattern with more than two designs"))) 
-	       (:pixmap (and (find +nowhere+ designs)
-			     (error "Can't make a pixmap from a transparent pattern"))))))
+	       (:bitmap
+		(or (eql n-designs 2)
+		    (error "Can't make a bitmap from pattern with more than two designs"))) 
+	       (:pixmap
+		(and (find +nowhere+ designs)
+		     (error "Can't make a pixmap from a transparent pattern"))))))
 	
 	(dotimes (n (length designs))
 	  (let ((design (elt designs n)))
@@ -652,7 +699,7 @@
 			 :width width
 			 :height height
 			 :depth depth)))
-	  (clim-sys:without-scheduling
+	  (excl:without-interrupts
 	    (tk::put-image pixmap 
 			   (if bitmap
 			       (port-copy-gc-depth-1 port)
@@ -719,18 +766,25 @@
   (let ((color-cache (palette-color-cache palette)))
     (or (gethash color color-cache)
 	(setf (gethash color color-cache)
-	  (with-slots (white-pixel black-pixel) palette
-	    (cond ((palette-color-p palette)
-		   (handler-case
-		       (tk::allocate-color
-			(palette-colormap palette) (get-xcolor color palette))
-		     (tk::x-colormap-full ()
-		       (error 'palette-full))))
-		  ;;-- support gray-scale here
-		  (t
-		   (multiple-value-bind (r g b) (color-rgb color)
-		     (let ((luminosity (color-luminosity r g b)))
-		       (if (< luminosity 0.5) black-pixel white-pixel))))))))))
+	  (if (palette-color-p palette)
+	      (loop
+		(restart-case
+		    (handler-case
+			(return
+			  (tk::allocate-color (palette-colormap palette)
+					      (get-xcolor color palette)))
+		      (tk::x-colormap-full ()
+			(error 'palette-full :palette palette)))
+		  (use-other (other)
+		      :report
+			(lambda (s)
+			  (format s "Use a different color"))
+		    (setq color other))))
+	    ;;-- support gray-scale here
+	    (with-slots (white-pixel black-pixel) palette
+	      (multiple-value-bind (r g b) (color-rgb color)
+		(let ((luminosity (color-luminosity r g b)))
+		  (if (< luminosity 0.5) black-pixel white-pixel)))))))))
 
 (defmethod decode-color-in-palette ((color dynamic-color) (palette xt-palette))
   (let ((dynamic-color-cache (palette-dynamic-color-cache palette)))
@@ -739,12 +793,15 @@
 			       (tk::alloc-color-cells
 				(palette-colormap palette) 1 0)
 			     (tk::x-colormap-full ()
-			       (error 'palette-full)))
+			       (error 'palette-full :palette palette)))
 			   0)))
 	  (update-palette-entry palette pixel (dynamic-color-color color))
 	  (push palette (dynamic-color-palettes color))
 	  (setf (gethash color dynamic-color-cache) pixel)))))
 
+(defmethod decode-color-in-palette ((color device-color) (palette xt-palette))
+  (device-color-pixel color))
+
 (defmethod decode-color-in-palette ((color layered-color) (palette xt-palette))
   (let ((layered-color-cache (palette-layered-color-cache palette)))
     (values-list
@@ -790,7 +847,7 @@
 	    (tk::alloc-color-cells
 	     (palette-colormap palette) 1 total-nplanes)
 	  (tk::x-colormap-full ()
-	    (error 'palette-full)))
+	    (error 'palette-full :palette palette)))
       (let ((pixel (aref pixels 0))
 	    (count 0)
 	    (planes nil))
@@ -823,12 +880,6 @@
 	(< (the fixnum ,x) 32000) (> (the fixnum ,x) -32000)
 	(< (the fixnum ,y) 32000) (> (the fixnum ,y) -32000)))
 
-(defmacro single-float-valid-point-p (x y)
-  `(and (< (the single-float ,x) 32000s0) 
-	(> (the single-float ,x) -32000s0)
-	(< (the single-float ,y) 32000s0) 
-	(> (the single-float ,y) -32000s0)))
-;;
 ;; Here we implement a simple version of the Cohen-Sutherland clipping
 ;; algorithm.  Specifically, we only try to clip the line so that it will
 ;; be legal to pass to X, we don't try to clip to window boundaries.
@@ -904,46 +955,6 @@
 
 ;; Discarding of other illegal graphics
 
-#|
-
-(defmacro int16ify (int &optional check-type-string)
-  "Make int (a fixnum) into an xlib:int16; int must be a
-   place.  Call check-type if it isn't in bounds."
-  ;; These are ordered in expected frequency of usage
-  `(if* (and (>= ,int -32768) (< ,int 32768))
-      then
-	   nil
-      else
-	   (setf ,int (make-into-int16 ,int ,check-type-string))))
-
-(defmacro card16ify (int &optional check-type-string)
-  "Make int (a fixnum) into an xlib:card16; int must be a
-   place.  Call check-type if it isn't in bounds."
-  ;; These are ordered in expected frequency of usage
-  `(if* (and (>= ,int 0) (< ,int 65536))
-      then
-	   nil
-      else
-	   (setf ,int (make-into-card16 ,int ,check-type-string))))
-
-(defun make-into-int16 (object string)
-  ;; Now it must be too big to fit in an xlib:int16.
-  (cond (cw::*fix-up-illegal-graphics-p*
-	 (max -32767 (min 32766 object)))
-	(t
-	 (check-type object xlib:int16 string)
-	 object)))
-
-(defun make-into-card16 (object string)
-  ;; Now it must be too big to fit in an xlib:int16.
-  (cond (cw::*fix-up-illegal-graphics-p*
-	 (max 0 (min 65534 object)))
-	(t
-	 (check-type object xlib:card16 string)
-	 object)))
-
-|#
-
 (defvar *discard-illegal-graphics* t)
 
 (defmacro discard-illegal-coordinates (function-name &rest positions)
@@ -959,25 +970,7 @@
        (if* *discard-illegal-graphics*
 	  then (return-from ,function-name)
 	  else (error "Coordinate(s) out of (signed-byte 16) range")))))
-
-
-(defmacro single-float-discard-illegal-coordinates (function-name &rest positions)
-  (assert (evenp (length positions)) (positions)
-    "There must be an even number of elements in ~S" positions)
-  (let ((forms nil))
-    (do ()
-	((null positions))
-      (let* ((x (pop positions))
-	     (y (pop positions)))
-	(push `(single-float-valid-point-p ,x ,y) forms)))
-    `(unless (and ,@forms)
-       (if* *discard-illegal-graphics*
-	  then (return-from ,function-name)
-	  else (error "Coordinate(s) out of (signed-byte 16) range")))))
 
- 
-
-
 (defmacro with-single-floats (variable-bindings &body body)
   (flet ((binding-var (x) (if (atom x) x (car x)))
 	 (binding-form (x) (if (atom x) x (second x))))
@@ -998,20 +991,32 @@
 
 (defmacro with-mins-and-maxes (variables &body body)
   `(let ,(mapcan #'(lambda (binding)
-		     (destructuring-bind (min-var max-var form1 form2) binding
-		       `((,min-var ,form1)
-			 (,max-var ,form2))))
-	  variables)
-     (declare (single-float ,@(mapcar #'first variables) ,@(mapcar #'second variables)))
+ 		     (destructuring-bind (min-var max-var form1 form2) binding
+ 		       `((,min-var ,form1)
+ 			 (,max-var ,form2))))
+ 	  variables)
+     (declare (fixnum ,@(mapcar #'first variables) ,@(mapcar #'second variables)))
      #+ignore (print-variables min-x min-y max-x max-y)
      ,@(mapcar #'(lambda (binding)
-		   (destructuring-bind (min-var max-var form1 form2) binding
-		     (declare (ignore form1 form2))
-		     `(when (> ,min-var ,max-var) 
-			(rotatef ,min-var ,max-var))))
-	       variables)
+ 		   (destructuring-bind (min-var max-var form1 form2) binding
+ 		     (declare (ignore form1 form2))
+ 		     `(when (> ,min-var ,max-var) 
+ 			(rotatef ,min-var ,max-var))))
+ 	       variables)
      ,@body))
 
+(defmacro with-clipped-fixnum-rectangle ((x1 y1 x2 y2) &body body)
+  `(with-fixnums ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2))
+     (unless (valid-point-p x1 y1)
+       (setq x1 (min (max -32000 x1) 32000))
+       (setq y1 (min (max -32000 y1) 32000)))
+     (unless (valid-point-p x2 y2)
+       (setq x2 (min (max -32000 x2) 32000))
+       (setq y2 (min (max -32000 y2) 32000)))
+     (with-mins-and-maxes ((min-x max-x x1 x2)
+ 			   (min-y max-y y1 y2))
+       ,@body)))
+
 
 (defmethod medium-draw-point* ((medium xt-medium) x y)
   (declare (optimize (speed 3) (safety 0)))
@@ -1035,22 +1040,22 @@
 	      (t
 	       ;;--rounding
 	       ;;--what is the most efficient way of doing this?
-	       (with-single-floats (x y)
-		 (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness
-		   (declare (ignore rthickness))
-		   (with-fixnums ((min-x (- x lthickness))
-				  (min-y (- y lthickness))
-				  (size thickness))
-		     (discard-illegal-coordinates medium-draw-point* min-x min-y)
-		     (tk::draw-ellipse-1
-		      drawable
-		      (adjust-ink (decode-ink ink medium)
-				  medium
-				  min-x
-				  min-y)
-		      min-x min-y 
-		      size size 0 #.(* 360 64)
-		      t))))))))))
+	       
+	       (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness
+		 (declare (ignore rthickness))
+		 (with-fixnums ((min-x (- x lthickness))
+				(min-y (- y lthickness))
+				(size thickness))
+		   (discard-illegal-coordinates medium-draw-point* min-x min-y)
+		   (tk::draw-ellipse-1
+		    drawable
+		    (adjust-ink (decode-ink ink medium)
+				medium
+				min-x
+				min-y)
+		    min-x min-y 
+		    size size 0 #.(* 360 64)
+		    t)))))))))
 
 (defmethod medium-draw-points* ((medium xt-medium) position-seq)
   (let ((drawable (medium-drawable medium)))
@@ -1066,68 +1071,67 @@
 	       (minx #.(ash 1 15))
 	       (miny #.(ash 1 15)))
 	  (declare (fixnum len j xpoints minx miny))
-	  (macrolet ((inner-guts ()
-		       `(if (listp position-seq)
-			    (loop
-			      (when (null position-seq) (return nil))
-			      (guts (pop position-seq) (pop position-seq)))
-			  (do ((i 0 (+ i 2)))
-			      ((= i len))
-			    (declare (fixnum i))
-			    (guts (aref position-seq i) (aref position-seq (1+ i)))))))
-	    (cond ((< thickness 1.5)
-		   (let ((points (tk::make-xpoint-array :number xpoints)))
-		     (macrolet ((guts (x y)
-				  `(let ((x ,x)
-					 (y ,y))
-				     (convert-to-device-coordinates transform x y)
-				     (when (valid-point-p x y)
-				       (minf minx x)
-				       (minf miny y)
-				       (setf (tk::xpoint-array-x points j) x
-					     (tk::xpoint-array-y points j) y)
-				       (incf j)))))
-		       (inner-guts))
-		     (x11:xdrawpoints
-		      (tk::object-display drawable)
-		      drawable
-		      (adjust-ink (decode-ink ink medium)
-				  medium
-				  minx miny)
-		      points
-		      j
-		      x11:coordmodeorigin)))
-		  (t
-		   (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness
-                     (declare (ignore rthickness))
-		     (setq thickness (round thickness))
-		       (let ((points (tk::make-xarc-array :number xpoints)))
-			 (macrolet ((guts (x y)
-				      `(let ((x ,x)
-					     (y ,y))
-					 (transform-positions transform x y)
-					 (with-fixnums ((x (- x lthickness))
-							(y (- y lthickness)))
-					   (when (valid-point-p x y)
-					     (minf minx x)
-					     (minf miny y)
-					     (setf (tk::xarc-array-x points j) x
-						   (tk::xarc-array-y points j) y
-						   (tk::xarc-array-width points j) thickness
-						   (tk::xarc-array-height points j) thickness
-						   (tk::xarc-array-angle1 points j) 0
-						   (tk::xarc-array-angle2 points j) #.(* 360 64))
-					     (incf j))))))
-			   (inner-guts))
-			 (x11::xfillarcs
-			  (tk::object-display drawable)
-			  drawable
-			  (adjust-ink (decode-ink ink medium)
-				      medium
-				      minx
-				      miny)
-			  points
-			  j)))))))))))
+	  (macrolet 
+	      ((process-positions ()
+		 `(if (listp position-seq)
+		      (loop
+			(when (null position-seq) (return nil))
+			(process-position (pop position-seq)
+					  (pop position-seq)))
+		    (do ((i 0 (+ i 2)))
+			((= i len))
+		      (declare (fixnum i))
+		      (process-position (aref position-seq i)
+					(aref position-seq (1+ i)))))))
+	    (if (< thickness 1.5)
+		(tk::with-xpoint-array (points xpoints)
+		  (macrolet
+		      ((process-position (x y)
+			 `(let ((x ,x)
+				(y ,y))
+			    (convert-to-device-coordinates transform x y)
+			    (when (valid-point-p x y)
+			      (minf minx x)
+			      (minf miny y)
+			      (setf (x11:xpoint-array-x points j) x
+				    (x11:xpoint-array-y points j) y)
+			      (incf j)))))
+		    (process-positions))
+		  (x11:xdrawpoints (tk::object-display drawable)
+				   drawable
+				   (adjust-ink (decode-ink ink medium)
+					       medium minx miny)
+				   points
+				   j
+				   x11:coordmodeorigin))
+	      (clim-internals::with-half-thickness-1 (lthickness rthickness) thickness
+	        (declare (ignore rthickness))
+		(setq thickness (round thickness))
+		(tk::with-xarc-array (points xpoints)
+		  (macrolet 
+		      ((process-position (x y)
+			 `(let ((x ,x)
+				(y ,y))
+			    (transform-positions transform x y)
+			    (with-fixnums ((x (- x lthickness))
+					   (y (- y lthickness)))
+			      (when (valid-point-p x y)
+				(minf minx x)
+				(minf miny y)
+				(setf (x11:xarc-array-x points j) x
+				      (x11:xarc-array-y points j) y
+				      (x11:xarc-array-width points j) thickness
+				      (x11:xarc-array-height points j) thickness
+				      (x11:xarc-array-angle1 points j) 0
+				      (x11:xarc-array-angle2 points j) #.(* 360 64))
+				(incf j))))))
+		    (process-positions))
+		  (x11::xfillarcs (tk::object-display drawable)
+				  drawable
+				  (adjust-ink (decode-ink ink medium)
+					      medium minx miny)
+				  points
+				  j))))))))))
 
 
 (defmethod medium-draw-line* ((medium xt-medium) x1 y1 x2 y2)
@@ -1147,7 +1151,6 @@
 		       (the fixnum (min (the fixnum y1) (the fixnum y2))))
 	   x1 y1 x2 y2))))))
 
-
 (defmethod medium-draw-lines* ((medium xt-medium) position-seq)
   (let ((drawable (medium-drawable medium)))
     (when drawable
@@ -1155,67 +1158,51 @@
 	     (transform (sheet-device-transformation sheet))
 	     (len (length position-seq))
 	     (npoints (/ len 4))
-	     (points (tk::make-xsegment-array :number npoints))
 	     ;; These really are fixnums, since we're fixing coordinates below
 	     (minx most-positive-fixnum)
 	     (miny most-positive-fixnum)
 	     ink)
-	(macrolet ((stuff-line-guts (x1 y1 x2 y2)
-		     `(let ((x1 ,x1)
-			    (y1 ,y1)
-			    (x2 ,x2)
-			    (y2 ,y2))
-			(convert-to-device-coordinates transform x1 y1)
-			(convert-to-device-coordinates transform x2 y2)
-			(when (clip-invalidate-line x1 y1 x2 y2)
-			  (minf minx x1)
-			  (minf miny y1)
-			  (minf minx x2)
-			  (minf miny y2)
-			  (setf (tk::xsegment-array-x1 points i) x1
-				(tk::xsegment-array-y1 points i) y1
-				(tk::xsegment-array-x2 points i) x2
-				(tk::xsegment-array-y2 points i) y2)))))
-	  (let ((i 0))
-	    (declare (fixnum i))
-	    (if (listp position-seq)
-		(do ((ps position-seq))
-		    ((null ps))
-		  (when (stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps))
-		    (incf i)))
-	      (do ((ps position-seq)
-		   (j 0 (+ j 4)))
-		  ((= j len))
-		(declare (fixnum i))
-		(when (stuff-line-guts (aref ps j) (aref ps (1+ j))
-				       (aref ps (+ 2 j)) (aref ps (+ 3 j)))
-		  (incf i))))
-	    (unless (zerop i)
-	      (setq ink 
-		(adjust-ink (decode-ink (medium-ink medium) medium) medium
-			    minx miny))
-	      (x11:xdrawsegments
-	       (tk::object-display drawable)
-	       drawable
-	       ink
-	       points
-	       i))))))))
-
-(defmacro with-clipped-fixnum-rectangle ((x1 y1 x2 y2) &body body)
-  `(with-single-floats ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2))
-     (unless (single-float-valid-point-p x1 y1)
-       (setq x1 (min (max -32000s0 x1) 32000s0))
-       (setq y1 (min (max -32000s0 y1) 32000s0)))
-     (unless (single-float-valid-point-p x2 y2)
-       (setq x2 (min (max -32000s0 x2) 32000s0))
-       (setq y2 (min (max -32000s0 y2) 32000s0)))
-     (with-mins-and-maxes ((min-x max-x x1 x2)
-			   (min-y max-y y1 y2))
-       (with-fixnums ((fmin-x min-x)
-		      (fmin-y min-y)
-		      (fwidth (- max-x min-x))
-		      (fheight (- max-y min-y)))
-	 ,@body))))
+	(tk::with-xsegment-array (points npoints)
+	  (macrolet ((stuff-line-guts (x1 y1 x2 y2)
+		       `(let ((x1 ,x1)
+			      (y1 ,y1)
+			      (x2 ,x2)
+			      (y2 ,y2))
+			  (convert-to-device-coordinates transform x1 y1)
+			  (convert-to-device-coordinates transform x2 y2)
+			  (when (clip-invalidate-line x1 y1 x2 y2)
+			    (minf minx x1)
+			    (minf miny y1)
+			    (minf minx x2)
+			    (minf miny y2)
+			    (setf (x11:xsegment-array-x1 points i) x1
+				  (x11:xsegment-array-y1 points i) y1
+				  (x11:xsegment-array-x2 points i) x2
+				  (x11:xsegment-array-y2 points i) y2)))))
+	    (let ((i 0))
+	      (declare (fixnum i))
+	      (if (listp position-seq)
+		  (do ((ps position-seq))
+		      ((null ps))
+		    (when (stuff-line-guts (pop ps) (pop ps) (pop ps) (pop ps))
+		      (incf i)))
+		(do ((ps position-seq)
+		     (j 0 (+ j 4)))
+		    ((= j len))
+		  (declare (fixnum i))
+		  (when (stuff-line-guts (aref ps j) (aref ps (1+ j))
+					 (aref ps (+ 2 j)) (aref ps (+ 3 j)))
+		    (incf i))))
+	      (unless (zerop i)
+		(setq ink 
+		  (adjust-ink (decode-ink (medium-ink medium) medium) medium
+			      minx miny))
+		(x11:xdrawsegments
+		 (tk::object-display drawable)
+		 drawable
+		 ink
+		 points
+		 i)))))))))
 
 #+debugging
 (defmacro print-variables (&rest variables)
@@ -1228,26 +1215,23 @@
 	   ,@variables))
 
 (defmethod medium-draw-rectangle* ((medium xt-medium) ox1 oy1 ox2 oy2 filled)
-  #+this-would-be-nice (declare (optimize (safety 0) (speed 3)))
-  #-this-would-be-nice (declare (optimize (safety 3) (speed 0)))
+  (declare (optimize (safety 0) (speed 3)))
   (let ((drawable (medium-drawable medium)))
     (when drawable
       (let* ((ink (medium-ink medium))
 	     (sheet (medium-sheet medium))
 	     (transform (sheet-device-transformation sheet)))
 	(assert (rectilinear-transformation-p transform))
-	;;--rounding
-	(transform-positions transform ox1 oy1 ox2 oy2)
-	;; Clipping a rectangle is ridiculously easy.
+	(convert-to-device-coordinates transform ox1 oy1 ox2 oy2)
 	(with-clipped-fixnum-rectangle (ox1 oy1 ox2 oy2)
 	  (tk::draw-rectangle
 	   drawable
 	   (adjust-ink (decode-ink ink medium)
 		       medium
-		       fmin-x fmin-y)
-	   fmin-x fmin-y
-	   fwidth
-	   fheight
+		       min-x min-y)
+	   min-x min-y
+	   (- max-x min-x)
+	   (- max-y min-y)
 	   filled))))))
 
 (defmethod medium-draw-rectangles* ((medium xt-medium) rectangles filled) 
@@ -1259,109 +1243,110 @@
 	     (transform (sheet-device-transformation sheet))
 	     (len (length rectangles))
 	     (nrects (/ len 4))
-	     (rects (xt::make-xrectangle-array :number nrects))
 	     (overall-min-x #.(1- (ash 1 16)))
 	     (overall-min-y #.(1- (ash 1 16))))
 	(declare (fixnum len nrects overall-min-x overall-min-y))
 	(assert (zerop (mod len 4)) () "Must be a multiple of 4")
 	(assert (rectilinear-transformation-p transform))
-	(macrolet ((guts (x1 y1 x2 y2)
-		     `(let ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2))
-			(transform-positions transform x1 y1 x2 y2)
-			(with-clipped-fixnum-rectangle (x1 y1 x2 y2)
-			  (minf overall-min-x fmin-x)
-			  (minf overall-min-y fmin-y)
-			  (setf (tk::xrectangle-array-x rects i) fmin-x 
-				(tk::xrectangle-array-y rects i) fmin-y
-				(tk::xrectangle-array-width rects i) fwidth
-				(tk::xrectangle-array-height rects i) fheight)
-			  (incf i)))))
-	  (let ((i 0))
-	    (declare (fixnum i))
-	    (if (listp rectangles)
-		(loop
-		  (when (null rectangles) (return nil))
-		  (guts (pop rectangles) (pop rectangles) (pop rectangles) (pop rectangles)))
-	      (do ((j 0 (+ j 4)))
-		  ((= j len))
-		(declare (fixnum j))
-		(guts (aref rectangles j)
-		      (aref rectangles (+ 1 j))
-		      (aref rectangles (+ 2 j))
-		      (aref rectangles (+ 3 j))))))
-	  (tk::draw-rectangles
-	   drawable
-	   (adjust-ink (decode-ink ink medium)
-		       medium
-		       overall-min-x overall-min-y)
-	   rects
-	   nrects
-	   filled))))))
+	(tk::with-xrectangle-array (rects nrects)
+	  (macrolet ((guts (x1 y1 x2 y2)
+		       `(let ((x1 ,x1) (y1 ,y1) (x2 ,x2) (y2 ,y2))
+			  (convert-to-device-coordinates transform x1 y1 x2 y2)
+			  (with-clipped-fixnum-rectangle (x1 y1 x2 y2)
+			    (minf overall-min-x min-x)
+			    (minf overall-min-y min-y)
+			    (setf (x11:xrectangle-array-x rects i) min-x 
+				  (x11:xrectangle-array-y rects i) min-y
+				  (x11:xrectangle-array-width rects i)
+				  (- max-x min-x)
+				  (x11:xrectangle-array-height rects i)
+				  (- max-y min-y))
+			    (incf i)))))
+	    (let ((i 0))
+	      (declare (fixnum i))
+	      (if (listp rectangles)
+		  (loop
+		    (when (null rectangles) 
+		      (return nil))
+		    (guts (pop rectangles) (pop rectangles)
+			  (pop rectangles) (pop rectangles))) 
+		(do ((j 0 (+ j 4)))
+		    ((= j len))
+		  (declare (fixnum j))
+		  (guts (aref rectangles j)
+			(aref rectangles (+ 1 j))
+			(aref rectangles (+ 2 j))
+			(aref rectangles (+ 3 j))))))
+	    (tk::draw-rectangles
+	     drawable
+	     (adjust-ink (decode-ink ink medium)
+			 medium
+			 overall-min-x overall-min-y)
+	     rects
+	     nrects
+	     filled)))))))
 
 
 (defmethod medium-draw-polygon* ((medium xt-medium) position-seq closed filled)
-  (medium-draw-polygon-1 medium  position-seq closed filled))
-
-(defun medium-draw-polygon-1 (medium position-seq closed filled)
   (let ((drawable (medium-drawable medium)))
     (when drawable
       (let* ((sheet (medium-sheet medium))
 	     (transform (sheet-device-transformation sheet))
 	     (len (length position-seq))
 	     (npoints (/ len 2))
-	     (points (xt::make-xpoint-array :number (cond ((and closed (not filled))
-							   (incf npoints))
-							  (t npoints))))
 	     ;; These really are fixnums, since we're fixing coordinates below
 	     (minx most-positive-fixnum)
 	     (miny most-positive-fixnum)
 	     ink)
-	(if (listp position-seq)
-	    (do ((ps position-seq (cddr ps))
+	(when (and closed (not filled))
+	  (incf npoints))
+	(tk::with-xpoint-array (points npoints)
+	  (if (listp position-seq)
+	      (do ((ps position-seq (cddr ps))
+		   (i 0 (1+ i)))
+		  ((null ps))
+		(let ((x (first ps))
+		      (y (second ps)))
+		  (convert-to-device-coordinates transform x y)
+		  (discard-illegal-coordinates medium-draw-polygon* x y)
+		  (minf minx x)
+		  (minf miny y)
+		  (setf (x11:xpoint-array-x points i) x
+			(x11:xpoint-array-y points i) y)))
+	    (do ((ps position-seq)
+		 (j 0 (+ 2 j))
 		 (i 0 (1+ i)))
-		((null ps))
-	      (let ((x (first ps))
-		    (y (second ps)))
+		((= j len))
+	      (let ((x (aref ps j))
+		    (y (aref ps (1+ j))))
 		(convert-to-device-coordinates transform x y)
-		(discard-illegal-coordinates medium-draw-polygon-1 x y)
+		(discard-illegal-coordinates medium-draw-polygon* x y)
 		(minf minx x)
 		(minf miny y)
-		(setf (tk::xpoint-array-x points i) x
-		      (tk::xpoint-array-y points i) y)))
-	  (do ((ps position-seq)
-	       (j 0 (+ 2 j))
-	       (i 0 (1+ i)))
-	      ((= j len))
-	    (let ((x (aref ps j))
-		  (y (aref ps (1+ j))))
-	      (convert-to-device-coordinates transform x y)
-	      (discard-illegal-coordinates medium-draw-polygon-1 x y)
-	      (minf minx x)
-	      (minf miny y)
-	      (setf (tk::xpoint-array-x points i) x
-		    (tk::xpoint-array-y points i) y))))
-	(when (and closed (not filled))
-	  (setf (tk::xpoint-array-x points (- npoints 1)) (tk::xpoint-array-x points 0)
-		(tk::xpoint-array-y points (- npoints 1)) (tk::xpoint-array-y points 0)))
-	(setq ink 
-	  (adjust-ink (decode-ink (medium-ink medium) medium) medium
-		      minx miny))
-	(if filled
-	    (x11:xfillpolygon
+		(setf (x11:xpoint-array-x points i) x
+		      (x11:xpoint-array-y points i) y))))
+	  (when (and closed (not filled))
+	    (setf (x11:xpoint-array-x points (- npoints 1)) (x11:xpoint-array-x points 0)
+		  (x11:xpoint-array-y points (- npoints 1)) (x11:xpoint-array-y points 0)))
+	  (setq ink 
+	    (adjust-ink (decode-ink (medium-ink medium) medium) medium
+			minx miny))
+	  (if filled
+	      (x11:xfillpolygon
+	       (tk::object-display drawable)
+	       drawable
+	       ink
+	       points
+	       npoints
+	       x11:complex
+	       x11:coordmodeorigin)
+	    (x11:xdrawlines
 	     (tk::object-display drawable)
 	     drawable
 	     ink
 	     points
 	     npoints
-	     x11:complex
-	     x11:coordmodeorigin)
-	  (x11:xdrawlines
-	    (tk::object-display drawable)
-	    drawable
-	    ink
-	    points
-	    npoints
-	    x11:coordmodeorigin))))))
+	     x11:coordmodeorigin)))))))
 
 (defmethod medium-draw-ellipse* ((medium xt-medium)
 				 center-x center-y
@@ -1438,6 +1423,7 @@
 			      string-or-char x y start end
 			      align-x align-y
 			      towards-x towards-y transform-glyphs)
+  (declare (optimize (speed 3) (safety 0)))
   (let ((drawable (medium-drawable medium)))
     (when drawable
       (let* ((port (port medium))
@@ -1911,7 +1897,7 @@
        (x11::xfontstruct-max-bounds-width font))))
 
 (defmethod medium-beep ((medium xt-medium))
-  (x11:xbell (port-display (port medium)) 100))
+  (x11:xbell (port-display (port medium)) 0))
 
 (defmethod medium-force-output ((medium xt-medium))
   (x11:xflush (port-display (port medium))))
diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp
index 34c8cf650f5d8a4856fa9a979a41ab28fdbfdd70..99bdb0f360f77afc3f3cef70149e57e752d165b8 100644
--- a/tk-silica/xt-pixmaps.lisp
+++ b/tk-silica/xt-pixmaps.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-pixmaps.lisp,v 1.18 1993/11/18 18:45:45 cer Exp $
+;; $fiHeader: xt-pixmaps.lisp,v 1.19 1993/12/07 05:34:29 colin Exp $
 
 
 (in-package :xm-silica)
@@ -142,7 +142,6 @@
 	   pixmap copy-gc from-x from-y width height
 	   window to-x to-y))))))
 
-
 (defmethod medium-copy-area 
     ((from-medium xt-medium) from-x from-y width height
      (pixmap xt-pixmap) to-x to-y
@@ -160,4 +159,27 @@
 	   window copy-gc from-x from-y width height 
 	   pixmap to-x to-y))))))
 
-
+(defmethod make-pattern-from-pixmap ((pixmap xt-pixmap) 
+				     &key
+				     (x 0)
+				     (y 0)
+				     (width (pixmap-width pixmap))
+				     (height (pixmap-height pixmap)))
+  (let* ((image (tk::get-image pixmap :x x :y y :width width :height height))
+	 (image-data (tk::image-data image))
+	 (pattern-data (make-array (list height width)))
+	 (pixels nil)
+	 (palette (port-default-palette (port pixmap))))
+    (dotimes (w width)
+      (dotimes (h height)
+	(let ((pixel (aref image-data h w)))
+	  (unless (member pixel pixels)
+	    (setf pixels (nconc pixels (list pixel))))
+	  (setf (aref pattern-data h w)
+	    (position pixel pixels)))))
+    (tk::destroy-image image)
+    (make-pattern pattern-data 
+		  (mapcar #'(lambda (pixel)
+			      (device-color-color
+			       (make-device-color palette pixel)))
+			  pixels))))
diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp
index bca524fde6961f555c43b7f21d4c08ba83c08d9b..dfe735e0371337fdbaff3fdc2ce590684e72556c 100644
--- a/tk-silica/xt-silica.lisp
+++ b/tk-silica/xt-silica.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-silica.lisp,v 1.92 1993/11/18 18:45:48 cer Exp $
+;; $fiHeader: xt-silica.lisp,v 1.94 1994/01/11 23:34:49 georgej Exp $
 
 (in-package :xm-silica)
 
@@ -92,7 +92,7 @@
       (when process
 	(clim-sys:destroy-process process))
       (setq process
-	(mp:process-run-restartable-function
+	(mp:process-run-function
 	 (list :name (format nil "CLIM Event Dispatcher for ~A"
 			     (port-server-path port))
 	       :priority 1000)
@@ -100,13 +100,6 @@
       (setf (getf (mp:process-property-list process) ':survive-dumplisp) #'cleanup-port-after-dumplisp)
       (setf (port-process port) process))))
 
-(defmethod port-event-loop :around ((port xt-port))
-  (handler-case (call-next-method)
-    (tk::x-connection-lost (condition)
-      (port-terminated port condition)
-      (mp:process-kill mp:*current-process*))))
-
-       
 (defparameter *use-color* t)		; For debugging monochrome
 
 (defvar *unreliable-server-vendors*
@@ -114,38 +107,48 @@
       "Tektronix"))
  
 (defmethod initialize-instance :after ((port xt-port) &key server-path)
-  (handler-case
-      (destructuring-bind
-	  (&key (display nil display-p)
-		(application-name nil application-name-p)
-		(application-class nil application-class-p))
-	  (cdr server-path)
-	(let ((args nil))
-	  (when display-p (setf (getf args :host) display))
-	  (when application-name-p (setf (getf args :application-name) application-name))
-	  (when application-class-p (setf (getf args :application-class) application-class))
-	  (multiple-value-bind (context display application-shell)
-	      (apply #'tk::initialize-toolkit args)
-	    (setf (slot-value port 'application-shell) application-shell
-		  (slot-value port 'context) context
-		  (slot-value port 'display) display
-		  (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
-		  (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
-		  (slot-value port 'silica::default-palette) 
-		  (make-palette port :colormap 
-				(tk::default-colormap (port-display port))))
-	    (let* ((screen (x11:xdefaultscreenofdisplay display))
-		   (bs-p (not (zerop (x11::screen-backing-store screen))))
-		   (su-p (not (zerop (x11::screen-save-unders screen))))
-		   (vendor (ff:char*-to-string (x11::display-vendor display))))
-	      (if (and bs-p su-p
-		       ;; An amazing crock.  XXX
-		       (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*))
-		  (setf (slot-value port 'safe-backing-store) t)))
-	    (initialize-xlib-port port display))))
-    (tk::x-connection-lost (condition)
-      (port-terminated port condition))))
-
+  (setq tk::*x-io-error-hook* #'xt-fatal-error-handler)
+  (destructuring-bind
+      (&key (display nil display-p)
+	    (application-name nil application-name-p)
+	    (application-class nil application-class-p))
+      (cdr server-path)
+    (let ((args nil))
+      (when display-p (setf (getf args :host) display))
+      (when application-name-p (setf (getf args :application-name) application-name))
+      (when application-class-p (setf (getf args :application-class) application-class))
+      (multiple-value-bind (context display application-shell)
+	  (apply #'tk::initialize-toolkit args)
+	(setf (slot-value port 'application-shell) application-shell
+	      (slot-value port 'context) context
+	      (slot-value port 'display) display
+	      (port-depth port) (x11:xdefaultdepth display (tk::display-screen-number display))
+	      (port-visual-class port) (tk::screen-root-visual-class (tk::default-screen display))
+	      (slot-value port 'silica::default-palette) 
+	      (make-palette port :colormap 
+			    (tk::default-colormap (port-display port))))
+	(let* ((screen (x11:xdefaultscreenofdisplay display))
+	       (bs-p (not (zerop (x11::screen-backing-store screen))))
+	       (su-p (not (zerop (x11::screen-save-unders screen))))
+	       (vendor (ff:char*-to-string (x11::display-vendor display))))
+	  (if (and bs-p su-p
+		   ;; An amazing crock.  XXX
+		   (notany #'(lambda (x) (search x vendor)) *unreliable-server-vendors*))
+	      (setf (slot-value port 'safe-backing-store) t)))
+	(initialize-xlib-port port display)))))
+
+(defun xt-fatal-error-handler (d)
+  (excl:without-interrupts
+    (let* ((display (tk::find-object-from-address d))
+	   (context (tk::display-context display)))
+      (block done
+	(map-over-ports
+	 #'(lambda (port)
+	     (when (eq (port-context port) context)
+	       (destroy-port port)
+	       (return-from done))))))
+      (when tk::*inside-event-wait-function*
+	(throw tk::*inside-event-wait-function* :error))))
 
 (defmethod port-color-p ((port xt-port))
   (and *use-color*
@@ -326,9 +329,12 @@
     (when port
       (setq clim-event
 	(ecase (tk::event-type event)
-	  ((:map-notify :unmap-notify :selection-clear :selection-request
+	  ((:reparent-notify :selection-clear :selection-request
 	    :selection-notify :client-message :mapping-notify :no-expose)
 	   nil)
+	  ((:map-notify :unmap-notify)
+	   (sheet-mirror-map-callback event sheet)
+	   nil)
 	  (:configure-notify
 	   (sheet-mirror-resized-callback widget nil event sheet)
 	   nil)
@@ -505,6 +511,8 @@
   ;; in ensure-blinker-for-cursor.
   (declare (ignore window))
   (when (let ((port (port sheet)))
+	  ;; why does this care about port-safe-backing-store?????
+	  ;; (cim 10/19/94) 
 	  (and port (port-safe-backing-store port)))
     (let ((window (tk::widget-window widget)))
       (unless (getf (window-property-list window) 'backing-store-on)
@@ -610,6 +618,18 @@
 					     (x11::xbuttonevent-state event))))))
       )))
 
+(defmethod sheet-mirror-map-callback (event sheet)
+  (let ((frame (pane-frame sheet)))
+    (when frame
+      (let ((state (frame-state frame)))
+	(case (tk::event-type event)
+	  (:map-notify 
+	   (when (eq state :shrunk)
+	     (note-frame-deiconified (frame-manager frame) frame)))
+	  (:unmap-notify
+	   (when (eq state :enabled)
+	     (note-frame-iconified (frame-manager frame) frame))))))))
+  
 (defmethod find-widget-class-and-initargs-for-sheet
     ((port xt-port) (parent t) (sheet basic-sheet))
   (error "we should not be here"))
@@ -672,8 +692,9 @@
   (sheet-mirror sheet))
 
 (defmethod find-shell-of-calling-frame ((sheet basic-sheet))
-  (and (pane-frame sheet)
-       (find-shell-of-calling-frame (pane-frame sheet))))
+  (let ((frame (pane-frame sheet)))
+    (and frame
+	 (find-shell-of-calling-frame frame))))
 
 (defmethod find-shell-of-calling-frame ((frame application-frame))
   (let (cf)
@@ -713,40 +734,6 @@
   (unless (xt::is-managed-p mirror)
     (manage-child mirror)))
 
-;(defmethod enable-mirror ((port xt-port) (sheet top-level-sheet))
-;  (let* ((mirror (sheet-mirror sheet))
-; 	 (parent (widget-parent mirror)))
-;    (manage-child mirror)
-;    (xt:realize-widget parent)		; Make sure widget is realized.
-;    (let ((ussp (slot-value sheet 'silica::user-specified-size-p))
-; 	  (uspp (slot-value sheet 'silica::user-specified-position-p)))
-;      (unless (and (eq ussp :unspecified)
-; 		   (eq uspp :unspecified))
-; 	(let* ((window (tk::widget-window parent))
-; 	       (display (tk::widget-display parent))
-; 	       (size-hints (x11::xallocsizehints)))
-; 	  (tk::with-ref-par ((supplied 0))
-; 	    (when (zerop
-; 		   (x11::xgetwmnormalhints display window size-hints supplied))
-; 	      (warn "top-level-sheet had no size hints?!")
-; 	      (return-from enable-mirror))
-; 	    (let ((flags (x11::xsizehints-flags size-hints)))
-; 	      (if* (and uspp (not (eq uspp :unspecified)))
-; 		 then (setf flags (logior flags x11::uspositionhint))
-; 	       elseif (null uspp)
-; 		 then (setf flags (logandc2 flags x11::uspositionhint)))
-; 	      (if* (and ussp (not (eq ussp :unspecified)))
-; 		 then (setf flags (logior flags x11::ussizehint))
-; 	       elseif (null ussp)
-; 		 then (setf flags (logandc2 flags x11::ussizehint)))
-; 	      (setf (x11::xsizehints-flags size-hints) flags))
-; 	    (x11::xsetwmnormalhints display window size-hints)))))
-;    (popup parent)))
- 
-;(defmethod enable-xt-widget ((parent top-level-shell) mirror)
-;  (manage-child mirror)
-;  (popup (widget-parent mirror)))
-
 (defmethod disable-mirror ((port xt-port) sheet)
   (let ((mirror (sheet-mirror sheet)))
     (when mirror
@@ -1072,7 +1059,12 @@
 (define-xt-keysym (keysym 255 255) :rubout)
 (define-xt-keysym (keysym 255 008) :backspace)
 (define-xt-keysym (keysym 009 227) :page)
-;;(define-xt-keysym (keysym 255 010) :linefeed)
+
+;;; this was being immediately redefined to be :newline causing
+;;; redefinition warning. Why does clim have separate :linefeed and
+;;; :newline keysyms? (cim)
+#+ignore (define-xt-keysym (keysym 255 010) :linefeed)
+
 (define-xt-keysym (keysym 255 027) :escape)
 ;;;---
 (define-xt-keysym (keysym 255 010) :newline)
@@ -1177,46 +1169,50 @@
 (defun lookup-character-and-keysym (sheet mirror event)
   (declare (ignore mirror)
 	   (optimize (speed 3) (safety 0)))
-  (multiple-value-bind (character keysym)
-      (tk::lookup-string event (port-compose-status (port sheet)))
-    (setq character (and (= (length (the simple-string character)) 1)
-			 (aref (the simple-string character) 0)))
-    ;;--- Map the asci control-characters into the common lisp
-    ;;--- control characters except where they are special!
-    ;; Also deal with the modifier bits
-    ;; This gets stuff wrong because for example to type-< you have to
-    ;; use the shift key and so instead for m-< you aget m-sh-<
-    ;; Perhaps there is a way of checking to see whether shifting
-    ;; makes sense given the keyboard layout!
-    (when character
-      (let ((x (state->modifiers
-		(x11::xkeyevent-state event))))
-	(setq character (cltl1:make-char
-			 (if (and (<= (char-int character) 26)
-				  (not (member character 
-					       '(#\return 
-						 #\tab
-						 #\page
-						 #\backspace
-						 #\linefeed
-						 #\escape)
-					       :test #'eq)))
-			     (cltl1::int-char
-			      (+ (cltl1::char-int character)
-				 (1- (if (logtest x +shift-key+)
-					 (char-int #\A)
-				       (char-int #\a)))))
-			   character)
-			 (logior
-			  (if (logtest x +control-key+)
-			      cltl1:char-control-bit 0)
-			  (if (logtest x +meta-key+)
-			      cltl1:char-meta-bit 0)
-			  (if (logtest x +super-key+)
-			      cltl1:char-super-bit 0)
-			  (if (logtest x +hyper-key+)
-			      cltl1:char-hyper-bit 0))))))
-    (values character (xt-keysym->keysym keysym))))
+  (let ((port (port sheet)))
+    (multiple-value-bind (character keysym)
+	(tk::lookup-string event 
+			   (if port 
+			       (port-compose-status port)
+			     0))
+      (setq character (and (= (length (the simple-string character)) 1)
+			   (aref (the simple-string character) 0)))
+      ;;--- Map the asci control-characters into the common lisp
+      ;;--- control characters except where they are special!
+      ;; Also deal with the modifier bits
+      ;; This gets stuff wrong because for example to type-< you have to
+      ;; use the shift key and so instead for m-< you aget m-sh-<
+      ;; Perhaps there is a way of checking to see whether shifting
+      ;; makes sense given the keyboard layout!
+      (when character
+	(let ((x (state->modifiers
+		  (x11::xkeyevent-state event))))
+	  (setq character (cltl1:make-char
+			   (if (and (<= (char-int character) 26)
+				    (not (member character 
+						 '(#\return 
+						   #\tab
+						   #\page
+						   #\backspace
+						   #\linefeed
+						   #\escape)
+						 :test #'eq)))
+			       (cltl1::int-char
+				(+ (cltl1::char-int character)
+				   (1- (if (logtest x +shift-key+)
+					   (char-int #\A)
+					 (char-int #\a)))))
+			     character)
+			   (logior
+			    (if (logtest x +control-key+)
+				cltl1:char-control-bit 0)
+			    (if (logtest x +meta-key+)
+				cltl1:char-meta-bit 0)
+			    (if (logtest x +super-key+)
+				cltl1:char-super-bit 0)
+			    (if (logtest x +hyper-key+)
+				cltl1:char-hyper-bit 0))))))
+      (values character (xt-keysym->keysym keysym)))))
 
 
 (defun state->modifiers (x)
@@ -1229,11 +1225,14 @@
     (if (logtest x x11:mod2mask) +super-key+ 0)
     (if (logtest x x11:mod3mask) +hyper-key+ 0)))
 
+(defvar *in-find-widget-name-and-class-hack*
+    nil)
 
 (defmethod find-widget-name-and-class
     ((port xt-port) (parent t) (sheet mirrored-sheet-mixin))
   (multiple-value-bind (class initargs)
-      (find-widget-class-and-initargs-for-sheet port parent sheet)
+      (let ((*in-find-widget-name-and-class-hack* t))
+	(find-widget-class-and-initargs-for-sheet port parent sheet))
     (values (tk::tkify-lisp-name (or (getf initargs :name)
 				     class))
 	    (tk::tkify-lisp-name class :class t))))
@@ -1248,7 +1247,13 @@
     (get-xt-resources port names classes)))
 
 (defmethod get-sheet-resources ((port xt-port) sheet)
-  (let ((parent-widget (sheet-mirror (sheet-parent sheet))))
+  ;; perhaps this should be (find-widget-parent port sheet) so that
+  ;; the top level shell widget is included for top-level-sheets 
+  ;; However, changing this introduces a problem because another top
+  ;; level shell is created when this sheet is finally mirrored -
+  ;; hence causing a memory leak. (cim) 1/7/94
+  (let ((parent-widget #-ignore (sheet-mirror (sheet-parent sheet))
+		       #+ignore (find-widget-parent port sheet)))
     (multiple-value-bind (names classes)
 	(tk::widget-resource-name-and-class parent-widget)
       (multiple-value-bind (name class)
@@ -1258,6 +1263,9 @@
 		classes (append classes (list class))))
 	(get-xt-resources port names classes)))))
 
+;; --- these should be defresource'd otherwise there may be problems with
+;; multiple concurrent queries (cim 8/94) 
+
 (defvar *resource-name* (make-string 40))
 (defvar *resource-class* (make-string 40))
 
@@ -1316,6 +1324,14 @@
 	 (parse-text-style spec)
        (let ((font-name (or (and (stringp spec) spec)
 			    text-style)))
+
+	 ;; device fonts should be cached - cos otherwise this is
+	 ;; very inefficient if the server doesn't notice that it's
+	 ;; the same font name (cim 1/7/94)
+	 ;; in fact it's so bad - let's not support them till this is
+	 ;; fixed
+	 (error "Named fonts not supported")
+	 #+ignore
 	 (silica::make-device-font port 
 				   (make-instance 'tk::font 
 				     :display display
@@ -1459,7 +1475,6 @@ the geometry of the children. Instead the parent has control. "))
      :gadget sheet
      :value value)))
 
-
 (defun find-sheet-from-widget-address (address)
   (let* ((widget (tk::find-object-from-address address))
 	 (display (tk::widget-display widget))
@@ -1471,21 +1486,19 @@ the geometry of the children. Instead the parent has control. "))
 	((not errorp))
 	(t (error "Could not find sheet for widget ~S" widget))))
 
-      
 (defun find-port-from-display (display)
   (find-if #'(lambda (port)
 	       (and (typep port 'xt-port)
 		    (eq (port-display port) display)))
 	   *ports*))
 
-
 (defmethod port-canonicalize-gesture-spec 
     ((port xt-port) gesture-spec &optional modifier-state)
   (declare (optimize (speed 3) (safety 0)))
   (multiple-value-bind (keysym shifts)
       (if modifier-state
 	  (values gesture-spec modifier-state)
-	  (parse-gesture-spec gesture-spec))
+	(parse-gesture-spec gesture-spec))
     ;; Here, we must take the gesture spec, turn it back into
     ;; a keycode, then see what the keysyms are for that keycode
     (let ((x-keysym 
@@ -1544,37 +1557,44 @@ the geometry of the children. Instead the parent has control. "))
   (x11:xlowerwindow (port-display port)
 		    (tk::widget-window (tk::widget-parent (sheet-mirror sheet)))))
 
-
 (defmethod enable-mirror ((port xt-port) (sheet top-level-sheet))
   (let* ((mirror (sheet-mirror sheet))
- 	 (parent (widget-parent mirror)))
+ 	 (parent (widget-parent mirror))
+	 (display (tk::widget-display parent)))
     (manage-child mirror)
     (xt:realize-widget parent)		; Make sure widget is realized.
-    (let ((ussp (slot-value sheet 'silica::user-specified-size-p))
- 	  (uspp (slot-value sheet 'silica::user-specified-position-p)))
-      (unless (and (eq ussp :unspecified)
- 		   (eq uspp :unspecified))
- 	(let* ((window (tk::widget-window parent))
- 	       (display (tk::widget-display parent))
- 	       (size-hints (x11::xallocsizehints)))
- 	  (tk::with-ref-par ((supplied 0))
- 	    (when (zerop
- 		   (x11::xgetwmnormalhints display window size-hints supplied))
- 	      (warn "top-level-sheet had no size hints?!")
- 	      (return-from enable-mirror))
- 	    (let ((flags (x11::xsizehints-flags size-hints)))
- 	      (if* (and uspp (not (eq uspp :unspecified)))
- 		 then (setf flags (logior flags x11::uspositionhint))
- 	       elseif (null uspp)
- 		 then (setf flags (logandc2 flags x11::uspositionhint)))
- 	      (if* (and ussp (not (eq ussp :unspecified)))
- 		 then (setf flags (logior flags x11::ussizehint))
- 	       elseif (null ussp)
- 		 then (setf flags (logandc2 flags x11::ussizehint)))
- 	      (setf (x11::xsizehints-flags size-hints) flags))
- 	    (x11::xsetwmnormalhints display window size-hints)))))
+    (let ((window (tk::widget-window parent)))
+      (x11:xdefinecursor display window
+			 (realize-cursor port sheet 
+					 (or (sheet-pointer-cursor sheet)
+					     :default)))      
+      (let ((ussp (slot-value sheet 'silica::user-specified-size-p))
+	    (uspp (slot-value sheet 'silica::user-specified-position-p)))
+	(unless (and (eq ussp :unspecified)
+		     (eq uspp :unspecified))
+	  (let ((size-hints (x11::xallocsizehints)))
+	    (tk::with-ref-par ((supplied 0))
+	      (when (zerop
+		     (x11::xgetwmnormalhints display window size-hints supplied))
+		(warn "top-level-sheet had no size hints?!")
+		(return-from enable-mirror))
+	      (let ((flags (x11::xsizehints-flags size-hints)))
+		(if* (and uspp (not (eq uspp :unspecified)))
+		   then (setf flags (logior flags x11::uspositionhint))
+		 elseif (null uspp)
+		   then (setf flags (logandc2 flags x11::uspositionhint)))
+		(if* (and ussp (not (eq ussp :unspecified)))
+		   then (setf flags (logior flags x11::ussizehint))
+		 elseif (null ussp)
+		   then (setf flags (logandc2 flags x11::ussizehint)))
+		(setf (x11::xsizehints-flags size-hints) flags))
+	      (x11::xsetwmnormalhints display window size-hints))))))
     (popup parent)))
- 
+
+;;; so is this next method ever called???? let's comment it out and
+;;; see... (cim 4/25/94)
+
+#+ignore
 (defmethod enable-xt-widget ((parent top-level-shell) (mirror t))
   (manage-child mirror)
   (popup (widget-parent mirror)))
@@ -1585,63 +1605,60 @@ the geometry of the children. Instead the parent has control. "))
     ;;--- This costs a round trip to the display server.  A better
     ;;--- scheme would be to have the map/unmap-notify set a flag
     ;;--- that we could simply read here, as in CLIM 1.1
-    ;;--- What does unviewable mean?
-    (not (eq (tk::window-map-state (tk::widget-window mirror)) :unmapped))))
+    (eq (tk::window-map-state (tk::widget-window mirror))
+	:viewable)))
 
 ;;;---- Cursor stuff
 
-(defvar *xt-cursor-type-alist*
-	'((:default 132)
-	  (:vertical-scroll 116)
-	  (:scroll-up 114)
-	  (:scroll-down 106)
-	  (:horizontal-scroll 108)
-	  (:scroll-left 110)
-	  (:scroll-right 112)
-	  (:busy 150)
-	  (:upper-left 134)
-	  (:upper-right 136)
-	  (:lower-left 12)
-	  (:lower-right 14)
-	  (:vertical-thumb 112)
-	  (:horizontal-thumb 114)
-	  (:button 132)
-	  (:prompt 132)
-	  (:move 52)
-	  (:position 34)))
-
-
+;;; if you're feeling bored extend and replace constants with
+;;; x11:xc-xxx
+
+(defparameter *xt-cursor-type-alist*
+    `((:default 68)
+      (:vertical-scroll 116)
+      (:scroll-up 114)
+      (:scroll-down 106)
+      (:horizontal-scroll 108)
+      (:scroll-left 110)
+      (:scroll-right 112)
+      (:busy 150)
+      (:upper-left 134)
+      (:upper-right 136)
+      (:lower-left 12)
+      (:lower-right 14)
+      (:vertical-thumb 112)
+      (:horizontal-thumb 114)
+      (:button 68)
+      (:prompt 68)
+      (:move 52)
+      (:position 34)
+      (:menu ,x11:xc-arrow)))
 
 (defmethod port-set-pointer-cursor ((port xt-port) pointer cursor)
   (unless (eq (pointer-cursor pointer) cursor)
-    (let* ((cursor (and cursor (realize-cursor port nil cursor)))
+    (let* ((cursor (realize-cursor port nil cursor))
+	   (sheet (pointer-sheet pointer))
 	   (widget (sheet-direct-mirror 
-		     (let ((frame (pane-frame (pointer-sheet pointer))))
-		       (if frame
-			   (frame-top-level-sheet frame)
-			   (pointer-sheet pointer)))))
+		    (let ((frame (pane-frame sheet)))
+		      (if frame
+			  (frame-top-level-sheet frame)
+			sheet))))
 	   (window (and widget (tk::widget-window widget nil))))
       (when window
-	(if cursor
-	    (x11:xdefinecursor
-	     (port-display port) window cursor)
-	  (x11:xundefinecursor
-	   (port-display port) window))
-	(port-force-output port)))
-    cursor))
+	(x11:xdefinecursor
+	 (port-display port) window cursor)
+	(port-force-output port))))
+  cursor)
 
 
 (defmethod port-set-sheet-pointer-cursor ((port xt-port) sheet cursor)
   (unless (eq (sheet-pointer-cursor sheet)  cursor)
-    (let* ((cursor (and cursor (realize-cursor port sheet cursor)))
+    (let* ((cursor (realize-cursor port sheet cursor))
 	   (widget (sheet-mirror sheet))
 	   (window (tk::widget-window widget nil)))
       (when window
-	(if cursor
-	    (x11:xdefinecursor
-	     (port-display port) window cursor)
-	  (x11:xundefinecursor
-	   (port-display port) window))
+	(x11:xdefinecursor
+	 (port-display port) window cursor)
 	(port-force-output port))))
   cursor)
 
@@ -1649,18 +1666,21 @@ the geometry of the children. Instead the parent has control. "))
   (with-slots (cursor-cache) port
     (or (getf cursor-cache cursor)
 	(setf (getf cursor-cache cursor)
-	      (call-next-method)))))
+	  (call-next-method)))))
+
+(defmethod realize-cursor ((port xt-port) sheet (cursor null))
+  x11:none)
 
 (defmethod realize-cursor ((port xt-port) sheet (cursor symbol))
   (let ((cursor (or (second (assoc cursor *xt-cursor-type-alist*))
-		    132)))
+		    (error "Unknown cursor name: ~S" cursor))))
     (realize-cursor port sheet cursor)))
 
 (defmethod realize-cursor ((port xt-port) sheet (cursor number))
   (declare (ignore sheet))
-  (x11:xcreatefontcursor
-   (port-display port)
-   cursor))
+  (x11:xcreatefontcursor (port-display port) cursor))
+
+;;;--could this be made to use pixmap-from pattern in xt-graphics?
 
 (defmethod realize-cursor ((port xt-port) sheet (cursor pattern))
   (multiple-value-bind (array designs)
@@ -1773,24 +1793,22 @@ the geometry of the children. Instead the parent has control. "))
 
 (defvar *pointer-grabbed* nil)
 
-
-(defmethod port-invoke-with-pointer-grabbed ((port xt-port) (sheet basic-sheet) continuation 
-								    &key
-								    confine-to cursor
-								    (ungrab-on-error t))
+(defmethod port-invoke-with-pointer-grabbed
+    ((port xt-port) (sheet basic-sheet) continuation 
+     &key confine-to cursor (ungrab-on-error t))
   (let ((widget (sheet-mirror sheet)))
     (unwind-protect
 	(progn
 	  (tk::xt_grab_pointer
 	   widget 
-	   ;;---- Are these parameters correct????
-	   0				; owner-events
-	   (xt-grabbed-event-mask)
-					; Event-mask
+	   ;; we make this true so that scroll-bars can work in
+	   ;; menu-choose-from-drawer windows (cim 10/13/94)
+	   1				; owner-events
+	   (xt-grabbed-event-mask)	; Event-mask
 	   x11:grabmodeasync		; pointer-grab-mode
 	   x11:grabmodeasync		; keyboard
-	   (if confine-to widget 0)	; confine to
-	   (if cursor (realize-cursor port sheet cursor) 0)
+	   (if confine-to (tk::widget-window widget) 0) ; confine to
+	   (realize-cursor port sheet cursor)
 	   0				; current-time
 	   )
 	  (handler-bind ((error #'(lambda (condition)
@@ -1826,20 +1844,21 @@ the geometry of the children. Instead the parent has control. "))
   (fix-coordinates x y)
   (check-type x (signed-byte 16))
   (check-type y (signed-byte 16))
-  ;;--what is the right thing to do?
-  (let ((m (sheet-direct-mirror (frame-top-level-sheet frame))))
-    (tk::set-values m :x x :y y)))
-
+  (tk::set-values (frame-shell frame) :x x :y y))
 
 (defmethod port-resize-frame ((port xt-port) frame width height)
   (check-type width (signed-byte 16))
   (check-type height (signed-byte 16))
   (tk::set-values (frame-shell frame) :width width :height height))
 
+;;; why don't we use the default in silica/port.lisp???
+
 (defmethod destroy-port ((port xt-port))
-  (when (port-process port)
-    (clim-sys:destroy-process (port-process port)))
-  (port-terminated port (make-condition 'error)))
+  (excl:without-interrupts
+    (tk::xt_destroy_application_context (port-context port))
+    (when (port-process port)
+      (clim-sys:destroy-process (port-process port)))
+    (port-terminated port (make-condition 'error))))
 
 (defmethod clim-internals::port-query-pointer ((port xt-port) sheet)
   (multiple-value-bind (same-p root child root-x root-y
@@ -1862,3 +1881,5 @@ the geometry of the children. Instead the parent has control. "))
 (defmacro with-toolkit-dialog-component ((tag value) &body body)
   `(letf-globally (((getf (mp:process-property-list mp:*current-process*) ',tag) ,value))
        ,@body))
+
+
diff --git a/tk/convenience.lisp b/tk/convenience.lisp
index b54d77b72ac2f00dab567a44ac2308896fc50fbb..04e788c5d2f702657906fd6ee42fd297dedf151c 100644
--- a/tk/convenience.lisp
+++ b/tk/convenience.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: convenience.lisp,v 1.15 1993/07/27 01:52:36 colin Exp $
+;; $fiHeader: convenience.lisp,v 1.16 1993/10/26 03:22:18 colin Exp $
 
 (in-package :tk)
 
@@ -43,19 +43,20 @@
 	 (defmethod make-widget ((w ,class) name parent &rest args
 				 &key (managed t) &allow-other-keys)
 	   (remf args :managed)
-	   (let* ((arglist (make-arglist-for-class
-			    (find-class ',class)
-			    parent
-			    args))
-		  (o 
-		   (,c-function-name
-		    parent
-		    (string-to-char* name)
-		    arglist
-		    (truncate (length arglist) 2))))
-	     (when managed
-	       (xt_manage_child o))
-	     o))))))
+	   (with-malloced-objects
+	       (let* ((arglist (make-arglist-for-class
+				(find-class ',class)
+				parent
+				args))
+		      (o 
+		       (,c-function-name
+			parent
+			(note-malloced-object (string-to-char* name))
+			arglist
+			(truncate (length arglist) 2))))
+		 (when managed
+		   (xt_manage_child o))
+		 o)))))))
 
 (define-convenience-class xm-menu-bar (xm-row-column) "XmCreateMenuBar")
 (define-convenience-class xm-pulldown-menu (xm-row-column) "XmCreatePulldownMenu")
@@ -68,6 +69,7 @@
 (define-convenience-class xm-warning-dialog (xm-message-box) "XmCreateWarningDialog")
 (define-convenience-class xm-information-dialog (xm-message-box) "XmCreateInformationDialog")
 (define-convenience-class xm-error-dialog (xm-message-box) "XmCreateErrorDialog")
+(define-convenience-class xm-message-dialog (xm-message-box) "XmCreateMessageDialog")
 
 (define-convenience-class xm-file-selection-dialog
     (xm-file-selection-box) 
diff --git a/tk/event.lisp b/tk/event.lisp
index 22cc25071b4dbbd1ebce25bcfee5aff2be032ce5..545a8aa247f33d785475f5cb37d5975d4e596d1c 100644
--- a/tk/event.lisp
+++ b/tk/event.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: event.lisp,v 1.23 1993/11/23 19:58:55 cer Exp $
+;; $fiHeader: event.lisp,v 1.24 1993/12/07 05:34:10 colin Exp $
 
 (in-package :tk)
 
@@ -39,12 +39,14 @@
 ;;; In wait-for-event, pending input is checked for before the process
 ;;; waits. This is necessary as if there are any timer events that
 ;;; have "occurred" but have not yet been processed then
-;;; xt_app_interval_next_timer will return 0 which would otherwise
+;;; xt_app_interval_next_timer will return -1 which would otherwise
 ;;; result in an indefinite block hence losing the timer event.
 ;;; If mp:wait-for-input-available returns nil - indicating time out -
 ;;; then mask is set by a further call to xt_app_pending. (cim)
 
 
+(defvar *inside-event-wait-function* nil)
+
 (defun wait-for-event (context &key timeout wait-function)
   (let ((mask 0))
     (if (plusp (setq mask (xt_app_pending context)))
@@ -60,7 +62,7 @@
     
     (flet ((wait-function (fd)
 	     (declare (ignore fd))
-	     (let ((*inside-event-wait-function* fds))
+	     (let ((*inside-event-wait-function* '#:wait-for-event))
 	       (catch *inside-event-wait-function*
 		 (or (plusp (setq mask (xt_app_pending context)))
 		     (and wait-function
@@ -68,14 +70,15 @@
 			  (setq reason :wait)))))))
       
       (let* ((interval (xt_app_interval_next_timer context))
-	     (new-timeout (if (plusp interval)
-			      (if (and timeout
-				       (< (* timeout 1000) interval))
-				  timeout
-				(multiple-value-bind (sec msec)
-				    (truncate interval 1000)
-				  (cons sec msec)))
-			    timeout)))
+	     (new-timeout (if (< interval 0)
+			      timeout
+			    ;; rewrite this so it doesn't cons!
+			    (if (and timeout
+				     (<= (* timeout 1000) interval))
+				timeout
+			      (multiple-value-bind (sec msec)
+				  (truncate interval 1000)
+				(cons sec msec))))))
 	(unless (mp:wait-for-input-available fds 
 					     :wait-function #'wait-function
 					     :timeout new-timeout)
diff --git a/tk/foreign.lisp b/tk/foreign.lisp
index 440306486eba0a2fe24f939bb0fd0c1a62b2d590..af249d67f8b32c127f0226bf0e5e8697601919ff 100644
--- a/tk/foreign.lisp
+++ b/tk/foreign.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: foreign.lisp,v 1.15 1993/07/27 01:52:52 colin Exp $
+;; $fiHeader: foreign.lisp,v 1.16 1993/10/25 16:16:25 cer Exp $
 
 (in-package :tk)
 
@@ -84,7 +84,8 @@
   (push d (application-context-displays (slot-value d 'context)))
   (setf (foreign-pointer-address d)
     (or display
-	(apply #'open-display args))))
+	(apply #'open-display args)))
+  (register-address d))
 
 (defun display-database (display)
   (make-instance 'resource-database 
diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp
index 7421911675bd6295d91cd3080e89d9595c67502d..84890aac24d3db324f1bcbcc96bff8a0f9297e0a 100644
--- a/tk/load-ol.lisp
+++ b/tk/load-ol.lisp
@@ -18,16 +18,22 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-ol.lisp,v 1.24 1993/07/29 20:51:52 layer Exp $
+;; $fiHeader: load-ol.lisp,v 1.25 1993/11/23 19:58:58 cer Exp $
 
 (in-package :user)
 
-(provide :climxm)
 (require :climg)
 
 #+svr4
 (unless (ff:get-entry-point (ff:convert-to-lang "ol_appl_add_item")
 			    :note-shared-library-references nil)
+  (defun reinitialize-toolkit ()
+    (ol-initialize)
+    (xt_toolkit_initialize)
+    (setup-error-handlers)
+    (install-ol-error-handlers)
+    (fixup-class-entry-points))
+  (push '(:eval reinitialize-toolkit) excl::*restart-actions*)
   (load "climol.so"))
 
 #-svr4
diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp
index e1ab355c5d9bf338b1863a50cf51149b197e3f59..32f27fde81fc3f90611124965bc18a9926a93e71 100644
--- a/tk/load-xm.lisp
+++ b/tk/load-xm.lisp
@@ -18,17 +18,21 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: load-xm.lisp,v 1.28 1993/07/29 20:51:54 layer Exp $
+;; $fiHeader: load-xm.lisp,v 1.29 1993/11/23 19:59:01 cer Exp $
 
 (in-package :user)
 
-(provide :climxm)
 (require :climg)
 
 #+svr4
 (unless (ff:get-entry-point (ff:convert-to-lang "XmCreateMyDrawingArea")
 			    :note-shared-library-references nil)
-  (load "climxm.so"))
+  (load "climxm.so")
+  (defun reinitialize-toolkit ()
+    (xt_toolkit_initialize)
+    (setup-error-handlers)
+    (fixup-class-entry-points))
+  (push '(:eval reinitialize-toolkit) excl::*restart-actions*))
 
 #-svr4
 (progn
diff --git a/tk/macros.lisp b/tk/macros.lisp
index 1c4d6a96948044b609979ab63816194d77ebbc19..3ced696a0aac239cec0d640b6d2145893f331a3e 100644
--- a/tk/macros.lisp
+++ b/tk/macros.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: macros.lisp,v 1.13 93/05/05 01:40:14 cer Exp $
+;; $fiHeader: macros.lisp,v 1.14 1993/07/27 01:53:11 colin Exp $
 
 (in-package :tk)
 
@@ -55,5 +55,16 @@
   `(locally (declare (optimize (speed 3) (safety 0)))
      (excl::slot-value-using-class-name 'display-object ,object
 					'display)))
-  
 
+(defvar *malloced-objects*)
+
+(defun note-malloced-object (obj &optional (free #'excl::free))
+  (push (cons free obj) *malloced-objects*)
+  obj)
+
+(defmacro with-malloced-objects (&body body)
+  `(let ((*malloced-objects* nil))
+     (unwind-protect
+	 (progn ,@body)
+       (dolist (entry *malloced-objects*)
+	 (funcall (car entry) (cdr entry))))))
diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp
index 634ad39fd898f3e99ab78c69e72605ee4d4474b0..1317ad4f3a1dc76d0eebdaf47ceae529faacfcf7 100644
--- a/tk/make-classes.lisp
+++ b/tk/make-classes.lisp
@@ -20,15 +20,15 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: make-classes.lisp,v 1.36 1993/07/29 20:51:56 layer Exp $
+;; $fiHeader: make-classes.lisp,v 1.38 1994/06/08 06:56:51 duane Exp $
 
 (in-package :tk)
 
 (defun get-foreign-variable-value (x)
   (let ((ep #-svr4 (ff:get-extern-data-address x)
 	    #+svr4 (ff:get-entry-point
-		       x
-		       :note-shared-library-references nil)))
+		    x
+		    :note-shared-library-references nil)))
     (unless ep (error "Entry point ~S not found" x))
     (class-array ep 0)))
 
@@ -36,6 +36,7 @@
 (defun get-resource-internal (class fn resource-class resource-name)
   (let ((x (make-array 1 :element-type '(unsigned-byte 32)))
 	(y (make-array 1 :element-type '(unsigned-byte 32)))
+	(tk-resource-name (tkify-lisp-name resource-name))
 	result)
     ;;--- Perhaps we can just do this when we want to grab the resources.
     ;;--- In this way we would only have to do one the display is
@@ -47,22 +48,19 @@
       (setq result
 	(dotimes (i n)
 	  (let* ((res (xt-resource-list resources i))
-		 (original-name (xt-resource-name res))
-		 (name (lispify-resource-name (char*-to-string original-name))))
-	    (if (equal name resource-name)
-		(let ((*package* (find-package :tk)))
-		  (return (make-instance resource-class
-			    :original-name original-name
-			    :name name
-			    :class (lispify-resource-class 
-				    (char*-to-string (xt-resource-class res)))
-			    :type (lispify-resource-type 
-				   (char*-to-string (xt-resource-type res))))))))))
+		 (original-name (xt-resource-name res)))
+	    (when (string-equal (char*-to-string original-name)
+				tk-resource-name)
+	      (let ((*package* (find-package :tk)))
+		(return
+		  (make-instance resource-class
+		    :original-name original-name
+		    :name resource-name
+		    :class (lispify-resource-class 
+			    (char*-to-string (xt-resource-class res)))
+		    :type (lispify-resource-type 
+			   (char*-to-string (xt-resource-type res))))))))))
       (xt_free resources))
-    #+ignore
-    (unless result
-      ;; Error is actually caught in calling functions.
-      (error "No resource named ~s found for class ~s" resource-name class))
     result))
 
 ;; These are so we don't need the foreign functions at run time.
@@ -240,43 +238,97 @@
 		     :test #'member))
 	name)))
   
-(defun lispify-tk-name (string &key 
-			       (start 0)
-			       (package *package*)
-			       prefix)
-  (let ((string
-	 (let ((n start) 
-	       (frags (and prefix (list prefix)))
-	       old-n)
-	   (loop
-	    (setq old-n n
-		  n (position-if #'upper-case-p string 
-				 :start (or n 0)))
-	    (if n
-		(progn 
-		  (push (subseq string (or old-n 0) n) frags)
-		  (when (> n 0) (push "-" frags))
-		  (push (string-downcase (subseq string n (1+ n))) frags)
-		  (incf n))
-	      (return (apply #'concatenate 
-			     'simple-string
-			     (nreverse (cons (subseq string old-n)
-					     frags)))))))))
-    (if package
-	(intern 
-	 (ecase excl:*current-case-mode*
-	   ((:case-sensitive-lower :case-insensitive-lower) string)
-	   ((:case-sensitive-upper :case-insensitive-upper) (string-upcase string)))
-	 package)
-      string)))
+(defun lispify-tk-name (string &key (package *package*))
+  (let* ((len (length string))
+	 (nbreaks 0))
+    (declare (fixnum nbreaks len))
+
+    ;; find the case breaks
+    (dotimes (i len)
+      (declare (fixnum i))
+      (when (and (<= #.(char-code #\A)
+		     (char-code (schar string i))
+		     #.(char-code #\Z))
+		 (not (zerop i)))
+	(incf nbreaks)))
+
+    ;; make a new string
+    (let ((new (make-string (+ len nbreaks)))
+	  (j 0)
+	  l m n)
+      (declare (fixnum j l m n))
+      
+      (ecase excl:*current-case-mode*
+	((:case-sensitive-lower :case-insensitive-lower)
+	 (setq l #.(char-code #\A) m #.(char-code #\Z)
+	       n  #.(- (char-code #\a) (char-code #\A))))
+	((:case-sensitive-upper :case-insensitive-upper)
+	 (setq l #.(char-code #\a) m #.(char-code #\z)
+	       n  #.(- (char-code #\A) (char-code #\a)))))
+      
+      (macrolet ((push-char (c)
+		   `(progn 
+		      (setf (schar new j) ,c)
+		      (incf j))))
+	(dotimes (i len)
+	  (declare (fixnum i))
+	  (let* ((c (schar string i))
+		 (cc (char-code c)))
+	    (declare (fixnum cc))
+	    (when (and (<= #.(char-code #\A) cc #.(char-code #\Z))
+		       (not (zerop i)))
+	      (push-char #\-))
+	    (push-char (if (<= l cc m)
+			   (code-char (+ cc n))
+			 c)))))
+      (values 
+       (intern new package)))))
 
 (defun tkify-lisp-name (name &key class)
-  (if (stringp name)
-      name
-    (let ((tk-name (remove #\- (string-capitalize (string name)))))
-      (if class
-	  tk-name
-	(string-downcase tk-name :start 0 :end 1)))))
+  (setq name (string name))
+  (let ((len (length name))
+	(nbreaks 0))
+    (declare (fixnum nbreaks len))
+
+    ;; find the breaks
+    (dotimes (i len)
+      (declare (fixnum i))
+      (when (eql (schar name i) #\-)
+	(incf nbreaks)))
+
+    ;; make a new string
+    (let ((new (make-string (- len nbreaks)))
+	  (j 0)
+	  (break class))
+      (declare (fixnum j))
+            
+      (macrolet ((push-char (c)
+		   `(progn 
+		      (setf (schar new j) ,c)
+		      (incf j))))
+	(dotimes (i len)
+	  (declare (fixnum i))
+	  (let* ((c (schar name i))
+		 (cc (char-code c)))
+	    (declare (fixnum cc))
+	    (if (eql c #\-)
+		(setq break t)
+	      (progn
+		(push-char
+		 (if break
+		     (if (<= #.(char-code #\a) cc #.(char-code #\z))
+			 (code-char (+ cc
+				       #.(- (char-code #\A)
+					    (char-code #\a))))
+		       c)
+		   (if (<= #.(char-code #\A) cc #.(char-code #\Z))
+		       (code-char (+ cc
+				     #.(- (char-code #\a)
+					  (char-code #\A))))
+		     c)))
+		(setq break nil))))))
+      new)))
+
 	  
 (defun-c-callable toolkit-error-handler ((message :unsigned-long))
   (let ((*error-output* excl:*initial-terminal-io*))
diff --git a/tk/ol-defs.lisp b/tk/ol-defs.lisp
index 51bd583c7102cec58ec96bb1c631d598f6b19942..1fb77f670a5b322b24411a9a47b6a394b83cb69f 100644
--- a/tk/ol-defs.lisp
+++ b/tk/ol-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-defs.lisp,v 1.6 93/04/23 09:18:35 cer Exp $
+;; $fiHeader: ol-defs.lisp,v 1.7 1993/07/27 01:53:26 colin Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -28,6 +28,8 @@
 
 (in-package :tk)
 
+(provide :clim-debugol)
+
 (def-c-type (ol-callback-struct :no-defuns) :struct
 	    (reason :int))
 
diff --git a/tk/ol-init.lisp b/tk/ol-init.lisp
index c2884685e921c6ee78922e6f817928a81983f561..e0f2cc29bd45bd9fe9cc3aa741628545b913a1d5 100644
--- a/tk/ol-init.lisp
+++ b/tk/ol-init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-init.lisp,v 1.18 1993/07/27 01:53:36 colin Exp $
+;; $fiHeader: ol-init.lisp,v 1.19 1993/10/26 03:22:25 colin Exp $
 
 (in-package :tk)
 
@@ -88,7 +88,7 @@
 				      (string-to-char*
 				       "menuPane")))
 
-#+:svr4
+#+ignore ;; moved to load-ol
 (progn
   (defun reinitialize-toolkit ()
     (ol-initialize)
diff --git a/tk/ol-widgets.lisp b/tk/ol-widgets.lisp
index f23917d3423e9d14e49789e2ac40fb2bf0357e3f..08de833addf6d87a3ed70c19d79c4b795f887b24 100644
--- a/tk/ol-widgets.lisp
+++ b/tk/ol-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ol-widgets.lisp,v 1.6 1993/07/30 23:58:23 colin Exp $
+;; $fiHeader: ol-widgets.lisp,v 1.7 1993/10/26 03:22:28 colin Exp $
 
 (in-package :xt)
 
@@ -101,3 +101,10 @@
 					  :type 'pixel
 					  :original-name 
 					  (string-to-char* "fontColor")))
+
+(tk::add-resource-to-class (find-class 'notice-shell)
+			   (make-instance 'resource
+					  :name :focus-widget
+					  :type 'widget
+					  :original-name 
+					  (string-to-char* "focusWidget")))
diff --git a/tk/resources.lisp b/tk/resources.lisp
index 0be6e4b954e6e71989d22a29b4610e24f0a73ae9..00af24985bf6ae2a9712c367a2720a5ebfc08c75 100644
--- a/tk/resources.lisp
+++ b/tk/resources.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: resources.lisp,v 1.49 1993/07/30 23:58:27 colin Exp $
+;; $fiHeader: resources.lisp,v 1.50 1993/08/12 16:04:44 cer Exp $
 
 
 (in-package :tk)
@@ -314,38 +314,39 @@
 (defun set-values (widget &rest resources-and-values)
   (declare (optimize (speed 3))
 	   (dynamic-extent resources-and-values))
-  (let ((resources nil)
-	(values nil))
-    (do ((rvs resources-and-values (cddr rvs)))
-	((null rvs))
-      (push (car rvs) resources)
-      (push (cadr rvs) values))
-    (setq resources (nreverse resources))
-    (setq values (nreverse values))
-    (excl::without-interrupts
-      ;; We don't really want anyone else to grab the same cache entry.
-	(let* ((class (class-of widget))
-	       (parent-class (let ((p (tk::widget-parent widget)))
-			       (and p (class-of p))))
-	       (entry (gethash resources (class-set-values-cache class))))
-	(declare (optimize (safety 0)))
-	(unless entry
-	  (setf entry (fill-sv-cache parent-class class resources)))
+  (with-malloced-objects
+      (let ((resources nil)
+	    (values nil))
+	(do ((rvs resources-and-values (cddr rvs)))
+	    ((null rvs))
+	  (push (car rvs) resources)
+	  (push (cadr rvs) values))
+	(setq resources (nreverse resources))
+	(setq values (nreverse values))
+	(excl::without-interrupts
+	  ;; We don't really want anyone else to grab the same cache entry.
+	  (let* ((class (class-of widget))
+		 (parent-class (let ((p (tk::widget-parent widget)))
+				 (and p (class-of p))))
+		 (entry (gethash resources (class-set-values-cache class))))
+	    (declare (optimize (safety 0)))
+	    (unless entry
+	      (setf entry (fill-sv-cache parent-class class resources)))
     
-	(destructuring-bind (arglist length &rest resource-descriptions)
-	    entry
-	  (do ((resdess resource-descriptions (cdr resdess))
-	       (i 0 (1+ i))
-	       (values values (cdr values)))
-	      ((null resdess))
-	    (destructuring-bind (convert-p type)
-		(car resdess)
-	      ;; Yuck -- the following should be handled somehow by cstructs...
-	      (setf (sys:memref-int (xt-arglist arglist i) 4 0 :signed-long)
-		(if convert-p
-		    (convert-resource-out widget type (car values))
-		  (car values)))))
-	  (xt_set_values widget arglist length))))))
+	    (destructuring-bind (arglist length &rest resource-descriptions)
+		entry
+	      (do ((resdess resource-descriptions (cdr resdess))
+		   (i 0 (1+ i))
+		   (values values (cdr values)))
+		  ((null resdess))
+		(destructuring-bind (convert-p type)
+		    (car resdess)
+		  ;; Yuck -- the following should be handled somehow by cstructs...
+		  (setf (sys:memref-int (xt-arglist arglist i) 4 0 :signed-long)
+		    (if convert-p
+			(convert-resource-out widget type (car values))
+		      (car values)))))
+	      (xt_set_values widget arglist length)))))))
 
 ;; This is used by initialize-instance methods for widgets...
 (defun make-arglist-for-class (class parent args)
@@ -446,7 +447,8 @@
 	 (constraint-resource-used nil)
 	 (i 0))
     (dotimes (j len)
-      (setf (xt-arglist-value arglist j) (excl::malloc 8))) ;--- A crock...
+      (setf (xt-arglist-value arglist j) 
+	(excl::malloc 8)))	;--- A crock...
     (dolist (r resources)
       (let ((resource (or (find-class-resource class r)
 			  (psetq constraint-resource-used t)
@@ -464,38 +466,43 @@
 	(incf i)))
     (let ((r (list* arglist len (nreverse rds))))
       (if constraint-resource-used
-	  r
+	  ;; so the crock continues
+	  (progn
+	    (dotimes (j len)
+	      (note-malloced-object (xt-arglist-value arglist j)))
+	    r)
 	(setf (gethash resources (class-get-values-cache class)) r)))))
     
 (defun get-values (widget &rest resources)
   (declare (optimize (speed 3))
 	   (dynamic-extent resources))
-  (excl::without-interrupts
-    ;; We don't really want anyone else to grab the same cache entry.
-      (let* ((class (class-of widget))
-	     (parent-class (let ((p (tk::widget-parent widget)))
+  (with-malloced-objects
+      (excl::without-interrupts
+	;; We don't really want anyone else to grab the same cache entry.
+	(let* ((class (class-of widget))
+	       (parent-class (let ((p (tk::widget-parent widget)))
 			       (and p (class-of p))))
-	     (entry (gethash resources (class-get-values-cache class))))
-      (declare (optimize (safety 0)))
-      (unless entry
-	(setf entry (fill-gv-cache parent-class class resources)))
+	       (entry (gethash resources (class-get-values-cache class))))
+	  (declare (optimize (safety 0)))
+	  (unless entry
+	    (setf entry (fill-gv-cache parent-class class resources)))
     
-      (destructuring-bind (arglist length &rest resource-descriptions)
-	  entry
-	(xt_get_values widget arglist length)
-
-	(let ((i 0)
-	      (values nil))
-	  (dolist (resource-desc resource-descriptions)
-	    (destructuring-bind (get-memref-type convert-p type)
-		resource-desc
-	      (let ((value (sys:memref-int (xt-arglist-value arglist i) 0 0
-					   get-memref-type)))
-		(incf i)
-		(if convert-p
-		    (setq value (convert-resource-in widget type value)))
-		(push value values))))
-	  (values-list (nreverse values)))))))
+	  (destructuring-bind (arglist length &rest resource-descriptions)
+	      entry
+	    (xt_get_values widget arglist length)
+
+	    (let ((i 0)
+		  (values nil))
+	      (dolist (resource-desc resource-descriptions)
+		(destructuring-bind (get-memref-type convert-p type)
+		    resource-desc
+		  (let ((value (sys:memref-int (xt-arglist-value arglist i) 0 0
+					       get-memref-type)))
+		    (incf i)
+		    (if convert-p
+			(setq value (convert-resource-in widget type value)))
+		    (push value values))))
+	      (values-list (nreverse values))))))))
 
 
 
@@ -553,6 +560,9 @@
 (defmethod convert-resource-out ((parent t) (type (eql 'prim-foreground-pixmap)) value)
   (convert-pixmap-out parent value))
 
+(defmethod convert-resource-out ((parent t) (type (eql 'man-foreground-pixmap)) value)
+  (convert-pixmap-out parent value))
+
 (defmethod convert-resource-out ((parent t) (type (eql 'gadget-pixmap)) value)
   (convert-pixmap-out parent value))
 
@@ -574,12 +584,9 @@
 (defmethod convert-resource-out ((parent t) (type (eql 'bool)) value)
   (if value 1 0))
 
-(defvar *string-counter* 0)
-
 (defmethod convert-resource-out ((parent  t) (type (eql 'string)) value)
-  ;;--- Allocate-no-free
-  (incf *string-counter* (length value))
-  (string-to-char* value))
+  (note-malloced-object
+   (string-to-char* value)))
 
 (defvar *font-counter* 0)
 (defmethod convert-resource-out ((parent t) (type (eql 'font-struct)) value)
@@ -610,11 +617,13 @@
 
 ;;; Accelerator table stuff
 
+(defvar *empty-table* nil)
+
 (defmethod convert-resource-out (parent (type (eql 'xt::accelerator-table))
 				 (value (eql nil)))
   (declare (ignore parent))
-  ;;--- Allocate-no-free
-  (xt_parse_accelerator_table ""))
+  (or *empty-table*
+      (setq *empty-table* (xt_parse_accelerator_table ""))))
 
 
 
@@ -716,6 +725,10 @@
 					  (:in 7)
 					  (:out 8)))
 
+(define-enumerated-resource navigation-type (:none 
+					     :tab-group
+					     :sticky-tab-group
+					     :exclusive-tab-group))
 
 (define-enumerated-resource ol-wrap-mode  ((:wrap-off 74) 
 					   (:wrap-any 75)
@@ -733,9 +746,8 @@
 ;; solaris 2.2 stuff
 
 (defmethod convert-resource-out ((parent  t) (type (eql 'ol-str)) value)
-  ;;--- Allocate-no-free
-  (incf *string-counter* (length value))
-  (string-to-char* value))
+  (note-malloced-object 
+   (string-to-char* value)))
 
 (defmethod convert-resource-in ((parent t) (type (eql 'ol-str)) value)
   (unless (zerop value)
diff --git a/tk/widget.lisp b/tk/widget.lisp
index c2ce19984b1d55fe76c16e2811408f969e827fe0..89e0f1a9c406eee6663075887ed427fa90b1e805 100644
--- a/tk/widget.lisp
+++ b/tk/widget.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: widget.lisp,v 1.34 1993/10/25 16:16:29 cer Exp $
+;; $fiHeader: widget.lisp,v 1.35 1993/10/26 03:22:30 colin Exp $
 
 (in-package :tk)
 
@@ -30,21 +30,22 @@
 			      (widget-class (error "Class not specified"))
 			      (display (error "Display not specified"))
 			 &allow-other-keys)
-  (let* ((class (find-class widget-class))
-	 (handle (class-handle class))
-	 (arglist (make-arglist-for-class class nil args)))
-    (register-address
-     (apply #'make-instance
-	    class
-	    :foreign-address
-	    (xt_app_create_shell application-name
-				 application-class
-				 handle
-				 display
-				 arglist
-				 (truncate (length arglist) 2))
-	    :display display
-	    args))))
+  (with-malloced-objects
+      (let* ((class (find-class widget-class))
+	     (handle (class-handle class))
+	     (arglist (make-arglist-for-class class nil args)))
+	(register-address
+	 (apply #'make-instance
+		class
+		:foreign-address
+		(xt_app_create_shell application-name
+				     application-class
+				     handle
+				     display
+				     arglist
+				     (truncate (length arglist) 2))
+		:display display
+		args)))))
 
 ;; These are so we don't need the foreign functions at run time.
 
@@ -71,14 +72,15 @@
 
 (defun create-widget-1 (fn name widget-class parent &rest args)
   (assert parent)
-  (let* ((class (find-class-maybe widget-class))
-	 (handle (class-handle class))
-	 (arglist (make-arglist-for-class class parent args)))
-    (funcall fn name
-	     handle
-	     parent
-	     arglist
-	     (truncate (length arglist) 2))))
+  (with-malloced-objects
+      (let* ((class (find-class-maybe widget-class))
+	     (handle (class-handle class))
+	     (arglist (make-arglist-for-class class parent args)))
+	(funcall fn name
+		 handle
+		 parent
+		 arglist
+		 (truncate (length arglist) 2)))))
 
 (defun realize-widget (widget)
   (xt_realize_widget widget))
@@ -114,17 +116,16 @@
        (xt_popdown shell))
 
 (defun create-popup-shell (name widget-class parent &rest args)
-  (let* ((class (find-class-maybe widget-class))
-	 (handle (class-handle class))
-	 (arglist (make-arglist-for-class class parent args)))
-    (incf *widget-count*)
-    (xt_create_popup_shell
-     ;;-- allocate-no-free
-     (string-to-char* name)
-	     handle
-	     parent
-	     arglist
-	     (truncate (length arglist) 2))))
+  (with-malloced-objects
+      (let* ((class (find-class-maybe widget-class))
+	     (handle (class-handle class))
+	     (arglist (make-arglist-for-class class parent args)))
+	(incf *widget-count*)
+	(xt_create_popup_shell (note-malloced-object (string-to-char* name))
+			       handle
+			       parent
+			       arglist
+			       (truncate (length arglist) 2)))))
 
 (defun find-class-maybe (x)
   (if (typep x 'clos::class) x
@@ -273,14 +274,14 @@
 
 ;; Could not think of anywhere better!
 
-;; note that this is different from xt-initialize which calls
-;; XtToolkitInitialize. This is closer to XtAppInitialize
-
 (defvar *fallback-resources* '("clim*dragInitiatorProtocolStyle: DRAG_NONE"
 			       "clim*dragreceiverprotocolstyle:	DRAG_NONE"
 			       )
   "A list of resource specification strings")
 
+;; note that this is different from xt-initialize which calls
+;; XtToolkitInitialize. This is closer to XtAppInitialize
+
 (defun initialize-toolkit (&rest args)
   (let* ((context (create-application-context)))
     (when *fallback-resources*
diff --git a/tk/xlib.lisp b/tk/xlib.lisp
index fa035ef7519b3b30151bd958fc1255172266dfb4..60664fc66a7b49b163cc5bd64e2f0816a87e1bf7 100644
--- a/tk/xlib.lisp
+++ b/tk/xlib.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xlib.lisp,v 1.49 1993/09/17 19:06:49 cer Exp $
+;; $fiHeader: xlib.lisp,v 1.51 1994/11/23 23:29:16 smh Exp $
 
 (in-package :tk)
 
@@ -190,21 +190,32 @@
     (setf (foreign-pointer-address db) (x11:xrmgetstringdatabase ""))))
 
 (defun get-resource (db name class)
-  (with-ref-par ((type 0))
+  (with-ref-par ((type-ref 0))
     (let ((xrmvalue (x11:make-xrmvalue)))
       (unless (zerop (x11:xrmgetresource db 
 					 name
 					 class
-					 type xrmvalue))
-	(values (char*-to-string (x11:xrmvalue-addr xrmvalue))
-		(char*-to-string (aref type 0)))))))
+					 type-ref xrmvalue))
+	(let ((type (char*-to-string (aref type-ref 0))))
+	  (values
+	   
+	   (cond
+	    ((equal type "String")
+	     (char*-to-string (x11:xrmvalue-addr xrmvalue)))
+	    ((equal type "Pixel")
+	     (sys::memref-int (x11:xrmvalue-addr xrmvalue) 0 0
+			      :unsigned-long))
+	    (t
+	     (error "Unknown resource type: ~A" type)))
+	   type))))))
 
 (defun convert-string (widget string to-type)
   (let ((from (x11:make-xrmvalue))
 	(to-in-out (x11:make-xrmvalue)))
     (setf (x11:xrmvalue-size from) (1+ (length string))
-	  ;;-- allocate-no-free
-	  (x11:xrmvalue-addr from) (progn (incf *string-counter* (length string)) (string-to-char* string))
+	  (x11:xrmvalue-addr from)
+	  (note-malloced-object
+	   (string-to-char* string))
 	  (x11:xrmvalue-addr to-in-out) 0)
     (unless (zerop (xt::xt_convert_and_store widget "String" from to-type
 				      to-in-out))
@@ -248,15 +259,14 @@
 	    resourceid)))
 
 (defun-c-callable x-error-handler ((display :unsigned-long) (event :unsigned-long))
-  (let ((*error-output* excl:*initial-terminal-io*))
-    (error 'x-error
-	   :display display
-	   :error-code (x11:xerrorevent-error-code event)
-	   :request-code (x11:xerrorevent-request-code event)
-	   :minor-code (x11:xerrorevent-minor-code event)
-	   :resourceid (x11:xerrorevent-resourceid event)
-	   :serial (x11:xerrorevent-serial event)
-	   :current-serial (x11:display-request display))))
+  (error 'x-error
+	 :display display
+	 :error-code (x11:xerrorevent-error-code event)
+	 :request-code (x11:xerrorevent-request-code event)
+	 :minor-code (x11:xerrorevent-minor-code event)
+	 :resourceid (x11:xerrorevent-resourceid event)
+	 :serial (x11:xerrorevent-serial event)
+	 :current-serial (x11:display-request display)))
 
 (define-condition x-connection-lost (error)
   ((display :reader x-error-display :initarg :display))
@@ -267,15 +277,12 @@
       (format stream "Xlib: Connection to X11 server '~a' lost"
 	      (ff:char*-to-string (x11:display-display-name display)))))
 
-(defvar *inside-event-wait-function* nil)
+(defvar *x-io-error-hook* nil)
 
 (defun-c-callable x-io-error-handler ((display :unsigned-long))
-  (if *inside-event-wait-function*
-      (throw *inside-event-wait-function* :error)
-    (let ((*error-output* excl:*initial-terminal-io*))
-      (error 'x-connection-lost :display display))))
-
-
+  (when *x-io-error-hook*
+    (funcall *x-io-error-hook* display))
+  (error 'x-connection-lost :display display))
 
 (defun get-error-text (code display-handle)
   (let ((s (make-string 1000)))
@@ -445,15 +452,23 @@
    pixel
    flags))
 
-(defvar *xcolor-array* (x11:make-xcolor-array :number 16))
-(defvar *xcolor-array-size* 16)
-
-(defun get-xcolor-array (n)
-  (when (> n *xcolor-array-size*)
-    (setq *xcolor-array-size* n
-	  *xcolor-array* (x11:make-xcolor-array :number n)))
-  *xcolor-array*)
-
+(defmacro def-foreign-array-resource (name constructor)
+  `(progn
+     (clim-sys:defresource ,name (n)
+       :constructor (cons n (,constructor :number n))
+       :matcher (not (< (car ,name) n)))
+     (defmacro ,(intern (format nil "~A-~A" 'with name))
+	 ((var n) &body body)
+       `(clim-sys:using-resource (,var ,',name ,n)
+	  (let ((,var (cdr ,var)))
+	    ,@body)))))
+    
+(def-foreign-array-resource xcolor-array x11:make-xcolor-array)
+(def-foreign-array-resource xsegment-array x11:make-xsegment-array)
+(def-foreign-array-resource xpoint-array x11:make-xpoint-array)
+(def-foreign-array-resource xrectangle-array x11:make-xrectangle-array)
+(def-foreign-array-resource xarc-array x11:make-xarc-array)
+  
 (defun store-colors (colormap colors ncolors)
   (x11:xstorecolors
    (object-display colormap)
@@ -710,6 +725,37 @@
      (image-width image)
      (image-height image))))
 
+(defmethod get-image (pixmap &key (x 0) (y 0) 
+				  (width (pixmap-width pixmap))
+				  (height (pixmap-height pixmap))
+				  (format x11:zpixmap))
+  (let* ((display (object-display pixmap))
+	 (data (make-array (list height width)))
+	 (image (make-instance 'image
+		  :width width
+		  :height height
+		  :data data
+		  :depth (pixmap-depth pixmap)
+		  :format format
+		  :foreign-address (x11:xgetimage display
+						  pixmap
+						  x
+						  y
+						  width
+						  height
+						  #xff
+						  format))))
+    (push display (realized-displays image))
+    (dotimes (h height)
+      (dotimes (w width)
+	(setf (aref data h w)
+	  (x11:xgetpixel image w h))))
+    image))
+
+
+;;--- calls to this should be replaced by the new and more general
+;; get-image defined above (cim 9/12/94)
+
 (defun image-from-pixmap (pixmap)
   (x11:xgetimage
    (object-display pixmap)
diff --git a/tk/xm-callbacks.lisp b/tk/xm-callbacks.lisp
index 54f5b152a298580cdf00fbea64a67ce4d6e4eaa1..d405c8198796b2104e3e5af77f515526da046cb7 100644
--- a/tk/xm-callbacks.lisp
+++ b/tk/xm-callbacks.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-callbacks.lisp,v 1.4 1993/07/27 01:53:51 colin Exp $
+;; $fiHeader: xm-callbacks.lisp,v 1.5 1993/08/12 16:04:50 cer Exp $
 
 
 (in-package :tk)
@@ -36,25 +36,5 @@
     (dotimes (i (xm-list-callback-struct-selected-item-count call-data) (nreverse r))
       (push (xm-selected-position-array si i) r))))
 
-;;--- This should probably be in xm-resources.lisp
 
-(defmethod convert-resource-out ((parent t) (type (eql 'xm-string-table)) value)
-  (if value
-      (do* ((n (length value))
-	    (r (make-xm-string-table :number n :in-foreign-space t))
-	    (v value (cdr v))
-	    (i 0 (1+ i)))
-	  ((null v)
-	   r)
-	(setf (xm-string-table r i)
-	  (convert-resource-out parent 'xm-string (car v))))
-    0))
 
-(defmethod convert-pixmap-out (parent value)
-  (etypecase value
-    (string
-     (let* ((display (widget-display parent))
-	    (screen (x11:xdefaultscreenofdisplay display))
-	    (white (x11::xwhitepixel display 0))
-	    (black (x11::xblackpixel display 0)))
-       (xm_get_pixmap screen value white black)))))
diff --git a/tk/xm-defs.lisp b/tk/xm-defs.lisp
index e317dea4d844d07ce2509648b740f2adc9377e8f..cc1220a19e3d98d475ed35136f7ec1e019b989f1 100644
--- a/tk/xm-defs.lisp
+++ b/tk/xm-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-defs.lisp,v 1.7 92/11/18 15:55:02 colin Exp $
+;; $fiHeader: xm-defs.lisp,v 1.8 1993/07/27 01:53:57 colin Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -28,6 +28,8 @@
 
 (in-package :tk)
 
+(provide :clim-debugxm)
+
 (def-c-type (xm-proto-callback-info :no-defuns :in-foreign-space) :struct
 	     (handle :int)
 	     (data :int))
diff --git a/tk/xm-font-list.lisp b/tk/xm-font-list.lisp
index 3cb4edc0fe21600bda75075079586472779fbf9d..fd8df5c40fdaac11ebe237a782a36aa1259c1c39 100644
--- a/tk/xm-font-list.lisp
+++ b/tk/xm-font-list.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-font-list.lisp,v 1.10 93/04/27 14:35:58 cer Exp $
+;; $fiHeader: xm-font-list.lisp,v 1.11 1993/07/27 01:54:01 colin Exp $
 
 (in-package :tk)
 
@@ -37,18 +37,19 @@
   (let* ((font-list
 	  (xm_font_list_append_entry
 	   0			; old entry
-	   (xm_font_list_entry_create
-	    xm-font-list-default-tag
-	    xm-font-is-font
-	    (car value)))))
+	   (note-malloced-object (xm_font_list_entry_create
+				  xm-font-list-default-tag
+				  xm-font-is-font
+				  (car value))))))
     (dolist (font (cdr value))
       (setq font-list
 	(xm_font_list_append_entry font-list 
-				   (xm_font_list_entry_create
-				    ""
-				    xm-font-is-font
-				    font))))
-    font-list))
+				   (note-malloced-object (xm_font_list_entry_create
+							  ""
+							  xm-font-is-font
+							  font)))))
+    (note-malloced-object font-list 
+			  #'xm_font_list_free)))
 
 #+:dec3100
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-font-list)) value)
diff --git a/tk/xm-funs.lisp b/tk/xm-funs.lisp
index 8d51a90d7c87890910505a83cc16952bbb1bfc70..18bfd22fa9de855b68062a20f9be26e6fd97e8aa 100644
--- a/tk/xm-funs.lisp
+++ b/tk/xm-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-funs.lisp,v 1.13 1993/08/12 16:04:52 cer Exp $
+;; $fiHeader: xm-funs.lisp,v 1.14 1993/09/17 19:06:51 cer Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -82,6 +82,22 @@
     :arg-checking nil
     :return-type :unsigned-integer)
 
+(defforeign 'xm_font_list_free
+    :entry-point (ff:convert-to-lang "XmFontListFree")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :void)
+
+(defforeign 'xm_font_list_entry_free
+    :entry-point (ff:convert-to-lang "XmFontListEntryFree")
+    :call-direct t
+    :callback nil
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :void)
+
 (defforeign 'xm_add_protocol_callback
     :entry-point (ff:convert-to-lang "XmAddProtocolCallback")
     :call-direct t
diff --git a/tk/xm-init.lisp b/tk/xm-init.lisp
index 578a24e88664ce2d995ce3b333704f6bb1ba3467..a157bfc9ca0564211754629fda4a71dca4df8a0b 100644
--- a/tk/xm-init.lisp
+++ b/tk/xm-init.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-init.lisp,v 1.8 92/05/07 13:11:02 cer Exp $
+;; $fiHeader: xm-init.lisp,v 1.11 1993/11/24 03:57:02 duane Exp $
 
 (in-package :tk)
 
@@ -34,8 +34,10 @@
   (setq *xm-done* t))
 
 
-#+svr4
-(unless (ff::symbol-in-main-symbol-table-p "xt_toolkit_initialize")
+
+
+#+ignore ;; moved into load-xm.lisp
+(unless (ff::symbol-in-main-symbol-table-p "XtToolkitInitialize")
   (defun reinitialize-toolkit ()
     (xt_toolkit_initialize)
     (setup-error-handlers)
diff --git a/tk/xm-protocols.lisp b/tk/xm-protocols.lisp
index af87ae55c9264d9624c0025e69d60777e154775d..719319efa67b0e346b6ca2cbb9af8189e83321fe 100644
--- a/tk/xm-protocols.lisp
+++ b/tk/xm-protocols.lisp
@@ -20,35 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-protocols.lisp,v 1.9 92/11/20 08:46:21 cer Exp $
+;; $fiHeader: xm-protocols.lisp,v 1.10 1993/07/27 01:54:07 colin Exp $
 
 (in-package :tk)
 
-(defun-c-callable protocol-callback-handler ((something-weird-widget :unsigned-long)
-					     (x :unsigned-long)
-					     (call-data
-					      :unsigned-long))
-
-  (declare (ignore something-weird-widget))
-  ;;-- Seems that the first argument is not a widget but a pointer to
-  ;;-- one of the above, and that the protocol component is the widget
-  #+debug
-  (let ((x (list something-weird-widget
-	       (xm-protocol-object something-weird-widget)
-	       (xm-protocol-ext something-weird-widget)
-	       (xm-protocol-protocol something-weird-widget)
-	       (xm-proto-callback-info-handle x))))
-    (print (list x 
-		 (mapcar #'(lambda (x) 
-			     (find-object-from-address x nil))
-			 x))))
-  
-  (callback-handler-1 (xm-proto-callback-info-handle x)
-		      (xm-proto-callback-info-data x)
-		      call-data))
-
-(defvar *protocol-callback-handler-address* (register-function 'protocol-callback-handler))
-
 (defmethod spread-callback-data (widget call-data (type (eql :protocol-callback)))
   (declare (ignore widget call-data))
  (values))
@@ -59,15 +34,10 @@
      shell
      (if (integerp property) property (xm-intern-atom shell property))
      (if (integerp protocol) protocol (xm-intern-atom shell protocol))
-     *protocol-callback-handler-address*
-     ;;--- Malloc thing
-     (let ((x (make-xm-proto-callback-info :in-foreign-space t)))
-       (setf (xm-proto-callback-info-handle x) shell
-	     (xm-proto-callback-info-data x)
-	     (caar (push
-		    (list (new-callback-id) (cons function args) type)
-		    (widget-callback-data shell))))
-       x))))
+     *callback-handler-address*
+     (caar (push
+	    (list (new-callback-id) (cons function args) type)
+	    (widget-callback-data shell))))))
 
 (defun add-wm-protocol-callback (shell protocol fn &rest args)
   (apply 
@@ -86,9 +56,3 @@
    (object-display shell)
    (string name)
    (if only-if-exists 1 0)))
-
-
-
-
-   
-
diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp
index 99e989f28143bc52f731617ff85672d39b67476f..6f397ca8d20dc7a8578921bf5e4153646ddc954c 100644
--- a/tk/xm-widgets.lisp
+++ b/tk/xm-widgets.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xm-widgets.lisp,v 1.16 1993/08/12 16:04:54 cer Exp $
+;; $fiHeader: xm-widgets.lisp,v 1.17 1993/10/26 03:22:35 colin Exp $
 
 (in-package :tk)
 
@@ -101,15 +101,53 @@
 	    r))))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value)
-  (incf *string-counter* (length value))
-  ;;-- allocate-no-free
-  (xm_string_create_l_to_r (string-to-char* value) (string-to-char* "")))
+  (note-malloced-object
+   (xm_string_create_l_to_r 
+    (note-malloced-object (string-to-char* value))
+    (note-malloced-object (string-to-char* "")))))
 
 (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value)
   (etypecase value
     (pixmap
      (encode-pixmap nil value))))
 
+(defun encode-box-child (child)
+  (let ((x (getf '(
+                   :none                  0 
+                   :apply         1
+                   :cancel    2
+                   :default   3
+                   :ok        4
+                   :filter-label     5
+                   :filter-text      6
+                   :help      7
+                   :list                  8
+                   :history-list     :list
+                   :list-label    9
+                   :message-label    10
+                   :selection-label  11
+                   :prompt-label     :selection-label
+                   :symbol-label     12
+                   :text                  13
+                   :value-text       :text
+                   :command-text     :text
+                   :separator             14
+                   :dir-list         15
+                   :dir-list-label   16
+                   :file-list        :list
+                   :file-list-label  :list-label
+                   ) 
+                 child)))
+    (cond ((null x)
+           (error "cannot encode child ~S" child))
+          ((symbolp x)
+           (encode-box-child x))
+          (t x))))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'default-button-type)) value)
+  (encode-box-child value))
+
+
 (tk::add-resource-to-class (find-class 'xm-text)
 			   (make-instance 'resource
 					  :name :scroll-horizontal
@@ -133,3 +171,23 @@
 					  :original-name 
 					  (string-to-char*
 					   "wordWrap")))
+
+(defmethod convert-resource-out ((parent t) (type (eql 'xm-string-table)) value)
+  (if value
+      (do* ((n (length value))
+	    (r (note-malloced-object
+		(make-xm-string-table :number n :in-foreign-space t)))
+	    (v value (cdr v))
+	    (i 0 (1+ i)))
+	  ((null v)
+	   r)
+	(setf (xm-string-table r i)
+	  (convert-resource-out parent 'xm-string (car v))))
+    0))
+
+(defmethod convert-pixmap-out (parent (value string))
+  (let* ((display (widget-display parent))
+	 (screen (x11:xdefaultscreenofdisplay display))
+	 (white (x11::xwhitepixel display 0))
+	 (black (x11::xblackpixel display 0)))
+    (xm_get_pixmap screen value white black)))
diff --git a/tk/xt-defs.lisp b/tk/xt-defs.lisp
index 77d1105de9ae432b00ff2ff5b2a640b5c0e96594..80dcfe2e689038937ffaa827343ed9e031dcd355 100644
--- a/tk/xt-defs.lisp
+++ b/tk/xt-defs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-defs.lisp,v 1.8 93/01/11 15:45:59 colin Exp $
+;; $fiHeader: xt-defs.lisp,v 1.9 1993/07/27 01:54:16 colin Exp $
 
 ;;
 ;; This file contains compile time only code -- put in clim-debug.fasl.
@@ -146,7 +146,4 @@
   (sibling xt-widget)
   (stack-mode :int))
 
-(def-c-type (xpoint-array :no-defuns) 1 x11::xpoint)
-(def-c-type (xsegment-array :no-defuns) 1 x11::xsegment)
-(def-c-type (xarc-array :no-defuns) 1 x11::xarc)
-(def-c-type (xrectangle-array :no-defuns) 1 x11::xrectangle)
+
diff --git a/tk/xt-funs.lisp b/tk/xt-funs.lisp
index 3a8b6cd7d624e53b4a7363ad61c98d0606ab6d92..5ac4d7460a5dab35efe59e21775c70382d447d80 100644
--- a/tk/xt-funs.lisp
+++ b/tk/xt-funs.lisp
@@ -20,7 +20,7 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: xt-funs.lisp,v 1.22 1993/10/25 16:16:31 cer Exp $
+;; $fiHeader: xt-funs.lisp,v 1.24 1994/11/23 23:29:18 smh Exp $
 
 
 ;;
@@ -72,6 +72,12 @@
     :arg-checking nil
     :return-type :unsigned-integer)
 
+(defforeign 'xt_destroy_application_context
+    :entry-point (ff:convert-to-lang "XtDestroyApplicationContext")
+    :call-direct t
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
 
 (defforeign 'xt_app_set_error_handler
     :entry-point (ff:convert-to-lang "XtAppSetErrorHandler")
@@ -95,6 +101,13 @@
     :arg-checking nil
     :return-type :unsigned-integer)
 
+(defforeign 'xt_close_display
+    :entry-point (ff:convert-to-lang "XtCloseDisplay")
+    :call-direct t
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :unsigned-integer)
+
 (defforeign 'xt_database
     :entry-point (ff:convert-to-lang "XtDatabase")
     :call-direct t
@@ -152,6 +165,13 @@
     :arg-checking nil
     :return-type :void)
     
+(defforeign 'xt_is_realized
+    :entry-point (ff:convert-to-lang "XtIsRealized")
+    :call-direct t
+    :arguments '(foreign-address)
+    :arg-checking nil
+    :return-type :fixnum)
+
 (defforeign 'xt_destroy_widget
     :entry-point (ff:convert-to-lang "XtDestroyWidget")
     :call-direct t
@@ -301,7 +321,7 @@
     ;; Maybe callback can be safely set to nil...
     :callback t
     :arg-checking nil
-    :return-type :unsigned-integer
+    :return-type :fixnum
     :entry-point (ff:convert-to-lang "XtAppIntervalNextTimer"))
 
 (defforeign 'xt_add_event_handler
@@ -438,3 +458,5 @@
     :entry-point (ff:convert-to-lang "xt_widget_num_popups")
     :return-type :fixnum)
 
+
+
diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp
index c0b29cc2f06073d3c4b8a20f3e5922ded2545ee6..dc28bffd7ba6386424bb9fd0467e8dfc043a2102 100644
--- a/utils/base-designs.lisp
+++ b/utils/base-designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: base-designs.lisp,v 1.6 92/12/03 10:30:33 cer Exp $
+;; $fiHeader: base-designs.lisp,v 1.8 1993/08/19 20:10:25 smh Exp $
 
 (in-package :clim-utils)
 
@@ -128,7 +128,6 @@
   (with-slots (color) color
     `(make-dynamic-color ,color)))
 
-
 ;;; Layered Colors
 
 (defclass layered-color-set ()
@@ -153,6 +152,17 @@
 (define-constructor make-layered-color layered-color (set layers)
   :set set :layers layers)
 
+;;; Device Colors 
+
+(defclass device-color (color)
+    ((palette :reader device-color-palette :initarg :palette)
+     (pixel :reader device-color-pixel :initarg :pixel)))
+
+(defmethod make-load-form ((color device-color) &optional environment)
+  (declare (ignore environment))
+  (with-slots (palette pixel) color
+    `(make-device-color ,palette ,pixel)))
+
 
 ;;; Foreground and background (indirect) inks
 
@@ -203,8 +213,10 @@
 ;;; Patterns
 
 (defclass pattern (design)
-    ((array   :type (array * (* *)) :initarg :array)
-     (designs :type vector	    :initarg :designs)))
+  ((array :type (array * (* *)) :initarg :array 
+	    :reader pattern-array)
+   (designs :type vector :initarg :designs
+	    :reader pattern-designs)))
 
 (defun make-pattern (array designs)
   #+Genera (declare lt:(side-effects simple reducible))
diff --git a/utils/designs.lisp b/utils/designs.lisp
index 332fb2266edb94fc9ffaaefccd4e262321ff134a..b11237ea9ae8c0387dbee4926f65071a15bc808f 100644
--- a/utils/designs.lisp
+++ b/utils/designs.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: designs.lisp,v 1.16 1993/07/27 01:57:08 colin Exp $
+;; $fiHeader: designs.lisp,v 1.17 1993/09/07 21:47:39 colin Exp $
 
 (in-package :clim-utils)
 
@@ -89,11 +89,8 @@
   (with-slots (red green blue) color
     (values red green blue)))
 
-(defmethod color-ihs ((color rgb-color))
-  (let* ((red (slot-value color 'red))
-	 (green (slot-value color 'green))
-	 (blue (slot-value color 'blue))
-	 (x (* ihs-rgb-c1 (- (+ red red) blue green)))
+(defun convert-rgb-to-ihs (red green blue)
+  (let* ((x (* ihs-rgb-c1 (- (+ red red) blue green)))
 	 (y (* ihs-rgb-c2 (- green blue)))
 	 (z (* ihs-rgb-c3 (+ red green blue)))
 	 (q (+ (* x x) (* y y)))
@@ -106,6 +103,10 @@
 	       (saturation (atan f2 f1)))
 	  (values intensity hue saturation)))))
 
+(defmethod color-ihs ((color rgb-color))
+  (with-slots (red green blue) color
+    (convert-rgb-to-ihs red green blue)))
+
 (defun-inline color-luminosity (r g b)
   ;; From Foley and Van Dam, page 613 (discussion of YIQ color model)...
   (+ (* 0.299f0 r) (* 0.587f0 g) (* 0.114f0 b)))
@@ -289,11 +290,8 @@
     (with-slots (intensity hue saturation) color
       (format stream "i=~F h=~F s=~F>" intensity hue saturation))))
 
-(defmethod color-rgb ((color ihs-color))
-  (let* ((intensity (slot-value color 'intensity))
-	 (hue (slot-value color 'hue))
-	 (saturation (slot-value color 'saturation))
-	 (hh (mod (- hue .5f0) 1.0f0))
+(defun convert-ihs-to-rgb (intensity hue saturation)
+  (let* ((hh (mod (- hue .5f0) 1.0f0))
 	 (hh (- (* hh 2.0f0 3.1415926535f0) 3.1415926535f0))
 	 (s3 (sin saturation))
 	 (x (* ihs-rgb-c1 s3 (cos hh) intensity))
@@ -305,6 +303,10 @@
 	      (range (+ y z (- x)))
 	      (range (- z x y))))))
 
+(defmethod color-rgb ((color ihs-color))
+  (with-slots (intensity hue saturation) color
+    (convert-ihs-to-rgb intensity hue saturation)))
+
 (defmethod color-ihs ((color ihs-color))
   (with-slots (intensity hue saturation) color
     (values intensity hue saturation)))
@@ -445,6 +447,20 @@
 		  set layers)
 		dynamics)))))
 
+
+;;; Device Colors
+
+(defmethod print-object ((color device-color) stream)
+  (print-unreadable-object (color stream :type t :identity t)
+    (with-slots (pixel) color
+      (format stream "~D:~A" pixel (device-color-color color)))))
+
+(defmethod color-rgb ((color device-color))
+  (color-rgb (device-color-color color)))
+
+(defmethod color-ihs ((color device-color))
+  (color-ihs (device-color-color color)))
+
 
 ;;; Foreground and background (indirect) inks
 
diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp
index 2bc218039e6382e22cb70d42604aa469c62a0197..faaa5faf062f6ffe2c99c968a3d841a289e3b8c6 100644
--- a/utils/lisp-utilities.lisp
+++ b/utils/lisp-utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: lisp-utilities.lisp,v 1.30 93/04/15 15:08:35 cer Exp $
+;; $fiHeader: lisp-utilities.lisp,v 1.32 1994/06/08 06:56:57 duane Exp $
 
 (in-package :clim-utils)
 
@@ -152,8 +152,22 @@
 
 #+Allegro
 (defmacro fix-coordinate (coord)
-  ;; ROUND is good enough in Allegro for 90% of the speed, and it's less filling.
-  `(the fixnum (round ,coord)))
+  `(the fixnum (fixit ,coord)))
+
+#+Allegro
+(defun fixit (coord)
+  (declare (optimize speed))
+  (typecase coord
+    (fixnum
+     coord)
+    (single-float
+     ;; note we use [x+0.5] rather than ROUND because 
+     ;; (1+ (round 1.5)) != (round 2.5) (cim 8/6/94)
+     (values (the fixnum (floor (+ (the single-float coord) .5f0)))))
+    (double-float
+     (values (the fixnum (floor (+ (the double-float coord) .5f0)))))
+    (t
+     (values (floor (+ coord .5f0))))))
 
 #-(or Genera Minima Allegro)
 (defun fix-coordinate (coord)
@@ -567,35 +581,7 @@
      (declare (dynamic-extent ,var))
      ,@body))
 
-#-(version>= 4 2 7)
-(progn
-  #+(and (target-class h r t) (version>= 4 1))
-  ;; Hack to allow compiling CLIM without a dcl.
-  (eval-when (eval compile)
-    comp::(def-qc-ll-fcn qc-ll_<u :<u
-	    (with-u-computed
-		(qc-boolean-compare :ltu u target cc))))
-
-  #+(and (target-class h) (version>= 4 1))
-  (defun-inline evacuate-list (list)
-    ;; the HP's stack grows toward higher memory
-    (if (comp::ll :<u (comp::ll :glob-c-value 'sys::c_stackmax) list)
-	(copy-list list)
-      list))
-
-  #+(and (target-class r) (version>= 4 1))
-  (defun-inline evacuate-list (list)
-    (if (comp::ll :<u (comp::ll :register :stack-pointer) list)
-	(copy-list list)
-      list))
-
-  #-(and (target-class h r t) (version>= 4 1))
-  (defmacro evacuate-list (list) `,list)
-  )
-
-#+(version>= 4 2 7)
 (defun-inline evacuate-list (list)
-  ;; the HP's stack grows toward higher memory
   (if (and (consp list)
 	   (excl::stack-allocated-p list))
       (copy-list list)
@@ -1022,6 +1008,38 @@
     (setf (gethash symbol table) value))
   value)
 
+#+Allegro
+(defmacro define-dynamic-extent-args (name lambda-list &rest de-args)
+  (flet ((lambda-vars (lambda-list)
+	   (let ((vars nil))
+	     (dolist (var lambda-list)
+	       (when (consp var)
+		 (setq var (car var)))
+	       (when (and (symbolp var)
+			  (not (member var lambda-list-keywords
+				       :test #'eq)))
+		 (push var vars)))
+	     vars)))
+    (let ((arglist '#:arglist)
+	  (vars '#:vars)
+	  (vals '#:vals))
+      `(define-compiler-macro ,name (&rest ,arglist)
+	 (destructuring-bind ,lambda-list ,arglist
+	   ,@(lambda-vars lambda-list)
+	   (let ((,vars nil)
+		 (,vals nil))
+	     (mapc #'(lambda (x y)
+		       (when y
+			 (push x ,vars)
+			 (push y ,vals)))
+		   ',(mapcar #'copy-symbol de-args)
+		   (list ,@de-args))
+	     `(let ,(mapcar #'list ,vars ,vals)
+		(declare (dynamic-extent ,@,vars))
+		(funcall ',',name  ,@(sublis (mapcar #'cons ,vals ,vars)
+					     ,arglist)))))))))
+
+
 #-(or Genera (and ansi-90 (not (and Allegro (not (version>= 4 1))))))
 (defmacro define-compiler-macro (name lambda-list &body body &environment env)
   env
diff --git a/utils/packages.lisp b/utils/packages.lisp
index fe14badd96ee99b1264c524783679f9198c3549f..4fba452ac37c85c474dd56c9d48b8aac79643417 100644
--- a/utils/packages.lisp
+++ b/utils/packages.lisp
@@ -1,98 +1,20 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: packages.lisp,v 1.61 1993/11/18 18:45:55 cer Exp $
+;; $fiHeader: packages.lisp,v 1.63 1994/06/08 06:57:00 duane Exp $
 
-(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
+(in-package :common-lisp-user)
 
 "Copyright (c) 1991, 1992 Symbolics, Inc.  All rights reserved."
 
 
 ;; Define the CLIM-LISP package, a package designed to mimic ANSI Common Lisp
 ;; as closely as possible (including CLOS).
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-lisp
-   #+Allegro (:implementation-packages :clim-lisp :clim-utils)
- (:use #-ANSI-90 lisp #+ANSI-90 common-lisp
+(defpackage clim-lisp
+  #+Allegro (:implementation-packages :clim-lisp :clim-utils)
+ (:use common-lisp
        #+Allegro clos
        #+(and CLIM-uses-lisp-stream-classes Allegro) stream)
- 
- #-ANSI-90
- (:shadowing-import-from #+PCL pcl
-			 #+(and (not PCL) (or Genera Cloe-Runtime)) clos-internals
-			 #+(and (not PCL) (not (or Genera Cloe-Runtime))) clos
-   defstruct
-   documentation
-   setf)
-
- #-ANSI-90
- (:import-from #+PCL pcl #-PCL clos
-   add-method
-   allocate-instance
-   built-in-class
-   call-method
-   call-next-method
-   change-class
-   class
-   class-direct-subclasses
-   class-direct-superclasses
-   class-name
-   class-of
-   class-precedence-list
-   class-prototype
-    class-slots
-   #+PCL classp
-   compute-applicable-methods
-   defclass
-   defgeneric
-   define-method-combination
-   defmethod
-   describe-object
-   ensure-generic-function
-   find-class
-   find-method
-   funcallable-standard-class
-   function-keywords
-   generic-flet
-   generic-function
-   generic-labels
-   initialize-instance
-   invalid-method-error
-   make-instance
-   make-instances-obsolete
-   make-load-form
-   make-load-form-saving-slots
-   make-method
-   method
-   method-combination
-   method-combination-error
-   method-qualifiers
-   next-method-p
-   no-applicable-method
-   no-next-method
-   print-object
-   reinitialize-instance
-   remove-method
-   shared-initialize
-   slot-boundp
-   slot-exists-p
-   slot-makunbound
-   slot-missing
-   slot-unbound
-   slot-value
-   standard
-   standard-class
-   standard-generic-function
-   standard-method
-   standard-object
-   standard-slot-definition
-   structure-class
-   structure-object
-   symbol-macrolet
-   update-instance-for-different-class
-   update-instance-for-redefined-class
-   with-accessors
-   with-slots)
 
- #+(and ANSI-90 (not CCL-2))
  (:import-from #+PCL pcl #-PCL clos
    class-direct-subclasses 
    class-direct-superclasses 
@@ -100,93 +22,6 @@
    class-prototype
    funcallable-standard-class)
 
- #+CCL-2
- (:import-from ccl
-   class
-   class-direct-subclasses
-   class-direct-superclasses
-   class-precedence-list
-   class-prototype)
-
- #-ANSI-90
- (:shadowing-import-from #+Lucid lucid-common-lisp 
-			 #+Allegro common-lisp
-			 #-(or Lucid Allegro) conditions
-   *break-on-signals*
-   *debugger-hook*
-   abort
-   arithmetic-error
-   arithmetic-error-operands
-   arithmetic-error-operation
-   assert
-   break
-   ccase
-   cell-error
-   cell-error-name
-   cerror
-   check-type
-   compute-restarts
-   condition
-   continue
-   control-error
-   ctypecase
-   #-Lucid define-condition
-   division-by-zero
-   ecase
-   end-of-file
-   error
-   etypecase
-   file-error
-   #-Lucid file-error-pathname
-   find-restart
-   floating-point-inexact
-   floating-point-invalid-operation
-   floating-point-overflow
-   floating-point-underflow
-   handler-bind
-   handler-case
-   ignore-errors
-   invoke-debugger
-   invoke-restart
-   invoke-restart-interactively
-   make-condition
-   muffle-warning
-   package-error
-   package-error-package
-   #-Lucid parse-error
-   #-Lucid print-not-readable
-   #-Lucid print-not-readable-object
-   program-error
-   #-Lucid restart
-   restart-bind
-   restart-case
-   restart-name
-   serious-condition
-   signal
-   simple-condition
-   simple-condition-format-arguments
-   #+ANSI-90 simple-condition-format-control
-   #-ANSI-90 simple-condition-format-string
-   simple-error
-   simple-type-error
-   simple-warning
-   storage-condition
-   store-value
-   stream-error
-   stream-error-stream
-   #-Lucid style-warning
-   type-error
-   #-Lucid type-error-datum
-   #-Lucid type-error-expected-type
-   #-Lucid unbound-slot
-   #-Lucid unbound-slot-instance
-   unbound-variable
-   undefined-function
-   use-value
-   warn
-   warning
-   with-simple-restart)
-
  #+Lucid (:shadow define-condition)
 
  #+(and Genera (not ANSI-90))
@@ -577,6 +412,7 @@
    boole-orc2
    boole-set
    boole-xor
+   boolean
    both-case-p
    boundp
    break
@@ -719,8 +555,7 @@
    define-condition
    define-method-combination
    define-modify-macro
-   #+ANSI-90 define-setf-expander
-   #-ANSI-90 define-setf-method
+   define-setf-expander
    defmacro
    defmethod
    defpackage
@@ -856,9 +691,7 @@
    get-macro-character
    get-output-stream-string
    get-properties
-   #+ANSI-90 get-setf-expansion
-   #-ANSI-90 get-setf-method
-   #-ANSI-90 get-setf-method-multiple-value
+   get-setf-expansion
    get-universal-time
    getf
    gethash
@@ -1237,8 +1070,7 @@
    simple-bit-vector-p
    simple-condition
    simple-condition-format-arguments
-   #+ANSI-90 simple-condition-format-control
-   #-ANSI-90 simple-condition-format-string
+   simple-condition-format-control
    simple-error
    simple-string
    simple-string-p
@@ -1455,7 +1287,7 @@
 
 
 ;; Define the CLIM-SYS package
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-sys
+(defpackage clim-sys
   (:use)				;use nothing
   (:export
     ;; Resources
@@ -1504,7 +1336,7 @@
 
 
 ;; Define the CLIM package
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim
+(defpackage clim
   (:use)				;use nothing
   #+Allegro (:implementation-packages 
 	     :silica 
@@ -1515,6 +1347,7 @@
 	     :xm-silica)
   (:import-from clim-lisp
     and
+    boolean
     character
     close
     complex
@@ -2086,6 +1919,8 @@
     make-stencil
     pattern-height
     pattern-width
+    pattern-array
+    pattern-designs
     
     ;; Palettes
     add-colors-to-palette
@@ -2912,14 +2747,12 @@
     oriented-gadget-mixin
     push-button
     push-button-pane
-    push-button-show-as-default-p
+    push-button-show-as-default
     radio-box
     radio-box-current-selection
     radio-box-pane
     radio-box-selections
     scroll-bar
-    scroll-bar-current-size
-    scroll-bar-current-value
     scroll-bar-drag-callback
     scroll-bar-pane
     set-gadget-items
@@ -2956,7 +2789,8 @@
   (:export
    read-bitmap-file
    *bitmap-search-path*
-   make-pattern-from-bitmap-file)
+   make-pattern-from-bitmap-file
+   make-pattern-from-pixmap)
 
   ;; Primary colors
   (:export
@@ -3035,8 +2869,8 @@
 
 
 ;; Now define all of the implementation packages
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-utils
-   #+Allegro (:implementation-packages :clim-utils :clim-silica
+(defpackage clim-utils
+  #+Allegro (:implementation-packages :clim-utils :clim-silica
 				       :clim-internals :xt-silica)
   (:use	clim-lisp clim-sys clim)
 
@@ -3133,6 +2967,7 @@
     convert-to-device-coordinates
     convert-to-device-distances
     copy-vector-portion
+    define-dynamic-extent-args
     define-group
     define-keywords
     defun-inline
@@ -3313,11 +3148,18 @@
     composite-over
     contrasting-ink
     contrasting-ink-index
+    convert-ihs-to-rgb
+    convert-rgb-to-ihs
     deallocate-color
     decode-flipping-ink
     decode-pattern
     decode-rectangular-tile
     decode-tile-as-stipple
+    device-color
+    device-color-color
+    device-color-pixel
+    device-color-palette
+    make-device-color
     dynamic-color
     dynamic-color-palettes
     flipping-ink
@@ -3354,7 +3196,7 @@
     modifier-key-index-name))
 
 
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-silica
+(defpackage clim-silica
    (:nicknames silica pyrex)
    #+Allegro (:implementation-packages :clim-silica :clim-internals :xt-silica)
   (:use	clim-lisp clim-sys clim clim-utils)
@@ -3431,6 +3273,8 @@
     focus-in-gadget-event
     focus-out-gadget-event
     frame-background
+    frame-foreground
+    frame-text-style
     frame-input-buffer
     frame-manager-matches-options-p
     frame-manager-note-pretty-name-changed
@@ -3551,6 +3395,7 @@
     scroller-pane-gadget-supplies-scrolling-p
     scroller-pane-horizontal-scroll-bar
     scroller-pane-vertical-scroll-bar
+    scroller-pane-drag-scroll
     set-mirror-edges*
     set-mirror-region*
     set-sheet-mirror-edges*
@@ -3605,7 +3450,7 @@
     wrapping-space-mixin))
 
 
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-internals
+(defpackage clim-internals
   (:use	:clim-lisp :clim-sys :clim :clim-utils :clim-silica)
   #+Allegro (:implementation-packages :clim-internals :xt-silica)
   #+CCL-2
@@ -3631,7 +3476,7 @@
 
 
 ;; A package for casual use...
-(#-(or ANSI-90 Lucid) clim-lisp::defpackage #+(or ANSI-90 Lucid) defpackage clim-user
+(defpackage clim-user
    (:use clim-lisp clim))
 
 ;;; Nasty hack to improve debuggability
diff --git a/utils/processes.lisp b/utils/processes.lisp
index 3678ec718c93bb88f1915f167c9cf41911adf924..642cdf170aeb93bec1589b9bb2bbe7a17702d0e8 100644
--- a/utils/processes.lisp
+++ b/utils/processes.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: processes.lisp,v 1.16 1993/08/31 04:55:10 layer Exp $
+;; $fiHeader: processes.lisp,v 1.17 1993/09/17 19:07:36 cer Exp $
 
 (in-package :clim-utils)
 
@@ -75,7 +75,7 @@
 	  (unless (null place-value)
 	    (flet ((waiter ()
 		     (null (first place))))
-	      (declare (dynamic-extent #'waiter))
+	      #-Allegro (declare (dynamic-extent #'waiter))
 	      (process-wait state #'waiter)))
 	  (unwind-protect
 	      (progn (rplaca place store-value)
diff --git a/utils/utilities.lisp b/utils/utilities.lisp
index 25ec1356ba8f2795c5028054924f7b12e30241eb..5351b1aa2ca757f37b5882a181d0f4306fd169b1 100644
--- a/utils/utilities.lisp
+++ b/utils/utilities.lisp
@@ -1,6 +1,6 @@
 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*-
 
-;; $fiHeader: utilities.lisp,v 1.7 92/08/18 17:24:19 cer Exp $
+;; $fiHeader: utilities.lisp,v 1.8 1993/07/27 01:58:29 colin Exp $
 
 ;;;
 ;;; Copyright (c) 1989, 1990 by Xerox Corporation.  All rights reserved. 
@@ -16,6 +16,8 @@
 ;;; COMMONLISP Extensions
 ;;; 
 
+;; now we have cl:boolean we don't need this (cim 2/24/94)
+#+ignore 
 (deftype boolean nil '(member nil t))
 
 (defmacro compile-time-warn (warn-string)
diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp
index e93527d0d4c228eb0d671654d833c5c3011b7c92..a8004780c63a4853eb18f83a7c2f6cea2dfc32b1 100644
--- a/xlib/ffi.lisp
+++ b/xlib/ffi.lisp
@@ -18,7 +18,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: ffi.lisp,v 1.14 92/12/14 15:05:12 cer Exp $
+;; $fiHeader: ffi.lisp,v 1.15 1993/07/22 15:39:51 cer Exp $
 
 (in-package :x11)
 
@@ -54,18 +54,24 @@
   (intern (apply #'format nil control args)))
 
 (defmacro def-exported-foreign-struct (name-and-options &rest slots)
-  (let (name (options nil))
+  (let (name array-name (options nil))
     (if (atom name-and-options)
 	(setq name name-and-options)
       (setq name (car name-and-options)
 	    options (cdr name-and-options)))
+    (when (member :array options)
+      (setq array-name (fintern "~A-~A" name 'array)
+	    options (delete :array options)))
     `(progn
-       (eval-when (eval load compile)
-	 (export '(,name
-		   ,(fintern "~A~A" 'make- name)
-		   ,@(mapcar #'(lambda (x)
-				 (fintern "~A-~A" name (car x)))
-		      slots))))
+       ,(flet ((make-exports (name)
+		 (list* name
+			(fintern "~A-~A" 'make name)
+			(mapcar #'(lambda (x)
+				    (fintern "~A-~A" name (car x)))
+				slots))))
+	  `(eval-when (eval load compile)
+	     (export '(,@(make-exports name)
+		       ,@(make-exports array-name)))))
        ,(flet ((foo-slot (slot)
 		 (destructuring-bind
 		     (name &key type) slot
@@ -89,7 +95,10 @@
 						 (remf (cdr slot) :overlays)
 						 (foo-slot slot))
 					     slots))
-		(error ":overlays used in a way we cannot handle"))))))))
+		(error ":overlays used in a way we cannot handle")))))
+       ,(when array-name
+	  `(ff::def-c-type (,array-name :no-defuns ,@options)
+	     1 ,name)))))
 
 	  
 
@@ -104,18 +113,6 @@
 	(declare (ignore ignore))
 	`(,@indicies ,type))))))
 
-#+ignore
-(defmacro def-exported-foreign-function ((name &rest options) &rest args)
-  `(foreign-functions:defforeign 
-       ',name 
-       :arguments ',(mapcar #'(lambda (x) x t) args)
-       :call-direct t
-       :callback nil
-       :arg-checking nil
-       :return-type 'integer
-       :entry-point ,(ff:convert-to-lang (second (assoc :name options)))))
-
-
 ;;; Delay version
 
 (defun trans-arg-type (type)
@@ -154,7 +151,7 @@
      (eval-when (compile eval load)
        ,(let ((c-name (ff:convert-to-lang (second (assoc :name options))))
 	      (return-type (or (second (assoc :return-type options))
-			       'integer)))
+			       'void)))
 	  `(delayed-defforeign
 	    ',name
 	    :arguments ',(mapcar #'trans-arg-type (mapcar #'second args))
@@ -171,10 +168,9 @@
   (setf *defforeigned-functions*
     (delete name *defforeigned-functions* :key #'car))
   (push (cons name arguments) *defforeigned-functions*))
-  
 
-(defmacro defforeign-functions-now ()
-  `(ff:defforeign-list ',*defforeigned-functions*))
+(defun defforeign-functions-now ()
+  (ff:defforeign-list *defforeigned-functions*))
 
 ;;; End of delay version
 
diff --git a/xlib/last.lisp b/xlib/last.lisp
index 21ae25b866cc738647fcff5f76e7e4433574f8a8..34041318e35cb3293db1cb71ac87fb2c35777215 100644
--- a/xlib/last.lisp
+++ b/xlib/last.lisp
@@ -20,10 +20,10 @@
 ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;; $fiHeader: last.lisp,v 1.3 92/02/24 13:06:34 cer Exp $
+;; $fiHeader: last.lisp,v 1.4 1993/07/27 01:59:01 colin Exp $
 
 (in-package :x11)
 
 (defforeign-functions-now)
 
-
+(provide :clim-debug)
diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp
index 17497c811da8b577bc4ead343f7fe28406cd6337..9cdcec88c30127615485a7cd4211eee74ca94662 100644
--- a/xlib/xlib-defs.lisp
+++ b/xlib/xlib-defs.lisp
@@ -19,7 +19,7 @@
 ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
 ;; applicable.
 ;;
-;;; $fiHeader: xlib-defs.lisp,v 1.6 92/12/02 13:31:44 colin Exp $
+;;; $fiHeader: xlib-defs.lisp,v 1.7 1993/07/27 01:59:18 colin Exp $
 
 ;;      (c) Copyright 1989, 1990, 1991 Sun Microsystems, Inc. Sun design
 ;;      patents pending in the U.S. and foreign countries. OPEN LOOK is a
@@ -820,7 +820,7 @@
   (sibling :type window)
   (stack-mode :type int))
 
-(def-exported-foreign-struct xcolor
+(def-exported-foreign-struct (xcolor :array)
   (pixel :type unsigned-long)
   (red :type unsigned-short)
   (green :type unsigned-short)
@@ -828,36 +828,23 @@
   (flags :type unsigned-char)
   (pad :type unsigned-char))
 
-;; anyone fancy doing a def-exported-foreign-array??
-
-(ff::def-c-type (xcolor-array :no-defuns) 1 xcolor)
-(eval-when (compile load eval)
-  (export '(xcolor-array-pixel xcolor-array-red xcolor-array-green
-	    xcolor-array-blue xcolor-array-flags xcolor-array-pad
-	    xcolor-array make-xcolor-array)))
-
-(def-exported-foreign-struct xsegment
+(def-exported-foreign-struct (xsegment :array)
   (x1 :type short) 
   (y1 :type short) 
   (x2 :type short) 
   (y2 :type short))
 
-(def-exported-foreign-struct xpoint
+(def-exported-foreign-struct (xpoint :array)
   (x :type short) 
   (y :type short))
 
-(def-exported-foreign-struct xrectangle
+(def-exported-foreign-struct (xrectangle :array)
   (x :type short)
   (y :type short)
   (width :type unsigned-short)
   (height :type unsigned-short))
 
-(ff::def-c-type (xrectangle-array :no-defuns) 1 xrectangle)
-(eval-when (compile load eval)
-  (export '(xrectangle-array-x xrectangle-array-y xrectangle-array-width
-	    xrectangle-array-height xrectangle-array make-xrectangle-array)))
-
-(def-exported-foreign-struct xarc
+(def-exported-foreign-struct (xarc :array)
   (x :type short)
   (y :type short)
   (width :type unsigned-short)
diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp
index 5d4e4952cdebf1b2d9af14c00087a8b235f0aa35..269d8329c72f1d1636736bda4a9d9175859c0c16 100644
--- a/xlib/xlib-funs.lisp
+++ b/xlib/xlib-funs.lisp
@@ -45,7 +45,7 @@
 ;;      OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION
 ;;      WITH THE USE OR PERFORMANCE OF THIS OBJECT CODE.
 
-;;; $fiHeader: xlib-funs.lisp,v 1.13 1993/07/27 01:59:24 colin Exp $
+;;; $fiHeader: xlib-funs.lisp,v 1.14 1993/11/18 18:46:00 cer Exp $
 
 (in-package :x11)
 
@@ -71,73 +71,73 @@
    (gmask (:pointer unsigned-long))
    (bmask (:pointer unsigned-long)))
 
-(def-exported-foreign-function (xallowevents (:return-type int) (:name "XAllowEvents")) 
+(def-exported-foreign-function (xallowevents (:name "XAllowEvents")) 
    (dpy (:pointer display))
    (mode int)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xautorepeaton (:return-type int) (:name "XAutoRepeatOn")) 
+(def-exported-foreign-function (xautorepeaton (:name "XAutoRepeatOn")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xautorepeatoff (:return-type int) (:name "XAutoRepeatOff")) 
+(def-exported-foreign-function (xautorepeatoff (:name "XAutoRepeatOff")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xsetwindowbackground (:return-type int) (:name "XSetWindowBackground")) 
+(def-exported-foreign-function (xsetwindowbackground (:name "XSetWindowBackground")) 
    (dpy (:pointer display))
    (w window)
    (pixel unsigned-long))
 
-(def-exported-foreign-function (xsetwindowborderwidth (:return-type int) (:name "XSetWindowBorderWidth")) 
+(def-exported-foreign-function (xsetwindowborderwidth (:name "XSetWindowBorderWidth")) 
    (dpy (:pointer display))
    (w window)
    (width unsigned-int))
 
-(def-exported-foreign-function (xbell (:return-type int) (:name "XBell")) 
+(def-exported-foreign-function (xbell (:name "XBell")) 
    (dpy (:pointer display))
    (percent int))
 
-(def-exported-foreign-function (xsetwindowborder (:return-type int) (:name "XSetWindowBorder")) 
+(def-exported-foreign-function (xsetwindowborder (:name "XSetWindowBorder")) 
    (dpy (:pointer display))
    (w window)
    (pixel unsigned-long))
 
-(def-exported-foreign-function (xenableaccesscontrol (:return-type int) (:name "XEnableAccessControl")) 
+(def-exported-foreign-function (xenableaccesscontrol (:name "XEnableAccessControl")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xdisableaccesscontrol (:return-type int) (:name "XDisableAccessControl")) 
+(def-exported-foreign-function (xdisableaccesscontrol (:name "XDisableAccessControl")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xsetaccesscontrol (:return-type int) (:name "XSetAccessControl")) 
+(def-exported-foreign-function (xsetaccesscontrol (:name "XSetAccessControl")) 
    (dpy (:pointer display))
    (mode int))
 
-(def-exported-foreign-function (xchangeactivepointergrab (:return-type int) (:name "XChangeActivePointerGrab")) 
+(def-exported-foreign-function (xchangeactivepointergrab (:name "XChangeActivePointerGrab")) 
    (dpy (:pointer display))
    (event-mask unsigned-int)
    (curs cursor)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xsetclosedownmode (:return-type int) (:name "XSetCloseDownMode")) 
+(def-exported-foreign-function (xsetclosedownmode (:name "XSetCloseDownMode")) 
    (dpy (:pointer display))
    (mode int))
 
-(def-exported-foreign-function (xsetwindowcolormap (:return-type int) (:name "XSetWindowColormap")) 
+(def-exported-foreign-function (xsetwindowcolormap (:name "XSetWindowColormap")) 
    (dpy (:pointer display))
    (w window)
    (colormap colormap))
 
-(def-exported-foreign-function (xchangegc (:return-type int) (:name "XChangeGC")) 
+(def-exported-foreign-function (xchangegc (:name "XChangeGC")) 
    (dpy (:pointer display))
    (gc gc)
    (valuemask unsigned-long)
    (values (:pointer xgcvalues)))
 
-(def-exported-foreign-function (xchangekeyboardcontrol (:return-type int) (:name "XChangeKeyboardControl")) 
+(def-exported-foreign-function (xchangekeyboardcontrol (:name "XChangeKeyboardControl")) 
    (dpy (:pointer display))
    (mask unsigned-long)
    (value-list (:pointer xkeyboardcontrol)))
 
-(def-exported-foreign-function (xchangepointercontrol (:return-type int) (:name "XChangePointerControl")) 
+(def-exported-foreign-function (xchangepointercontrol (:name "XChangePointerControl")) 
    (dpy (:pointer display))
    (do-acc int)
    (do-thresh int)
@@ -145,7 +145,7 @@
    (acc-denominator int)
    (threshold int))
 
-(def-exported-foreign-function (xchangeproperty (:return-type int) (:name "XChangeProperty")) 
+(def-exported-foreign-function (xchangeproperty (:name "XChangeProperty")) 
    (dpy (:pointer display))
    (w window)
    (property :unsigned-32bit)
@@ -155,26 +155,26 @@
    (data (:pointer unsigned-char))
    (nelements int))
 
-(def-exported-foreign-function (xchangesaveset (:return-type int) (:name "XChangeSaveSet")) 
+(def-exported-foreign-function (xchangesaveset (:name "XChangeSaveSet")) 
    (dpy (:pointer display))
    (win window)
    (mode int))
 
-(def-exported-foreign-function (xaddtosaveset (:return-type int) (:name "XAddToSaveSet")) 
+(def-exported-foreign-function (xaddtosaveset (:name "XAddToSaveSet")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xremovefromsaveset (:return-type int) (:name "XRemoveFromSaveSet")) 
+(def-exported-foreign-function (xremovefromsaveset (:name "XRemoveFromSaveSet")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xchangewindowattributes (:return-type int) (:name "XChangeWindowAttributes")) 
+(def-exported-foreign-function (xchangewindowattributes (:name "XChangeWindowAttributes")) 
    (dpy (:pointer display))
    (w window)
    (valuemask unsigned-long)
    (attributes (:pointer xsetwindowattributes)))
 
-(def-exported-foreign-function (xresizewindow (:return-type int) (:name "XResizeWindow")) 
+(def-exported-foreign-function (xresizewindow (:name "XResizeWindow")) 
    (dpy (:pointer display))
    (w window)
    (width unsigned-int)
@@ -208,27 +208,27 @@
    (mask long)
    (event (:pointer xevent)))
 
-(def-exported-foreign-function (xcirculatesubwindows (:return-type int) (:name "XCirculateSubwindows")) 
+(def-exported-foreign-function (xcirculatesubwindows (:name "XCirculateSubwindows")) 
    (dpy (:pointer display))
    (w window)
    (direction int))
 
-(def-exported-foreign-function (xcirculatesubwindowsdown (:return-type int) (:name "XCirculateSubwindowsDown")) 
+(def-exported-foreign-function (xcirculatesubwindowsdown (:name "XCirculateSubwindowsDown")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xcirculatesubwindowsup (:return-type int) (:name "XCirculateSubwindowsUp")) 
+(def-exported-foreign-function (xcirculatesubwindowsup (:name "XCirculateSubwindowsUp")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xclosedisplay (:return-type int) (:name "XCloseDisplay")) 
+(def-exported-foreign-function (xclosedisplay (:name "XCloseDisplay")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xclearwindow (:return-type int) (:name "XClearWindow")) 
+(def-exported-foreign-function (xclearwindow (:name "XClearWindow")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xcleararea (:return-type int) (:name "XClearArea")) 
+(def-exported-foreign-function (xcleararea (:name "XClearArea")) 
    (dpy (:pointer display))
    (w window)
    (x int)
@@ -237,7 +237,7 @@
    (height unsigned-int)
    (exposures int))
 
-(def-exported-foreign-function (xmoveresizewindow (:return-type int) (:name "XMoveResizeWindow")) 
+(def-exported-foreign-function (xmoveresizewindow (:name "XMoveResizeWindow"))
    (dpy (:pointer display))
    (w window)
    (x int)
@@ -245,7 +245,7 @@
    (width unsigned-int)
    (height unsigned-int))
 
-(def-exported-foreign-function (xconvertselection (:return-type int) (:name "XConvertSelection")) 
+(def-exported-foreign-function (xconvertselection (:name "XConvertSelection")) 
    (dpy (:pointer display))
    (selection :unsigned-32bit)
    (target :unsigned-32bit)
@@ -253,7 +253,7 @@
    (requestor window)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xcopyarea (:return-type int) (:name "XCopyArea")) 
+(def-exported-foreign-function (xcopyarea (:name "XCopyArea")) 
    (dpy (:pointer display))
    (src-drawable drawable)
    (dst-drawable drawable)
@@ -265,17 +265,17 @@
    (dst-x int)
    (dst-y int))
 
-(def-exported-foreign-function (xcopycolormapandfree (:return-type colormap) (:name "XCopyColormapAndFree")) 
+(def-exported-foreign-function (xcopycolormapandfree (:name "XCopyColormapAndFree")) 
    (dpy (:pointer display))
    (src-cmap colormap))
 
-(def-exported-foreign-function (xcopygc (:return-type int) (:name "XCopyGC")) 
+(def-exported-foreign-function (xcopygc (:name "XCopyGC")) 
    (dpy (:pointer display))
    (mask unsigned-long)
    (srcgc gc)
    (destgc gc))
 
-(def-exported-foreign-function (xcopyplane (:return-type int) (:name "XCopyPlane")) 
+(def-exported-foreign-function (xcopyplane (:name "XCopyPlane")) 
    (dpy (:pointer display))
    (src-drawable drawable)
    (dst-drawable drawable)
@@ -343,21 +343,21 @@
    (dpy (:pointer display))
    (which unsigned-int))
 
-(def-exported-foreign-function (xdefinecursor (:return-type int) (:name "XDefineCursor")) 
+(def-exported-foreign-function (xdefinecursor (:name "XDefineCursor")) 
    (dpy (:pointer display))
    (w window)
    (cursor cursor))
 
-(def-exported-foreign-function (xdeleteproperty (:return-type int) (:name "XDeleteProperty")) 
+(def-exported-foreign-function (xdeleteproperty (:name "XDeleteProperty")) 
    (dpy (:pointer display))
    (window window)
    (property :unsigned-32bit))
 
-(def-exported-foreign-function (xdestroysubwindows (:return-type int) (:name "XDestroySubwindows")) 
+(def-exported-foreign-function (xdestroysubwindows (:name "XDestroySubwindows")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xdestroywindow (:return-type int) (:name "XDestroyWindow")) 
+(def-exported-foreign-function (xdestroywindow (:name "XDestroyWindow")) 
    (dpy (:pointer display))
    (w window))
 
@@ -365,13 +365,13 @@
    (display (:pointer char)))
 
 
-(def-exported-foreign-function (xgeterrortext (:return-type :null) (:name "XGetErrorText")) 
+(def-exported-foreign-function (xgeterrortext (:name "XGetErrorText")) 
    (dpy (:pointer display))
    (code int)
    (buffer (:pointer char))
    (nbytes int))  
 
-(def-exported-foreign-function (xgeterrordatabasetext (:return-type int) (:name "XGetErrorDatabaseText")) 
+(def-exported-foreign-function (xgeterrordatabasetext (:name "XGetErrorDatabaseText")) 
    (name (:pointer char))
    (type (:pointer char))
    (defaultp (:pointer char))
@@ -379,16 +379,16 @@
    (buffer (:pointer char))
    (nbytes int))
 
-(def-exported-foreign-function (xseterrorhandler (:return-type :null) (:name "XSetErrorHandler")) 
+(def-exported-foreign-function (xseterrorhandler (:name "XSetErrorHandler")) 
    (handler callback-function-addr))
 
-(def-exported-foreign-function (xsetioerrorhandler (:return-type :null) (:name "XSetIOErrorHandler")) 
+(def-exported-foreign-function (xsetioerrorhandler (:name "XSetIOErrorHandler")) 
    (handler callback-function-addr))
 
-(def-exported-foreign-function (xactivatescreensaver (:return-type int) (:name "XActivateScreenSaver")) 
+(def-exported-foreign-function (xactivatescreensaver (:name "XActivateScreenSaver")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xresetscreensaver (:return-type int) (:name "XResetScreenSaver")) 
+(def-exported-foreign-function (xresetscreensaver (:name "XResetScreenSaver")) 
    (dpy (:pointer display)))
 
 (def-exported-foreign-function (xforcescreensaver (:return-type int) (:name "XForceScreenSaver")) 
@@ -405,7 +405,7 @@
    (w window)
    (icon-name (:pointer (:pointer char))))
 
-(def-exported-foreign-function (xfillarc (:return-type int) (:name "XFillArc")) 
+(def-exported-foreign-function (xfillarc (:name "XFillArc")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
@@ -416,14 +416,14 @@
    (angle1 int)
    (angle2 int))
 
-(def-exported-foreign-function (xfillarcs (:return-type int) (:name "XFillArcs")) 
+(def-exported-foreign-function (xfillarcs (:name "XFillArcs")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
    (arcs (:pointer xarc))
    (n-arcs int))
 
-(def-exported-foreign-function (xfillpolygon (:return-type int) (:name "XFillPolygon")) 
+(def-exported-foreign-function (xfillpolygon (:name "XFillPolygon")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
@@ -432,7 +432,7 @@
    (shape int)
    (mode int))
 
-(def-exported-foreign-function (xfillrectangle (:return-type int) (:name "XFillRectangle")) 
+(def-exported-foreign-function (xfillrectangle (:name "XFillRectangle")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
@@ -441,21 +441,21 @@
    (width unsigned-int)
    (height unsigned-int))
 
-(def-exported-foreign-function (xfillrectangles (:return-type int) (:name "XFillRectangles")) 
+(def-exported-foreign-function (xfillrectangles (:name "XFillRectangles")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
    (rectangles (:pointer xrectangle))
    (n-rects int))
 
-(def-exported-foreign-function (xflush (:name "XFlush") (:return-type :fixnum))
+(def-exported-foreign-function (xflush (:name "XFlush"))
    (dpy (:pointer display)))
 
 (def-exported-foreign-function (xloadqueryfont (:return-type (:pointer xfontstruct)) (:name "XLoadQueryFont")) 
    (dpy (:pointer display))
    (name (:pointer char)))
 
-(def-exported-foreign-function (xfreefont (:return-type int) (:name "XFreeFont")) 
+(def-exported-foreign-function (xfreefont (:name "XFreeFont")) 
    (dpy (:pointer display))
    (fs (:pointer xfontstruct)))
 
@@ -470,7 +470,7 @@
    (actualcount (:pointer int))
    (info (:pointer (:pointer xfontstruct))))
 
-(def-exported-foreign-function (xfreefontinfo (:return-type int) (:name "XFreeFontInfo")) 
+(def-exported-foreign-function (xfreefontinfo (:name "XFreeFontInfo")) 
    (names (:pointer (:pointer char)))
    (info (:pointer xfontstruct))
    (actualcount int))
@@ -481,53 +481,53 @@
    (maxnames int)
    (actualcount (:pointer int)))
 
-(def-exported-foreign-function (xfreefontnames (:return-type int) (:name "XFreeFontNames")) 
+(def-exported-foreign-function (xfreefontnames (:name "XFreeFontNames")) 
    (list (:pointer (:pointer char))))
 
-(def-exported-foreign-function (xfreecolormap (:return-type int) (:name "XFreeColormap")) 
+(def-exported-foreign-function (xfreecolormap (:name "XFreeColormap")) 
    (dpy (:pointer display))
    (cmap colormap))
 
-(def-exported-foreign-function (xfreecolors (:return-type int) (:name "XFreeColors")) 
+(def-exported-foreign-function (xfreecolors (:name "XFreeColors")) 
    (dpy (:pointer display))
    (cmap colormap)
    (pixels (:pointer unsigned-long))
    (npixels int)
    (planes unsigned-long))
 
-(def-exported-foreign-function (xfreecursor (:return-type int) (:name "XFreeCursor")) 
+(def-exported-foreign-function (xfreecursor (:name "XFreeCursor")) 
    (dpy (:pointer display))
    (cursor cursor))
 
-(def-exported-foreign-function (xfreegc (:return-type int) (:name "XFreeGC")) 
+(def-exported-foreign-function (xfreegc (:name "XFreeGC")) 
    (dpy (:pointer display))
    (gc gc))
 
-(def-exported-foreign-function (xfreepixmap (:return-type int) (:name "XFreePixmap")) 
+(def-exported-foreign-function (xfreepixmap (:name "XFreePixmap")) 
    (dpy (:pointer display))
    (pixmap pixmap))
 
-(def-exported-foreign-function (xsetarcmode (:return-type int) (:name "XSetArcMode")) 
+(def-exported-foreign-function (xsetarcmode (:name "XSetArcMode")) 
    (dpy (:pointer display))
    (gc gc)
    (arc-mode int))
 
-(def-exported-foreign-function (xsetfillrule (:return-type int) (:name "XSetFillRule")) 
+(def-exported-foreign-function (xsetfillrule (:name "XSetFillRule")) 
    (dpy (:pointer display))
    (gc gc)
    (fill-rule int))
 
-(def-exported-foreign-function (xsetfillstyle (:return-type int) (:name "XSetFillStyle")) 
+(def-exported-foreign-function (xsetfillstyle (:name "XSetFillStyle")) 
    (dpy (:pointer display))
    (gc gc)
    (fill-style int))
 
-(def-exported-foreign-function (xsetgraphicsexposures (:return-type int) (:name "XSetGraphicsExposures")) 
+(def-exported-foreign-function (xsetgraphicsexposures (:name "XSetGraphicsExposures")) 
    (dpy (:pointer display))
    (gc gc)
    (graphics-exposures int))
 
-(def-exported-foreign-function (xsetsubwindowmode (:return-type int) (:name "XSetSubwindowMode")) 
+(def-exported-foreign-function (xsetsubwindowmode (:name "XSetSubwindowMode")) 
    (dpy (:pointer display))
    (gc gc)
    (subwindow-mode int))
@@ -547,7 +547,7 @@
    (dpy (:pointer display))
    (npaths (:pointer int)))
 
-(def-exported-foreign-function (xfreefontpath (:return-type int) (:name "XFreeFontPath")) 
+(def-exported-foreign-function (xfreefontpath (:name "XFreeFontPath")) 
    (list (:pointer (:pointer char))))
 
 (def-exported-foreign-function (xgetfontproperty (:return-type int) (:name "XGetFontProperty")) 
@@ -571,7 +571,7 @@
    (cmap colormap)
    (def (:pointer xcolor)))
 
-(def-exported-foreign-function (xgetinputfocus (:return-type int) (:name "XGetInputFocus")) 
+(def-exported-foreign-function (xgetinputfocus (:name "XGetInputFocus")) 
    (dpy (:pointer display))
    (focus (:pointer window))
    (revert-to (:pointer int)))
@@ -599,7 +599,7 @@
    (dest-x int)
    (dest-y int))
 
-(def-exported-foreign-function (xgetkeyboardcontrol (:return-type void) (:name "XGetKeyboardControl")) 
+(def-exported-foreign-function (xgetkeyboardcontrol (:name "XGetKeyboardControl")) 
    (dpy (:pointer display))
    (state (:pointer xkeyboardstate)))
 
@@ -610,7 +610,7 @@
    (w window)
    (nevents (:pointer int)))
 
-(def-exported-foreign-function (xgetpointercontrol (:return-type int) (:name "XGetPointerControl")) 
+(def-exported-foreign-function (xgetpointercontrol (:name "XGetPointerControl")) 
    (dpy (:pointer display))
    (accel-numer (:pointer int))
    (accel-denom (:pointer int))
@@ -645,7 +645,7 @@
    (dpy (:pointer display))
    (selection :unsigned-32bit))
 
-(def-exported-foreign-function (xgetscreensaver (:return-type int) (:name "XGetScreenSaver")) 
+(def-exported-foreign-function (xgetscreensaver (:name "XGetScreenSaver")) 
    (dpy (:pointer display))
    (timeout (:pointer int))
    (interval (:pointer int))
@@ -657,7 +657,7 @@
    (w window)
    (att (:pointer xwindowattributes)))
 
-(def-exported-foreign-function (xgrabbutton (:return-type int) (:name "XGrabButton")) 
+(def-exported-foreign-function (xgrabbutton (:name "XGrabButton")) 
    (dpy (:pointer display))
    (modifiers unsigned-int)
    (button unsigned-int)
@@ -669,7 +669,7 @@
    (confine-to window)
    (curs cursor))
 
-(def-exported-foreign-function (xgrabkey (:return-type int) (:name "XGrabKey")) 
+(def-exported-foreign-function (xgrabkey (:name "XGrabKey")) 
    (dpy (:pointer display))
    (key int)
    (modifiers unsigned-int)
@@ -697,28 +697,28 @@
    (curs cursor)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xgrabserver (:return-type int) (:name "XGrabServer")) 
+(def-exported-foreign-function (xgrabserver (:name "XGrabServer")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xaddhost (:return-type int) (:name "XAddHost")) 
+(def-exported-foreign-function (xaddhost (:name "XAddHost")) 
    (dpy (:pointer display))
    (host (:pointer xhostaddress)))
 
-(def-exported-foreign-function (xremovehost (:return-type int) (:name "XRemoveHost")) 
+(def-exported-foreign-function (xremovehost (:name "XRemoveHost")) 
    (dpy (:pointer display))
    (host (:pointer xhostaddress)))
 
-(def-exported-foreign-function (xaddhosts (:return-type int) (:name "XAddHosts")) 
+(def-exported-foreign-function (xaddhosts (:name "XAddHosts")) 
    (dpy (:pointer display))
    (hosts (:pointer xhostaddress))
    (n int))
 
-(def-exported-foreign-function (xremovehosts (:return-type int) (:name "XRemoveHosts")) 
+(def-exported-foreign-function (xremovehosts (:name "XRemoveHosts")) 
    (dpy (:pointer display))
    (hosts (:pointer xhostaddress))
    (n int))
 
-(def-exported-foreign-function (xifevent (:return-type int) (:name "XIfEvent")) 
+(def-exported-foreign-function (xifevent (:name "XIfEvent")) 
    (dpy (:pointer display))
    (event (:pointer xevent))
    (predicate (:pointer :pointer))
@@ -793,7 +793,7 @@
    (extension int)
    (proc (:pointer :pointer)))
 
-(def-exported-foreign-function (xinstallcolormap (:return-type int) (:name "XInstallColormap")) 
+(def-exported-foreign-function (xinstallcolormap (:name "XInstallColormap")) 
    (dpy (:pointer display))
    (cmap colormap))
 
@@ -802,14 +802,14 @@
    (name (:pointer char))
    (onlyifexists int))
 
-(def-exported-foreign-function (xrefreshkeyboardmapping (:return-type int) (:name "XRefreshKeyboardMapping")) 
+(def-exported-foreign-function (xrefreshkeyboardmapping (:name "XRefreshKeyboardMapping")) 
    (event (:pointer xmappingevent)))
 
 #+ignore
 (def-exported-foreign-function (xusekeymap (:return-type int) (:name "XUseKeymap")) 
    (filename (:pointer char)))
 
-(def-exported-foreign-function (xrebindkeysym (:return-type int) (:name "XRebindKeysym")) 
+(def-exported-foreign-function (xrebindkeysym (:name "XRebindKeysym")) 
    (dpy (:pointer display))
    (keysym keysym)
    (mlist (:pointer keysym))
@@ -817,7 +817,7 @@
    (str (:pointer unsigned-char))
    (nbytes int))
 
-(def-exported-foreign-function (xkillclient (:return-type int) (:name "XKillClient")) 
+(def-exported-foreign-function (xkillclient (:name "XKillClient")) 
    (dpy (:pointer display))
    (resource xid))
 
@@ -840,7 +840,7 @@
    (dpy (:pointer display))
    (nextensions (:pointer int)))
 
-(def-exported-foreign-function (xfreeextensionlist (:return-type int) (:name "XFreeExtensionList")) 
+(def-exported-foreign-function (xfreeextensionlist (:name "XFreeExtensionList")) 
    (list (:pointer (:pointer char))))
 
 (def-exported-foreign-function (xloadfont (:return-type font) (:name "XLoadFont")) 
@@ -854,7 +854,7 @@
    (def (:pointer xcolor))
    (scr (:pointer xcolor)))
 
-(def-exported-foreign-function (xlowerwindow (:return-type int) (:name "XLowerWindow")) 
+(def-exported-foreign-function (xlowerwindow (:name "XLowerWindow")) 
    (dpy (:pointer display))
    (w window))
 
@@ -1024,7 +1024,7 @@
 (def-exported-foreign-function (xeventmaskofscreen (:return-type long) (:name "XEventMaskOfScreen")) 
    (s (:pointer screen)))
 
-(def-exported-foreign-function (xnoop (:return-type int) (:name "XNoOp")) 
+(def-exported-foreign-function (xnoop (:name "XNoOp")) 
    (dpy (:pointer display)))
 
 (def-exported-foreign-function (XParseColor (:return-type int) 
@@ -1042,19 +1042,19 @@
   (width-return (:pointer unsigned-int))
   (height-return (:pointer unsigned-int)))
 
-(def-exported-foreign-function (xmapraised (:return-type int) (:name "XMapRaised")) 
+(def-exported-foreign-function (xmapraised (:name "XMapRaised")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xmapsubwindows (:return-type int) (:name "XMapSubwindows")) 
+(def-exported-foreign-function (xmapsubwindows (:name "XMapSubwindows")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xmapwindow (:return-type int) (:name "XMapWindow")) 
+(def-exported-foreign-function (xmapwindow (:name "XMapWindow")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xmaskevent (:return-type int) (:name "XMaskEvent")) 
+(def-exported-foreign-function (xmaskevent (:name "XMaskEvent")) 
    (dpy (:pointer display))
    (mask long)
    (event (:pointer xevent)))
@@ -1068,7 +1068,7 @@
 (def-exported-foreign-function (xdisplaymotionbuffersize (:return-type unsigned-long) (:name "XDisplayMotionBufferSize")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xdisplaykeycodes (:return-type int) (:name "XDisplayKeycodes")) 
+(def-exported-foreign-function (xdisplaykeycodes (:name "XDisplayKeycodes")) 
    (dpy (:pointer display))
    (min-keycode-return (:pointer int))
    (max-keycode-return (:pointer int)))
@@ -1086,7 +1086,7 @@
 (def-exported-foreign-function (xnewmodifiermap (:return-type (:pointer xmodifierkeymap)) (:name "XNewModifiermap")) 
    (keyspermodifier int))
 
-(def-exported-foreign-function (xfreemodifiermap (:return-type void) (:name "XFreeModifiermap")) 
+(def-exported-foreign-function (xfreemodifiermap (:name "XFreeModifiermap")) 
    (map (:pointer xmodifierkeymap)))
 
 (def-exported-foreign-function (xinsertmodifiermapentry (:return-type (:pointer xmodifierkeymap)) (:name "XInsertModifiermapEntry")) 
@@ -1099,24 +1099,24 @@
    (keysym :character) ;; (keysym keycode)
    (modifier int))
 
-(def-exported-foreign-function (xmovewindow (:return-type int) (:name "XMoveWindow")) 
+(def-exported-foreign-function (xmovewindow (:name "XMoveWindow")) 
    (dpy (:pointer display))
    (w window)
    (x int)
    (y int))
 
-(def-exported-foreign-function (xnextevent (:return-type int) (:name "XNextEvent")) 
+(def-exported-foreign-function (xnextevent (:name "XNextEvent")) 
    (dpy (:pointer display))
    (event (:pointer xevent)))
 
 (def-exported-foreign-function (xopendisplay (:return-type (:pointer display)) (:name "XOpenDisplay")) 
    (display (:pointer char)))
 
-(def-exported-foreign-function (xpeekevent (:return-type int) (:name "XPeekEvent")) 
+(def-exported-foreign-function (xpeekevent (:name "XPeekEvent")) 
    (dpy (:pointer display))
    (event (:pointer xevent)))
 
-(def-exported-foreign-function (xpeekifevent (:return-type int) (:name "XPeekIfEvent")) 
+(def-exported-foreign-function (xpeekifevent (:name "XPeekIfEvent")) 
    (dpy (:pointer display))
    (event (:pointer xevent))
    (predicate (:pointer :pointer))
@@ -1129,21 +1129,21 @@
 (def-exported-foreign-function (xpending (:return-type fixnum-int) (:name "XPending")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xsetwindowbackgroundpixmap (:return-type int) (:name "XSetWindowBackgroundPixmap")) 
+(def-exported-foreign-function (xsetwindowbackgroundpixmap (:name "XSetWindowBackgroundPixmap")) 
    (dpy (:pointer display))
    (w window)
    (pixmap pixmap))
 
-(def-exported-foreign-function (xsetwindowborderpixmap (:return-type int) (:name "XSetWindowBorderPixmap")) 
+(def-exported-foreign-function (xsetwindowborderpixmap (:name "XSetWindowBorderPixmap")) 
    (dpy (:pointer display))
    (w window)
    (pixmap pixmap))
 
-(def-exported-foreign-function (xputbackevent (:return-type int) (:name "XPutBackEvent")) 
+(def-exported-foreign-function (xputbackevent (:name "XPutBackEvent")) 
    (dpy (:pointer display))
    (event (:pointer xevent)))
 
-(def-exported-foreign-function (xputimage (:return-type int) (:name "XPutImage")) 
+(def-exported-foreign-function (xputimage (:name "XPutImage")) 
    (dpy (:pointer display))
    (d drawable)
    (gc gc)
@@ -1164,12 +1164,12 @@
    (ret-width (:pointer unsigned-int))
    (ret-height (:pointer unsigned-int)))
 
-(def-exported-foreign-function (xquerycolor (:return-type int) (:name "XQueryColor")) 
+(def-exported-foreign-function (xquerycolor (:name "XQueryColor")) 
    (dpy (:pointer display))
    (cmap colormap)
    (def (:pointer xcolor)))
 
-(def-exported-foreign-function (xquerycolors (:return-type int) (:name "XQueryColors")) 
+(def-exported-foreign-function (xquerycolors (:name "XQueryColors")) 
    (dpy (:pointer display))
    (cmap colormap)
    (defs (:pointer xcolor))
@@ -1190,7 +1190,7 @@
    (first-event (:pointer int))
    (first-error (:pointer int)))
 
-(def-exported-foreign-function (xquerykeymap (:return-type int) (:name "XQueryKeymap")) 
+(def-exported-foreign-function (xquerykeymap (:name "XQueryKeymap")) 
    (dpy (:pointer display))
    (keys (:array char (32))))
 
@@ -1213,7 +1213,7 @@
    (ret-width (:pointer unsigned-int))
    (ret-height (:pointer unsigned-int)))
 
-(def-exported-foreign-function (xquerytextextents16 (:return-type int) (:name "XQueryTextExtents16")) 
+(def-exported-foreign-function (xquerytextextents16 (:name "XQueryTextExtents16")) 
    (dpy (:pointer display))
    (fid font)
    (string (:pointer xchar2b))
@@ -1223,7 +1223,7 @@
    (font-descent (:pointer int))
    (overall (:pointer xcharstruct)))
 
-(def-exported-foreign-function (xquerytextextents (:return-type int) (:name "XQueryTextExtents")) 
+(def-exported-foreign-function (xquerytextextents (:name "XQueryTextExtents")) 
    (dpy (:pointer display))
    (fid font)
    (string (:pointer char))
@@ -1249,35 +1249,35 @@
    (children (:pointer (:pointer window)))
    (nchildren (:pointer unsigned-int)))
 
-(def-exported-foreign-function (xraisewindow (:return-type int) (:name "XRaiseWindow")) 
+(def-exported-foreign-function (xraisewindow (:name "XRaiseWindow")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xrecolorcursor (:return-type int) (:name "XRecolorCursor")) 
+(def-exported-foreign-function (xrecolorcursor (:name "XRecolorCursor")) 
    (dpy (:pointer display))
    (cursor cursor)
    (foreground (:pointer xcolor))
    (background (:pointer xcolor)))
 
-(def-exported-foreign-function (xconfigurewindow (:return-type int) (:name "XConfigureWindow")) 
+(def-exported-foreign-function (xconfigurewindow (:name "XConfigureWindow")) 
    (dpy (:pointer display))
    (w window)
    (mask unsigned-int)
    (changes (:pointer xwindowchanges)))
 
-(def-exported-foreign-function (xreparentwindow (:return-type int) (:name "XReparentWindow")) 
+(def-exported-foreign-function (xreparentwindow (:name "XReparentWindow")) 
    (dpy (:pointer display))
    (w window)
    (p window)
    (x int)
    (y int))
 
-(def-exported-foreign-function (xrestackwindows (:return-type int) (:name "XRestackWindows")) 
+(def-exported-foreign-function (xrestackwindows (:name "XRestackWindows")) 
    (dpy (:pointer display))
    (windows (:pointer window))
    (n int))
 
-(def-exported-foreign-function (xrotatewindowproperties (:return-type int) (:name "XRotateWindowProperties")) 
+(def-exported-foreign-function (xrotatewindowproperties (:name "XRotateWindowProperties")) 
    (dpy (:pointer display))
    (w window)
    (properties (:pointer atom))
@@ -1296,12 +1296,12 @@
    (event-mask long)
    (event (:pointer xevent)))
 
-(def-exported-foreign-function (xsetbackground (:return-type int) (:name "XSetBackground")) 
+(def-exported-foreign-function (xsetbackground (:name "XSetBackground")) 
    (dpy (:pointer display))
    (gc gc)
    (background unsigned-long))
 
-(def-exported-foreign-function (xsetcliprectangles (:return-type int) (:name "XSetClipRectangles")) 
+(def-exported-foreign-function (xsetcliprectangles (:name "XSetClipRectangles")) 
    (dpy (:pointer display))
    (gc gc)
    (clip-x-origin int)
@@ -1310,57 +1310,57 @@
    (n int)
    (ordering int))
 
-(def-exported-foreign-function (xsetclipmask (:return-type int) (:name "XSetClipMask")) 
+(def-exported-foreign-function (xsetclipmask (:name "XSetClipMask")) 
    (dpy (:pointer display))
    (gc gc)
    (mask pixmap))
 
-(def-exported-foreign-function (xsetcliporigin (:return-type int) (:name "XSetClipOrigin")) 
+(def-exported-foreign-function (xsetcliporigin (:name "XSetClipOrigin")) 
    (dpy (:pointer display))
    (gc gc)
    (xorig int)
    (yorig int))
 
-(def-exported-foreign-function (xsetdashes (:return-type int) (:name "XSetDashes")) 
+(def-exported-foreign-function (xsetdashes (:name "XSetDashes")) 
    (dpy (:pointer display))
    (gc gc)
    (dash-offset int)
    (list (:pointer char))
    (n int))
 
-(def-exported-foreign-function (xsetfontpath (:return-type int) (:name "XSetFontPath")) 
+(def-exported-foreign-function (xsetfontpath (:name "XSetFontPath")) 
    (dpy (:pointer display))
    (directories (:pointer (:pointer char)))
    (ndirs int))
 
-(def-exported-foreign-function (xsetfont (:return-type int) (:name "XSetFont")) 
+(def-exported-foreign-function (xsetfont (:name "XSetFont")) 
    (dpy (:pointer display))
    (gc gc)
    (font font))
 
-(def-exported-foreign-function (xsetforeground (:return-type int) (:name "XSetForeground")) 
+(def-exported-foreign-function (xsetforeground (:name "XSetForeground")) 
    (dpy (:pointer display))
    (gc gc)
    (foreground unsigned-long))
 
-(def-exported-foreign-function (xsetfunction (:return-type int) (:name "XSetFunction")) 
+(def-exported-foreign-function (xsetfunction (:name "XSetFunction")) 
    (dpy (:pointer display))
    (gc gc)
    (function int))
 
-(def-exported-foreign-function (xsetcommand (:return-type int) (:name "XSetCommand")) 
+(def-exported-foreign-function (xsetcommand (:name "XSetCommand")) 
    (dpy (:pointer display))
    (w window)
    (argv (:pointer (:pointer char)))
    (argc int))
 
-(def-exported-foreign-function (xsetinputfocus (:return-type int) (:name "XSetInputFocus")) 
+(def-exported-foreign-function (xsetinputfocus (:name "XSetInputFocus")) 
    (dpy (:pointer display))
    (focus window)
    (revert-to int)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xsetlineattributes (:return-type int) (:name "XSetLineAttributes")) 
+(def-exported-foreign-function (xsetlineattributes (:name "XSetLineAttributes")) 
    (dpy (:pointer display))
    (gc gc)
    (linewidth unsigned-int)
@@ -1368,7 +1368,7 @@
    (capstyle int)
    (joinstyle int))
 
-(def-exported-foreign-function (xsetplanemask (:return-type int) (:name "XSetPlaneMask")) 
+(def-exported-foreign-function (xsetplanemask (:name "XSetPlaneMask")) 
    (dpy (:pointer display))
    (gc gc)
    (planemask unsigned-long))
@@ -1378,27 +1378,27 @@
    (map (:pointer unsigned-char))
    (nmaps int))
 
-(def-exported-foreign-function (xchangekeyboardmapping (:return-type int) (:name "XChangeKeyboardMapping")) 
+(def-exported-foreign-function (xchangekeyboardmapping (:name "XChangeKeyboardMapping")) 
    (dpy (:pointer display))
    (first-keycode int)
    (keysyms-per-keycode int)
    (keysyms (:pointer keysym))
    (nkeycodes int))
 
-(def-exported-foreign-function (xsetselectionowner (:return-type int) (:name "XSetSelectionOwner")) 
+(def-exported-foreign-function (xsetselectionowner (:name "XSetSelectionOwner")) 
    (dpy (:pointer display))
    (selection :unsigned-32bit)
    (owner window)
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xsetscreensaver (:return-type int) (:name "XSetScreenSaver")) 
+(def-exported-foreign-function (xsetscreensaver (:name "XSetScreenSaver")) 
    (dpy (:pointer display))
    (timeout int)
    (interval int)
    (prefer-blank int)
    (allow-exp int))
 
-(def-exported-foreign-function (xsetstate (:return-type int) (:name "XSetState")) 
+(def-exported-foreign-function (xsetstate (:name "XSetState")) 
    (dpy (:pointer display))
    (gc gc)
    (function int)
@@ -1406,46 +1406,46 @@
    (foreground unsigned-long)
    (background unsigned-long))
 
-(def-exported-foreign-function (xsetstipple (:return-type int) (:name "XSetStipple")) 
+(def-exported-foreign-function (xsetstipple (:name "XSetStipple")) 
    (dpy (:pointer display))
    (gc gc)
    (stipple pixmap))
 
-(def-exported-foreign-function (xsettsorigin (:return-type int) (:name "XSetTSOrigin")) 
+(def-exported-foreign-function (xsettsorigin (:name "XSetTSOrigin")) 
    (dpy (:pointer display))
    (gc gc)
    (x int)
    (y int))
 
-(def-exported-foreign-function (xsettile (:return-type int) (:name "XSetTile")) 
+(def-exported-foreign-function (xsettile (:name "XSetTile")) 
    (dpy (:pointer display))
    (gc gc)
    (tile pixmap))
 
-(def-exported-foreign-function (xstorecolor (:return-type int) (:name "XStoreColor")) 
+(def-exported-foreign-function (xstorecolor (:name "XStoreColor")) 
    (dpy (:pointer display))
    (cmap colormap)
    (def (:pointer xcolor)))
 
-(def-exported-foreign-function (xstorecolors (:return-type int) (:name "XStoreColors")) 
+(def-exported-foreign-function (xstorecolors (:name "XStoreColors")) 
    (dpy (:pointer display))
    (cmap colormap)
    (defs (:pointer xcolor))
    (ncolors int))
 
-(def-exported-foreign-function (xstorenamedcolor (:return-type int) (:name "XStoreNamedColor")) 
+(def-exported-foreign-function (xstorenamedcolor (:name "XStoreNamedColor")) 
    (dpy (:pointer display))
    (cmap colormap)
    (name (:pointer char))
    (pixel unsigned-long)
    (flags int))
 
-(def-exported-foreign-function (xstorename (:return-type int) (:name "XStoreName")) 
+(def-exported-foreign-function (xstorename (:name "XStoreName")) 
    (dpy (:pointer display))
    (w window)
    (name (:pointer char)))
 
-(def-exported-foreign-function (xseticonname (:return-type int) (:name "XSetIconName")) 
+(def-exported-foreign-function (xseticonname (:name "XSetIconName")) 
    (dpy (:pointer display))
    (w window)
    (icon-name (:pointer char)))
@@ -1456,7 +1456,7 @@
 (def-exported-foreign-function (xkeysymtostring (:return-type (:pointer char)) (:name "XKeysymToString")) 
    (ks keysym))
 
-(def-exported-foreign-function (xsync (:return-type int) (:name "XSync")) 
+(def-exported-foreign-function (xsync (:name "XSync")) 
    (dpy (:pointer display))
    (discard int))
 
@@ -1468,7 +1468,7 @@
    (dpy (:pointer display))
    (func (:pointer :pointer)))
 
-(def-exported-foreign-function (xtextextents (:return-type int) (:name "XTextExtents")) 
+(def-exported-foreign-function (xtextextents (:name "XTextExtents")) 
    (fontstruct (:pointer xfontstruct))
    (string (:pointer char))
    (nchars int)
@@ -1482,7 +1482,7 @@
    (string (:pointer char))
    (count int))
 
-(def-exported-foreign-function (xtextextents16 (:return-type int) (:name "XTextExtents16")) 
+(def-exported-foreign-function (xtextextents16 (:name "XTextExtents16")) 
    (fontstruct (:pointer xfontstruct))
    (string (:pointer xchar2b))
    (nchars int)
@@ -1506,50 +1506,50 @@
    (dst-y (:pointer int))
    (child (:pointer window)))
 
-(def-exported-foreign-function (xundefinecursor (:return-type int) (:name "XUndefineCursor")) 
+(def-exported-foreign-function (xundefinecursor (:name "XUndefineCursor")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xungrabbutton (:return-type int) (:name "XUngrabButton")) 
+(def-exported-foreign-function (xungrabbutton (:name "XUngrabButton")) 
    (dpy (:pointer display))
    (button unsigned-int)
    (modifiers unsigned-int)
    (grab-window window))
 
-(def-exported-foreign-function (xungrabkeyboard (:return-type int) (:name "XUngrabKeyboard")) 
+(def-exported-foreign-function (xungrabkeyboard (:name "XUngrabKeyboard")) 
    (dpy (:pointer display))
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xungrabkey (:return-type int) (:name "XUngrabKey")) 
+(def-exported-foreign-function (xungrabkey (:name "XUngrabKey")) 
    (dpy (:pointer display))
    (key int)
    (modifiers unsigned-int)
    (grab-window window))
 
-(def-exported-foreign-function (xungrabpointer (:return-type int) (:name "XUngrabPointer")) 
+(def-exported-foreign-function (xungrabpointer (:name "XUngrabPointer")) 
    (dpy (:pointer display))
    (time :unsigned-32bit))
 
-(def-exported-foreign-function (xungrabserver (:return-type int) (:name "XUngrabServer")) 
+(def-exported-foreign-function (xungrabserver (:name "XUngrabServer")) 
    (dpy (:pointer display)))
 
-(def-exported-foreign-function (xuninstallcolormap (:return-type int) (:name "XUninstallColormap")) 
+(def-exported-foreign-function (xuninstallcolormap (:name "XUninstallColormap")) 
    (dpy (:pointer display))
    (cmap colormap))
 
-(def-exported-foreign-function (xunloadfont (:return-type int) (:name "XUnloadFont")) 
+(def-exported-foreign-function (xunloadfont (:name "XUnloadFont")) 
    (dpy (:pointer display))
    (font font))
 
-(def-exported-foreign-function (xunmapsubwindows (:return-type int) (:name "XUnmapSubwindows")) 
+(def-exported-foreign-function (xunmapsubwindows (:name "XUnmapSubwindows")) 
    (dpy (:pointer display))
    (win window))
 
-(def-exported-foreign-function (xunmapwindow (:return-type int) (:name "XUnmapWindow")) 
+(def-exported-foreign-function (xunmapwindow (:name "XUnmapWindow")) 
    (dpy (:pointer display))
    (w window))
 
-(def-exported-foreign-function (xwarppointer (:return-type int) (:name "XWarpPointer")) 
+(def-exported-foreign-function (xwarppointer (:name "XWarpPointer")) 
    (dpy (:pointer display))
    (src-win window)
    (dest-win window)
@@ -1560,7 +1560,7 @@
    (dest-x int)
    (dest-y int))
 
-(def-exported-foreign-function (xwindowevent (:return-type int) (:name "XWindowEvent")) 
+(def-exported-foreign-function (xwindowevent (:name "XWindowEvent")) 
    (dpy (:pointer display))
    (w window)
    (mask long)
@@ -1580,7 +1580,7 @@
    (valuemask unsigned-long)
    (attributes (:pointer xsetwindowattributes)))
 
-(def-exported-foreign-function (xfree (:return-type fixnum-int) (:name "XFree")) 
+(def-exported-foreign-function (xfree (:name "XFree")) 
    (data (:pointer char)))
 
 
@@ -1618,7 +1618,7 @@
   (subimage-width unsigned-int)
   (subimage-height unsigned-int))
 
-(def-exported-foreign-macro (xaddpixel (:return-type int) (:name "XAddPixel"))
+(def-exported-foreign-macro (xaddpixel (:name "XAddPixel"))
   (ximage (:pointer ximage))
   (value long))
 
@@ -1800,7 +1800,6 @@
    (start fixnum-int)
    (end fixnum-int))
 
-
 (def-exported-foreign-function 
   (xpermalloc (:return-type (:pointer char)) 
 	      (:name "Xpermalloc"))
@@ -2016,6 +2015,6 @@
     (vinfo-return (:pointer visual-info)))
 
 
-(def-exported-foreign-function (_xflushgccache (:return-type int) (:name "_XFlushGCCache")) 
+(def-exported-foreign-function (_xflushgccache (:name "_XFlushGCCache")) 
    (dpy (:pointer display))
    (gc gc))
diff --git a/xlib/xlibsupport.c b/xlib/xlibsupport.c
index ef1e5a6c5c8981acfbcd7bb76f6d88c188336eeb..59f2b9cdaaf68c2c7adb1a570132075341353b45 100644
--- a/xlib/xlibsupport.c
+++ b/xlib/xlibsupport.c
@@ -17,7 +17,7 @@
  * 52.227-19 or DOD FAR Supplement 252 52.227-7013 (c) (1) (ii), as
  * applicable.
  *
- * $fiHeader: xlibsupport.c,v 1.3 92/12/03 10:30:54 cer Exp $
+ * $fiHeader: xlibsupport.c,v 1.4 1993/07/27 01:59:28 colin Exp $
  */
 
 /************************************************************************/
@@ -37,3 +37,4 @@ lisp_XDrawString(dpy, d, gc, x, y, string, start, end)
     XDrawString(dpy, d, gc, x, y, &string[start], end - start);
 }
 
+