diff --git a/clim/activities.lisp b/clim/activities.lisp index 0a8160c10652d6fc306ac746b4bea8e7fc793f89..23368b1ee561e08cc391900ddad2c946c936bcef 100644 --- a/clim/activities.lisp +++ b/clim/activities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: activities.lisp,v 1.9 92/12/03 10:26:01 cer Exp $ +;; $fiHeader: activities.lisp,v 1.10 92/12/16 16:45:59 cer Exp $ (in-package :clim-internals) @@ -147,6 +147,10 @@ (defclass activity-frame (standard-application-frame) ((activity :initform nil :accessor frame-activity :initarg :activity))) +(defmethod frame-top-level-process ((frame activity-frame)) + (let ((act (frame-activity frame))) + (and act (slot-value act 'top-level-process)))) + (defmethod initialize-instance :after ((frame activity-frame) &key activity) (assert activity () "The activity frame ~S requires an activity" frame)) @@ -273,3 +277,8 @@ ;;--- We should set flag in frame so that the default top level ;;--- notices this and exits or throws ))) + + +(defmethod destroy-activity ((activity activity)) + ;;-- Need it do anything else? + (mapc #'destroy-frame (frame-manager-frames activity))) diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index 3f57164d4d169db5820b74046e695b84c70686a9..0e9e4d8073cc69dc93e9bf23d095a21f83164d08 100644 --- a/clim/basic-translators.lisp +++ b/clim/basic-translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: basic-translators.lisp,v 1.14 92/12/16 16:46:02 cer Exp $ +;; $fiHeader: basic-translators.lisp,v 1.15 93/01/21 14:57:40 cer Exp $ (in-package :clim-internals) @@ -62,7 +62,7 @@ (find-presentation-translator 'presentation-menu 'presentation-menu-command-table)) (defun call-presentation-menu (presentation input-context frame window x y - &key (for-menu t) label) + &key (for-menu t) label (gesture :menu)) (let* ((translators (find-applicable-translators presentation input-context frame window x y :event nil :for-menu for-menu)) @@ -89,7 +89,8 @@ (let ((chosen (menu-choose item-list :associated-window window :label label - :printer #'translator-documentation))) + :printer #'translator-documentation + :gesture gesture))) (when chosen ;; Anticipate the day when we can move the mouse off the menu (let* ((translator (pop chosen)) diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index d91b42da6e01122a43bf7f0aa63851806cf159fb..8719a6d4945451119057f73f26a5a626ccc25db5 100644 --- a/clim/command-processor.lisp +++ b/clim/command-processor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command-processor.lisp,v 1.19 92/11/19 14:17:10 cer Exp $ +;; $fiHeader: command-processor.lisp,v 1.20 92/12/03 10:26:09 cer Exp $ (in-package :clim-internals) @@ -469,8 +469,14 @@ :numeric-argument numeric-arg))) (when (presentation-typep command command-type) (return-from menu-command-parser - (values command command-type))))) - (beep stream))) + (values command + command-type))))) + (beep stream) + ;;--- Nasty hack + (when (typep stream 'input-editing-stream-mixin) + (let ((input-buffer + (input-editor-buffer stream))) + (ie-rub-del stream input-buffer -1))))) (let ((token (read-token stream :click-only t :timeout timeout))) (if (eq token :timeout) (return-from menu-command-parser nil) @@ -523,11 +529,12 @@ (define-presentation-method accept ((type command-name) stream (view textual-view) &key) (setq command-table (find-command-table command-table)) - (complete-input stream - #'(lambda (string action) - (command-table-complete-input command-table string action - :frame *application-frame*)) - :partial-completers *command-name-delimiters*)) + (values + (complete-input stream + #'(lambda (string action) + (command-table-complete-input command-table string action + :frame *application-frame*)) + :partial-completers *command-name-delimiters*))) (define-presentation-method present (symbol (type command-name) stream (view textual-view) &key for-context-type) diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp index 639e3b030b91031d6fd68d6009c916748e4b2c64..9ec41ce4dbc157173ede897a332e78e8e8ad1e47 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.9 92/12/03 10:26:31 cer Exp $ +;; $fiHeader: drag-and-drop.lisp,v 1.10 93/01/18 13:54:23 cer Exp $ (in-package :clim-internals) @@ -121,178 +121,180 @@ (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*)) - (let* ((command-table (frame-command-table frame)) - (translators - (let ((all-translators + *drag-and-drop-finish-on-release*)) + (catch-abort-gestures ("Abort drag and drop") + (let* ((command-table (frame-command-table frame)) + (translators + (let ((all-translators (find-presentation-translators - (presentation-type presentation) context-type command-table))) - ;; This find all translators that could conceivably apply - (mapcan #'(lambda (translator) - (when (and (typep translator 'drag-and-drop-translator) - (test-presentation-translator + (presentation-type presentation) context-type command-table))) + ;; This find all translators that could conceivably apply + (mapcan #'(lambda (translator) + (when (and (typep translator 'drag-and-drop-translator) + (test-presentation-translator translator presentation context-type frame window x y :event event)) - (list translator))) - all-translators))) - (destination-types - ;; So we can let TRACKING-POINTER do the work of finding applicable - ;; destination presentations... - (mapcar #'presentation-translator-destination-type translators)) - ;; Get the feedback and highlighting functions - ;;--- This should really check to make sure that the feedback and - ;;--- highlighting functions and the pointer cursor are the same for - ;;--- the related set of translators - (feedback - (and translators (presentation-translator-feedback (first translators)))) - (highlighting - (and translators (presentation-translator-highlighting (first translators)))) - (pointer-cursor - (or (and translators (presentation-translator-pointer-cursor (first translators))) - :move)) - (pointer (port-pointer (port window))) - (old-pointer-cursor (pointer-cursor pointer)) - (initial-x x) - (initial-y y) - (last-x nil) - (last-y nil) - (last-window nil) - (from-presentation presentation) - ;; The presentation we finally landed on, and the event used - (destination nil) - (destination-event nil) - ;; Defeat the normal gesture processing stuff - (*input-wait-handler* nil) - (*input-wait-test* nil) - (*pointer-button-press-handler* nil)) - (read-gesture :stream window :timeout 0) ;eat the initial mouse click - (when (output-recording-stream-p window) - (unhighlight-highlighted-presentation window)) - (when (null translators) - (return-from invoke-drag-and-drop-translator nil)) - (flet ((find-translator (destination-presentation window x y) - (let* ((translator - (find (presentation-type destination-presentation) translators - :key #'presentation-translator-destination-type - :test #'presentation-subtypep-1)) - (tester - (and translator (presentation-translator-real-tester translator)))) - (when (or (null tester) - (funcall tester - object presentation context-type - frame event window x y - (presentation-object destination-presentation) - destination-presentation)) - translator)))) - (declare (dynamic-extent #'find-translator)) - (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 - initial-x initial-y ,x ,y ,state)) - (highlight (presentation window state) - `(when (and ,presentation - (output-recording-stream-p ,window)) - (funcall highlighting frame ,presentation ,window ,state)))) - (block drag-presentation - (tracking-pointer (window :context-type `((or ,@destination-types)) - :multiple-window t :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))) - (: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))) - (: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))) - (: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))) - (: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 + (list translator))) + all-translators))) + (destination-types + ;; So we can let TRACKING-POINTER do the work of finding applicable + ;; destination presentations... + (mapcar #'presentation-translator-destination-type translators)) + ;; Get the feedback and highlighting functions + ;;--- This should really check to make sure that the feedback and + ;;--- highlighting functions and the pointer cursor are the same for + ;;--- the related set of translators + (feedback + (and translators (presentation-translator-feedback (first translators)))) + (highlighting + (and translators (presentation-translator-highlighting (first translators)))) + (pointer-cursor + (or (and translators (presentation-translator-pointer-cursor (first translators))) + :move)) + (pointer (port-pointer (port window))) + (old-pointer-cursor (pointer-cursor pointer)) + (initial-x x) + (initial-y y) + (last-x nil) + (last-y nil) + (last-window nil) + (from-presentation presentation) + ;; The presentation we finally landed on, and the event used + (destination nil) + (destination-event nil) + ;; Defeat the normal gesture processing stuff + (*input-wait-handler* nil) + (*input-wait-test* nil) + (*pointer-button-press-handler* nil)) + (read-gesture :stream window :timeout 0) ;eat the initial mouse click + (when (output-recording-stream-p window) + (unhighlight-highlighted-presentation window)) + (when (null translators) + (return-from invoke-drag-and-drop-translator nil)) + (flet ((find-translator (destination-presentation window x y) + (let* ((translator + (find (presentation-type destination-presentation) translators + :key #'presentation-translator-destination-type + :test #'presentation-subtypep-1)) + (tester + (and translator (presentation-translator-real-tester translator)))) + (when (or (null tester) + (funcall tester + object presentation context-type frame event window x y - (presentation-object destination) destination - doc-stream))))))) - (: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 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 - ;; No destination presentation? Then use the null presentation - (setq destination *null-presentation*)) - (let ((translator (find-translator destination last-window last-x last-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 - (presentation-object destination) destination) - (setq result-type (or result-type (evacuate-list context-type))) - ;; Find the tag to throw to, and do so - (dolist (this-context *input-context*) - (let* ((context-type (input-context-type this-context)) - (tag (input-context-tag this-context))) - (when (presentation-subtypep-1 result-type context-type) - (throw tag - (values result-object - result-type - (or destination-event event) - options))))))))))) + (presentation-object destination-presentation) + destination-presentation)) + translator)))) + (declare (dynamic-extent #'find-translator)) + (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 + initial-x initial-y ,x ,y ,state)) + (highlight (presentation window state) + `(when (and ,presentation + (output-recording-stream-p ,window)) + (funcall highlighting frame ,presentation ,window ,state)))) + (block drag-presentation + (tracking-pointer (window :context-type `((or ,@destination-types)) + :multiple-window t :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))) + (: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))) + (: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))) + (: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))) + (: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))))))) + (: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 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 + ;; No destination presentation? Then use the null presentation + (setq destination *null-presentation*)) + (let ((translator (find-translator destination last-window last-x last-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 + (presentation-object destination) destination) + (setq result-type (or result-type (evacuate-list context-type))) + ;; Find the tag to throw to, and do so + (dolist (this-context *input-context*) + (let* ((context-type (input-context-type this-context)) + (tag (input-context-tag this-context))) + (when (presentation-subtypep-1 result-type context-type) + (throw tag + (values result-object + result-type + (or destination-event event) + options))))))))))) + (throw 'no-translation nil)) ;; NEW-X and NEW-Y are in stream coordinates. (defmethod frame-drag-and-drop-feedback diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index 38f213bd8cb8dfa180dcad7a6c687c4890e7839f..872518093244b8dcac62e4e474a283eeea55262a 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -1,6 +1,6 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- +M;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-defs.lisp,v 1.15 92/09/24 09:39:00 cer Exp $ +;; $fiHeader: input-defs.lisp,v 1.16 92/11/19 14:17:55 cer Exp $ (in-package :clim-internals) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index e6f0c1b304aff578a7d9a003876c88428ef1ce64..9ad615dc42b62615b6b1c75698c9b5e0ddaf132b 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.37 92/12/16 16:46:36 cer Exp $ +;; $fiHeader: input-protocol.lisp,v 1.38 93/01/21 14:58:09 cer Exp $ (in-package :clim-internals) @@ -159,8 +159,8 @@ (cond ((and (member event *asynchronous-abort-gestures* :test #'keyboard-event-matches-gesture-name-p) (setq temp (pane-frame stream)) - (setq temp (slot-value temp 'top-level-process))) - (process-interrupt temp #'abort)) + (setq temp (frame-top-level-process temp))) + (process-interrupt temp #'(lambda () (process-abort-gesture stream event)))) ((and (characterp char) (or (ordinary-char-p char) (diacritic-char-p char))) @@ -388,34 +388,37 @@ :numeric-argument (or *accelerator-numeric-argument* 1))) ((member gesture *abort-gestures* :test #'keyboard-event-matches-gesture-name-p) - (let* ((frame (pane-frame stream)) - ;; When dealing with an application frame, prefer an - ;; interactor pane to any other stream - (stream (cond ((typep stream 'interactor-pane) - stream) - ((typep *standard-input* 'interactor-pane) - *standard-input*) - (t - (or (and frame - (find-frame-pane-of-type frame 'interactor-pane)) - (and (typep stream 'application-pane) - stream))))) - (cursor (and stream (stream-text-cursor stream)))) - (when (and cursor - (cursor-active cursor)) - ;; OK, this is wierd. Try to find an input editing stream - ;; to do the output on, but only if that input editing stream - ;; encapsulates the stream we chose above - (let ((istream (encapsulated-stream stream))) - (if (and (input-editing-stream-p istream) - (eq (encapsulating-stream-stream istream) stream)) - (progn - (input-editor-format istream "[Abort]") - (force-output istream)) - (progn - (write-string "[Abort]" stream) - (force-output stream)))))) - (error 'abort-gesture :event gesture)))) + (process-abort-gesture stream gesture)))) + +(defun process-abort-gesture (stream gesture) + (let* ((frame (pane-frame stream)) + ;; When dealing with an application frame, prefer an + ;; interactor pane to any other stream + (stream (cond ((typep stream 'interactor-pane) + stream) + ((typep *standard-input* 'interactor-pane) + *standard-input*) + (t + (or (and frame + (find-frame-pane-of-type frame 'interactor-pane)) + (and (typep stream 'application-pane) + stream))))) + (cursor (and stream (stream-text-cursor stream)))) + (when (and cursor + (cursor-active cursor)) + ;; OK, this is wierd. Try to find an input editing stream + ;; to do the output on, but only if that input editing stream + ;; encapsulates the stream we chose above + (let ((istream (encapsulated-stream stream))) + (if (and (input-editing-stream-p istream) + (eq (encapsulating-stream-stream istream) stream)) + (progn + (input-editor-format istream "[Abort]") + (force-output istream)) + (progn + (write-string "[Abort]" stream) + (force-output stream)))))) + (error 'abort-gesture :event gesture)) ;;; This function is just a convenience for the programmer, defaulting the ;;; keyword :STREAM argument to *standard-input*. The application can call diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp index 5ac3b883b3e600189b7d2f35d692f4ce9fabf14d..0afa3a712dc234757bee24916148be4ad000338e 100644 --- a/clim/noting-progress.lisp +++ b/clim/noting-progress.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: noting-progress.lisp,v 1.4 92/07/08 16:30:44 cer Exp $ +;; $fiHeader: noting-progress.lisp,v 1.5 93/02/08 15:56:54 cer Exp $ (in-package :clim-internals) @@ -40,7 +40,6 @@ note)) (defun remove-progress-note (note) - (frame-manager-clear-progress-note (frame-manager (slot-value note 'frame)) note) (without-scheduling (setq *progress-notes* (delete note *progress-notes*)))) @@ -56,14 +55,16 @@ (defun invoke-with-noting-progress (stream name continuation) (let ((note (add-progress-note name stream))) - (unwind-protect - (frame-manager-invoke-with-noting-progress - (frame-manager *application-frame*) note continuation) - (remove-progress-note note)))) + (frame-manager-invoke-with-noting-progress + (frame-manager (if stream (pane-frame stream) *application-frame*)) + note continuation))) (defmethod frame-manager-invoke-with-noting-progress ((framem standard-frame-manager) note continuation) - (funcall continuation note)) + (unwind-protect (funcall continuation note) + (with-slots (stream) note + (when stream + (window-clear stream))))) (defun note-progress (numerator &optional (denominator 1) (note *current-progress-note*)) (when note @@ -113,35 +114,16 @@ ;; even though DOTIMES is zero-based, so add one to the numerator. (note-progress (1+ ,var) ,count-var)))))) - -(defmethod frame-manager-clear-progress-note - ((framem standard-frame-manager) (note progress-note)) - (with-slots (stream) note - (when stream - (window-clear stream)))) - (defmethod frame-manager-display-progress-note - ((framem standard-frame-manager) (note progress-note)) + ((framem standard-frame-manager) (note progress-note)) (with-slots (name stream numerator denominator name-displayed bar-length) note (when stream (let* ((stream-width (bounding-rectangle-width stream)) (line-height (stream-line-height stream)) (new-bar-length (floor (* stream-width numerator) denominator))) - (unless name-displayed - (window-clear stream)) + (window-clear stream) (with-output-recording-options (stream :record nil) (with-end-of-line-action (stream :allow) (with-end-of-page-action (stream :allow) - (unless name-displayed - (stream-set-cursor-position stream 0 0) - (write-string name stream) - (setq name-displayed t)) - (when (< new-bar-length bar-length) - (draw-line* stream - 0 (+ line-height 2) bar-length (+ line-height 2) - :line-thickness 2 :ink +background-ink+)) - (draw-line* stream - 0 (+ line-height 2) new-bar-length (+ line-height 2) - :line-thickness 2) - (setq bar-length new-bar-length) - (force-output stream)))))))) + (format stream "~A: ~3d%" name (round (* 100 numerator) denominator))))) + (force-output stream))))) diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 7287a94f2fa9d4a2bbe76e3e267668ea8256a64c..a215633d4e06460a086bf5ed7b0ee398eb236fc5 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.25 92/12/16 16:46:58 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.26 93/03/04 19:00:04 colin Exp $ (in-package :clim-internals) @@ -361,7 +361,7 @@ (write object :stream stream :escape t)) (write-string object stream))) -(define-presentation-method present (object (type string) stream (view textual-dialog-view) +(define-presentation-method present (object (type string) stream (view dialog-view-mixin) &key acceptably) (if (or acceptably (zerop (length object))) (with-standard-io-syntax @@ -947,7 +947,7 @@ (declare (dynamic-extent options)) (apply #'present-sequence sequence type stream view options)) -(define-presentation-method present (sequence (type sequence) stream (view textual-dialog-view) +(define-presentation-method present (sequence (type sequence) stream (view dialog-view-mixin) &rest options) (declare (dynamic-extent options)) ;; Give the user a target to click on when the sequence is empty diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index 2376bb56c877b1864a685d5d2bad3815df60d747..b26471c797f2283574c1e51426c49d0acfb44896 100644 --- a/clim/tracking-pointer.lisp +++ b/clim/tracking-pointer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: tracking-pointer.lisp,v 1.14 92/10/02 15:20:08 cer Exp $ +;; $fiHeader: tracking-pointer.lisp,v 1.15 92/12/03 10:28:03 cer Exp $ (in-package :clim-internals) @@ -32,15 +32,18 @@ (register-tracking-pointer-clause :presentation (presentation window x y)) (register-tracking-pointer-clause :presentation-button-press (presentation event x y)) (register-tracking-pointer-clause :presentation-button-release (presentation event x y)) +(register-tracking-pointer-clause :timeout ()) (defvar *tracking-pointer-presentation-clauses* - '(:presentation :presentation-button-press :presentation-button-release)) + '(:presentation :presentation-button-press + :presentation-button-release)) ) ;eval-when (defmacro tracking-pointer ((&optional stream &key pointer multiple-window transformp - (context-type t) (highlight nil highlight-p)) + (context-type t) (highlight nil + highlight-p) timeout) &body clauses) (default-output-stream stream tracking-pointer) (let ((do-highlighting highlight) @@ -84,11 +87,12 @@ :multiple-window ,multiple-window :transformp ,transformp :context-type ,context-type - :highlight ,do-highlighting)))))) + :highlight ,do-highlighting + :timeout ,timeout)))))) (defun tracking-pointer-1 (stream pointer generator &key multiple-window transformp - context-type highlight) + context-type highlight timeout) (unless pointer (setq pointer (stream-primary-pointer stream))) (let* ((moved-p nil) @@ -96,6 +100,7 @@ (last-window nil) (last-x nil) (last-y nil) (input-happened nil) + (timed-out nil) ;; Grab these up front. The closures will share the same environment. (motion-function (funcall generator :pointer-motion)) (button-press-function (funcall generator :pointer-button-press)) @@ -104,6 +109,7 @@ (presentation-press-function (funcall generator :presentation-button-press)) (presentation-release-function (funcall generator :presentation-button-release)) (keyboard-function (funcall generator :keyboard)) + (timeout-function (funcall generator :timeout)) ;; Tell the input streams not to discard pointer release events (*discard-pointer-release-events* nil) (highlighted-presentation nil) @@ -194,9 +200,10 @@ ;; when all the windows share the same I/O buffer. Same ;; deal with the READ-GESTURE below, too. ;;--- It's a bug that multiple-window has that restriction... - (setq input-happened - (stream-input-wait stream - :input-wait-test #'pointer-motion-pending))) + (multiple-value-setq (input-happened timed-out) + (stream-input-wait stream + :timeout timeout + :input-wait-test #'pointer-motion-pending))) ;; Don't call READ-GESTURE if there is no gesture to read ;;--- If we called READ-GESTURE on CURRENT-WINDOW, we would ;;--- get the (possibly undesirable) side-effect that the @@ -207,6 +214,9 @@ (read-gesture :stream stream :timeout 0)))) (block process-gesture (cond ((null gesture) + (if (and (eq timed-out :timeout) + timeout-function) + (funcall timeout-function)) (return-from input-wait)) ((keyboard-event-p gesture) (when keyboard-function diff --git a/demo/peek-frame.lisp b/demo/peek-frame.lisp index c0fcb70930845ecb5d31de3027e01e79dec18795..70a9431667fc35111bcbc9dd9659b951a29b627a 100644 --- a/demo/peek-frame.lisp +++ b/demo/peek-frame.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: peek-frame.lisp,v 1.2 92/10/02 15:20:41 cer Exp $ +;; $fiHeader: peek-frame.lisp,v 1.3 92/10/07 14:43:45 cer Exp $ (in-package :clim-user) @@ -218,7 +218,8 @@ Revised and stripped down by Scott McKay (SWM@Symbolics.COM) for CLIM 2.0. (presentation frame window x y) (call-presentation-menu presentation *input-context* frame window x y - :for-menu t)) + :for-menu t + :gesture :select)) (define-peek-command (com-activate-process) ((thing 'process :gesture nil)) diff --git a/misc/undefinedsymbols b/misc/undefinedsymbols index 8d40276679c0057982e33727080895a0e8502a27..711e4936bc061c31ff072f586fc4c6675835dd10 100644 --- a/misc/undefinedsymbols +++ b/misc/undefinedsymbols @@ -345,3 +345,4 @@ XrmStringToBindingQuarkList XrmStringToQuark XrmStringToQuarkList XrmUniqueQuark +XIconifyWindow diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index d98e7e06bcac650052fa44f4a13142b05c4adcde..8fa071babcf7c6bca8bbbea034cf6dfc2481a346 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.41 93/01/21 14:58:57 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.42 93/03/18 14:37:54 colin Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -174,35 +174,9 @@ (- (gadget-range sheet) size))))) (bounding-rectangle-min-y region))))))) -(defun update-region (sheet nleft ntop nright nbottom &key no-repaint) - ;;--- I suspect that we should pass in mins and maxs since this does - ;;--- assume that the window origin is 0,0 and I think that this - ;;--- causes the compass menu test to fail since there are graphics at - ;;--- negative coordinates. - #---ignore - (with-bounding-rectangle* (left top right bottom) sheet - (when (or (< nleft left) - (< ntop top) - (> nright right) - (> nbottom bottom)) - ;; It should be safe to modify the sheet's region - (let ((region (sheet-region sheet))) - (setf (slot-value region 'left) (min nleft left) - (slot-value region 'top) (min ntop top) - (slot-value region 'right) (max nright right) - (slot-value region 'bottom) (max nbottom bottom)) - (note-sheet-region-changed sheet)))) - #+++ignore - (let ((width (- nright nleft)) - (height (- nbottom ntop))) - (when (or (> width (bounding-rectangle-width sheet)) - (> height (bounding-rectangle-height sheet))) - ;; It should be safe to modify the sheet's region - (let ((region (sheet-region sheet))) - (setf (slot-value region 'left) 0 - (slot-value region 'top) 0 - (slot-value region 'right) (max (bounding-rectangle-width sheet) width) - (slot-value region 'bottom) (max (bounding-rectangle-height sheet) height)))))) +(defmethod update-region ((sheet basic-sheet) nleft ntop nright nbottom &key no-repaint) + (declare (ignore nleft ntop nright nbottom no-repaint)) + nil) (defun scroll-extent (sheet x y) ;;--- CER says that this really isn't right... @@ -223,7 +197,8 @@ (update-scroll-bars viewport) (with-bounding-rectangle* (nleft ntop nright nbottom) (pane-viewport-region sheet) - ;;--- Do we really want to do this here?? + ;; If we are scrolling programatically then this might + ;; reveal more of the sheet than currently exists (update-region sheet nleft ntop nright nbottom) (cond ;; If some of the stuff that was previously on display is still on diff --git a/silica/db-table.lisp b/silica/db-table.lisp index b1fd60fefc2114eb48d3c13a57b9da952a91cdf9..74266ae47bbace9d903c411445a0b487cca40d19 100644 --- a/silica/db-table.lisp +++ b/silica/db-table.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-table.lisp,v 1.15 92/09/08 10:34:22 cer Exp $ +;; $fiHeader: db-table.lisp,v 1.16 92/09/24 09:37:36 cer Exp $ (in-package :silica) @@ -138,7 +138,7 @@ (sheet-enabled-p item)) (move-and-resize-sheet item x y - (min column-width (1- (- width x))) - (min row-height (1- (- height y))))) + column-width + row-height)) (incf x column-width))) (incf y row-height)))))) diff --git a/silica/framem.lisp b/silica/framem.lisp index 96d5ed5cebd744528d4ae773b5e53bba4d893ba5..711b9fccb958d054527a2487a8fab131daf8eaca 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: framem.lisp,v 1.26 92/12/03 10:29:21 cer Exp $ +;; $fiHeader: framem.lisp,v 1.27 93/02/08 15:57:28 cer Exp $ (in-package :silica) @@ -39,7 +39,7 @@ &key port palette (server-path *default-server-path*) &allow-other-keys) (declare (dynamic-extent options)) - (with-keywords-removed (options options '(:port :palette :server-path)) + (with-keywords-removed (new-options options '(:port :palette :server-path)) (unless port (setq port (find-port :server-path server-path))) (unless palette @@ -47,19 +47,19 @@ (cond ;; (find-frame-manager) -> default one ((and (null options) *default-frame-manager*)) - ;; We specified a port, so make sure the default framem matches it + ;; We specified a port and perhaps other options so make sure the default framem matches it ((and *default-frame-manager* (apply #'frame-manager-matches-options-p - *default-frame-manager* port options)) + *default-frame-manager* port :palette palette new-options)) *default-frame-manager*) ;; No default, look for one in the port, or create a new one (t (dolist (framem (port-frame-managers port)) (when (apply #'frame-manager-matches-options-p - framem port :palette palette options) + framem port :palette palette new-options) (return-from find-frame-manager framem))) (let ((framem (apply #'make-frame-manager - port :palette palette options))) + port :palette palette new-options))) (setf (port-frame-managers port) (nconc (port-frame-managers port) (list framem))) framem))))) @@ -76,8 +76,8 @@ (defmethod frame-manager-matches-options-p ((framem standard-frame-manager) port &key palette &allow-other-keys) (declare (ignore palette)) - (eq (port framem) port)) - + (and (eq (port framem) port) + (eq (frame-manager-palette framem) palette))) (defun map-over-frames (function &key port frame-manager) (cond (frame-manager @@ -106,13 +106,13 @@ (let* ((top-pane (frame-panes frame)) (sheet (with-look-and-feel-realization (framem frame) (make-pane 'top-level-sheet - :event-queue (frame-input-buffer frame) - :user-specified-position-p (frame-user-specified-position-p frame) - :user-specified-size-p (frame-user-specified-size-p frame) - :region (multiple-value-bind (width height) - (bounding-rectangle-size top-pane) - (make-bounding-rectangle 0 0 width height)) - :parent (find-graft :port (port frame)))))) + :event-queue (frame-input-buffer frame) + :user-specified-position-p (frame-user-specified-position-p frame) + :user-specified-size-p (frame-user-specified-size-p frame) + :region (multiple-value-bind (width height) + (bounding-rectangle-size top-pane) + (make-bounding-rectangle 0 0 width height)) + :parent (find-graft :port (port frame)))))) (setf (frame-top-level-sheet frame) sheet (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) diff --git a/silica/scroll-pane.lisp b/silica/scroll-pane.lisp index 03c0412041e6e4ca7a5280f52cf86349938dbf44..5fd51efaaf70bd30332fe2e9ced0b1990186317d 100644 --- a/silica/scroll-pane.lisp +++ b/silica/scroll-pane.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: scroll-pane.lisp,v 1.2 92/12/16 16:49:44 cer Exp $ +;; $fiHeader: scroll-pane.lisp,v 1.3 93/03/18 14:38:16 colin Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -11,7 +11,7 @@ ;; An implementation of a scroller pane (defclass generic-scroller-pane (scroller-pane - client-space-requirement-mixin + client-overridability-mixin wrapping-space-mixin permanent-medium-sheet-output-mixin pane-repaint-background-mixin diff --git a/test/test-demos.lisp b/test/test-demos.lisp new file mode 100644 index 0000000000000000000000000000000000000000..5b24146e12eaf147bc8c4bbc23ae66b418ef9ad9 --- /dev/null +++ b/test/test-demos.lisp @@ -0,0 +1,212 @@ +(in-package :clim-user) + +;; $fiHeader: test-demos.lisp,v 1.5 92/12/07 12:14:53 cer Exp $ + +(define-frame-test test-puzzle-demo (clim-demo::puzzle) + ( + ;;-- Should verify which command gets executed + (:presentation-click clim-demo::display clim-demo::puzzle-cell) + (:presentation-click clim-demo::display clim-demo::puzzle-cell) + (:presentation-click clim-demo::display clim-demo::puzzle-cell) + (:presentation-click clim-demo::display clim-demo::puzzle-cell) + ;; + (clim-demo::com-scramble) + (clim-demo::com-scramble) + (clim-demo::com-scramble)) + (clim-demo::com-exit-puzzle) + ) + +(define-frame-test test-flight-planner (clim-demo::flight-planner :width 1000 :height 800) + ( + (clim-demo::com-zoom-in) + (clim-demo::com-zoom-out) + (clim-demo::com-show-map) + ;; Describe some things + (:presentation-click clim-demo::display + clim-demo::concrete-object :gesture :describe) + (:presentation-click clim-demo::display + clim-demo::concrete-object :gesture :describe) + (:presentation-click clim-demo::display + clim-demo::concrete-object :gesture :describe) + (:presentation-click clim-demo::display + clim-demo::concrete-object :gesture :describe) + ;; Build a route + (:presentation-click clim-demo::display + clim-demo::named-position + :gesture :select) + (:presentation-click clim-demo::display + clim-demo::named-position + :gesture :select) + (:presentation-click clim-demo::display + clim-demo::named-position + :gesture :select) + (:presentation-click clim-demo::display + clim-demo::named-position + :gesture :select) + #\return + ;; + (:presentation-click clim-demo::display + clim-demo::route + :gesture :delete) + (:presentation-click clim-demo::display + clim-demo::concrete-object + :gesture :delete) + ;; + (:command clim-demo::display clim-demo::com-show-distance) + ;; Missing the plan flight stuff + ) + (clim-demo::com-exit-flight-planner) + ) + + +;;; Taking commands for a walk. + + +(define-frame-test test-flight-planner-2 (clim-demo::flight-planner :width 1000 :height 800) + ( + (:command clim-demo::display clim-demo::com-describe-object) + ) + (clim-demo::com-exit-flight-planner) + ) + +;; Listener + +;;;--- The listener is using a nonstandard top level and does not +;;;---- seemed to be looking at the queue + +(define-frame-test test-lisp-listener (clim-demo::lisp-listener :width 1000 :height 800) + ( + "(cons nil nil) +" + (:command clim-demo::interactor clim-demo::com-clear-output-history + :colon-prefix t) + (:command clim-demo::interactor clim-demo::com-show-some-commands + :colon-prefix t) + ) + (:command clim-demo::interactor clim-demo::com-quit-listener + :colon-prefix t) + ) + +;; graphics-demos + +(define-frame-test test-graphics-demos (clim-demo::graphics-demo :width 840 :height 800) + ( + (clim-demo::com-spin-graphics-demo) + (clim-demo::com-big-spin-graphics-demo) + (clim-demo::com-cbs-logo-graphics-demo) + (clim-demo::com-polygons-graphics-demo) + (:sleep 20) + (clim-demo::com-circles-graphics-demo) + (clim-demo::com-maze-graphics-demo) + (:sleep 10) + ) + (clim-demo::com-exit-graphics-demo) + ) + +;; cad-demo + +;; address-book + +(define-frame-test test-address-book (clim-demo::address-book :width 400 :height 400) + ( + (:presentation-click clim-demo::names clim-demo::address) + (:presentation-click clim-demo::names clim-demo::address) + (:presentation-click clim-demo::names clim-demo::address) + ) + (clim-demo::com-quit-address-book) + ) + +;; Thinkadot +;; plot +;; color-editor +;; graphics-editor + +(define-frame-test test-graphics-editor (clim-graphics-editor::graphics-editor :width 800 :height 600) + ( + ;;-- These work only because of a timing error. + ;;-- They should be press, move, release. + + (:press clim-graphics-editor::display 30 30) + (:release clim-graphics-editor::display 70 70) + + (clim-graphics-editor::com-clear) + + (:press clim-graphics-editor::display 30 30) + (:release clim-graphics-editor::display 70 70) + + + (:press clim-graphics-editor::display 100 100) + (:release clim-graphics-editor::display 150 200) + + (:press clim-graphics-editor::display 300 100) + (:release clim-graphics-editor::display 400 200) + + (clim-graphics-editor::com-redisplay) + + (:presentation-click clim-graphics-editor::display + clim-graphics-editor::box) + (:presentation-click clim-graphics-editor::display + clim-graphics-editor::box) + (:presentation-click clim-graphics-editor::display + clim-graphics-editor::box) + + ;; try moving one + + (:presentation-press clim-graphics-editor::display + clim-graphics-editor::box + :gesture :describe) + + (:release clim-graphics-editor::display 200 200) + (clim-graphics-editor::com-deselect-object) + + (:presentation-click clim-graphics-editor::display + clim-graphics-editor::box + :gesture :delete) + + (:presentation-click clim-graphics-editor::display + clim-graphics-editor::box + :gesture :delete) + + ) + (clim-graphics-editor::com-quit) + ) + +;; bitmap-editor +;; ico + +(define-frame-test test-ico (clim-demo::ico-frame :width 400 :height 400) + ( + (clim-demo::com-ico-throw-ball) + (:sleep 30) + (clim-demo::com-ico-catch-ball) + ) + (clim-demo::com-ico-quit) + ) + +;; browser +;; peek-frame +;; process-browser + +(define-frame-test test-process-browser (clim-demo::process-browser :width 800 :height 400) + ( + (:sleep 30) + ) + (clim-demo::com-quit-process-browser) + ) + +;; customer-records +;; demo-acivity + +(define-frame-test test-bitmap-editor (clim-demo::bitmap-editor :width 700 :height 500) + ( + (:presentation-click clim-demo::edit-pane + clim-demo::bitmap-editor-cell) + (:edit-avv clim-demo::palette "Colors" #.+white+) + (:presentation-click clim-demo::edit-pane + clim-demo::bitmap-editor-cell) + (:edit-avv clim-demo::palette "Colors" #.+black+) + (:presentation-click clim-demo::edit-pane + clim-demo::bitmap-editor-cell) + + ) + (clim-demo::com-bitmap-editor-quit)) diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp index ad92c79a1626d8ff5c1ceab4f7e4603100a96b87..d0090a157f4e6672d886edb0f186d5fc0bf20f21 100644 --- a/tk-silica/xm-dialogs.lisp +++ b/tk-silica/xm-dialogs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-dialogs.lisp,v 1.3 92/11/20 08:46:39 cer Exp $ +;; $fiHeader: xm-dialogs.lisp,v 1.4 92/12/01 09:47:07 cer Exp $ (in-package :clim-internals) @@ -31,11 +31,12 @@ (define-application-frame motif-accept-values-own-window (accept-values-own-window) () (:pane - (with-slots (stream own-window exit-button-stream scroll-bars) *application-frame* + (with-slots (stream own-window exit-button-stream scroll-bars align-prompts) *application-frame* (vertically () (progn (setq stream (make-instance 'accept-values-stream + :align-prompts align-prompts :stream (setf own-window (make-pane 'clim-stream-pane :initial-cursor-visibility :off)))) diff --git a/tk/convenience.lisp b/tk/convenience.lisp index f7ca956a9a4b49cb9db9cefd0f14908d4fc04ae3..1ea90b171ff60e331b8900e3afc6723c3b1f3648 100644 --- a/tk/convenience.lisp +++ b/tk/convenience.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: convenience.lisp,v 1.12 92/08/18 17:53:30 cer Exp $ +;; $fiHeader: convenience.lisp,v 1.13 92/12/14 15:03:50 cer Exp $ (in-package :tk) @@ -75,3 +75,6 @@ (define-convenience-class xm-file-selection-dialog (xm-file-selection-box) "XmCreateFileSelectionDialog") + + +(define-convenience-class xm-working-dialog (xm-message-box) "XmCreateWorkingDialog") diff --git a/xlib/pkg.lisp b/xlib/pkg.lisp index 43b8439b04f81fe68f8c7e31470cd070ecaec29b..a6e6a779f34ebbaaf7b944016fd84fa28b50e425 100644 --- a/xlib/pkg.lisp +++ b/xlib/pkg.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: pkg.lisp,v 1.7 92/05/22 19:27:25 cer Exp $ +;; $fiHeader: pkg.lisp,v 1.8 92/10/02 15:18:57 cer Exp $ (defpackage :x11 @@ -625,6 +625,7 @@ #:xwmhints-icon-pixmap #:xwmhints-icon-window #:xwmhints-icon-x #:xwmhints-icon-y #:xwmhints-initial-state #:xwmhints-input #:xwmhints-window-group #:xwritebitmapfile #:xybitmap #:xypixmap - #:ysorted #:yxbanded #:yxsorted #:zoomstate #:zpixmap) + #:ysorted #:yxbanded #:yxsorted #:zoomstate #:zpixmap + #:xiconifywindow) )