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); } +