Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23472

Modified Files: presentation-defs.lisp Log Message: This patch HANDLER-BINDs the ABORT-GESTURE condition to #'abort for the function ACCEPT in presentation-defs.lisp.

ABORT-GESTURE is the condition that is signaled when any of the gestures in *ABORT-GESTURES* is read (in STREAM-READ-GESTURE). Right now *ABORT-GESTURES* contains only :abort on mcclim, which is a the keyboard gesture (#\c :control) (on Genera it contains #\Abort, the ABORT-key).

I do not find explicitly in the clim specification that an ACCEPT should be aborted on an ABORT-GESTURE, but it seems to be the right thing (and I have to admit that I haven't been looking very hard).

I did short tests with ACCEPTING-VALUES and it seems to behave correctly with this patch, i.e. the whole dialog will be aborted. But perhaps it would be nicer if, as long as a gadget of the dialog is selected, only the edit of that gadget were aborted.

Date: Thu Aug 25 22:24:12 2005 Author: mretzlaff

Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.45 mcclim/presentation-defs.lisp:1.46 --- mcclim/presentation-defs.lisp:1.45 Mon Aug 8 19:15:07 2005 +++ mcclim/presentation-defs.lisp Thu Aug 25 22:24:10 2005 @@ -664,71 +664,72 @@ display-default query-identifier activation-gestures additional-activation-gestures delimiter-gestures additional-delimiter-gestures)) - (let* ((real-type (expand-presentation-type-abbreviation type)) - (real-default-type (cond (default-type-p - (expand-presentation-type-abbreviation - default-type)) - ((or defaultp provide-default) - real-type) - (t nil))) - (real-history-type (cond ((null historyp) real-type) - ((null history) nil) - (t (expand-presentation-type-abbreviation - history)))) - (*recursive-accept-p* *recursive-accept-1-p*) - (*recursive-accept-1-p* t)) - (with-keywords-removed (rest-args (:stream)) - (when (or default-type-p defaultp) - (setf rest-args - (list* :default-type real-default-type rest-args))) - (when historyp - (setf rest-args (list* :history real-history-type rest-args))) - (cond ((and viewp (symbolp view)) - (setf rest-args - (list* :view (funcall #'make-instance view) rest-args))) - ((consp view) - (setf rest-args - (list* :view (apply #'make-instance view) rest-args)))) - ;; Presentation type history interaction. According to the spec, - ;; if provide-default is true, we take the default from the - ;; presentation history. In addition, we'll implement the Genera - ;; behavior of temporarily putting the default on the history - ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) - (let* ((default-from-history (and (not defaultp) provide-default)) - (history (get-history)) - (results - (multiple-value-list - (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) - (do-accept rest-args)))) - (results-history (get-history))) - (when results-history - (presentation-history-add results-history - (car results) - (cadr results))) - (values-list results)))))) + (handler-bind ((abort-gesture #'abort)) + (let* ((real-type (expand-presentation-type-abbreviation type)) + (real-default-type (cond (default-type-p + (expand-presentation-type-abbreviation + default-type)) + ((or defaultp provide-default) + real-type) + (t nil))) + (real-history-type (cond ((null historyp) real-type) + ((null history) nil) + (t (expand-presentation-type-abbreviation + history)))) + (*recursive-accept-p* *recursive-accept-1-p*) + (*recursive-accept-1-p* t)) + (with-keywords-removed (rest-args (:stream)) + (when (or default-type-p defaultp) + (setf rest-args + (list* :default-type real-default-type rest-args))) + (when historyp + (setf rest-args (list* :history real-history-type rest-args))) + (cond ((and viewp (symbolp view)) + (setf rest-args + (list* :view (funcall #'make-instance view) rest-args))) + ((consp view) + (setf rest-args + (list* :view (apply #'make-instance view) rest-args)))) + ;; Presentation type history interaction. According to the spec, + ;; if provide-default is true, we take the default from the + ;; presentation history. In addition, we'll implement the Genera + ;; behavior of temporarily putting the default on the history + ;; stack so the user can conveniently suck it in. + (flet ((do-accept (args) + (apply #'stream-accept stream real-type args)) + (get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream)))) + (let* ((default-from-history (and (not defaultp) provide-default)) + (history (get-history)) + (results + (multiple-value-list + (if history + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-head history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (do-accept rest-args)))) + (results-history (get-history))) + (when results-history + (presentation-history-add results-history + (car results) + (cadr results))) + (values-list results)))))))

(defgeneric stream-accept (stream type &key