diff --git a/ChangeLog.n b/ChangeLog.n index 42bd2bac1a72add38415e4db78e943c0384af969..453891ae982c043080b58027cd6867ffe5722b91 100644 --- a/ChangeLog.n +++ b/ChangeLog.n @@ -1,3 +1,145 @@ +******************************************************************************* +Tue Jul 23 14:29:37 PDT 1996 Colin Meldrum (colin@vapor) + +Makefile.defs + Changed WNNLIB to be libwnn.a instead of ./libwnn.a - was confusing + the make rules for building a developer CLIM (slim) + +Makefile.hpprism, Makefile.sun4, Makefile.sun4-svr4 + Commented out WNNLIB=/usr/fi/X11R5/lib/libwnn.a becuase all the + libwnn stuff is part of the main clim-2.0 tree in clim-2.0/wnn + +clim/accept-values.lisp + Fixed dumb :right y-position bug in invoke-accepting-values - see + patch3502 + Fix bug in space allocation resulting in dialogs being larger than + the screen - see patch3510 + pass view-gadget-initargs to pixmap-from-menu-item in + invoke-accept-values-command-button-1 - fixes bug with background + not being set for certain classes of accept-values-command-button + - see patch3505-02 + Added support for graying out of accept-values-command-buttons in + conjunction with computed prompts in call to pixmap-from-menu-item + - see patch3505-03 +clim/drag-and-drop.lisp + rework of drag-and-drop for spr14044 and spr14290 + +clim/frames.lisp + Added a frame-manager method for graft - see patch3507 + added *graft-maximum-size-factor* - see patch3511 + +clim/gadget-output.lisp + Added :label-options and :borders initargs to views for + radio-box-view and check-box-view - see patch3505 + Added :borders initarg to views for slider-view and + toggle-button-view - see patch3504 + pass view-gadget-initargs to pixmap-from-menu-item in + accept-present-default method for radio-box-view and check-box-view + - fixes bug with background being set - see patch3505-02 + Added support for graying out of toggle button labels radio-box and + check-box-view in call to pixmap-from-menu-item - see patch3505-03 + +clim/interactive-protocol.lisp + Added default stream-scan-pointer method which calls file-position + +clim/output-protocol.lisp + Added default stream-cursor-position method to make filling-output + work on string-streams + +clim/pixmap-streams.lisp + Added support for graying out in pixmap-from-menu-item to make + CLIM gray out inactive gadgets because Motif doesn't provide the + support for graying out of pixmap labels - see patch3505-03 + Added :text-style, :background and :foreground initargs to + pixmap-from-menu-item - see changes for gadget-output.lisp and + accept-values.lisp - see patch3505-02 + +clim/tanslators.lisp + added optional use-default-args arg to write-translator-function + misc support for drag-and-drop changes. + +demo/listener.lisp + added (:pointer-documentation t) clause to lisp-listener demo + +misc/compile-1.lisp + removed #+ics check compiling 'wnn system. Change made to allow + building of non-ics developer CLIM (slim) + +silica/gadgets.lisp + Added spacing slot to row-column-gadget-mixin - see patch3506 + Changed default visible-items in compute-list-pane-selected-items + to +fill+ - see patch3508 + +silica/text-style.lisp + Addeded text-style-xxx trampoline methods for text-style + specifications given as lists - see patch3503-02 + +test/test-clim.lisp + Added a filling-output-on-string-stream-test + +test/test-suite.lisp + Extended drag and drop test to check out new :documention and + :pointer-documentation options + Added a gadget-resoure-dialog test to test the new + pixmap-from-menu-item fixes + added (:pointer-documentation t) clause to clim-tests frame + +tk/graphics.lisp + fixed bug in draw-image-string to call xdrawimagestring + +tk/macros.lisp + fixed bug in lisp-string-to-string16 to do the right thing with + byte ordering - this fixes what would otherwise be a bug with + iaclim for the dec alpha. + +tk/resources.lisp + removed bogus convert-resource-in method on (type (eql 'string)) + This was a a 4.3 ics merge bug - see patch3500 + +tk/xm-widgets.lisp + fixes bug in convert-resource-out method for xm-string in non ICS + CLIM which was breaking notify-user (and some other) dialogs + - see patch3501 + +tk-silica/xm-dialogs.lisp + Added :end-of-page-action :allow to the stream pane in a Motif + accepting-values :own-window t dialog + +tk-silica/xm-frames.lisp + fixed frame-manager-construct-menu method for motif-frame-manager + to deal with menu item sensitivity for buttons labelled with + pixmaps. CLIM now grays out the pixmap - see pixmap-from-menu-item + above in clim/pixmap-streams.lisp - see patch3505-03 + +tk-silica/xm-gadgets.lisp + Added support for :spacing initarg in find-widget-initargs-for-sheet + :around method on motif-row-column-gadget-mixin - see patch3506 + Cleaned up :list-size-policy code for motif-list-pane + find-widget-initargs-class-and-name-for-sheet method + added a gadget-visible-items for motif-list-pane method - see patch3508 + added :text-style, :background and :foreground args in call to + pixmap-from-menu-item for motif-option-pane setting and update code + - see patch3505-02 + +tk-silica/xt-silica.lisp + made font->text-style more robust in the presence of incomplete + font descriptions as provided with certain X servers + - see patch3509 + +utils/excl-verification.lisp + Changed *clim-version* to be "CLIM 2.1" This was missed for the 4.3 + release - take note! + +wnn/jserver.lisp + Changed initialize-instance :after method on jserver to call + ff:string-to-char* instead of tk::lisp-string-to-string8 so that + the wnn system can be compiled independently of xm-tk. Also in this + case it's probably safer to have the string malloc'd. + +wnn/load-wnn.lisp + Wrapped this all in an excl:ics-target-case so that developer + builds of a non ICS CLIM image (slim) work. + ******************************************************************************* 4.3.devel.17 diff --git a/Makefile.defs b/Makefile.defs index 7a354123327e119361336e12c5fe9832fde307d1..09da2a671e14f4a29bbc4cc0297452f18fbaa97f 100644 --- a/Makefile.defs +++ b/Makefile.defs @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.defs,v 1.36 1996/03/13 09:55:08 colin Exp $ +# $fiHeader: Makefile.defs,v 1.37 1996/03/15 05:17:58 colin Exp $ # # Makefile.defs for CLIM 2.0 # @@ -103,7 +103,7 @@ SHARED-XM-OBJS= climxm.so STATIC-OL-OBJS= stub-olit.o olsupport.o SHARED-OL-OBJS= climol.so -WNNLIB = ./libwnn.a +WNNLIB = libwnn.a STATIC-WNN-OBJS=stub-wnn.o $(WNNLIB) # The default is for statically linked Motif diff --git a/Makefile.hpprism b/Makefile.hpprism index d788cfe0206e5e1d52aa6e16913ff9990e061be6..644eb35f43f1dca51f2e21307ea6e32f62233596 100644 --- a/Makefile.hpprism +++ b/Makefile.hpprism @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.hpprism,v 1.8 1995/10/20 17:36:08 colin Exp $ +# $fiHeader: Makefile.hpprism,v 1.9 1996/03/13 09:55:12 colin Exp $ # # Makefile.hpprism for CLIM 2.0 # @@ -18,9 +18,6 @@ TKLIB=/usr/lib/Motif1.2/libXm.a XTLIB=/usr/lib/X11R5/libXt.a XLIB=/usr/lib/X11R5/libX11.a -# not needed anymore - we make libwnn.a in clim-2.0 -#WNNLIB=/usr/fi/X11R5/lib/libwnn.a - XINCLUDES= -I/usr/include/Motif1.2 -I/usr/include/X11R5 include Makefile.generic diff --git a/Makefile.sun4 b/Makefile.sun4 index 3201d73d160b0a88b084e48827721ac4be70e5a6..05252dfd754f9f00e150771eb1156364b9a571cc 100644 --- a/Makefile.sun4 +++ b/Makefile.sun4 @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.sun4,v 1.13 1996/03/13 09:55:17 colin Exp $ +# $fiHeader: Makefile.sun4,v 1.14 1996/03/15 05:18:05 colin Exp $ # # Makefile.sun4 for CLIM 2.0 # @@ -17,7 +17,5 @@ XLIB=/net/louie/malle/colin/X11R5/Ximp-libs/libX11.a AR = ar cq -# not needed anymore - we make libwnn.a in clim-2.0 -#WNNLIB=/usr/fi/X11R5/lib/libwnn.a include Makefile.generic diff --git a/Makefile.sun4-svr4 b/Makefile.sun4-svr4 index 44b06a90d43248599e69782f0cebc0259eadfe96..f80fe5b5ff674eeb2308f3aef2fbd523e8226d2a 100644 --- a/Makefile.sun4-svr4 +++ b/Makefile.sun4-svr4 @@ -1,4 +1,4 @@ -# $fiHeader: Makefile.sun4-svr4,v 1.10 1996/03/01 05:41:34 colin Exp $ +# $fiHeader: Makefile.sun4-svr4,v 1.11 1996/03/13 09:55:19 colin Exp $ # # Makefile.sun4-svr4 for CLIM 2.0 # @@ -17,9 +17,6 @@ TKLIB=-lXm XTLIB=-lXt XLIB=-lX11 -# not needed anymore - we make libwnn.a in clim-2.0 -#WNNLIB=/net/ultra/export/home/colin/X11R6/contrib/programs/Xsi/Wnn/jlib/libwnn.a - SET_LIBRARY_PATH= \ LD_LIBRARY_PATH=/usr/dt/lib:/usr/openwin/lib:/usr/lib; export LD_LIBRARY_PATH diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 899a77600916c31bcff70b3ec667d16255d33985..8365e39714602e42a1417d8a1acbcc47e8fe3074 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.77 1995/10/17 05:01:12 colin Exp $ +;; $fiHeader: accept-values.lisp,v 1.78 1996/03/01 05:41:48 colin Exp $ (in-package :clim-internals) @@ -11,7 +11,7 @@ ;;; For historical reasons "AVV" means "accepting-values"... (defclass accept-values-stream - (standard-encapsulating-stream) + (standard-encapsulating-stream) ((avv-record :initform nil) (avv-frame :initform nil) (align-prompts :initform nil :initarg :align-prompts))) @@ -21,7 +21,7 @@ (defvar *current-accept-values-tick* 0) (defclass accept-values-output-record - (standard-sequence-output-record) + (standard-sequence-output-record) ((query-table :initarg :query-table) (tick :initform *current-accept-values-tick*) (resynchronize :initform nil)) @@ -42,22 +42,22 @@ (defclass accept-values-query () ((query-identifier :initarg :query-identifier) (presentation-type :initarg :presentation-type - :reader accept-values-query-type) + :reader accept-values-query-type) (value :initarg :value - :accessor accept-values-query-value) + :accessor accept-values-query-value) (presentation :initarg :presentation - :accessor accept-values-query-presentation) + :accessor accept-values-query-presentation) (changed-p :initform nil - :accessor accept-values-query-changed-p) + :accessor accept-values-query-changed-p) (active-p :initform t - :accessor accept-values-query-active-p) + :accessor accept-values-query-active-p) (error-p :initform nil - :accessor accept-values-query-error-p)) + :accessor accept-values-query-error-p)) (:default-initargs :presentation nil)) (defresource accept-values-stream (stream &key align-prompts) :constructor (make-instance 'accept-values-stream :stream stream) - :matcher 't ;any will suffice + :matcher 't ;any will suffice :initializer (progn (setf (slot-value accept-values-stream 'stream) stream) @@ -70,10 +70,10 @@ (return record)))) (defmethod prompt-for-accept :around ((stream accept-values-stream) type (view view) - &rest accept-args - &key query-identifier (prompt t) (display-default nil) - (active-p t) - &allow-other-keys) + &rest accept-args + &key query-identifier (prompt t) (display-default nil) + (active-p t) + &allow-other-keys) (declare (dynamic-extent accept-args)) ;;--- When ACTIVE-P is NIL, this should do some sort of "graying out" (declare (ignore active-p)) @@ -84,175 +84,175 @@ (setq query-identifier (list ':query-identifier prompt type))) (when (or prompt display-default) (updating-output (stream :unique-id (list :prompt query-identifier) - :id-test #'equal - :cache-value prompt) + :id-test #'equal + :cache-value prompt) (with-keywords-removed (prompt-args accept-args '(:display-default :query-identifier)) - ;; Explicitly pass DISPLAY-DEFAULT so that if it is not supplied by the - ;; user, we forcibly default it to NIL, which gives better-looking AVVs. - (apply #'call-next-method stream type view - :display-default display-default - :query-identifier query-identifier - prompt-args)))) + ;; Explicitly pass DISPLAY-DEFAULT so that if it is not supplied by the + ;; user, we forcibly default it to NIL, which gives better-looking AVVs. + (apply #'call-next-method stream type view + :display-default display-default + :query-identifier query-identifier + prompt-args)))) query-identifier) (defmethod prompt-for-accept ((stream accept-values-stream) type view - &rest accept-args - &key query-identifier &allow-other-keys) + &rest accept-args + &key query-identifier &allow-other-keys) ;; This does nothing, the gadget ACCEPT methods should provide a label (unless (gadget-includes-prompt-p type stream view) (call-next-method)) query-identifier) (defmethod stream-accept ((stream accept-values-stream) type - &rest accept-args - &key (prompt t) query-identifier (default nil default-supplied-p) - (view (stream-default-view stream)) (active-p t) - &allow-other-keys) + &rest accept-args + &key (prompt t) query-identifier (default nil default-supplied-p) + (view (stream-default-view stream)) (active-p t) + &allow-other-keys) (declare (dynamic-extent accept-args)) ;;--- When ACTIVE-P is NIL, this should do some sort of "graying out" (let ((align-prompts (slot-value stream 'align-prompts)) query) (cond (align-prompts - ;; The user has asked to line up the labels, so oblige him - (updating-output (stream :unique-id (cons '#:accept (or query-identifier prompt)) - :id-test #'equal) - (formatting-row (stream) - (formatting-cell (stream :align-x align-prompts) - (setq query-identifier - (apply #'prompt-for-accept - (encapsulating-stream stream) type view accept-args))) - (letf-globally (((slot-value stream 'align-prompts) nil)) - (formatting-cell (stream :align-x :left) - (setq query (find-or-add-query stream query-identifier type prompt - default default-supplied-p view active-p))))))) - (t - (setq query-identifier - (apply #'prompt-for-accept - (encapsulating-stream stream) type view accept-args)) - (setq query (find-or-add-query stream query-identifier type prompt - default default-supplied-p view active-p)))) + ;; The user has asked to line up the labels, so oblige him + (updating-output (stream :unique-id (cons '#:accept (or query-identifier prompt)) + :id-test #'equal) + (formatting-row (stream) + (formatting-cell (stream :align-x align-prompts) + (setq query-identifier + (apply #'prompt-for-accept + (encapsulating-stream stream) type view accept-args))) + (letf-globally (((slot-value stream 'align-prompts) nil)) + (formatting-cell (stream :align-x :left) + (setq query (find-or-add-query stream query-identifier type prompt + default default-supplied-p view active-p))))))) + (t + (setq query-identifier + (apply #'prompt-for-accept + (encapsulating-stream stream) type view accept-args)) + (setq query (find-or-add-query stream query-identifier type prompt + default default-supplied-p view active-p)))) (values (accept-values-query-value query) - (accept-values-query-type query) - ;; Set this to NIL so that it appears that nothing has - ;; changed at the start of the next pass. - (prog1 (accept-values-query-changed-p query) - (setf (accept-values-query-changed-p query) nil))))) + (accept-values-query-type query) + ;; Set this to NIL so that it appears that nothing has + ;; changed at the start of the next pass. + (prog1 (accept-values-query-changed-p query) + (setf (accept-values-query-changed-p query) nil))))) ;; Probably should be keyword arguments... (defmethod find-or-add-query ((stream accept-values-stream) query-identifier ptype prompt - default default-supplied-p view active-p) + default default-supplied-p view active-p) (let ((avv-record (slot-value stream 'avv-record))) (with-slots (query-table) avv-record (multiple-value-bind (query found-p) - (gethash query-identifier query-table) - (unless query - (setq query (make-instance 'accept-values-query - :presentation-type ptype - :value default - :query-identifier query-identifier))) - (setf (accept-values-query-active-p query) active-p) - ;;--- Really wants to reuse existing presentation if found and - ;;--- make sure that that presentation gets re-parented if necessary - ;;--- (suppose inside FORMATTING TABLE...) - (setf (accept-values-query-presentation query) - (updating-output - (stream :unique-id query-identifier - ;;-- If the old-style text field value is - ;;-- unchanged then we need this hack - :all-new (and (not (typep view 'actual-gadget-view)) - (accept-values-query-changed-p query)) - :id-test #'equal - :cache-value (list (if (accept-values-query-changed-p query) - (accept-values-query-value query) - default) - ptype - active-p) - :cache-test #'(lambda (x y) - (unless (accept-values-query-changed-p query) - (equal x y)))) - ;;--- Calling ACCEPT-1 directly bypasses default preprocessing, - ;;--- is that OK? - (cond ((or default-supplied-p (accept-values-query-changed-p query)) - (accept-1 stream ptype - :view view :prompt prompt - ;; If this field changed, use the value it changed to, - ;; making sure that the query object gets changed, too. - ;; We need to do this because the body of the dialog - ;; can change values without changing the query itself. - :default (if (accept-values-query-changed-p query) - (accept-values-query-value query) - (setf (accept-values-query-error-p query) nil - (accept-values-query-value query) default)) - :history ptype - :present-p `(accept-values-choice ,query) - :query-identifier query - :active-p active-p)) - ((and found-p - (presentation-typep (accept-values-query-value query) ptype)) - ;; The programmer supplied no default, but a previous edit - ;; has put something in the query that we now must use as - ;; the default. - (accept-1 stream ptype - :view view :prompt prompt - :default (accept-values-query-value query) - :history ptype - :present-p `(accept-values-choice ,query) - :query-identifier query - :active-p active-p)) - (t - ;; No default supplied, field has never been edited. - (accept-1 stream ptype - :view view :prompt prompt - :history ptype :provide-default nil - :present-p `(accept-values-choice ,query) - :query-identifier query - :active-p active-p))))) - ;; really wants to move the cursor position to some reasonable - ;; place in case we're just reusing an existing presentation - (unless found-p - (setf (gethash query-identifier query-table) query)) - query)))) + (gethash query-identifier query-table) + (unless query + (setq query (make-instance 'accept-values-query + :presentation-type ptype + :value default + :query-identifier query-identifier))) + (setf (accept-values-query-active-p query) active-p) + ;;--- Really wants to reuse existing presentation if found and + ;;--- make sure that that presentation gets re-parented if necessary + ;;--- (suppose inside FORMATTING TABLE...) + (setf (accept-values-query-presentation query) + (updating-output + (stream :unique-id query-identifier + ;;-- If the old-style text field value is + ;;-- unchanged then we need this hack + :all-new (and (not (typep view 'actual-gadget-view)) + (accept-values-query-changed-p query)) + :id-test #'equal + :cache-value (list (if (accept-values-query-changed-p query) + (accept-values-query-value query) + default) + ptype + active-p) + :cache-test #'(lambda (x y) + (unless (accept-values-query-changed-p query) + (equal x y)))) + ;;--- Calling ACCEPT-1 directly bypasses default preprocessing, + ;;--- is that OK? + (cond ((or default-supplied-p (accept-values-query-changed-p query)) + (accept-1 stream ptype + :view view :prompt prompt + ;; If this field changed, use the value it changed to, + ;; making sure that the query object gets changed, too. + ;; We need to do this because the body of the dialog + ;; can change values without changing the query itself. + :default (if (accept-values-query-changed-p query) + (accept-values-query-value query) + (setf (accept-values-query-error-p query) nil + (accept-values-query-value query) default)) + :history ptype + :present-p `(accept-values-choice ,query) + :query-identifier query + :active-p active-p)) + ((and found-p + (presentation-typep (accept-values-query-value query) ptype)) + ;; The programmer supplied no default, but a previous edit + ;; has put something in the query that we now must use as + ;; the default. + (accept-1 stream ptype + :view view :prompt prompt + :default (accept-values-query-value query) + :history ptype + :present-p `(accept-values-choice ,query) + :query-identifier query + :active-p active-p)) + (t + ;; No default supplied, field has never been edited. + (accept-1 stream ptype + :view view :prompt prompt + :history ptype :provide-default nil + :present-p `(accept-values-choice ,query) + :query-identifier query + :active-p active-p))))) + ;; really wants to move the cursor position to some reasonable + ;; place in case we're just reusing an existing presentation + (unless found-p + (setf (gethash query-identifier query-table) query)) + query)))) ;;--- It seems a little bizarre having a prompt argument, but we can't ;;--- think of a better way. (defmethod stream-present ((stream accept-values-stream) object presentation-type - &rest present-args - &key view (prompt nil prompt-p) (query-identifier nil) - &allow-other-keys) + &rest present-args + &key view (prompt nil prompt-p) (query-identifier nil) + &allow-other-keys) (declare (dynamic-extent present-args)) (declare (ignore prompt)) (unless prompt-p ;; This is the normal, non-gadget case of doing PRESENT (return-from stream-present (call-next-method))) (flet ((do-present (stream) - (updating-output (stream :unique-id query-identifier - :id-test #'equal - :cache-value object - :cache-test #'equal) - stream - ;;--- We did this because (SEQUENCE INTEGER) reinvoked - ;;--- PRESENT with the prompt for each of components of - ;;--- the stream, which ended up back here creating badly - ;;--- identified updating-output records. - (apply #'stream-present (encapsulating-stream-stream stream) - object presentation-type present-args)))) + (updating-output (stream :unique-id query-identifier + :id-test #'equal + :cache-value object + :cache-test #'equal) + stream + ;;--- We did this because (SEQUENCE INTEGER) reinvoked + ;;--- PRESENT with the prompt for each of components of + ;;--- the stream, which ended up back here creating badly + ;;--- identified updating-output records. + (apply #'stream-present (encapsulating-stream-stream stream) + object presentation-type present-args)))) (declare (dynamic-extent #'do-present)) (let ((align-prompts (slot-value stream 'align-prompts))) (cond (align-prompts - ;; The user has asked to line up the labels, so oblige him - (formatting-row (stream) - (formatting-cell (stream :align-x align-prompts) - (setq query-identifier - (apply #'prompt-for-accept (encapsulating-stream stream) - presentation-type view present-args))) - (formatting-cell (stream :align-x :left) - (do-present stream)))) - (t - (setq query-identifier - (apply #'prompt-for-accept (encapsulating-stream stream) - presentation-type view present-args)) - (do-present stream))))) + ;; The user has asked to line up the labels, so oblige him + (formatting-row (stream) + (formatting-cell (stream :align-x align-prompts) + (setq query-identifier + (apply #'prompt-for-accept (encapsulating-stream stream) + presentation-type view present-args))) + (formatting-cell (stream :align-x :left) + (do-present stream)))) + (t + (setq query-identifier + (apply #'prompt-for-accept (encapsulating-stream stream) + presentation-type view present-args)) + (do-present stream))))) (values object)) @@ -281,40 +281,40 @@ (align-prompts :initform nil :initarg :align-prompts)) (:pane (let ((frame *application-frame*) - panes) + panes) (with-slots (stream own-window exit-button-stream scroll-bars align-prompts) frame - (multiple-value-setq (panes own-window exit-button-stream) - (frame-manager-construct-avv-panes - frame (frame-manager frame))) - (setq stream (make-instance 'accept-values-stream - :align-prompts align-prompts - :stream own-window)) - panes))) + (multiple-value-setq (panes own-window exit-button-stream) + (frame-manager-construct-avv-panes + frame (frame-manager frame))) + (setq stream (make-instance 'accept-values-stream + :align-prompts align-prompts + :stream own-window)) + panes))) (:menu-bar nil) (:top-level (accept-values-top-level)) (:command-table accept-values) (:command-definer nil)) (defmethod frame-manager-construct-avv-panes ((frame accept-values-own-window) - (framem standard-frame-manager)) + (framem standard-frame-manager)) (let (exit-button-stream own-window) (values (with-look-and-feel-realization (framem frame) (with-slots (scroll-bars) frame - (vertically () - (outlining () - (progn - (setq own-window - (make-pane 'clim-stream-pane - :initial-cursor-visibility :off - :end-of-page-action :allow)) - (if scroll-bars - (scrolling (:scroll-bars scroll-bars) own-window) - own-window))) - (outlining () - (setf exit-button-stream - (make-pane 'clim-stream-pane - :initial-cursor-visibility nil)))))) + (vertically () + (outlining () + (progn + (setq own-window + (make-pane 'clim-stream-pane + :initial-cursor-visibility :off + :end-of-page-action :allow)) + (if scroll-bars + (scrolling (:scroll-bars scroll-bars) own-window) + own-window))) + (outlining () + (setf exit-button-stream + (make-pane 'clim-stream-pane + :initial-cursor-visibility nil)))))) own-window exit-button-stream))) @@ -326,7 +326,7 @@ '((:abort) (:exit))) (defmethod frame-manager-exit-box-labels - ((framem standard-frame-manager) frame view) + ((framem standard-frame-manager) frame view) (declare (ignore frame view)) '((:exit "Exit") (:abort "Cancel"))) @@ -336,283 +336,287 @@ (defun invoke-accepting-values (stream continuation - &key frame-class command-table - own-window background foreground text-style - (exit-boxes - (frame-manager-default-exit-boxes - (frame-manager stream))) - (resize-frame nil) (scroll-bars nil) - (initially-select-query-identifier nil) - (modify-initial-query nil) align-prompts - (resynchronize-every-pass nil) (check-overlapping t) - label x-position y-position - width height (right-margin 10) (bottom-margin 10) - view) + &key frame-class command-table + own-window background foreground text-style + (exit-boxes + (frame-manager-default-exit-boxes + (frame-manager stream))) + (resize-frame nil) (scroll-bars nil) + (initially-select-query-identifier nil) + (modify-initial-query nil) align-prompts + (resynchronize-every-pass nil) (check-overlapping t) + label x-position y-position + width height (right-margin 10) (bottom-margin 10) + view) (incf *accept-values-tick*) (setq align-prompts (ecase align-prompts - ((t :right) :right) - ((:left) :left) - ((nil) nil))) + ((t :right) :right) + ((:left) :left) + ((nil) nil))) (let ((frame-manager (frame-manager stream)) - (*current-accept-values-tick* *accept-values-tick*) - (the-own-window nil)) + (*current-accept-values-tick* *accept-values-tick*) + (the-own-window nil)) ;; Create the AVV, run it, and return its values (if own-window - (let ((frame (make-application-frame - (or frame-class - (frame-manager-accepting-values-frame-class - frame-manager)) - ;;--- What is the correct thing here? - :calling-frame (or (and (typep stream '(or basic-pane standard-encapsulating-stream)) - (pane-frame stream)) - *application-frame*) - :input-buffer (and (typep stream '(or input-protocol-mixin standard-encapsulating-stream)) - (stream-input-buffer stream)) - :frame-manager frame-manager - :pretty-name label - :continuation continuation - :exit-boxes exit-boxes - :own-window the-own-window - :own-window-properties (list x-position y-position - width height - right-margin bottom-margin) - :left x-position :right y-position - :initially-select-query-identifier - (and initially-select-query-identifier - (cons initially-select-query-identifier modify-initial-query)) - :resynchronize-every-pass resynchronize-every-pass - :check-overlapping check-overlapping - :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 - (setf (frame-command-table frame) command-table)) - (unwind-protect - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame)) - ;; Flush it so the GC can get rid of it - (destroy-frame frame))) - (using-resource (avv-stream accept-values-stream (or the-own-window stream) - :align-prompts align-prompts) - (let ((frame (make-application-frame (or frame-class 'accept-values) - :calling-frame *application-frame* - :stream avv-stream - :continuation continuation - :exit-boxes exit-boxes - :initially-select-query-identifier - (and initially-select-query-identifier - (cons initially-select-query-identifier modify-initial-query)) - :resynchronize-every-pass resynchronize-every-pass - :check-overlapping check-overlapping - ;; This frame won't necessarily be adopted, so make - ;; sure that we share the sheet with the parent frame - ;; in the case of "inlined" dialogs - :top-level-sheet (frame-top-level-sheet - *application-frame*) - :view view))) - (when command-table - (setf (frame-command-table frame) command-table)) - (unwind-protect - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame)) - ;; Since this frame isn't really adopted, we don't really want - ;; to disown it since that will end up disowning the calling - ;; frame. Flush it from the frame manager manually. Barf. - (let ((framem (frame-manager frame))) - (setf (frame-manager-frames framem) - (delete frame (frame-manager-frames framem)) - (slot-value frame 'frame-manager) nil)))))))) + (let ((frame (make-application-frame + (or frame-class + (frame-manager-accepting-values-frame-class + frame-manager)) + ;;--- What is the correct thing here? + :calling-frame (or (and (typep stream '(or basic-pane standard-encapsulating-stream)) + (pane-frame stream)) + *application-frame*) + :input-buffer (and (typep stream '(or input-protocol-mixin standard-encapsulating-stream)) + (stream-input-buffer stream)) + :frame-manager frame-manager + :pretty-name label + :continuation continuation + :exit-boxes exit-boxes + :own-window the-own-window + :own-window-properties (list x-position y-position + width height + right-margin bottom-margin) + :left x-position :top y-position + :initially-select-query-identifier + (and initially-select-query-identifier + (cons initially-select-query-identifier modify-initial-query)) + :resynchronize-every-pass resynchronize-every-pass + :check-overlapping check-overlapping + :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 + (setf (frame-command-table frame) command-table)) + (unwind-protect + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame)) + ;; Flush it so the GC can get rid of it + (destroy-frame frame))) + (using-resource (avv-stream accept-values-stream (or the-own-window stream) + :align-prompts align-prompts) + (let ((frame (make-application-frame (or frame-class 'accept-values) + :calling-frame *application-frame* + :stream avv-stream + :continuation continuation + :exit-boxes exit-boxes + :initially-select-query-identifier + (and initially-select-query-identifier + (cons initially-select-query-identifier modify-initial-query)) + :resynchronize-every-pass resynchronize-every-pass + :check-overlapping check-overlapping + ;; This frame won't necessarily be adopted, so make + ;; sure that we share the sheet with the parent frame + ;; in the case of "inlined" dialogs + :top-level-sheet (frame-top-level-sheet + *application-frame*) + :view view))) + (when command-table + (setf (frame-command-table frame) command-table)) + (unwind-protect + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame)) + ;; Since this frame isn't really adopted, we don't really want + ;; to disown it since that will end up disowning the calling + ;; frame. Flush it from the frame manager manually. Barf. + (let ((framem (frame-manager frame))) + (setf (frame-manager-frames framem) + (delete frame (frame-manager-frames framem)) + (slot-value frame 'frame-manager) nil)))))))) (defvar *editting-field-p* nil) (defmethod accept-values-top-level ((frame accept-values) &rest args) (declare (ignore args)) (with-slots (stream continuation resynchronize-every-pass check-overlapping - selected-item initially-select-query-identifier - own-window own-window-properties exit-button-stream view) frame + selected-item initially-select-query-identifier + own-window own-window-properties exit-button-stream view) frame (let* ((original-view (stream-default-view stream)) - (return-values nil) - (initial-query nil) - exit-button-record - avv avv-record - (align-prompts (slot-value stream 'align-prompts)) - (properties own-window-properties) - (own-window-x-position (pop properties)) - (own-window-y-position (pop properties)) - (own-window-width (pop properties)) - (own-window-height (pop properties)) - (own-window-right-margin (pop properties)) - (own-window-bottom-margin (pop properties)) - (view - (or view - (frame-manager-dialog-view (frame-manager frame)))) - (*editting-field-p* nil)) + (return-values nil) + (initial-query nil) + exit-button-record + avv avv-record + (align-prompts (slot-value stream 'align-prompts)) + (properties own-window-properties) + (own-window-x-position (pop properties)) + (own-window-y-position (pop properties)) + (own-window-width (pop properties)) + (own-window-height (pop properties)) + (own-window-right-margin (pop properties)) + (own-window-bottom-margin (pop properties)) + (view + (or view + (frame-manager-dialog-view (frame-manager frame)))) + (*editting-field-p* nil)) (letf-globally (((stream-default-view stream) view) - ((stream-read-gesture-cursor-state stream) nil)) - (labels ((run-continuation (stream avv-record) - (setf (slot-value stream 'avv-record) avv-record) - (setf (slot-value stream 'avv-frame) frame) - (with-output-recording-options (stream :draw nil :record t) - (let ((*application-frame* *avv-calling-frame*)) - (if align-prompts - ;; Use of FORMATTING-TABLE here implies that - ;; no output should be done by the user code - ;; outside of calls to FORMATTING-ROW and - ;; FORMATTING-CELL. Too bad. - (formatting-table (stream) - (setq return-values - (multiple-value-list - (funcall continuation - stream)))) - (progn - (display-view-background stream view) - (setq return-values - (multiple-value-list - (funcall continuation stream)))))) - (unless own-window - (display-exit-boxes frame stream - (stream-default-view stream))))) - (run-avv () - (and initially-select-query-identifier - (setq initial-query - (find-query avv-record - (car initially-select-query-identifier))) - (move-focus-to-query stream - initial-query - (not (cdr initially-select-query-identifier))) - ;; only do the redisplay if move-focus-to-query - ;; returns t - ie for the non-gadget case - (redisplay avv stream :check-overlapping check-overlapping)) - (loop - (let ((command - (let ((command-stream (encapsulating-stream-stream stream))) - ;; While we're reading commands, restore the view - ;; to what it was before we started. - (letf-globally (((stream-default-view command-stream) - original-view)) - (read-frame-command frame :stream command-stream))))) - (if (and command (not (keyboard-event-p command))) - (execute-frame-command frame command) - (beep stream))) - (with-deferred-gadget-updates - (when (or resynchronize-every-pass - (slot-value avv-record 'resynchronize)) - ;; When the user has asked to resynchronize every pass, that - ;; means we should run the continuation an extra time to see - ;; that all visible stuff is up to date. That's all! - (with-output-recording-options (stream :draw nil) - (redisplay avv stream :check-overlapping - check-overlapping))) - (setf (slot-value avv-record 'resynchronize) nil) - (when exit-button-record - (redisplay exit-button-record exit-button-stream)) - (redisplay avv stream :check-overlapping check-overlapping) - (when (ecase (frame-resizable frame) - ((nil) nil) - ((t :grow) - (and own-window - (multiple-value-bind (width height) - (bounding-rectangle-size - (stream-output-history own-window)) - (multiple-value-bind (vwidth vheight) - (bounding-rectangle-size - (window-viewport own-window)) - (if (eq (frame-resizable frame) :grow) - (or (> width vwidth) (> height vheight)) - (or (/= width vwidth) (/= height vheight)))))))) - (size-panes-appropriately))))) - (size-panes-appropriately () - (changing-space-requirements (:layout t) - ;; We really want to specify the min/max sizes of - ;; the exit-button pane also - (when exit-button-stream - (size-frame-from-contents exit-button-stream - :size-setter + ((stream-read-gesture-cursor-state stream) nil)) + (labels ((run-continuation (stream avv-record) + (setf (slot-value stream 'avv-record) avv-record) + (setf (slot-value stream 'avv-frame) frame) + (with-output-recording-options (stream :draw nil :record t) + (let ((*application-frame* *avv-calling-frame*)) + (if align-prompts + ;; Use of FORMATTING-TABLE here implies that + ;; no output should be done by the user code + ;; outside of calls to FORMATTING-ROW and + ;; FORMATTING-CELL. Too bad. + (formatting-table (stream) + (setq return-values + (multiple-value-list + (funcall continuation + stream)))) + (progn + (display-view-background stream view) + (setq return-values + (multiple-value-list + (funcall continuation stream)))))) + (unless own-window + (display-exit-boxes frame stream + (stream-default-view stream))))) + (run-avv () + (and initially-select-query-identifier + (setq initial-query + (find-query avv-record + (car initially-select-query-identifier))) + (move-focus-to-query stream + initial-query + (not (cdr initially-select-query-identifier))) + ;; only do the redisplay if move-focus-to-query + ;; returns t - ie for the non-gadget case + (redisplay avv stream :check-overlapping check-overlapping)) + (loop + (let ((command + (let ((command-stream (encapsulating-stream-stream stream))) + ;; While we're reading commands, restore the view + ;; to what it was before we started. + (letf-globally (((stream-default-view command-stream) + original-view)) + (read-frame-command frame :stream command-stream))))) + (if (and command (not (keyboard-event-p command))) + (execute-frame-command frame command) + (beep stream))) + (with-deferred-gadget-updates + (when (or resynchronize-every-pass + (slot-value avv-record 'resynchronize)) + ;; When the user has asked to resynchronize every pass, that + ;; means we should run the continuation an extra time to see + ;; that all visible stuff is up to date. That's all! + (with-output-recording-options (stream :draw nil) + (redisplay avv stream :check-overlapping + check-overlapping))) + (setf (slot-value avv-record 'resynchronize) nil) + (when exit-button-record + (redisplay exit-button-record exit-button-stream)) + (redisplay avv stream :check-overlapping check-overlapping) + (when (ecase (frame-resizable frame) + ((nil) nil) + ((t :grow) + (and own-window + (multiple-value-bind (width height) + (bounding-rectangle-size + (stream-output-history own-window)) + (multiple-value-bind (vwidth vheight) + (bounding-rectangle-size + (window-viewport own-window)) + (if (eq (frame-resizable frame) :grow) + (or (> width vwidth) (> height vheight)) + (or (/= width vwidth) (/= height vheight)))))))) + (size-panes-appropriately))))) + (size-panes-appropriately () + (changing-space-requirements (:layout t) + ;; We really want to specify the min/max sizes of + ;; the exit-button pane also + (when exit-button-stream + (size-frame-from-contents exit-button-stream + :size-setter + #'(lambda (pane w h) + (setf w (max w 1) h (max h 1)) + (change-space-requirements pane + :width w :min-width w :max-width w + :height h :min-height h :max-height h)) + :right-margin 0 + :bottom-margin 0)) + (when own-window + (size-frame-from-contents own-window + :size-setter #'(lambda (pane w h) - (change-space-requirements pane - :width w :min-width w :max-width w - :height h :min-height h :max-height h)) - :right-margin 0 - :bottom-margin 0)) - (when own-window - (size-frame-from-contents own-window - :size-setter - #'(lambda (pane w h) - (change-space-requirements pane - :width w :min-width w :max-width w - :height h :min-height h :max-height h - :resize-frame t)) + (change-space-requirements + pane + ;; only use the min-xxx if explicitly specified + ;; in call to accepting-values (cim 7/12/96) + :width w :min-width (and own-window-width w) + :height h :min-height (and own-window-height h) + :resize-frame t)) :width own-window-width - :height own-window-height - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin))))) - (declare (dynamic-extent #'run-continuation #'run-avv - #'size-panes-appropriately)) - (handler-bind ((frame-exit - #'(lambda (condition) - (let ((exit-frame (frame-exit-frame condition))) - (when (eq frame exit-frame) - (return-from accept-values-top-level - (values-list return-values))))))) - (setq avv - (updating-output (stream) - (setq avv-record - (with-end-of-line-action (stream :allow) - (with-end-of-page-action (stream :allow) - (with-new-output-record - (stream 'accept-values-output-record avv-record) - (run-continuation stream avv-record))))))) - ;; In own window dialogs the buttons are displayed separately - (when (and own-window exit-button-stream) - (setq exit-button-record - (updating-output (exit-button-stream) - (with-end-of-line-action (exit-button-stream :allow) - (with-end-of-page-action (exit-button-stream :allow) - (display-exit-boxes frame exit-button-stream - (stream-default-view stream))))))) - (unwind-protect - (cond (own-window - (size-panes-appropriately) - (frame-manager-position-dialog - (frame-manager frame) - frame - own-window-x-position own-window-y-position) - (setf (window-visibility own-window) t) - (with-input-focus (own-window) - (when exit-button-record - (replay exit-button-record exit-button-stream)) - (replay avv stream) - (run-avv))) - (t - ;; Ensure that bottom of the AVV is visible. I think that - ;; this is OK even if the AVV is bigger than the viewport. - (move-cursor-beyond-output-record - (encapsulating-stream-stream stream) avv) - (stream-ensure-cursor-visible stream) - (replay avv stream) - (run-avv))) - (unless own-window - (deactivate-all-gadgets avv-record) - (move-cursor-beyond-output-record - (encapsulating-stream-stream stream) avv))))))))) + :height own-window-height + :right-margin own-window-right-margin + :bottom-margin own-window-bottom-margin))))) + (declare (dynamic-extent #'run-continuation #'run-avv + #'size-panes-appropriately)) + (handler-bind ((frame-exit + #'(lambda (condition) + (let ((exit-frame (frame-exit-frame condition))) + (when (eq frame exit-frame) + (return-from accept-values-top-level + (values-list return-values))))))) + (setq avv + (updating-output (stream) + (setq avv-record + (with-end-of-line-action (stream :allow) + (with-end-of-page-action (stream :allow) + (with-new-output-record + (stream 'accept-values-output-record avv-record) + (run-continuation stream avv-record))))))) + ;; In own window dialogs the buttons are displayed separately + (when (and own-window exit-button-stream) + (setq exit-button-record + (updating-output (exit-button-stream) + (with-end-of-line-action (exit-button-stream :allow) + (with-end-of-page-action (exit-button-stream :allow) + (display-exit-boxes frame exit-button-stream + (stream-default-view stream))))))) + (unwind-protect + (cond (own-window + (size-panes-appropriately) + (frame-manager-position-dialog + (frame-manager frame) + frame + own-window-x-position own-window-y-position) + (setf (window-visibility own-window) t) + (with-input-focus (own-window) + (when exit-button-record + (replay exit-button-record exit-button-stream)) + (replay avv stream) + (run-avv))) + (t + ;; Ensure that bottom of the AVV is visible. I think that + ;; this is OK even if the AVV is bigger than the viewport. + (move-cursor-beyond-output-record + (encapsulating-stream-stream stream) avv) + (stream-ensure-cursor-visible stream) + (replay avv stream) + (run-avv))) + (unless own-window + (deactivate-all-gadgets avv-record) + (move-cursor-beyond-output-record + (encapsulating-stream-stream stream) avv))))))))) (defun find-query-gadget (query) (let ((record (accept-values-query-presentation query))) (when record (labels ((find-gadget-output-record (record) - (typecase record - (gadget-output-record - (return-from find-query-gadget (output-record-gadget record))) - (output-record - (map-over-output-records #'find-gadget-output-record record))))) - (declare (dynamic-extent #'find-gadget-output-record)) - (find-gadget-output-record record))))) + (typecase record + (gadget-output-record + (return-from find-query-gadget (output-record-gadget record))) + (output-record + (map-over-output-records #'find-gadget-output-record record))))) + (declare (dynamic-extent #'find-gadget-output-record)) + (find-gadget-output-record record))))) (defun move-focus-to-query (stream query &optional (editp t)) (declare (ignore stream)) @@ -620,13 +624,13 @@ ;;-- otherwise edit the field (let ((gadget (find-query-gadget query))) (cond (gadget - (move-focus-to-gadget gadget)) - ;;-- This stuff will still loose on old style CLIM - ;;-- member fields - (editp - (com-edit-avv-choice query)) - (t - (com-modify-avv-choice query))) + (move-focus-to-gadget gadget)) + ;;-- This stuff will still loose on old style CLIM + ;;-- member fields + (editp + (com-edit-avv-choice query)) + (t + (com-modify-avv-choice query))) ;; return nil for the gadget case so that we avoid redisplay which ;; would otherwise mess up the gadget focus (cim 2/2/95) (not gadget))) @@ -636,30 +640,30 @@ nil) (defmethod invoke-with-aligned-prompts ((stream accept-values-stream) continuation - &key (align-prompts t)) + &key (align-prompts t)) (setq align-prompts (ecase align-prompts - ((t :right) :right) - ((:left) :left) - ((nil) nil))) + ((t :right) :right) + ((:left) :left) + ((nil) nil))) (let ((return-values nil)) (flet ((run-continuation (stream) - (if align-prompts - (formatting-table (stream) - (setq return-values - (multiple-value-list - (funcall continuation stream)))) - (setq return-values - (multiple-value-list - (funcall continuation stream)))))) + (if align-prompts + (formatting-table (stream) + (setq return-values + (multiple-value-list + (funcall continuation stream)))) + (setq return-values + (multiple-value-list + (funcall continuation stream)))))) (let ((old-align-prompts (slot-value stream 'align-prompts))) - (unwind-protect - (progn (setf (slot-value stream 'align-prompts) align-prompts) - (if old-align-prompts - (formatting-row (stream) - (formatting-cell (stream) - (run-continuation stream))) - (run-continuation stream))) - (setf (slot-value stream 'align-prompts) old-align-prompts)))) + (unwind-protect + (progn (setf (slot-value stream 'align-prompts) align-prompts) + (if old-align-prompts + (formatting-row (stream) + (formatting-cell (stream) + (run-continuation stream))) + (run-continuation stream))) + (setf (slot-value stream 'align-prompts) old-align-prompts)))) (values-list return-values))) (defmethod invoke-with-aligned-prompts ((stream t) continuation &key align-prompts) @@ -667,12 +671,12 @@ (funcall continuation stream)) (defmethod frame-manager-display-input-editor-error - ((framem standard-frame-manager) (frame accept-values) stream error) + ((framem standard-frame-manager) (frame accept-values) stream error) ;;--- Resignal the error so the user can handle it ;;--- (in lieu of HANDLER-BIND-DEFAULT) (notify-user frame (princ-to-string error) - :title "Input error" - :style :error :exit-boxes '(:exit)) + :title "Input error" + :style :error :exit-boxes '(:exit)) (remove-activation-gesture stream) ;; Now wait until the user forces a rescan by typing ;; an input editing command @@ -685,10 +689,10 @@ ;;-- Yuck but think of a better way (let ((old-help *accept-help*)) (accepting-values (stream :exit-boxes '(:exit) - :label "Input editor help" - :own-window t) + :label "Input editor help" + :own-window t) (let ((*accept-help* old-help)) - (funcall continuation stream))))) + (funcall continuation stream))))) (defmethod accept-values-top-level :around ((frame accept-values-own-window) &rest args) @@ -697,60 +701,60 @@ (call-next-method) (with-slots (help-window) frame (when help-window - (deallocate-resource 'menu help-window) - (setq help-window nil))))) + (deallocate-resource 'menu help-window) + (setq help-window nil))))) (defmethod read-frame-command ((frame accept-values) &key (stream *standard-input*)) (read-command (frame-command-table frame) - :stream stream - :command-parser 'menu-command-parser - :use-keystrokes t)) + :stream stream + :command-parser 'menu-command-parser + :use-keystrokes t)) (defmethod accept-values-resynchronize ((stream accept-values-stream)) (setf (slot-value (slot-value stream 'avv-record) 'resynchronize) t)) (defmethod accept-values-resize-window ((stream accept-values-stream)) (with-slots (own-window own-window-properties) - (slot-value stream 'avv-frame) + (slot-value stream 'avv-frame) (when own-window (let* ((own-window-x-position (pop own-window-properties)) - (own-window-y-position (pop own-window-properties)) - (own-window-width (pop own-window-properties)) - (own-window-height (pop own-window-properties)) - (own-window-right-margin (pop own-window-properties)) - (own-window-bottom-margin (pop own-window-properties))) + (own-window-y-position (pop own-window-properties)) + (own-window-width (pop own-window-properties)) + (own-window-height (pop own-window-properties)) + (own-window-right-margin (pop own-window-properties)) + (own-window-bottom-margin (pop own-window-properties))) (declare (ignore own-window-x-position own-window-y-position - own-window-width own-window-height)) + own-window-width own-window-height)) (multiple-value-bind (new-width new-height) - (bounding-rectangle-size (slot-value stream 'avv-record)) - (multiple-value-bind (width height) - (window-inside-size own-window) - (when (or (> new-width width) - (> new-height height)) - (size-frame-from-contents own-window - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin)))))))) + (bounding-rectangle-size (slot-value stream 'avv-record)) + (multiple-value-bind (width height) + (window-inside-size own-window) + (when (or (> new-width width) + (> new-height height)) + (size-frame-from-contents own-window + :right-margin own-window-right-margin + :bottom-margin own-window-bottom-margin)))))))) (define-presentation-type accept-values-exit-box ()) (defmacro with-exit-box-decoded ((value label text-style documentation show-as-default) - exit-box labels &body body) + 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)) - (second (assoc ,value ,labels)))) - (,text-style (or (and (consp ,exit-box) - (getf (cddr ,exit-box) :text-style)) - (getf (cddr (assoc ,value ,labels)) :text-style))) - (,documentation (or (and (consp ,exit-box) - (getf (cddr ,exit-box) :documentation)) - (getf (cddr (assoc ,value ,labels)) :documentation))) - (,show-as-default - (if (and (consp ,exit-box) - (member :show-as-default (cddr ,exit-box))) - (getf (cddr ,exit-box) :show-as-default) - (getf (cddr (assoc ,value ,labels)) :show-as-default)))) + (,label (or (and (consp ,exit-box) + (second ,exit-box)) + (second (assoc ,value ,labels)))) + (,text-style (or (and (consp ,exit-box) + (getf (cddr ,exit-box) :text-style)) + (getf (cddr (assoc ,value ,labels)) :text-style))) + (,documentation (or (and (consp ,exit-box) + (getf (cddr ,exit-box) :documentation)) + (getf (cddr (assoc ,value ,labels)) :documentation))) + (,show-as-default + (if (and (consp ,exit-box) + (member :show-as-default (cddr ,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 @@ -764,26 +768,26 @@ (let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view))) (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 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) - #-CCL-2 - (write-string label stream) - #+CCL-2 - (if (eq value ':abort) - ;; Kludge to print the cloverleaf char in MCL. - ;; Needs an accompanying kludge in STREAM-WRITE-CHAR so that - ;; #\CommandMark doesn't get lozenged. - (progn - (with-text-style (stream '(:mac-menu :roman :normal)) - (write-char #\CommandMark stream)) - (write-string "-. aborts" stream)) - (write-string label stream))) - (write-string " " stream))))))))) + (dolist (exit-box exit-boxes) + (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) + #-CCL-2 + (write-string label stream) + #+CCL-2 + (if (eq value ':abort) + ;; Kludge to print the cloverleaf char in MCL. + ;; Needs an accompanying kludge in STREAM-WRITE-CHAR so that + ;; #\CommandMark doesn't get lozenged. + (progn + (with-text-style (stream '(:mac-menu :roman :normal)) + (write-char #\CommandMark stream)) + (write-string "-. aborts" stream)) + (write-string label stream))) + (write-string " " stream))))))))) ;;--- Get this right (defmethod frame-pointer-documentation-output ((frame accept-values-own-window)) @@ -800,8 +804,8 @@ (defmethod deactivate-all-gadgets :after ((record gadget-output-record)) (map-over-sheets #'(lambda (sheet) - (when (typep sheet 'gadget) - (deactivate-gadget sheet))) + (when (typep sheet 'gadget) + (deactivate-gadget sheet))) (output-record-gadget record))) @@ -816,8 +820,8 @@ (defun-inline accept-values-query-valid-p (query query-record) (and (or (null query) (accept-values-query-active-p query)) (let ((avv-record (find-accept-values-record query-record))) - (and avv-record - (= (slot-value avv-record 'tick) *current-accept-values-tick*))))) + (and avv-record + (= (slot-value avv-record 'tick) *current-accept-values-tick*))))) (define-accept-values-command com-edit-avv-choice ((choice 'accept-values-choice)) @@ -830,7 +834,7 @@ :documentation "Edit this field" :pointer-documentation "Edit this field" :tester ((object presentation) - (accept-values-query-valid-p object presentation)) + (accept-values-query-valid-p object presentation)) :gesture :edit-field) (object) (list object)) @@ -846,7 +850,7 @@ :documentation "Modify this field" :pointer-documentation "Modify this field" :tester ((object presentation) - (accept-values-query-valid-p object presentation)) + (accept-values-query-valid-p object presentation)) :gesture :modify-field) (object) (list object)) @@ -854,48 +858,48 @@ (defmethod accept-values-query-edit-value ((query accept-values-query) stream &key modify) (with-slots (presentation-type value changed-p prompt presentation) query (let ((stream (encapsulating-stream-stream stream)) - (*editting-field-p* t)) + (*editting-field-p* t)) (with-stream-cursor-position-saved (stream) - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent presentation)) - (multiple-value-bind (x y) (output-record-position presentation) - (stream-set-cursor-position stream (+ x xoff) (+ y yoff)))) - (unwind-protect - (progn - (erase-output-record presentation stream) - (let* ((new-value nil) - (aborted nil) - (record - (with-new-output-record (stream) - ;; The text cursor should be visible while this ACCEPT is - ;; waiting for input to be typed into this field - (letf-globally (((stream-read-gesture-cursor-state stream) t)) - (multiple-value-setq (new-value aborted) - (catch-abort-gestures ("Abort editing the current field") - (values - (accept presentation-type - :stream stream :prompt nil :default value - :insert-default modify)))))))) - ;; This so that the input editor's typing gets erased properly. - (erase-output-record record stream) - ;;--- Kludge until Bill can explain the whole - ;;"leave the delimiter" vs "process the delimiter" scheme to me - (when (read-gesture :stream stream :peek-p t :timeout 0) - (process-delimiter stream)) - (unless aborted - (setf value new-value)))) - (setf changed-p t)))))) + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent presentation)) + (multiple-value-bind (x y) (output-record-position presentation) + (stream-set-cursor-position stream (+ x xoff) (+ y yoff)))) + (unwind-protect + (progn + (erase-output-record presentation stream) + (let* ((new-value nil) + (aborted nil) + (record + (with-new-output-record (stream) + ;; The text cursor should be visible while this ACCEPT is + ;; waiting for input to be typed into this field + (letf-globally (((stream-read-gesture-cursor-state stream) t)) + (multiple-value-setq (new-value aborted) + (catch-abort-gestures ("Abort editing the current field") + (values + (accept presentation-type + :stream stream :prompt nil :default value + :insert-default modify)))))))) + ;; This so that the input editor's typing gets erased properly. + (erase-output-record record stream) + ;;--- Kludge until Bill can explain the whole + ;;"leave the delimiter" vs "process the delimiter" scheme to me + (when (read-gesture :stream stream :peek-p t :timeout 0) + (process-delimiter stream)) + (unless aborted + (setf value new-value)))) + (setf changed-p t)))))) (defun map-over-accept-values-queries (avv-record continuation) (declare (dynamic-extent continuation)) (labels ((map-queries (record) - (let ((unique-id (and (updating-output-record-p record) - (slot-value record 'unique-id)))) - (when (and (listp unique-id) - (eq (first unique-id) :query-identifier)) - (funcall continuation record unique-id))) - (map-over-output-records #'map-queries record))) + (let ((unique-id (and (updating-output-record-p record) + (slot-value record 'unique-id)))) + (when (and (listp unique-id) + (eq (first unique-id) :query-identifier)) + (funcall continuation record unique-id))) + (map-over-output-records #'map-queries record))) (declare (dynamic-extent #'map-queries)) (map-queries avv-record))) @@ -904,42 +908,42 @@ (with-slots (stream selected-item) *application-frame* (let ((avv-record (slot-value stream 'avv-record))) (cond ((null selected-item) - (map-over-accept-values-queries avv-record - #'(lambda (record unique-id) - (declare (ignore record)) - (return-from com-next-avv-choice - (setq selected-item (find-query avv-record unique-id)))))) - (t - (let* ((item (find-query avv-record (slot-value selected-item 'query-identifier))) - (item-record (slot-value item 'presentation)) - (found-item nil)) - (map-over-accept-values-queries avv-record - #'(lambda (record unique-id) - (if found-item - (return-from com-next-avv-choice - (setq selected-item (find-query avv-record unique-id))) - (when (eq record item-record) - (setq found-item t))))))))))) + (map-over-accept-values-queries avv-record + #'(lambda (record unique-id) + (declare (ignore record)) + (return-from com-next-avv-choice + (setq selected-item (find-query avv-record unique-id)))))) + (t + (let* ((item (find-query avv-record (slot-value selected-item 'query-identifier))) + (item-record (slot-value item 'presentation)) + (found-item nil)) + (map-over-accept-values-queries avv-record + #'(lambda (record unique-id) + (if found-item + (return-from com-next-avv-choice + (setq selected-item (find-query avv-record unique-id))) + (when (eq record item-record) + (setq found-item t))))))))))) #+Genera (define-accept-values-command (com-previous-avv-choice :keystroke (:p :control)) () (with-slots (stream selected-item) *application-frame* (let ((avv-record (slot-value stream 'avv-record))) (cond ((null selected-item) - ;;--- Do this - ) - (t - ;;--- Do this - ))))) + ;;--- Do this + ) + (t + ;;--- Do this + ))))) #+Genera (add-keystroke-to-command-table 'accept-values '(:e :control) :function #'(lambda (gesture numeric-argument) (declare (ignore gesture numeric-argument)) (with-slots (selected-item) *application-frame* - (if (null selected-item) - (beep) - `(com-edit-avv-choice ,selected-item)))) + (if (null selected-item) + (beep) + `(com-edit-avv-choice ,selected-item)))) :errorp nil) (define-accept-values-command com-delete-avv-choice @@ -951,7 +955,7 @@ :documentation "Remove this field" :pointer-documentation "Remove this field" :tester ((object presentation) - (accept-values-query-valid-p object presentation)) + (accept-values-query-valid-p object presentation)) :gesture :delete-field) (object) (list object)) @@ -960,7 +964,7 @@ (with-slots (presentation-type value changed-p) query (when (presentation-typep nil presentation-type) (setf value nil - changed-p t)))) + changed-p t)))) (define-gesture-name :exit-dialog :keyboard (:end)) #+allegro @@ -971,23 +975,23 @@ (let ((frame *application-frame*)) (with-slots (stream) frame (when (verify-queries frame stream (slot-value stream 'avv-record)) - (frame-exit frame))))) + (frame-exit frame))))) (defun verify-queries (frame stream avv-record) (let ((queries nil)) (maphash #'(lambda (query-identifier query) - (declare (ignore query-identifier)) - (when (and (accept-values-query-active-p query) - (output-record-stream (accept-values-query-presentation query)) - (accept-values-query-error-p query)) - (push query queries))) + (declare (ignore query-identifier)) + (when (and (accept-values-query-active-p query) + (output-record-stream (accept-values-query-presentation query)) + (accept-values-query-error-p query)) + (push query queries))) (slot-value avv-record 'query-table)) (if queries - (progn - (verify-queries-1 frame stream queries) - nil) + (progn + (verify-queries-1 frame stream queries) + nil) t))) (defun verify-queries-1 (frame stream queries) @@ -995,12 +999,12 @@ frame stream (mapcar #'(lambda (query) - (list - query - (slot-value query 'query-identifier) - (let ((condition (accept-values-query-error-p query))) - (and (not (eq condition t)) condition)))) - queries)) + (list + query + (slot-value query 'query-identifier) + (let ((condition (accept-values-query-error-p query))) + (and (not (eq condition t)) condition)))) + queries)) (move-focus-to-query stream (car queries))) @@ -1008,22 +1012,22 @@ (defmethod display-invalid-queries ((frame standard-application-frame) stream query-info) (declare (ignore stream)) (notify-user frame - (format nil "The following fields are not valid:~:{~%~4T~A~@[: ~A~]~}" - (mapcar #'(lambda (query-stuff) - (destructuring-bind (query id condition) query-stuff - (declare (ignore query)) - (list - (if (and (consp id) - (eq (car id) :query-identifier) - (consp (cdr id)) - (stringp (second id))) - (second id) - id) - (and (not (eq condition t)) condition)))) - query-info)) - :title "Invalid Fields" - :style :error - :exit-boxes '(:exit))) + (format nil "The following fields are not valid:~:{~%~4T~A~@[: ~A~]~}" + (mapcar #'(lambda (query-stuff) + (destructuring-bind (query id condition) query-stuff + (declare (ignore query)) + (list + (if (and (consp id) + (eq (car id) :query-identifier) + (consp (cdr id)) + (stringp (second id))) + (second id) + id) + (and (not (eq condition t)) condition)))) + query-info)) + :title "Invalid Fields" + :style :error + :exit-boxes '(:exit))) (defmethod display-invalid-queries ((frame accept-values-own-window) stream queries) (display-invalid-queries (frame-calling-frame frame) stream queries)) @@ -1040,9 +1044,9 @@ (let ((gadget (find-query-gadget query))) (when (and gadget (typep gadget '(or text-field text-editor))) (if errorp - (setf (gadget-original-background gadget) (gadget-background gadget) - (gadget-background gadget) +red+) - (setf (gadget-background gadget) (gadget-original-background gadget)))))) + (setf (gadget-original-background gadget) (gadget-background gadget) + (gadget-background gadget) +red+) + (setf (gadget-background gadget) (gadget-original-background gadget)))))) ;; Focus-in callback/ value changed - establish normal ;; Focus-out callback - establish error condition @@ -1056,11 +1060,11 @@ (define-presentation-translator abort-or-exit-avv (accept-values-exit-box (command :command-table accept-values) accept-values - :tester-definitive t ;just like a to-command translator + :tester-definitive t ;just like a to-command translator :documentation ((object stream) - (case object - (:exit (write-string "Exit" stream)) - (:abort (write-string "Abort" stream)))) + (case object + (:exit (write-string "Exit" stream)) + (:abort (write-string "Abort" stream)))) :gesture :select) (object) (case object @@ -1078,62 +1082,62 @@ (define-presentation-type accept-values-command-button ()) (defmacro accept-values-command-button ((&optional stream &rest options &key (view nil viewp) &allow-other-keys) prompt - &body body &environment env) + &body body &environment env) #+Genera (declare (zwei:indentation 1 3 2 1)) #-(or Genera Minima) (declare (ignore env)) (declare (arglist ((&optional stream - &key documentation query-identifier - (cache-value t) (cache-test #'eql) - view resynchronize) - prompt &body body))) + &key documentation query-identifier + (cache-value t) (cache-test #'eql) + view resynchronize) + prompt &body body))) (default-input-stream stream accept-values-command-button) (with-keywords-removed (options options '(:view)) (let ((constant-prompt-p - (and (constantp prompt #+(or Genera Minima) env) - (stringp (eval prompt #+(or Genera Minima-Developer) env))))) + (and (constantp prompt #+(or Genera Minima) env) + (stringp (eval prompt #+(or Genera Minima-Developer) env))))) `(flet ((avv-command-button-body () ,@body) - ,@(unless constant-prompt-p - `((avv-command-button-prompt (,stream) ,prompt)))) - ,@(unless constant-prompt-p - `((declare (dynamic-extent #'avv-command-button-prompt)))) - (invoke-accept-values-command-button - ,stream - #'avv-command-button-body ,(if viewp view `(stream-default-view ,stream)) - ,(if constant-prompt-p - (eval prompt #+(or Genera Minima-Developer) env) - '#'avv-command-button-prompt) - ,@options))))) + ,@(unless constant-prompt-p + `((avv-command-button-prompt (,stream) ,prompt)))) + ,@(unless constant-prompt-p + `((declare (dynamic-extent #'avv-command-button-prompt)))) + (invoke-accept-values-command-button + ,stream + #'avv-command-button-body ,(if viewp view `(stream-default-view ,stream)) + ,(if constant-prompt-p + (eval prompt #+(or Genera Minima-Developer) env) + '#'avv-command-button-prompt) + ,@options))))) (defmethod invoke-accept-values-command-button-1 - (stream continuation (view t) prompt - &key (documentation (if (stringp prompt) - prompt - (with-output-to-string (stream) - (funcall prompt stream)))) - (query-identifier (list ':button documentation)) - (cache-value t) (cache-test #'eql) - resynchronize - active-p) + (stream continuation (view t) prompt + &key (documentation (if (stringp prompt) + prompt + (with-output-to-string (stream) + (funcall prompt stream)))) + (query-identifier (list ':button documentation)) + (cache-value t) (cache-test #'eql) + resynchronize + active-p) (declare (dynamic-extent prompt) - (ignore active-p)) + (ignore active-p)) (updating-output (stream :unique-id query-identifier :id-test #'equal - :cache-value cache-value :cache-test cache-test) + :cache-value cache-value :cache-test cache-test) (flet ((doit (stream) - (with-output-as-presentation (stream - (make-instance 'accept-values-command-button - :continuation continuation - :documentation documentation - :resynchronize resynchronize) - 'accept-values-command-button) - (if (stringp prompt) - (write-string prompt stream) - (funcall prompt stream))))) + (with-output-as-presentation (stream + (make-instance 'accept-values-command-button + :continuation continuation + :documentation documentation + :resynchronize resynchronize) + 'accept-values-command-button) + (if (stringp prompt) + (write-string prompt stream) + (funcall prompt stream))))) (let ((align-prompts (slot-value stream 'align-prompts)) query) - (if align-prompts - (formatting-row (stream) - (formatting-cell (stream) stream) - (formatting-cell (stream) (doit stream))) - (doit stream)))))) + (if align-prompts + (formatting-row (stream) + (formatting-cell (stream) stream) + (formatting-cell (stream) (doit stream))) + (doit stream)))))) (define-accept-values-command com-avv-command-button ((button 'accept-values-command-button) @@ -1148,7 +1152,7 @@ :documentation document-command-button :pointer-documentation document-command-button :tester ((presentation) - (accept-values-query-valid-p nil presentation)) + (accept-values-query-valid-p nil presentation)) :gesture :select) (object presentation) (list object presentation)) @@ -1158,11 +1162,11 @@ (declare (ignore presentation context-type frame event window x y)) (let ((documentation (slot-value button 'documentation))) (cond ((stringp documentation) - (write-string documentation stream)) - (documentation - (funcall documentation stream)) - (t - (write-string "Execute this command button" stream))))) + (write-string documentation stream)) + (documentation + (funcall documentation stream)) + (t + (write-string "Execute this command button" stream))))) ;;; One-of and Some-of choices display @@ -1185,11 +1189,11 @@ (defun avv-choose-one-of-1 (choice) (let* ((choices (accept-values-multiple-choice-choices choice)) - (query (accept-values-multiple-choices-query-identifier choices))) + (query (accept-values-multiple-choices-query-identifier choices))) (setf (accept-values-query-value query) - (funcall (accept-values-multiple-choices-select-action choices) - (accept-values-multiple-choice-value choice) - (accept-values-query-value query))) + (funcall (accept-values-multiple-choices-select-action choices) + (accept-values-multiple-choice-value choice) + (accept-values-query-value query))) (setf (accept-values-query-changed-p query) t))) (define-presentation-to-command-translator avv-choose-one-of @@ -1197,21 +1201,21 @@ :documentation "Select this value" :pointer-documentation "Select this value" :tester ((object presentation) - (accept-values-query-valid-p - (accept-values-multiple-choices-query-identifier - (accept-values-multiple-choice-choices object)) - presentation)) + (accept-values-query-valid-p + (accept-values-multiple-choices-query-identifier + (accept-values-multiple-choice-choices object)) + presentation)) :echo nil :maintain-history nil :gesture :select) (object) (list object)) (defun accept-values-choose-from-sequence (stream sequence key selected-value tester - type query-identifier - select-action highlighting-function) + type query-identifier + select-action highlighting-function) (declare (dynamic-extent select-action highlighting-function)) (flet ((presenter (thing stream) - (present thing type :stream stream))) + (present thing type :stream stream))) (declare (dynamic-extent #'presenter)) (accept-values-choose-from-sequence-1 stream sequence key selected-value tester @@ -1220,38 +1224,38 @@ 'accept-values-one-of #'presenter))) (defun accept-values-choose-from-sequence-1 (stream sequence key selected-value tester - type query-identifier - select-action highlighting-function - choice-type choice-presenter) + type query-identifier + select-action highlighting-function + choice-type choice-presenter) (declare (dynamic-extent select-action highlighting-function tester choice-presenter)) (declare (ignore type)) ;;--- Unfortunately, this makes a new object every time we go around... (let ((choices (make-accept-values-multiple-choices - :query-identifier query-identifier - :select-action select-action))) + :query-identifier query-identifier + :select-action select-action))) (flet ((print-choice (object stream) - (let* ((value (funcall key object)) - (selected-p (funcall tester value selected-value))) - (updating-output (stream :unique-id object - :cache-value selected-p) - (with-output-as-presentation - (stream - (make-accept-values-multiple-choice :choices choices :value value) - choice-type) - (formatting-cell (stream) - (if selected-p - (funcall highlighting-function choice-presenter value stream) - (funcall choice-presenter value stream)))))))) + (let* ((value (funcall key object)) + (selected-p (funcall tester value selected-value))) + (updating-output (stream :unique-id object + :cache-value selected-p) + (with-output-as-presentation + (stream + (make-accept-values-multiple-choice :choices choices :value value) + choice-type) + (formatting-cell (stream) + (if selected-p + (funcall highlighting-function choice-presenter value stream) + (funcall choice-presenter value stream)))))))) (declare (dynamic-extent #'print-choice)) ;; :MAX-WIDTH makes it use as few rows as will fit in the available width. ;; :X-SPACING makes it not spread the choices to fill the whole width. ;; :INITIAL-SPACING NIL makes it not add whitespace at the start of the field. (formatting-item-list (stream :max-width (- (stream-text-margin stream) - (stream-cursor-position stream)) - :x-spacing '(2 :character) - :initial-spacing nil) - (doseq (object sequence) - (print-choice object stream)))))) + (stream-cursor-position stream)) + :x-spacing '(2 :character) + :initial-spacing nil) + (doseq (object sequence) + (print-choice object stream)))))) (define-accept-values-command com-avv-choose-some-of ((choice 'accept-values-some-of)) @@ -1259,17 +1263,17 @@ (defun avv-choose-some-of-1 (choice) (let* ((choices (accept-values-multiple-choice-choices choice)) - (query (accept-values-multiple-choices-query-identifier choices))) + (query (accept-values-multiple-choices-query-identifier choices))) (let ((new-value (funcall (accept-values-multiple-choices-select-action choices) - (accept-values-multiple-choice-value choice) - (accept-values-query-value query)))) + (accept-values-multiple-choice-value choice) + (accept-values-query-value query)))) (if (member new-value (accept-values-query-value query)) - ;; Use REMOVE instead of DELETE so the the new value is not EQ - ;; to the old one. If it were to stay EQ, the field would not - ;; be properly redisplayed. - (setf (accept-values-query-value query) - (remove new-value (accept-values-query-value query))) - (push new-value (accept-values-query-value query)))) + ;; Use REMOVE instead of DELETE so the the new value is not EQ + ;; to the old one. If it were to stay EQ, the field would not + ;; be properly redisplayed. + (setf (accept-values-query-value query) + (remove new-value (accept-values-query-value query))) + (push new-value (accept-values-query-value query)))) (setf (accept-values-query-changed-p query) t))) (define-presentation-to-command-translator avv-choose-some-of @@ -1277,25 +1281,25 @@ :documentation "De/Select this value" :pointer-documentation "De/Select this value" :tester ((object presentation) - (accept-values-query-valid-p - (accept-values-multiple-choices-query-identifier - (accept-values-multiple-choice-choices object)) - presentation)) + (accept-values-query-valid-p + (accept-values-multiple-choices-query-identifier + (accept-values-multiple-choice-choices object)) + presentation)) :gesture :select) (object) (list object)) (defun accept-values-choose-from-subset (stream sequence key selected-value tester - type query-identifier - select-action highlighting-function) + type query-identifier + select-action highlighting-function) (declare (dynamic-extent select-action highlighting-function)) (flet ((presenter (thing stream) - (present (list thing) type :stream stream))) + (present (list thing) type :stream stream))) (declare (dynamic-extent #'presenter)) (accept-values-choose-from-sequence-1 stream sequence key selected-value #'(lambda (object sequence) - (member object sequence :test tester)) + (member object sequence :test tester)) type query-identifier select-action highlighting-function 'accept-values-some-of #'presenter))) @@ -1313,58 +1317,58 @@ (setf (frame-pane-to-avv-stream-table frame) (make-hash-table)))) (defun accept-values-pane-displayer (frame pane - &key displayer - resynchronize-every-pass - (check-overlapping t) - view - align-prompts - max-height max-width) + &key displayer + resynchronize-every-pass + (check-overlapping t) + view + align-prompts + max-height max-width) (declare (ignore max-height max-width)) (setq align-prompts (ecase align-prompts - ((t :right) :right) - ((:left) :left) - ((nil) nil))) + ((t :right) :right) + ((:left) :left) + ((nil) nil))) (let* ((stream-and-record - (and (not *frame-layout-changing-p*) - (gethash pane (get-frame-pane-to-avv-stream-table frame)))) - (avv-stream (car stream-and-record)) - (avv-record (cdr stream-and-record))) + (and (not *frame-layout-changing-p*) + (gethash pane (get-frame-pane-to-avv-stream-table frame)))) + (avv-stream (car stream-and-record)) + (avv-record (cdr stream-and-record))) (cond ((and avv-stream - (output-record-stream avv-record)) - (with-deferred-gadget-updates - (letf-globally (((stream-default-view avv-stream) - (or view - (frame-manager-dialog-view (frame-manager frame))))) - (redisplay avv-record avv-stream :check-overlapping check-overlapping) - (when resynchronize-every-pass - (redisplay avv-record avv-stream :check-overlapping check-overlapping))))) - (t - (accept-values-pane-displayer-1 frame pane displayer - align-prompts view))))) + (output-record-stream avv-record)) + (with-deferred-gadget-updates + (letf-globally (((stream-default-view avv-stream) + (or view + (frame-manager-dialog-view (frame-manager frame))))) + (redisplay avv-record avv-stream :check-overlapping check-overlapping) + (when resynchronize-every-pass + (redisplay avv-record avv-stream :check-overlapping check-overlapping))))) + (t + (accept-values-pane-displayer-1 frame pane displayer + align-prompts view))))) (defun accept-values-pane-displayer-1 (frame pane displayer align-prompts view) (let ((avv-stream (make-instance 'accept-values-stream - :stream pane :align-prompts align-prompts)) - (avv-record nil) - (view (or view - (frame-manager-dialog-view (frame-manager frame))))) + :stream pane :align-prompts align-prompts)) + (avv-record nil) + (view (or view + (frame-manager-dialog-view (frame-manager frame))))) (setf (slot-value avv-stream 'avv-frame) frame) (letf-globally (((stream-default-view pane) - view)) + view)) (setq avv-record - (updating-output (avv-stream) - (with-new-output-record - (avv-stream 'accept-values-output-record avv-record) - (setf (slot-value avv-stream 'avv-record) avv-record) - (if align-prompts - (formatting-table (avv-stream) - (funcall displayer frame avv-stream)) - (progn - (display-view-background avv-stream view) - (funcall displayer frame avv-stream))))))) + (updating-output (avv-stream) + (with-new-output-record + (avv-stream 'accept-values-output-record avv-record) + (setf (slot-value avv-stream 'avv-record) avv-record) + (if align-prompts + (formatting-table (avv-stream) + (funcall displayer frame avv-stream)) + (progn + (display-view-background avv-stream view) + (funcall displayer frame avv-stream))))))) (unless *sizing-application-frame* (setf (gethash pane (get-frame-pane-to-avv-stream-table frame)) - (cons avv-stream avv-record))))) + (cons avv-stream avv-record))))) (define-command (com-edit-avv-pane-choice :command-table accept-values-pane) @@ -1378,8 +1382,8 @@ :pointer-documentation "Edit this field" :gesture :edit-field :tester ((object presentation) - (accept-values-query-valid-p object presentation)) - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + (accept-values-query-valid-p object presentation)) + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context ;; Echoing this is annoying, as is putting it into the command history :echo nil :maintain-history nil) (object window) @@ -1389,7 +1393,7 @@ ((choice 'accept-values-choice) (pane 't)) (accept-values-query-edit-value choice (car (gethash pane (get-frame-pane-to-avv-stream-table (pane-frame pane)))) - :modify t)) + :modify t)) (define-presentation-to-command-translator modify-avv-pane-choice (accept-values-choice com-modify-avv-pane-choice accept-values-pane @@ -1397,8 +1401,8 @@ :pointer-documentation "Modify this field" :gesture :modify-field :tester ((object presentation) - (accept-values-query-valid-p object presentation)) - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + (accept-values-query-valid-p object presentation)) + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context :echo nil :maintain-history nil) (object window) (list object window)) @@ -1412,9 +1416,9 @@ :documentation "Remove this field" :pointer-documentation "Remove this field" :tester ((object presentation) - (accept-values-query-valid-p object presentation)) + (accept-values-query-valid-p object presentation)) :gesture :delete-field - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context :echo nil :maintain-history nil) (object) (list object)) @@ -1425,19 +1429,19 @@ (funcall (slot-value button 'continuation)) (when (slot-value button 'resynchronize) (let* ((stream-and-record (and (not *frame-layout-changing-p*) - (gethash pane (get-frame-pane-to-avv-stream-table (pane-frame pane))))) - (avv-stream (car stream-and-record)) - (avv-record (cdr stream-and-record))) + (gethash pane (get-frame-pane-to-avv-stream-table (pane-frame pane))))) + (avv-stream (car stream-and-record)) + (avv-record (cdr stream-and-record))) (when avv-stream - (letf-globally (((stream-default-view avv-stream) +textual-dialog-view+)) - (redisplay avv-record avv-stream)))))) + (letf-globally (((stream-default-view avv-stream) +textual-dialog-view+)) + (redisplay avv-record avv-stream)))))) (define-presentation-to-command-translator avv-pane-command-button (accept-values-command-button com-avv-pane-command-button accept-values-pane :documentation document-command-button :pointer-documentation document-command-button :gesture :select - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context :echo nil :maintain-history nil) (object window) (list object window)) @@ -1451,7 +1455,7 @@ :documentation "Select this value" :pointer-documentation "Select this value" :gesture :select - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context :echo nil :maintain-history nil) (object) (list object)) @@ -1465,7 +1469,7 @@ :documentation "De/Select this value" :pointer-documentation "De/Select this value" :gesture :select - :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context + :priority 1 ;prefer this to IDENTITY when in COMMAND-OR-FORM context :echo nil :maintain-history nil) (object) (list object)) @@ -1479,34 +1483,34 @@ (let ((labels (frame-manager-exit-box-labels (frame-manager frame) frame view))) (with-slots (exit-boxes) frame (updating-output (stream :unique-id stream - :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 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 - :show-as-default show-as-default - text-style)))))))))))) + :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 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 + :show-as-default show-as-default + text-style)))))))))))) (defun handle-exit-box-callback (gadget) (if *editting-field-p* (beep) (let ((id (gadget-id gadget))) (case id - (:exit (com-exit-avv)) - (:abort (com-abort-avv)) - (t (funcall id)))))) + (:exit (com-exit-avv)) + (:abort (com-abort-avv)) + (t (funcall id)))))) ;; It's OK that this is only in the ACCEPT-VALUES command table because ;; we're going to execute it manually in the callbacks below @@ -1515,7 +1519,7 @@ (new-value t)) (with-slots (value changed-p) query (setf value new-value - changed-p t))) + changed-p t))) (defmethod accept-values-value-changed-callback ((gadget value-gadget) new-value stream query) (when (accept-values-query-valid-p query (accept-values-query-presentation query)) @@ -1527,11 +1531,11 @@ (process-command-event sheet (allocate-event 'presentation-event - :sheet sheet - :echo nil - :presentation-type 'command - :value `(com-change-query ,query ,new-value) - :frame (slot-value client 'avv-frame))))) + :sheet sheet + :echo nil + :presentation-type 'command + :value `(com-change-query ,query ,new-value) + :frame (slot-value client 'avv-frame))))) (defmethod accept-values-value-changed-callback ((gadget radio-box) new-value stream query-id) (call-next-method gadget (gadget-id new-value) stream query-id)) @@ -1549,114 +1553,114 @@ (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)) + 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))) (cons (setq view (apply #'make-instance view)))) (apply #'invoke-accept-values-command-button-1 - stream - continuation - (decode-indirect-view - 'accept-values-command-button - view - (frame-manager stream) - :query-identifier query-identifier) - prompt - :documentation documentation - :query-identifier query-identifier - options)) + stream + continuation + (decode-indirect-view + 'accept-values-command-button + view + (frame-manager stream) + :query-identifier query-identifier) + prompt + :documentation documentation + :query-identifier query-identifier + options)) (define-presentation-method decode-indirect-view ((type accept-values-command-button) (view gadget-dialog-view) - (framem standard-frame-manager) &key read-only) + (framem standard-frame-manager) &key read-only) (declare (ignore read-only)) +push-button-view+) (defmethod invoke-accept-values-command-button-1 (stream continuation (view push-button-view) prompt &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)) - (cache-value t) (cache-test #'eql) - resynchronize - (active-p t)) + prompt + ;;-- What is the right thing to do? + (ignore-errors + (with-output-to-string (stream) + (funcall prompt stream))))) + (query-identifier (list ':button documentation)) + (cache-value t) (cache-test #'eql) + resynchronize + (active-p t)) (declare (dynamic-extent prompt)) (move-cursor-to-view-position stream view) (updating-output (stream :unique-id query-identifier :id-test #'equal - :cache-value (cons active-p cache-value) - :cache-test #'(lambda (x y) - (and (eq (car x) (car y)) - (funcall cache-test (cdr x) (cdr y))))) + :cache-value (cons active-p cache-value) + :cache-test #'(lambda (x y) + (and (eq (car x) (car y)) + (funcall cache-test (cdr x) (cdr y))))) (labels ((update-gadget (record gadget) - (declare (ignore record)) ;;-- This sucks - (setf (gadget-label gadget) (compute-prompt)) - (if active-p - (activate-gadget gadget) - (deactivate-gadget gadget))) - (compute-prompt () - (if (stringp prompt) - prompt - ;;-- Does this suck or what??? - ;;-- If you do a - ;;surrounding-output-with-border without - ;;this write-string output does not get bordered. - (let ((*original-stream* nil)) - (pixmap-from-menu-item stream - prompt - #'funcall - nil)))) - (doit (stream) - (with-output-as-gadget (stream :update-gadget #'update-gadget) - (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) - (client (make-instance 'accept-values-command-button - :continuation continuation - :documentation documentation - :resynchronize resynchronize))) - (make-pane-from-view - 'push-button - view () - :id record :client client - :activate-callback #'(lambda (button) - (when (accept-values-query-valid-p nil record) ;---can't be right - (let ((sheet (sheet-parent button))) - (process-command-event - sheet - (allocate-event 'presentation-event - :sheet sheet - :echo nil - :presentation-type 'command - :value `(com-avv-command-button ,client ,record) - :frame *application-frame*))))) - :label (compute-prompt) - :name :accept-values-command-button - :help-callback documentation - :active active-p))))) + (declare (ignore record)) ;;-- This sucks + (setf (gadget-label gadget) (compute-prompt)) + (if active-p + (activate-gadget gadget) + (deactivate-gadget gadget))) + (compute-prompt () + (if (stringp prompt) + prompt + ;;-- Does this suck or what??? + ;;-- If you do a + ;;surrounding-output-with-border without + ;;this write-string output does not get bordered. + (let ((*original-stream* nil)) + (apply #'pixmap-from-menu-item + stream prompt #'funcall nil + :gray-out (not active-p) + (view-gadget-initargs view))))) + (doit (stream) + (with-output-as-gadget (stream :update-gadget #'update-gadget) + (let ((record (stream-current-output-record (encapsulating-stream-stream stream))) + (client (make-instance 'accept-values-command-button + :continuation continuation + :documentation documentation + :resynchronize resynchronize))) + (make-pane-from-view + 'push-button + view () + :id record :client client + :activate-callback #'(lambda (button) + (when (accept-values-query-valid-p nil record) ;---can't be right + (let ((sheet (sheet-parent button))) + (process-command-event + sheet + (allocate-event 'presentation-event + :sheet sheet + :echo nil + :presentation-type 'command + :value `(com-avv-command-button ,client ,record) + :frame *application-frame*))))) + :label (compute-prompt) + :name :accept-values-command-button + :help-callback documentation + :active active-p))))) (let ((align-prompts (slot-value stream 'align-prompts))) - (if align-prompts - (formatting-row (stream) - (formatting-cell (stream) stream) - (formatting-cell (stream) (doit stream))) - (doit stream)))))) + (if align-prompts + (formatting-row (stream) + (formatting-cell (stream) stream) + (formatting-cell (stream) (doit stream))) + (doit stream)))))) (defmethod frame-manager-position-dialog ((framem standard-frame-manager) - frame - own-window-x-position own-window-y-position) + frame + own-window-x-position own-window-y-position) (multiple-value-bind (x y) #+++ignore (pointer-position (port-pointer (port frame))) #---ignore (values 100 100) (when (and own-window-x-position own-window-y-position) - (setq x own-window-x-position - y own-window-y-position)) + (setq x own-window-x-position + y own-window-y-position)) (position-sheet-carefully (frame-top-level-sheet frame) x y))) diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp index 125531a97321f5679847f0df8f76a25f7393043f..59e2f5829d789bbb39d7cae5d37e1653ee39fd2e 100644 --- a/clim/drag-and-drop.lisp +++ b/clim/drag-and-drop.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: drag-and-drop.lisp,v 1.11 93/03/19 09:43:23 cer Exp $ +;; $fiHeader: drag-and-drop.lisp,v 1.12 1993/07/27 01:39:08 colin Exp $ (in-package :clim-internals) @@ -9,6 +9,8 @@ ;;; Direct manipulation ("click and drag", "drag and drop") translators +(defparameter *drag-and-drop-finish-on-release* t) + (defclass drag-and-drop-translator (presentation-translator) ((destination-type :initarg :destination-type :reader presentation-translator-destination-type) @@ -18,15 +20,18 @@ :reader presentation-translator-highlighting) (pointer-cursor :initform nil :initarg :pointer-cursor :reader presentation-translator-pointer-cursor) - ;; The body, tester, and documentation supplied by the programmer. - ;; DEFINE-DRAG-AND-DROP-TRANSLATOR uses the other body, tester, - ;; and documentaiton slots for its own purposes + (finish-on-release :initform *drag-and-drop-finish-on-release* + :initarg :finish-on-release + :reader presentation-translator-finish-on-release) + (destination-tester :initform nil :initarg :destination-tester + :reader presentation-translator-destination-tester) + (drag-documentation :initform nil :initarg :drag-documentation + :reader presentation-translator-drag-documentation) + ;; The body supplied by the programmer. + ;; DEFINE-DRAG-AND-DROP-TRANSLATOR uses the other body slot for + ;; its own purposes. (real-body :initarg :real-body - :reader presentation-translator-real-body) - (real-tester :initform nil :initarg :real-tester - :reader presentation-translator-real-tester) - (real-documentation :initform nil :initarg :real-documentation - :reader presentation-translator-real-documentation))) + :reader presentation-translator-real-body))) (defmethod print-object ((object drag-and-drop-translator) stream) (if *print-escape* @@ -41,87 +46,82 @@ (defmacro define-drag-and-drop-translator (name (from-type to-type destination-type command-table - &key (gesture ':select) tester - documentation (menu t) priority - feedback highlighting pointer-cursor) + &key (gesture ':select) tester destination-tester + documentation pointer-documentation + drag-documentation (menu t) + priority + (feedback 'frame-drag-and-drop-feedback) + (highlighting 'frame-drag-and-drop-highlighting) + pointer-cursor finish-on-release) arglist &body body) #+Genera (declare (zwei:indentation 1 3 3 1)) (with-warnings-for-definition name define-presentation-translator - (multiple-value-bind (body-function body-name) - (write-translator-function (cons arglist body) name 'real-body - '(destination-object destination-presentation)) - (multiple-value-bind (tester-function tester-name) - (when tester - (write-translator-function tester name 'real-tester - '(destination-object destination-presentation))) - (multiple-value-bind (doc-function doc-name) - (if (stringp documentation) - (values nil documentation) - (when documentation - (write-translator-function - documentation name 'real-doc - '(destination-object destination-presentation stream)))) - (multiple-value-bind (feedback-function feedback-name) - (if (symbolp feedback) - (values nil (or feedback 'frame-drag-and-drop-feedback)) - (write-drag-and-drop-function - feedback name 'feedback - '(frame presentation stream initial-x initial-y new-x new-y state))) - (multiple-value-bind (highlighting-function highlighting-name) - (if (symbolp highlighting) - (values nil (or highlighting 'frame-drag-and-drop-highlighting)) - (write-drag-and-drop-function - highlighting name 'highlighting - '(frame presentation stream state))) - `(progn - (define-presentation-translator-1 ,name - (,from-type ,to-type ,command-table - :gesture ,gesture - :tester nil - :tester-definitive t - :documentation "Drag presentation" - :pointer-documentation "Drag presentation" - :menu ,menu - :priority ,priority - :translator-class drag-and-drop-translator - :destination-type ',destination-type - :real-body ',body-name - :feedback ',feedback-name - :highlighting ',highlighting-name - ,@(when tester `(:real-tester ',tester-name)) - ,@(when documentation `(:real-documentation ',doc-name)) - :pointer-cursor ',pointer-cursor) + (flet ((translator-function-and-name (clause clause-name + &optional args + (use-default-args t) + string-ok) + (when clause + (cond ((or (functionp clause) + (symbolp clause) + (and string-ok (stringp clause))) + (values nil clause)) + (t (write-translator-function clause name clause-name args + use-default-args)))))) + (multiple-value-bind (body-function body-name) + (write-translator-function (cons arglist body) name 'real-body + '(destination-object destination-presentation)) + (multiple-value-bind (destination-tester-function destination-tester-name) + (translator-function-and-name + destination-tester 'destination-tester + '(destination-object destination-presentation)) + (multiple-value-bind (drag-documentation-function drag-documentation-name) + (translator-function-and-name + drag-documentation 'drag-documenation + '(destination-object destination-presentation stream) t t) + (multiple-value-bind (feedback-function feedback-name) + (translator-function-and-name + feedback 'feedback + '(frame presentation stream initial-x initial-y new-x new-y state) nil) + (multiple-value-bind (highlighting-function highlighting-name) + (translator-function-and-name + highlighting 'highlighting + '(frame presentation stream state) nil) + `(progn + (define-presentation-translator-1 ,name + (,from-type ,to-type ,command-table + :gesture ,gesture + :tester ,tester + :tester-definitive t + :documentation ,documentation + :pointer-documentation ,pointer-documentation + :menu ,menu + :priority ,priority + :translator-class drag-and-drop-translator + :destination-type ',destination-type + :real-body ',body-name + :feedback ',feedback-name + :highlighting ',highlighting-name + :pointer-cursor ',pointer-cursor + :finish-on-release ',finish-on-release + :destination-tester ',destination-tester-name + :drag-documentation ',drag-documentation-name) ,*translator-function-arglist* - (invoke-drag-and-drop-translator ,@*translator-function-arglist*)) - ,body-function - ,tester-function - ,doc-function - ,feedback-function - ,highlighting-function)))))))) - -(defun write-drag-and-drop-function (function translator-name clause-name args) - (let ((function-name (gensymbol translator-name clause-name)) - (arglist (first function)) - (body (rest function))) - (multiple-value-bind (arglist ignores) - (canonicalize-and-match-lambda-lists args arglist) - (values `(defun ,function-name ,arglist - ,@(and ignores `((declare (ignore ,@ignores)))) - ,@body) - function-name)))) - -(defparameter *drag-and-drop-finish-on-release* nil) + (invoke-drag-and-drop-translator ,@*translator-function-arglist*)) + ,body-function + ,destination-tester-function + ,drag-documentation-function + ,feedback-function + ,highlighting-function))))))))) ;; All the drag-and-drop translators that satisfy the current from-type, ;; to-type, and gesture will get here. However, the translator now being -;; run is not necessarily the right one. What we do here is to track the +;; run is not necessarily the right one. What we do here is to track the ;; pointer until the destination presentation has been reached, choose the ;; correct translator and run it. + (defun invoke-drag-and-drop-translator (object presentation context-type - frame event window x y - &optional (finish-on-release - *drag-and-drop-finish-on-release*)) + frame event window x y) (catch-abort-gestures ("Abort drag and drop") (let* ((command-table (frame-command-table frame)) (translators @@ -151,6 +151,8 @@ (pointer-cursor (or (and translators (presentation-translator-pointer-cursor (first translators))) :move)) + (finish-on-release + (and translators (presentation-translator-finish-on-release (first translators)))) (pointer (port-pointer (port window))) (old-pointer-cursor (pointer-cursor pointer)) (initial-x x) @@ -177,7 +179,7 @@ :key #'presentation-translator-destination-type :test #'presentation-subtypep-1)) (tester - (and translator (presentation-translator-real-tester translator)))) + (and translator (presentation-translator-destination-tester translator)))) (when (or (null tester) (funcall tester object presentation context-type @@ -189,7 +191,7 @@ (letf-globally (((pointer-cursor-override pointer) pointer-cursor)) (setf (pointer-cursor pointer) pointer-cursor) (macrolet ((feedback (window x y state) - `(funcall feedback frame from-presentation ,window + `(funcall feedback frame from-presentation ,window initial-x initial-y ,x ,y ,state)) (highlight (presentation window state) `(when (and ,presentation @@ -197,91 +199,80 @@ (funcall highlighting frame ,presentation ,window ,state)))) (block drag-presentation (tracking-pointer (window :context-type `((or ,@destination-types)) - :multiple-window t :highlight nil) + :multiple-window nil :highlight nil) (:presentation-button-press (presentation event) - (unless finish-on-release - (highlight destination last-window :unhighlight) - (setq destination presentation - destination-event event - last-window (event-sheet event) - last-x (pointer-event-x event) - last-y (pointer-event-y event)) - (return-from drag-presentation))) + (unless finish-on-release + (setq destination-event event + destination presentation) + (return-from drag-presentation))) + (:pointer-button-press (event) - (unless finish-on-release - (highlight destination last-window :unhighlight) - (setq destination nil - destination-event event - last-window (event-sheet event) - last-x (pointer-event-x event) - last-y (pointer-event-y event)) - (return-from drag-presentation))) + (unless finish-on-release + (setq destination-event event + destination nil) + (return-from drag-presentation))) + (:presentation-button-release (presentation event) - (when finish-on-release - (highlight destination last-window :unhighlight) - (setq destination presentation - destination-event event - last-window (event-sheet event) - last-x (pointer-event-x event) - last-y (pointer-event-y event)) - (return-from drag-presentation))) + (when finish-on-release + (setq destination-event event + destination presentation) + (return-from drag-presentation))) + (:pointer-button-release (event) - (when finish-on-release - (highlight destination last-window :unhighlight) - (setq destination nil - destination-event event - last-window (event-sheet event) - last-x (pointer-event-x event) - last-y (pointer-event-y event)) - (return-from drag-presentation))) + (when finish-on-release + (setq destination-event event + destination nil) + (return-from drag-presentation))) + (:presentation (presentation window x y) - (when last-x - (feedback last-window last-x last-y :unhighlight)) - (setq last-x x - last-y y - last-window window) - (feedback window x y :highlight) - (when (not (eq presentation destination)) - (highlight destination last-window :unhighlight) - (setq destination presentation) - (highlight presentation window :highlight) - #+++ignore ;--- documentation - (let ((translator (find-translator destination window x y))) - (when translator - (let ((documentation - (presentation-translator-real-documentation translator))) - (if (stringp documentation) - (write-string documentation doc-stream) - (funcall documentation - (presentation-object presentation) - presentation context-type - frame event window x y - (presentation-object destination) destination - doc-stream))))))) + (when last-x + (feedback last-window last-x last-y :unhighlight)) + (feedback window x y :highlight) + (when (not (eq presentation destination)) + (highlight destination last-window :unhighlight) + (let ((translator (find-translator presentation window x y))) + (setq destination (and translator presentation)) + (highlight destination window :highlight) + (document-drag-and-drop-translator translator + from-presentation destination + context-type + frame event + window x y))) + (setq last-x x last-y y last-window window)) + (:pointer-motion (window x y) - (when (typep window 'clim-stream-sheet) - (highlight destination last-window :unhighlight) - (setq destination nil) - (when last-x - (feedback last-window last-x last-y :unhighlight)) - (setq last-x x - last-y y - last-window window) - (feedback window x y :highlight))))) + (when (typep window 'clim-stream-sheet) + (when last-x + (feedback last-window last-x last-y :unhighlight)) + (feedback window x y :highlight) + (highlight destination last-window :unhighlight) + (setq destination nil) + (let ((translator (find-translator presentation window x y))) + (document-drag-and-drop-translator translator + from-presentation destination + context-type + frame event + window x y)) + (setq last-x x last-y y last-window window))))) + + (highlight destination last-window :unhighlight) (when last-x (feedback last-window last-x last-y :unhighlight))) (setf (pointer-cursor pointer) old-pointer-cursor)) ;; The user has put down the presentation, figure out what to do ;;--- What if there is more than one translator? - (unless destination + (unless destination ;; No destination presentation? Then use the null presentation (setq destination *null-presentation*)) - (let ((translator (find-translator destination last-window last-x last-y))) + (let* ((window (event-sheet destination-event)) + (x (pointer-event-x destination-event)) + (y (pointer-event-y destination-event)) + (translator (find-translator destination window x y))) (when translator (multiple-value-bind (result-object result-type options) (funcall (presentation-translator-real-body translator) object presentation context-type - frame event last-window last-x last-y + frame event window x y (presentation-object destination) destination) (setq result-type (or result-type (evacuate-list context-type))) ;; Find the tag to throw to, and do so @@ -297,17 +288,27 @@ (throw 'no-translation nil)) ;; NEW-X and NEW-Y are in stream coordinates. -(defmethod frame-drag-and-drop-feedback +(defmethod frame-drag-and-drop-feedback ((frame standard-application-frame) presentation stream initial-x initial-y new-x new-y state) - (declare (ignore initial-x initial-y state)) ;we'll just use XOR - (multiple-value-bind (width height) (bounding-rectangle-size presentation) - (with-output-recording-options (stream :record nil) - (with-identity-transformation (stream) - (draw-rectangle* stream new-x new-y (+ new-x width) (+ new-y height) - :filled nil :ink +flipping-ink+ :line-dashes #(4 4)))))) + (declare (optimize (speed 3) (safety 0) (debug 0))) + (declare (ignore state)) ;we'll just use XOR + (multiple-value-bind (xoff yoff) + (convert-from-relative-to-absolute-coordinates + stream (output-record-parent presentation)) + (with-bounding-rectangle* (left top right bottom) presentation + (let ((width (- right left)) + (height (- bottom top)) + (dx (- (+ left xoff) initial-x)) + (dy (- (+ top yoff) initial-y))) + (with-output-recording-options (stream :record nil) + (with-identity-transformation (stream) + (let ((x (+ new-x dx)) + (y (+ new-y dy))) + (draw-rectangle* stream x y (+ x width) (+ y height) + :filled nil :ink +flipping-ink+ :line-dashes #(4 4))))))))) -(defmethod frame-drag-and-drop-highlighting +(defmethod frame-drag-and-drop-highlighting ((frame standard-application-frame) presentation stream state) (ecase state (:highlight @@ -315,6 +316,33 @@ (:unhighlight (unhighlight-highlighted-presentation stream)))) +;; consider merging this with document-presentation-translator +;; specifying :documentation-type as :drag-documentation (cim 4/3/96) + +(defun document-drag-and-drop-translator + (translator from-presentation destination-presentation + context-type frame event window x y + &key (stream (frame-pointer-documentation-output frame))) + (when stream + (window-clear stream) + (when translator + (with-output-recording-options (stream :record nil) + (with-end-of-line-action (stream :allow) + (with-end-of-page-action (stream :allow) + (let ((documentation + (presentation-translator-drag-documentation translator))) + (when documentation + (if (stringp documentation) + (write-string documentation stream) + (funcall documentation + (presentation-object from-presentation) + from-presentation context-type + frame event window x y + (presentation-object destination-presentation) + destination-presentation + stream)))))))) + (force-output stream))) + ;; Used to extract all presentations of a certain type in a "surrounded region" #+++ignore (defun presentations-of-type-in-region (type stream region &optional (sort t)) diff --git a/clim/frames.lisp b/clim/frames.lisp index 524ab43492db3b37e3a9d4ebff2b615b53ea7d92..263b933b31f9414e74c69e09a767f3499def6ac9 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.81 1996/03/01 05:41:55 colin Exp $ +;; $fiHeader: frames.lisp,v 1.82 1996/03/13 09:55:32 colin Exp $ (in-package :clim-internals) @@ -81,6 +81,9 @@ (find-frame-manager))) (t (find-frame-manager)))) +(defmethod frame-manager ((graft graft)) + (find-frame-manager :port (port graft))) + (defmethod initialize-instance :after ((frame standard-application-frame) &key (frame-manager (find-frame-manager)) @@ -403,15 +406,22 @@ (dolist (x pane-constructors) (find-or-make-pane-named frame (car x))))) +;; Many window managers will negotiate correctly with the toolkit to +;; limit frames to the screen size. For those that don't (notably olwm) +;; *graft-maximum-size-factor* allows you to control how much of graft +;; to use. Setting it some value less than 1 will allow you to see the +;; window manager decoration (which CLIM can't know the size of) +;; cim 7/12/96 + +;; Perhaps this should be a slot in the graft and not set globally + +(defvar *graft-maximum-size-factor* nil) + (defmacro limit-size-to-graft (width height graft) `(multiple-value-bind (graft-width graft-height) (bounding-rectangle-size ,graft) ;;--- This fudge factor stuff looks dubious --SWM - ;; using 1 works ok by limiting the size of the top level window - ;; (not the top level window + frame). As you can't know (I don't - ;; think) what the particular wm frame size will be using a hard - ;; wired fudge factor of .9 seems ok to me (cim 9/4/95) - (let ((fudge-factor #-ignore 0.9 #+ignore 1)) + (let ((fudge-factor (or *graft-maximum-size-factor* 1))) (minf-or ,width (* graft-width fudge-factor)) (minf-or ,height (* graft-height fudge-factor))))) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index c414fc27ea5a9d625c813734c21a4aa0130c3afa..d0e0f58da676b60d4fb0cb5ade13509cc69adf45 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.58 1995/05/17 19:47:55 colin Exp $ +;; $fiHeader: gadget-output.lisp,v 1.59 1995/10/17 05:01:32 colin Exp $ (in-package :clim-internals) @@ -293,9 +293,9 @@ +radio-box-view+)) (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)) + ((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 prompt)) (move-cursor-to-view-position stream view) (let ((current-selection nil)) @@ -304,60 +304,75 @@ ;;--- This sucks (if active-p (activate-gadget radio-box) - (deactivate-gadget radio-box)) + (deactivate-gadget radio-box)) (map-over-sheets - #'(lambda (sheet) - (when (typep sheet 'toggle-button) - (when (setf (gadget-value sheet) - (and default-supplied-p - (funcall test (gadget-id sheet) default))) - (setf (radio-box-current-selection radio-box) sheet)))) - radio-box))) + #'(lambda (sheet) + (when (typep sheet 'toggle-button) + (when (setf (gadget-value sheet) + (and default-supplied-p + (funcall test (gadget-id sheet) default))) + (setf (radio-box-current-selection radio-box) sheet)))) + radio-box))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let* ((toggle-options - (getf (view-gadget-initargs view) :toggle-button-options)) + (getf (view-gadget-initargs view) :toggle-button-options)) (radio-box-label - (getf (view-gadget-initargs view) :label)) + (getf (view-gadget-initargs view) :label)) + (label-options + (getf (view-gadget-initargs view) :label-options)) + (borders + (getf (view-gadget-initargs view) :borders t)) (buttons - (map 'list - #'(lambda (element) - (let* ((value (funcall value-key element)) - (button - (apply #'make-pane 'toggle-button - :label - (let ((name (funcall name-key element))) - (if (eq printer #'write-token) - name - (pixmap-from-menu-item stream name printer nil))) - :indicator-type - (getf toggle-options :indicator-type :one-of) - :value - (and default-supplied-p - (funcall test value default)) - :id value - toggle-options))) - (when (and default-supplied-p - (funcall test value default)) - (setq current-selection button)) - button)) - sequence)) + (map 'list + #'(lambda (element) + (let* ((value (funcall value-key element)) + (button + (apply #'make-pane 'toggle-button + :label + (let ((name (funcall name-key element))) + (if (eq printer #'write-token) + name + (apply #'pixmap-from-menu-item + stream name printer nil + :gray-out (not active-p) + (view-gadget-initargs view)))) + :indicator-type + (getf toggle-options :indicator-type :one-of) + :value + (and default-supplied-p + (funcall test value default)) + :id value + toggle-options))) + (when (and default-supplied-p + (funcall test value default)) + (setq current-selection button)) + button)) + sequence)) (radio-box - (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 () - (make-pane 'label-pane :label radio-box-label) - radio-box)) - (outlining () radio-box)) + (make-pane-from-view + 'radio-box view + '(:toggle-button-options :label + :label-options :borders) + :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 (let ((labelled-radio-box + (if radio-box-label + (vertically () + (apply #'make-pane 'label-pane + :label radio-box-label + label-options) + radio-box) + radio-box))) + (if borders + (outlining () + labelled-radio-box) + labelled-radio-box)) radio-box)))))) @@ -371,9 +386,9 @@ +check-box-view+)) (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)) + ((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 prompt)) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget check-box) @@ -381,66 +396,80 @@ ;;--- This sucks (if active-p (activate-gadget check-box) - (deactivate-gadget check-box)) + (deactivate-gadget check-box)) (let ((current-selection nil)) (map-over-sheets - #'(lambda (sheet) - (when (typep sheet 'toggle-button) - (let ((value - (and default-supplied-p - (member (gadget-id sheet) default - :test test) - t))) - (when value (push sheet current-selection)) - (setf (gadget-value sheet) value)))) - check-box) + #'(lambda (sheet) + (when (typep sheet 'toggle-button) + (let ((value + (and default-supplied-p + (member (gadget-id sheet) default + :test test) + t))) + (when value (push sheet current-selection)) + (setf (gadget-value sheet) value)))) + check-box) (setf (check-box-current-selection check-box) current-selection)))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) (let* ((toggle-options - (getf (view-gadget-initargs view) :toggle-button-options)) + (getf (view-gadget-initargs view) :toggle-button-options)) (check-box-label - (getf (view-gadget-initargs view) :label)) + (getf (view-gadget-initargs view) :label)) + (label-options + (getf (view-gadget-initargs view) :label-options)) + (borders + (getf (view-gadget-initargs view) :borders t)) (current-selection nil) (buttons - (map 'list - #'(lambda (element) - (let* ((value (funcall value-key element)) - (actual-value (and default-supplied-p - (member value default - :test test) - t)) - (button - (apply #'make-pane 'toggle-button + (map 'list + #'(lambda (element) + (let* ((value (funcall value-key element)) + (actual-value (and default-supplied-p + (member value default + :test test) + t)) + (button + (apply #'make-pane 'toggle-button :label - (let ((name (funcall name-key element))) - (if (eq printer #'write-token) - name - (pixmap-from-menu-item stream name printer nil))) + (let ((name (funcall name-key element))) + (if (eq printer #'write-token) + name + (apply #'pixmap-from-menu-item + stream name printer nil + :gray-out (not active-p) + (view-gadget-initargs view)))) :indicator-type - (getf toggle-options :indicator-type :some-of) + (getf toggle-options :indicator-type :some-of) :value actual-value :id value toggle-options))) - (when actual-value (push button current-selection)) - button)) - sequence)) + (when actual-value (push button current-selection)) + button)) + sequence)) (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 () - (make-pane 'label-pane :label check-box-label) - check-box)) - (outlining () check-box)) + '(:toggle-button-options :label + :label-options :borders) + :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 (let ((labelled-check-box + (if check-box-label + (vertically () + (apply #'make-pane 'label-pane + :label check-box-label + label-options) + check-box) + check-box))) + (if borders + (outlining () + labelled-check-box) + labelled-check-box)) check-box))))) @@ -454,9 +483,9 @@ +toggle-button-view+)) (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)) + ((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 prompt)) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget button) @@ -464,18 +493,25 @@ ;;--- This sucks (if active-p (activate-gadget button) - (deactivate-gadget button)) + (deactivate-gadget button)) (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 () - :value default - :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 (outlining () button) button))))) + (let ((borders + (getf (view-gadget-initargs view) :borders t)) + (button (make-pane-from-view + 'toggle-button view + '(:borders) + :value default + :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 borders + (outlining () button) + button) + button))))) ;;; Numeric gadgets @@ -514,23 +550,30 @@ (setf (gadget-value slider) (if default-supplied-p default min-value)))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let ((slider + (let ((borders + (getf (view-gadget-initargs view) :borders t)) + (slider ;;--- What other initargs do we pass along from the view? - (make-pane-from-view 'slider view () - :value (if default-supplied-p default min-value) - :min-value min-value :max-value max-value - :orientation (gadget-orientation view) - :decimal-places (or (slider-decimal-places view) 0) - :show-value-p (gadget-show-value-p view) - :client stream :id query-identifier - :value-changed-callback - (and editable-p - (make-accept-values-value-changed-callback - stream query-identifier)) - :active active-p - :editable-p editable-p - :help-callback (make-gadget-help type)))) - (values (outlining () slider) slider)))))) + (make-pane-from-view + 'slider view + '(:borders) + :value (if default-supplied-p default min-value) + :min-value min-value :max-value max-value + :orientation (gadget-orientation view) + :decimal-places (or (slider-decimal-places view) 0) + :show-value-p (gadget-show-value-p view) + :client stream :id query-identifier + :value-changed-callback + (and editable-p + (make-accept-values-value-changed-callback + stream query-identifier)) + :active active-p + :editable-p editable-p + :help-callback (make-gadget-help type)))) + (values (if borders + (outlining () slider) + slider) + slider)))))) (define-presentation-method accept-present-default ((type integer) stream (view slider-view) @@ -562,28 +605,35 @@ ;;--- This sucks (if active-p (activate-gadget slider) - (deactivate-gadget slider)) + (deactivate-gadget slider)) (setf (gadget-value slider) - (if default-supplied-p default min-value)))) + (if default-supplied-p default min-value)))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let ((slider - ;;--- What other initargs do we pass along from the view? - (make-pane-from-view 'slider view () - :value (if default-supplied-p default min-value) - :min-value min-value :max-value max-value - :orientation (gadget-orientation view) - :number-of-quanta (- max-value min-value) - :decimal-places 0 - :show-value-p (gadget-show-value-p view) - :client stream :id query-identifier - :value-changed-callback - (and editable-p - (make-accept-values-value-changed-callback - stream query-identifier)) - :active active-p - :editable-p editable-p - :help-callback (make-gadget-help type)))) - (values (outlining () slider) slider)))))) + (let ((borders + (getf (view-gadget-initargs view) :borders t)) + (slider + ;;--- What other initargs do we pass along from the view? + (make-pane-from-view + 'slider view + '(:borders) + :value (if default-supplied-p default min-value) + :min-value min-value :max-value max-value + :orientation (gadget-orientation view) + :number-of-quanta (- max-value min-value) + :decimal-places 0 + :show-value-p (gadget-show-value-p view) + :client stream :id query-identifier + :value-changed-callback + (and editable-p + (make-accept-values-value-changed-callback + stream query-identifier)) + :active active-p + :editable-p editable-p + :help-callback (make-gadget-help type)))) + (values (if borders + (outlining () slider) + slider) + slider)))))) ;;; Text Field gadget diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index a3587f3a2efeca0753c3ff80707172a0af2c017a..4a13f327f1f3d214311b05f6a747abff1416f9f1 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.47 1995/05/17 19:48:00 colin Exp $ +;; $fiHeader: input-protocol.lisp,v 1.48 1995/10/17 05:01:36 colin Exp $ (in-package :clim-internals) @@ -126,8 +126,7 @@ (cursor-width-and-height-pending-protocol cursor) (with-bounding-rectangle* (left top right bottom) region (when (ltrb-overlaps-ltrb-p left top right bottom - x y (+ x width) (+ y - height)) + x y (+ x width) (+ y height)) (with-sheet-medium (medium stream) (with-medium-clipping-region (medium region) (declare (ignore medium)) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 0d38983fd9445af7fe1f88a9d8659f918d2294d5..a1608fd120faf35a032a034f11df83b9281d6245 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.34 1995/10/20 17:37:37 colin Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.35 1996/03/01 05:42:07 colin Exp $ (in-package :clim-internals) @@ -20,7 +20,8 @@ ;;; Fake methods to keep things like COMPLETE-INPUT from blowing up on ;;; non-input-editing streams like string streams. -(defmethod stream-scan-pointer ((stream t)) 0) +(defmethod stream-scan-pointer ((stream t)) + (file-position stream)) (defmethod (setf stream-scan-pointer) (position (stream t)) (file-position stream position)) diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 8524f7fa303ab1a12dfe02eaa29a6d3bf0e39b4d..c329a7629c360eb3ec70ba69a3ecfd9e27f297eb 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: output-protocol.lisp,v 1.40 1993/09/17 19:05:16 cer Exp $ +;; $fiHeader: output-protocol.lisp,v 1.42 1995/11/23 01:58:37 georgej Exp $ (in-package :clim-internals) @@ -123,6 +123,9 @@ (with-slots (cursor-x cursor-y) stream (values cursor-x cursor-y))) +;;; To make filling-output work on string-streams +(defmethod stream-cursor-position ((stream t)) 0) + (defmethod stream-set-cursor-position ((stream output-protocol-mixin) x y) (with-slots (cursor-x cursor-y current-line-height baseline) stream (when x diff --git a/clim/pixmap-streams.lisp b/clim/pixmap-streams.lisp index 8b8d5fe1cc1b790d9b2c0b195124455d497725b6..c5f5742c802a3fc07fd7760de338d4974c153eec 100644 --- a/clim/pixmap-streams.lisp +++ b/clim/pixmap-streams.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: pixmap-streams.lisp,v 1.21 1993/08/12 16:03:11 cer Exp $ +;; $fiHeader: pixmap-streams.lisp,v 1.22 1993/09/17 19:05:19 cer Exp $ (in-package :clim-internals) @@ -33,7 +33,7 @@ (multiple-value-setq (width height) (bounding-rectangle-size record))) (let* ((pixmap-medium (make-pixmap-medium (port stream) stream :width width :height height)) - (pixmap-stream (make-instance 'pixmap-stream + (pixmap-stream (make-instance 'pixmap-stream :default-text-margin width :port (port stream) :medium pixmap-medium @@ -54,13 +54,15 @@ (multiple-value-setq (width height) (bounding-rectangle-size record))) (let* ((pixmap-medium (make-pixmap-medium (port stream) stream :width width :height height)) - (pixmap-stream (make-instance 'pixmap-stream + (pixmap-stream (make-instance 'pixmap-stream :default-text-margin width :port (port stream) :medium pixmap-medium :width width :height height))) (setf (medium-foreground pixmap-medium) (medium-foreground stream) (medium-background pixmap-medium) (medium-background stream) + ;; Why do we set both medium-default-text-style and + ;; medium-text-style here? (cim 7/1/96) (medium-default-text-style pixmap-medium) (pane-text-style stream) (medium-text-style pixmap-medium) (pane-text-style stream)) (if record @@ -68,8 +70,12 @@ (funcall continuation pixmap-stream)) (slot-value pixmap-medium 'silica::pixmap)))) +(defconstant +gray-out-ink+ + (compose-in (make-opacity .5) +background-ink+)) + (defun pixmap-from-menu-item (associated-window menu-item printer presentation-type - &optional text-style) + &key text-style background foreground gray-out + &allow-other-keys) (with-menu (menu associated-window) (let ((record (with-output-recording-options (menu :draw nil :record t) (with-output-to-output-record (menu) @@ -87,12 +93,19 @@ (with-output-to-pixmap (stream associated-window :width width :height height) (when text-style (setf (medium-default-text-style stream) text-style)) + (when background + (setf (medium-background stream) background)) + (when foreground + (setf (medium-foreground stream) foreground)) (draw-rectangle* stream 0 0 width height :ink +background-ink+ :filled t) (replay-output-record record stream +everywhere+ (- (bounding-rectangle-left record)) - (- (bounding-rectangle-top record)))))))) + (- (bounding-rectangle-top record))) + (when gray-out + (draw-rectangle* stream 0 0 width height + :ink +gray-out-ink+ :filled t))))))) ;;; This code would be nice to use since it will eliminate the ;;; creation of a whole bunch of pixmaps. However, quite often you get @@ -111,7 +124,7 @@ (cond ((or (eq class (find-class 'standard-presentation)) (eq class (find-class 'standard-sequence-output-record))) (if (= (output-record-count record) 1) - (setq record (output-record-element record 0)) + (setq record (output-record-element record 0)) (return nil))) ((eq class (find-class 'standard-text-output-record)) (return record)) diff --git a/clim/translators.lisp b/clim/translators.lisp index ff2afd509cd3930c5f56bf8946a63583502d03b3..4d5aa9e9d957ccb00e698fcee66892bf5eaf11de 100644 --- a/clim/translators.lisp +++ b/clim/translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: translators.lisp,v 1.13 1993/07/27 01:41:46 colin Exp $ +;; $fiHeader: translators.lisp,v 1.14 1995/10/17 05:01:49 colin Exp $ (in-package :clim-internals) @@ -249,13 +249,17 @@ :errorp nil)) translator))) -(defun write-translator-function (function translator-name clause-name extra-args) +(defun write-translator-function (function translator-name clause-name + args &optional (use-default-args t)) (let ((function-name (gensymbol translator-name clause-name)) (arglist (first function)) (body (rest function))) (multiple-value-bind (arglist ignores) (canonicalize-and-match-lambda-lists - (append *translator-function-arglist* extra-args) arglist) + (if use-default-args + (append *translator-function-arglist* args) + args) + arglist) (values `(defun ,function-name ,arglist ,@(and ignores `((declare (ignore ,@ignores)))) ,@body) diff --git a/demo/listener.lisp b/demo/listener.lisp index 3e05404b9661ab738dec94e6840d9ecaf02990ee..9ba06e9ff0dc853b66076ebb22366f18a30a2b1c 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: listener.lisp,v 1.32 1995/05/15 07:17:48 duane Exp $ +;; $fiHeader: listener.lisp,v 1.33 1995/05/17 19:48:42 colin Exp $ (in-package :clim-demo) @@ -11,6 +11,7 @@ (:command-table (lisp-listener :inherit-from (user-command-table))) (:command-definer t) (:menu-bar nil) + (:pointer-documentation t) (:top-level (lisp-listener-top-level)) (:panes (interactor :interactor diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index db18ddf906be4afdc07132a93ba5ff8142ce51ce..30b73cc32f4e489ddc3c44e1aa8d2a7bb3f1bf50 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.29 1995/11/08 06:12:20 georgej Exp $ +;; $fiHeader: compile-1.lisp,v 1.31 1996/03/24 01:52:48 duane Exp $ (in-package :user) @@ -58,7 +58,6 @@ (tenuring (excl:load-system sys)) - #+ics (progn (excl:compile-system 'wnn :include-components t) (excl:load-system 'wnn)) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 65d9bed050e11911899321560df1e5a5a7cbce90..64769611ff38b7c1b70fb0afbb5f498db19cb798 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.60 1995/05/17 19:49:07 colin Exp $ +;; $fiHeader: gadgets.lisp,v 1.61 1995/10/17 05:02:37 colin Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -343,7 +343,8 @@ (defclass row-column-gadget-mixin (oriented-gadget-mixin) ((rows :initarg :rows :initform nil :accessor gadget-rows) - (columns :initarg :columns :initform nil :accessor gadget-columns))) + (columns :initarg :columns :initform nil :accessor gadget-columns) + (spacing :initarg :spacing :initform nil :accessor gadget-spacing))) ;;; Radio box [exclusive-choice] .. [inclusive-choice] (defclass radio-box @@ -760,8 +761,12 @@ (let* ((items (set-gadget-items sheet)) (total-items (length items)) (visible-items (or (gadget-visible-items sheet) - ;; what's the best default to assume here - 1))) + ;; we use +fill+ as the default here so + ;; that we don't try and do any + ;; scrolling if we don't know how many + ;; items are visible ie we assume the + ;; list-pane is infinite (cim 6/24/96) + +fill+))) (multiple-value-bind (selected-items m n) (ecase mode (:exclusive @@ -774,8 +779,7 @@ (let ((item (elt items i))) (when (member (funcall value-key item) value :test test) (push item selected-items) - (setq m (if m (min m i) i) - n (if n (max n i) i))))) + (setq m (or m i) n i)))) (when selected-items (values (nreverse selected-items) m n))))) (when selected-items diff --git a/silica/text-style.lisp b/silica/text-style.lisp index ddd22a7f046949767ecfd3950d8688a1bb2a6132..e8542a25ba7b6628c394c2c7fb2e03ff8d52690e 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-style.lisp,v 1.24 1996/03/01 05:42:55 colin Exp $ +;; $fiHeader: text-style.lisp,v 1.25 1996/03/13 09:55:49 colin Exp $ (in-package :silica) @@ -451,6 +451,21 @@ (defgeneric text-style-fixed-width-p (text-style medium)) (defgeneric text-size (medium string &key text-style start end)) +(defmethod text-style-height ((style list) medium) + (text-style-height (parse-text-style style) medium)) + +(defmethod text-style-width ((style list) medium) + (text-style-width (parse-text-style style) medium)) + +(defmethod text-style-ascent ((style list) medium) + (text-style-ascent (parse-text-style style) medium)) + +(defmethod text-style-descent ((style list) medium) + (text-style-descent (parse-text-style style) medium)) + +(defmethod text-style-fixed-width-p ((style list) medium) + (text-style-fixed-width-p (parse-text-style style) medium)) + (defmethod text-size ((medium basic-medium) string &key (text-style (medium-merged-text-style medium)) (start 0) end) (declare (values largest-x total-height last-x last-y baseline)) diff --git a/test/test-clim.lisp b/test/test-clim.lisp index 922f982b71c95545a30658f6642f930e8da70579..9b6b76609d85065fd7b16a0a5a90c14a4200e5d7 100644 --- a/test/test-clim.lisp +++ b/test/test-clim.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: test-clim.lisp,v 1.14 1993/10/25 16:16:10 cer Exp $ +;; $fiHeader: test-clim.lisp,v 1.16 1995/11/08 06:13:18 georgej Exp $ (in-package :clim-user) @@ -383,6 +383,14 @@ (filling-output (*standard-output* :fill-width '(20 :character)) (write-string *gettysburg-address* *standard-output*)))) +(push 'filling-output-on-string-stream-test clim-test:*frame-tests*) + +(defun filling-output-on-string-stream-test () + (clim-test:with-test-success-expected ('filling-output-on-string-stream-test) + (with-output-to-string (stream) + (filling-output (stream :fill-width '(20 :character)) + (write-string *gettysburg-address* stream))))) + ;;--- This would be nice but the problem occurs in the event handler process ;;---- diff --git a/test/test-suite.lisp b/test/test-suite.lisp index 6a74cbc0f5dee4a08b781d88a6460dd122842c36..d9a152d4c602c882716f043fbcc2960d1fa44cf2 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.77 1995/10/17 05:02:53 colin Exp $ +;; $fiHeader: test-suite.lisp,v 1.78 1996/03/01 05:43:09 colin Exp $ (in-package :clim-user) @@ -1925,10 +1925,26 @@ Luke Luck licks the lakes Luke's duck likes.")) :inherit-from 'integer) (define-drag-and-drop-translator test-suite-dnd - (drag-source string drop-target presentations) - (presentation destination-presentation) + (drag-source string drop-target presentations + :drag-documentation ((object destination-object stream) + (format stream "Drop ~s on ~s" object destination-object)) + :documentation "documentation" + :pointer-documentation "pointer-documentation" + :destination-tester ((object destination-object) + (not (eq object destination-object)))) + (presentation destination-presentation) (format nil "Dragged from ~D to ~D" - (presentation-object presentation) (presentation-object destination-presentation))) + (presentation-object presentation) (presentation-object + destination-presentation))) + + +(define-drag-and-drop-translator test-suite-dnd-blank + (drag-source string drop-target presentations + :drag-documentation "Don't drop now" + :pointer-documentation "bar bar" + :documentation "Documentatoin") + () + (format nil "Dragged to blank area")) (define-test (drag-and-drop-tests presentations) (stream) "Try drag and drop" @@ -2319,6 +2335,38 @@ Luke Luck licks the lakes Luke's duck likes.")) (5.0 float) (1 integer)))))))) +(define-test (gadget-resource-dialog menus-and-dialogs) (stream) + "Test gadgets with non-default background, text-style + printer" + (let ((printer #'princ) + (background +red+) + (text-style (make-text-style :sans-serif :italic :large))) + (accepting-values (stream) + (accept `((member a b c) :printer ,printer) + :stream stream :prompt "X" + :view `(radio-box-view :background ,background + :text-style ,text-style)) + (terpri stream) + (accept `((subset a b c) :printer ,printer) + :stream stream :prompt "Y" + :view `(check-box-view :background ,background + :text-style ,text-style)) + (terpri stream) + (accept `((member p q r) :printer ,printer) + :stream stream :prompt "Z" + :view `(option-pane-view :background ,background + :text-style ,text-style)) + (terpri stream) + (accept-values-command-button + (stream + :view `(push-button-view :background ,background + :text-style ,text-style)) + (funcall printer 'hello stream) + (menu-choose '(a b c) :printer printer + :background background + :text-style text-style))))) + + + (defun gadgets-dialog-internal (stream &optional own-window) (macrolet ((accepts (&rest accepts) `(progn @@ -3489,7 +3537,8 @@ Luke Luck licks the lakes Luke's duck likes.")) (make-instance (clim-tests-history-class *application-frame*)))) (:layouts (:default - (vertically () caption-pane display-pane)))) + (vertically () caption-pane display-pane))) + (:pointer-documentation t)) (defmethod frame-standard-output ((frame clim-tests)) (get-frame-pane frame 'display-pane)) @@ -3509,3 +3558,4 @@ Luke Luck licks the lakes Luke's duck likes.")) + diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp index 3238c644d93db97f08fe6fb15f5d1746326a54aa..b17eb87ad0fcb444170648d3a054406c952f9ec3 100644 --- a/tk-silica/xm-dialogs.lisp +++ b/tk-silica/xm-dialogs.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: xm-dialogs.lisp,v 1.10 1995/11/08 06:15:52 georgej Exp $ +;; $fiHeader: xm-dialogs.lisp,v 1.11 1996/03/01 05:44:07 colin Exp $ (in-package :clim-internals) @@ -36,7 +36,8 @@ :output-record (make-instance 'standard-sequence-output-history) :initial-cursor-visibility :off - :scroll-bars scroll-bars)) + :scroll-bars scroll-bars + :end-of-page-action :allow)) (make-pane 'silica::separator :orientation :horizontal) (setf exit-button-stream (make-pane 'clim-stream-pane diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 4f2f915b7050a35d5c7a274ee4d9732521d9b65a..d425718382f0d06c80dfa044bd9f33ba83b28ffe 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.71 1995/11/08 06:15:55 georgej Exp $ +;; $fiHeader: xm-frames.lisp,v 1.72 1996/03/01 05:44:09 colin Exp $ (in-package :xm-silica) @@ -434,10 +434,11 @@ (text-style (if item-text-style (merge-text-styles item-text-style menu-text-style) menu-text-style)) + (sensitive (clim-internals::menu-item-active item)) (button (if simplep (apply #'make-instance class - :sensitive (clim-internals::menu-item-active item) + :sensitive sensitive :parent parent :managed nil :label-string (princ-to-string (menu-item-display item)) @@ -451,10 +452,13 @@ item printer presentation-type - text-style)) + :text-style text-style + :background background + :foreground foreground + :gray-out (not sensitive))) (button (apply #'make-instance class - :sensitive (clim-internals::menu-item-active item) + :sensitive sensitive :parent parent :label-type :pixmap :label-pixmap pixmap diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 3040ec1d986598c73f1dc1c262b933e696603208..8ea051897bf9fe8e542214b8457b910ec3d87c46 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -17,7 +17,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.92 1996/03/01 05:44:12 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.93 1996/03/13 09:56:11 colin Exp $ (in-package :xm-silica) @@ -189,7 +189,8 @@ ((or null string) (with-sheet-medium (medium sheet) (multiple-value-setq (width height) - (text-size medium label :text-style (pane-text-style sheet))))) + (text-size medium label + :text-style (pane-text-style sheet))))) (tk::pixmap (setq width (xt::pixmap-width label) height (xt::pixmap-height label))) @@ -1076,17 +1077,21 @@ (parent t) (sheet motif-row-column-gadget-mixin)) (let ((initargs (call-next-method)) - (x (ecase (gadget-orientation sheet) - (:vertical (or (gadget-columns sheet) - (and (silica::gadget-rows sheet) + (columns + (ecase (gadget-orientation sheet) + (:vertical (or (gadget-columns sheet) + (and (silica::gadget-rows sheet) + (ceiling (length (sheet-children sheet)) + (silica::gadget-rows sheet))))) + (:horizontal (or (silica::gadget-rows sheet) + (and (silica::gadget-columns sheet) (ceiling (length (sheet-children sheet)) - (silica::gadget-rows sheet))))) - (:horizontal (or (silica::gadget-rows sheet) - (and (silica::gadget-columns sheet) - (ceiling (length (sheet-children sheet)) - (silica::gadget-columns sheet)))))))) - (when x - (setf (getf initargs :num-columns) x)) + (silica::gadget-columns sheet))))))) + (spacing (silica::gadget-spacing sheet))) + (when columns + (setf (getf initargs :num-columns) columns)) + (when spacing + (setf (getf initargs :spacing) spacing)) initargs)) ;;; @@ -1343,19 +1348,15 @@ (and (typep p 'motif-scroller-pane) (scroller-pane-scroll-bar-policy p))))) `(:list-size-policy - #-ignore ,(case scroll-mode + ;; specifying the list-size-policy as :variable is the + ;; only way of getting only vertical scroll-bars (: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 ((:horizontal :vertical t :both) :static) - (t :as-needed) - :as-needed) + (t :as-needed)) ,@(and selected-items `(:selected-item-count ,(length selected-items) :selected-items ,selected-items @@ -1368,6 +1369,12 @@ :items ,(mapcar name-key items) :item-count ,(length items)))))) +(defmethod gadget-visible-items ((gadget motif-list-pane)) + (let ((m (sheet-direct-mirror gadget))) + (if m + (tk::get-values m :visible-item-count) + (call-next-method)))) + (defmethod (setf set-gadget-items) :after (items (gadget motif-list-pane)) ;;---- What should this do about selected items and the value etc etc (let ((m (sheet-direct-mirror gadget))) @@ -1457,18 +1464,21 @@ (let* ((name (funcall name-key item)) (pixmap (unless (or (null printer) (eq printer #'write-token)) (pixmap-from-menu-item - (sheet-parent sheet) name printer nil))) + (sheet-parent sheet) name printer nil + :text-style (pane-text-style sheet) + :background (pane-background sheet) + :foreground (pane-foreground sheet)))) (button (if (null pixmap) (apply #'make-instance 'tk::xm-push-button - :label-string name - :parent pdm - initargs) + :label-string name + :parent pdm + initargs) (apply #'make-instance 'tk::xm-push-button - :label-pixmap pixmap - :label-type :pixmap - :parent pdm - initargs)))) + :label-pixmap pixmap + :label-type :pixmap + :parent pdm + initargs)))) (tk::add-callback button :activate-callback @@ -1509,21 +1519,24 @@ :font-list)) mirror)) -(defun set-option-menu-value (gadget nv) +(defun set-option-menu-value (sheet nv) (with-accessors ((items set-gadget-items) (value-key set-gadget-value-key) (test set-gadget-test) (printer silica::option-pane-printer) - (name-key set-gadget-name-key)) gadget - (when (sheet-direct-mirror gadget) + (name-key set-gadget-name-key)) sheet + (when (sheet-direct-mirror sheet) (let* ((x (position nv items :test test :key value-key)) - (widget (sheet-direct-mirror gadget))) + (widget (sheet-direct-mirror sheet))) (when x - (tk::set-values widget :menu-history (nth x (motif-option-menu-buttons gadget))) + (tk::set-values widget :menu-history (nth x (motif-option-menu-buttons sheet))) (let* ((name (funcall name-key (nth x items))) (pixmap (unless (or (null printer) (eq printer #'write-token)) (pixmap-from-menu-item - (sheet-parent gadget) name printer nil))) + (sheet-parent sheet) name printer nil + :text-style (pane-text-style sheet) + :background (pane-background sheet) + :foreground (pane-foreground sheet)))) (widget (tk::intern-widget (tk::xm_option_button_gadget widget)))) (if pixmap (tk::set-values widget :label-pixmap pixmap :label-type :pixmap) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 601e09be34ed47056b1ff6350811ad6a139e2c7e..1c1a9cde62f0647682f8d9a702977159b80554b0 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.102 1996/03/13 09:56:15 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.103 1996/03/15 05:18:31 colin Exp $ (in-package :xm-silica) @@ -207,10 +207,11 @@ (screen-pixels-per-inch (* 25.4 (/ (x11::xdisplayheight display screen) (x11:xdisplayheightmm display screen))))) - (labels ((parse-token (token) - (and token - (parse-integer token))) - (font->text-style (font family) + (flet ((font->text-style (font family) + (flet ((parse-token (token) + (if token + (parse-integer token) + (return-from font->text-style nil)))) (let* ((tokens (disassemble-x-font-name font)) (italic (member (nth 4 tokens) '("i" "o") :test #'equalp)) (bold (equalp (nth 3 tokens) "bold")) @@ -228,7 +229,7 @@ (or (eql pixel-size 0) (eql point-size 0) (eql average-width 0))) - (make-text-style family face (/ corrected-point-size 10)))))) + (make-text-style family face (/ corrected-point-size 10))))))) (dolist (per-charset *xt-font-families*) (destructuring-bind (character-set fallback &rest families) per-charset (dolist (per-family families) diff --git a/tk/graphics.lisp b/tk/graphics.lisp index 7cf4a02d8f105c86518f51271bd58dd01b13feaf..ca7135aa29a4131feb7fa6ebc296f4d72aaf3fb4 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: graphics.lisp,v 1.19 1996/01/23 06:46:58 duane Exp $ +;; $fiHeader: graphics.lisp,v 1.20 1996/03/01 05:43:25 colin Exp $ (in-package :tk) @@ -192,7 +192,7 @@ (defun draw-image-string (drawable gc x y string &optional (length (length string))) - (x11::drawimagestring + (x11::xdrawimagestring (object-display drawable) drawable gc diff --git a/tk/macros.lisp b/tk/macros.lisp index 928ba4e89457f8f35a97830dad6a7691943cdb60..d007cb935369da89267c7e2806e3f4f1efbca927 100644 --- a/tk/macros.lisp +++ b/tk/macros.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: macros.lisp,v 1.17 1996/01/23 06:47:01 duane Exp $ +;; $fiHeader: macros.lisp,v 1.18 1996/03/01 05:43:27 colin Exp $ (in-package :tk) @@ -103,16 +103,22 @@ (:-ics ,string))))) (defmacro lisp-string-to-string16 (string) - (clim-utils:with-gensyms (length string16 i) + (clim-utils:with-gensyms (length string16 i j code) (clim-utils:once-only (string) `(excl:ics-target-case (:+ics (let* ((,length (length ,string)) - (,string16 (make-array (1+ ,length) :element-type '(unsigned-byte 16)))) + (,string16 (make-array (* (1+ ,length) 2) + :element-type '(unsigned-byte 8))) + (,j 0)) (dotimes (,i ,length) - (setf (aref ,string16 ,i) - (xchar-code (char ,string ,i)))) - (setf (aref ,string16 ,length) 0) + (let ((,code (xchar-code (char ,string ,i)))) + (setf (aref ,string16 ,j) (ldb (byte 8 8) ,code)) + (incf ,j) + (setf (aref ,string16 ,j) (ldb (byte 8 0) ,code)) + (incf ,j))) + (setf (aref ,string16 ,j) 0 + (aref ,string16 (1+ ,j)) 0) ,string16)) (:-ics (error "~S called in non-ICS Lisp" 'lisp-string-to-string16)))))) diff --git a/tk/resources.lisp b/tk/resources.lisp index 857cd20557fbbf368bd81b53990c5d52c2e2f75d..e3c3e191b937df333a735d0bab6292a65b53fb2b 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: resources.lisp,v 1.55 1996/01/23 06:47:08 duane Exp $ +;; $fiHeader: resources.lisp,v 1.56 1996/03/01 05:43:35 colin Exp $ (in-package :tk) @@ -643,10 +643,6 @@ (excl:euc-to-string euc))) (:-ics (char*-to-string value))))) -(defmethod convert-resource-in ((parent t) (type (eql 'string)) value) - (unless (zerop value) -)) - (defmethod convert-resource-in ((parent t) (type (eql 'boolean)) value) (not (zerop value))) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index e5eaf4b1b55e17e7ddc3fb38e4cc3a0d1f907df3..38cacb6e1cf476231d723a397b318d13d6a2146f 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $fiHeader: xm-widgets.lisp,v 1.23 1996/01/23 06:47:20 duane Exp $ +;; $fiHeader: xm-widgets.lisp,v 1.24 1996/03/01 05:43:49 colin Exp $ (in-package :tk) @@ -155,7 +155,7 @@ (note-malloced-object (xm_string_create_l_to_r (note-malloced-object (string-to-char* value)) - (note-malloced-object (string-to-char* xm-font-list-default-tag))))))) + (note-malloced-object (string-to-char* ""))))))) (defmethod convert-resource-out ((parent t) (type (eql 'xm-background-pixmap)) value) (etypecase value diff --git a/utils/excl-verification.lisp b/utils/excl-verification.lisp index 8cb35586c323c6712a4f6a7580c3c93c9f933bd9..95e0b873d50bfe71797d9a328995a6168a40dfa1 100644 --- a/utils/excl-verification.lisp +++ b/utils/excl-verification.lisp @@ -19,7 +19,7 @@ ;; Commercial Software developed at private expense as specified in ;; DOD FAR Supplement 52.227-7013 (c) (1) (ii), as applicable. ;; -;; $Header: /repo/cvs.copy/clim2/utils/excl-verification.lisp,v 1.20 1995/11/08 06:16:31 georgej Exp $ +;; $Header: /repo/cvs.copy/clim2/utils/excl-verification.lisp,v 1.21 1996/07/23 21:34:52 colin Exp $ (in-package :sys) @@ -34,31 +34,11 @@ (pushnew :silica *features*) (pushnew :ansi-90 *features*)) -#-Silica -(eval-when (compile load eval) - (require :clx)) - (provide :clim) (provide :climg) -#+(not (version>= 4 1)) -(let* ((patch-package (find-package :patch)) - (patches-symbol (and patch-package - (find-symbol (string '*patches*) patch-package))) - (patches (and patches-symbol (symbol-value patches-symbol))) - (needed-patches '(26. 27. 46. 50.)) - (dont-have (remove-if - #'(lambda (pn) - (assoc pn patches)) - needed-patches))) - (when dont-have - (error "On Allegro 4.0 CLIM requires patches ~{~S ~} ~ -You do not have patches ~{~S ~}" - needed-patches - dont-have))) - (defvar *clim-version* - '("CLIM 2.1.beta" - "$Header: /repo/cvs.copy/clim2/utils/excl-verification.lisp,v 1.20 1995/11/08 06:16:31 georgej Exp $")) + '("CLIM 2.1" + "$Header: /repo/cvs.copy/clim2/utils/excl-verification.lisp,v 1.21 1996/07/23 21:34:52 colin Exp $")) (si::rcsnote (first *clim-version*) (second *clim-version*)) diff --git a/utils/packages.lisp b/utils/packages.lisp index 678599e7f123781bed42b5faa1be3fc314632438..e11fa33f7592b23fc8c5e42c66bc4e6ceef53166 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.68 1996/03/01 05:44:44 colin Exp $ +;; $fiHeader: packages.lisp,v 1.69 1996/03/13 09:56:23 colin Exp $ (in-package :common-lisp-user) @@ -2485,6 +2485,7 @@ gadget-output-record gadget-range gadget-range* + gadget-spacing gadget-show-value-p gadget-value gadget-value-changed-callback diff --git a/wnn/jserver.lisp b/wnn/jserver.lisp index 2102bf4a3ecbb14a5015b7c115476276a7531303..fd81ece197748d08c9091da26f49f000cffd8a81 100644 --- a/wnn/jserver.lisp +++ b/wnn/jserver.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: jserver.lisp,v 1.1 1995/10/20 17:42:17 colin Exp $ +;; $fiHeader: jserver.lisp,v 1.2 1996/03/01 05:44:50 colin Exp $ (in-package :wnn) @@ -61,9 +61,9 @@ ;; it's important to specify a timeout of -1 ;; in the call to jl_open_lang otherwise wnn ;; messes with sigalrm - (jl_open_lang (tk::lisp-string-to-string8 login) - (tk::lisp-string-to-string8 host) - (tk::lisp-string-to-string8 lang) + (jl_open_lang (ff:string-to-char* login) + (ff:string-to-char* host) + (ff:string-to-char* lang) 0 0 0 -1)) (setf (mp:process-quantum mp:*current-process*) temp) (mp:process-allow-schedule)))) diff --git a/wnn/load-wnn.lisp b/wnn/load-wnn.lisp index 4491315b91003ab375eed2a59c385b18ca2d9b4d..ffea5f656803670083107c30c4f8e07eb0d3777f 100644 --- a/wnn/load-wnn.lisp +++ b/wnn/load-wnn.lisp @@ -18,12 +18,15 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-wnn.lisp,v 1.2 1996/03/13 09:56:55 colin Exp $ +;; $fiHeader: load-wnn.lisp,v 1.3 1996/03/15 05:18:37 colin Exp $ (in-package :user) ;;; compare with tk/load-xm for update to new makefile style +(excl:ics-target-case +(:+ics + #-dlfcn (progn @@ -42,6 +45,6 @@ (provide :wnn) (pushnew :wnn *features*) - +)) ;; ics-target-case