diff --git a/Makefile b/Makefile index fba9075e638c6fe10fd5de80b7546712786c426c..579b8d2f2c94c72f17f5e3b4e090c16c779e10f0 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.43 92/08/19 10:24:17 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.44 92/08/21 16:34:13 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -143,6 +143,7 @@ CLIM-UTILS-OBJS = utils/excl-verification.fasl \ utils/lisp-utilities.fasl \ utils/processes.fasl \ utils/queue.fasl \ + utils/timers.fasl \ utils/protocols.fasl \ utils/autoconstructor.fasl \ utils/clim-streams.fasl \ @@ -275,6 +276,7 @@ MOTIF-CLIM-OBJS = tk-silica/pkg.fasl \ tk-silica/image.fasl \ tk-silica/xt-frames.fasl \ tk-silica/xm-frames.fasl \ + tk-silica/xm-dialogs.fasl \ tk-silica/xt-gadgets.fasl \ tk-silica/xm-gadgets.fasl \ tk-silica/xm-menus.fasl \ diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index e9a565c5b479545606c913fd9ecf668caf6de6d7..c5d11269d71457a98150d80f924cd65a90e34ae4 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.30 92/08/19 18:04:40 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.31 92/08/21 16:33:42 cer Exp Locker: cer $ (in-package :clim-internals) @@ -244,6 +244,9 @@ ;; So the continuation can run with the proper value of *APPLICATION-FRAME* (defvar *avv-calling-frame*) +(defmethod frame-manager-accepting-values-frame-class ((framem standard-frame-manager)) + 'accept-values-own-window) + (defun invoke-accepting-values (stream continuation &key frame-class command-table own-window (exit-boxes @@ -260,7 +263,9 @@ (right-margin 10) (bottom-margin 10)) (if own-window - (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) + (let ((frame (make-application-frame (or frame-class + (frame-manager-accepting-values-frame-class + (frame-manager *application-frame*))) :calling-frame *application-frame* :parent *application-frame* :pretty-name label @@ -344,15 +349,15 @@ (redisplay avv stream :check-overlapping check-overlapping)) (loop (let ((command - (let ((command-stream (slot-value 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))) + (let ((command-stream (slot-value 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)) @@ -380,20 +385,24 @@ (size-panes-appropriately))))) (size-panes-appropriately () (changing-space-requirements () - ;; We really want to specify the min/max sizes of - ;; the exit-button pane also - (size-frame-from-contents exit-button-stream - :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))) + ;; 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) + (change-space-requirements + pane + :width w :min-width w :max-width w + :height h :min-height h :max-height h)))) (when own-window (size-frame-from-contents own-window - :width own-window-width - :height own-window-height - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin))))) + :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)) (with-simple-restart (frame-exit "Exit from the ACCEPT-VALUES dialog") @@ -406,7 +415,7 @@ (stream 'accept-values-output-record avv-record) (run-continuation stream avv-record))))))) ;; In own window dialogs the buttons are displayed separately - (when own-window + (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) @@ -426,7 +435,8 @@ (frame-top-level-sheet (pane-frame own-window)) x y)) (window-expose own-window) (with-input-focus (own-window) - (replay exit-button-record exit-button-stream) + (when exit-button-record + (replay exit-button-record exit-button-stream)) (replay avv stream) (run-avv))) (t @@ -473,6 +483,22 @@ (read-gesture :stream help-window)) (setf (window-visibility help-window) nil))))) +(defmethod frame-manager-display-input-editor-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)) + ;; (beep stream) + (remove-activation-gesture stream) + ;; (with-input-editor-typeout (stream :erase t) + ;; (format stream "~A~%Please edit your input." error)) + ;; Now wait until the user forces a rescan by typing + ;; an input editing command + (loop (read-gesture :stream stream))) + + (defmethod accept-values-top-level :around ((frame accept-values-own-window) &rest args) (declare (ignore args)) (unwind-protect @@ -1103,18 +1129,18 @@ (with-slots (exit-boxes) frame (updating-output (stream :unique-id stream :cache-value 'exit-boxes) - (formatting-item-list (stream :n-columns (length exit-boxes) - :initial-spacing nil) - (dolist (exit-box exit-boxes) - (let* ((value (if (consp exit-box) (car exit-box) exit-box)) - (label (or (if (consp exit-box) (second exit-box)) - (second (assoc value labels))))) - (formatting-cell (stream) - (with-output-as-gadget (stream) - (make-pane 'push-button - :label label - :client frame :id value - :activate-callback #'handle-exit-box-callback)))))))))) + (formatting-table (stream :equalize-column-widths nil) + (dolist (exit-box exit-boxes) + (formatting-column (stream) + (let* ((value (if (consp exit-box) (car exit-box) exit-box)) + (label (or (if (consp exit-box) (second exit-box)) + (second (assoc value labels))))) + (formatting-cell (stream) + (with-output-as-gadget (stream) + (make-pane 'push-button + :label label + :client frame :id value + :activate-callback #'handle-exit-box-callback))))))))))) (defun handle-exit-box-callback (gadget) (let ((id (gadget-id gadget))) diff --git a/clim/command.lisp b/clim/command.lisp index 2970a4278c7a9b9a94e125c571de4e522f91cd01..d817a555f1b9d8ca167f4daf408fd4edbe8efb2f 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.13 92/08/18 17:24:45 cer Exp Locker: cer $ +;; $fiHeader: command.lisp,v 1.14 92/08/19 10:23:54 cer Exp Locker: cer $ (in-package :clim-internals) @@ -408,6 +408,7 @@ (defun add-menu-item-to-command-table (command-table string type value &key documentation (after ':end) keystroke + mnemonic text-style (errorp t)) (check-type string (or string null)) (check-type type (member :command :function :menu :divider)) @@ -444,6 +445,7 @@ (incf menu-tick) (setq keystrokes nil) (let* ((item `(,type ,value + ,@(and mnemonic `(:mnemonic ,mnemonic)) ,@(and documentation `(:documentation ,documentation)) ,@(and text-style `(:text-style ,text-style)))) ;; Entries are of the form (MENU-NAME KEYSTROKE MENU-ITEM) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 9f8cf13f4d6366851492ff350954e0660cf3a981..81287dcc989c45d1713e1640cd7bab0ed511795f 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.26 92/07/27 11:02:19 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.27 92/08/18 17:24:49 cer Exp Locker: cer $ (in-package :clim-internals) @@ -20,6 +20,7 @@ sheet-permanently-enabled-mixin sheet-mute-input-mixin sheet-multiple-child-mixin + silica::space-requirement-cache-mixin space-requirement-mixin permanent-medium-sheet-output-mixin pane) @@ -128,14 +129,21 @@ (eq sr-component :compute)) (multiple-value-bind (width height) (let ((record + ;;--- can we really do this + (if (and (stream-output-history pane) + (> (output-record-count (stream-output-history pane)) 0)) + (stream-output-history pane) (let ((*sizing-application-frame* t)) (with-output-to-output-record (pane) - (invoke-pane-display-function + (funcall + (if (slot-value pane 'incremental-redisplay-p) + #'invoke-pane-redisplay-function + #'invoke-pane-display-function) (pane-frame pane) pane ;;--- Are all pane display functions prepared to ;;--- ignore these arguments? I think not... :max-width width - :max-height height))))) + :max-height height)))))) (bounding-rectangle-size record)) (do-with-space-req-components progn sr-component (sr-width sr-min-width sr-max-width) @@ -297,18 +305,22 @@ (setf-unless :height 100) (setf-unless :min-height 0) (setf-unless :max-height +fill+)) - (let ((pane `(make-pane ,type ,@options))) + (let* ((stream (gensym)) + (pane `(setq ,stream (make-pane ,type ,@options)))) (when scroll-bars (setq pane `(scrolling (:scroll-bars ,scroll-bars) - ,pane))) + ,pane))) (when label (setq pane `(vertically () - ,pane + ,pane (make-pane 'label-pane - :label ,label - :max-width +fill+)))) - `(outlining (:thickness 1) - ,pane)))) + :label ,label + :max-width +fill+)))) + `(let (,stream) + (values + (outlining (:thickness 1) + ,pane) + ,stream))))) (defmacro make-clim-interactor-pane (&rest options) `(make-clim-stream-pane :type 'interactor-pane ,@options)) diff --git a/clim/frames.lisp b/clim/frames.lisp index 586204e86545746a7af0ed626bae14651482cbe4..25a1c2a24967faf85b216b17685e5226d3a98c04 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.37 92/08/18 17:54:10 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.38 92/08/19 10:23:59 cer Exp Locker: cer $ (in-package :clim-internals) @@ -271,6 +271,7 @@ (value (second options) (second options))) ((null options)) (case keyword + (:inherit-menu) (:inherit-from (if (listp value) (dolist (item value) @@ -516,7 +517,8 @@ (resize-sheet top-sheet width height)))))) (defmethod (setf frame-current-layout) (layout (frame standard-application-frame)) - (unless (eq (frame-current-layout frame) layout) + (unless (or (eq (frame-current-layout frame) layout) + (null (frame-top-level-sheet frame))) (setf (slot-value frame 'current-layout) layout) ;; First disown all the children (dolist (name-and-pane (slot-value frame 'all-panes)) @@ -531,17 +533,18 @@ (multiple-value-call #'layout-frame frame (bounding-rectangle-size (frame-top-level-sheet frame))) (let ((layout-space-requirements - (cddr (assoc layout (frame-layouts frame))))) + (cddr (assoc layout (frame-layouts frame))))) (changing-space-requirements (:layout nil) - (flet ((adjust-layout (sheet) - (change-space-requirements-to-default sheet) - (let ((x (and (panep sheet) - (assoc (pane-name sheet) layout-space-requirements)))) - (when x (apply #'change-space-requirements sheet (cdr x)))))) - (declare (dynamic-extent #'adjust-layout)) - (map-over-sheets #'adjust-layout (frame-top-level-sheet frame))))) + (flet ((adjust-layout (sheet) + (change-space-requirements-to-default sheet) + (let ((x (and (panep sheet) + (assoc (pane-name sheet) layout-space-requirements)))) + (when x (apply #'change-space-requirements sheet (cdr x)))))) + (declare (dynamic-extent #'adjust-layout)) + (map-over-sheets #'adjust-layout (frame-top-level-sheet frame))))) ;;--- Don't throw, just recompute stream bindings in a principled way - (throw 'layout-changed nil))) + (handler-case (throw 'layout-changed nil) + (error () nil)))) (defmethod frame-all-layouts ((frame standard-application-frame)) (mapcar #'first (frame-layouts frame))) @@ -628,19 +631,19 @@ ;; then we should be using that ;; If the frame already exists then we probably should be using ;; the top level sheet size - (multiple-value-call #'layout-frame - frame - (ecase old - (:disowned - (if (and width height) - (values width height) - (values))) - (:disabled - (bounding-rectangle-size - (frame-top-level-sheet frame))))) - (when (and left top) - (move-sheet (frame-top-level-sheet frame) left top)) - (note-frame-enabled (frame-manager frame) frame)))))) + (multiple-value-bind (w h) + (ecase old + (:disowned + (if (and width height) + (values width height) + (values))) + (:disabled + (bounding-rectangle-size + (frame-top-level-sheet frame)))) + (layout-frame frame w h) + (when (and left top) + (move-sheet (frame-top-level-sheet frame) left top)) + (note-frame-enabled (frame-manager frame) frame))))))) (defmethod destroy-frame ((frame standard-application-frame)) (when (eq (frame-state frame) :enabled) @@ -1042,12 +1045,15 @@ (synchronous-command-event-command c))))) (call-next-method))))) -;; Actually this should be treated as a command event +;;--- Actually this should be named command-event + (defclass presentation-event (event) - ((value :initarg :value :reader presentation-event-value) - (sheet :initarg :sheet :reader event-sheet) - (frame :initarg :frame :reader event-frame) - (presentation-type :initarg :presentation-type :reader event-presentation-type))) + ((value :initarg :value :reader presentation-event-value) + (sheet :initarg :sheet :reader event-sheet) + (frame :initarg :frame :reader event-frame) + (queuep :initarg :queuep :initform nil) + (presentation-type :initarg :presentation-type :reader event-presentation-type)) + (:default-initargs :presentation-type 'command)) (defmethod handle-event (sheet (event presentation-event)) (process-command-event sheet event)) @@ -1057,35 +1063,58 @@ (let ((command (presentation-event-value event))) (if (partial-command-p command) (throw-highlighted-presentation - (make-instance 'standard-presentation - :object command - :type (event-presentation-type event)) - *input-context* - (allocate-event 'pointer-button-press-event - :sheet sheet - :x 0 :y 0 - :modifier-state 0 - :button +pointer-left-button+)) - (progn - (when (and *input-buffer-empty* - (eq *application-frame* (event-frame event))) - (signal 'synchronous-command-event - :command command)) - ;; Perhaps if this results directly from a user action then either - ;; we should do it right away, ie. loose the input buffer or beep if - ;; it has to be deffered, - (queue-frame-command (event-frame event) (presentation-event-value event)))))) + (make-instance 'standard-presentation + :object command + :type (event-presentation-type event)) + *input-context* + (allocate-event 'pointer-button-press-event + :sheet sheet + :x 0 :y 0 + :modifier-state 0 + :button +pointer-left-button+)) + (progn + (when (and *input-buffer-empty* + (eq *application-frame* (event-frame event))) + (signal 'synchronous-command-event + :command command)) + ;; Perhaps if this results directly from a user action then either + ;; we should do it right away, ie. loose the input buffer or beep if + ;; it has to be deffered, + (if (slot-value event 'queuep) + (queue-frame-command (event-frame event) (presentation-event-value event)) + (beep sheet)))))) (defun queue-frame-command (frame command) (queue-push (frame-command-queue frame) command)) -(defmethod execute-command-in-frame ((frame standard-application-frame) command) +(defmethod execute-command-in-frame ((frame standard-application-frame) + command &rest initargs) (distribute-event (port frame) - (allocate-event 'presentation-event - :frame frame - :sheet (frame-top-level-sheet frame) - :value command))) + (apply #'allocate-event + 'presentation-event + :frame frame + :sheet (frame-top-level-sheet frame) + :value command + initargs))) + +(defun make-command-timer (frame + command arguments delay + &key repeat + (command-table (frame-command-table frame))) + (flet ((queue-command-event (timer) + (declare (ignore timer)) + (execute-command-in-frame + frame + (cons command arguments) + :queuep t + :presentation-type `(command :command-table ,command-table)))) + (let ((timer + (make-instance 'clim-utils::timer + :function #'queue-command-event + :delay delay :repeat repeat))) + (clim-utils::add-timer timer) + timer))) ;;; The contract of this is to find an "appropriate" presentation; i.e., one @@ -1317,3 +1346,6 @@ (values left left-presentation left-context middle middle-presentation middle-context right right-presentation right-context))) + + + diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 1db36a3ec831d2fea54d20a4a94b132c2871ae54..f8cd3dbdab848ea18443fc4d58bac3ce38dfb1d4 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.24 92/08/18 17:24:55 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.25 92/08/21 16:33:48 cer Exp Locker: cer $ (in-package :clim-internals) @@ -269,57 +269,70 @@ ;;--- number of items, etc. +radio-box-view+) -;;--- Gadget currently does not include prompt + +(define-presentation-method gadget-includes-prompt-p + ((type completion) (stream t) (view radio-box-view)) + t) + (define-presentation-method accept-present-default - ((type completion) stream (view radio-box-view) - default default-supplied-p present-p query-identifier - &key (prompt t)) + ((type completion) stream (view radio-box-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) (declare (ignore present-p)) (let ((current-selection nil)) (flet ((update-gadget (record gadget radio-box) (declare (ignore gadget record)) (map-over-sheets - #'(lambda (sheet) - (when (typep sheet 'toggle-button) - (when (setf (gadget-value sheet) - (and default-supplied-p - (funcall test - (funcall value-key (gadget-id sheet)) - (funcall value-key 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 + (funcall value-key (gadget-id sheet)) + (funcall value-key default)))) + (setf (radio-box-current-selection radio-box) sheet)))) + radio-box))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let* ((buttons - (map 'list - #'(lambda (element) - (let ((button - (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 :one-of - :value (and default-supplied-p - (funcall test - (funcall value-key element) - (funcall value-key default))) - :id element))) - (when (and default-supplied-p - (funcall test - (funcall value-key element) - (funcall value-key default))) - (setq current-selection button)) - button)) - sequence)) - (radio-box (make-pane-from-view 'radio-box view - :label (and (stringp prompt) prompt) - :choices buttons - :selection current-selection - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier)))) - (values (outlining () radio-box) radio-box)))))) + (let* ((toggle-options (getf (view-gadget-initargs view) :toggle-button-options)) + (buttons + (map 'list + #'(lambda (element) + (let ((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 + (funcall value-key element) + (funcall value-key default))) + :id element + toggle-options))) + (when (and default-supplied-p + (funcall test + (funcall value-key element) + (funcall value-key default))) + (setq current-selection button)) + button)) + sequence)) + (radio-box (apply #'make-pane 'radio-box + (append (with-keywords-removed + (args (view-gadget-initargs view) '(:toggle-button-options)) + args) + (list :label (and (stringp prompt) prompt) + :choices buttons :selection + current-selection + :client stream + :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback stream query-identifier)) + )))) + (values (vertically () + (make-pane 'label-pane :label prompt) + (outlining () radio-box)) + radio-box)))))) ;;; Subset completion gadget @@ -328,6 +341,10 @@ ((type subset-completion) (view gadget-dialog-view) (framem standard-frame-manager)) +check-box-view+) +(define-presentation-method gadget-includes-prompt-p + ((type subset-completion) (stream t) (view check-box-view)) + t) + (define-presentation-method accept-present-default ((type subset-completion) stream (view check-box-view) default default-supplied-p present-p query-identifier @@ -347,31 +364,39 @@ t)))) check-box))) (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) - (let* ((buttons + (let* ((toggle-options (getf (view-gadget-initargs view) :toggle-button-options)) + (buttons (map 'list #'(lambda (element) (let* ((value (funcall value-key element)) (button (make-pane 'toggle-button :label (funcall name-key element) - :indicator-type :some-of + :indicator-type (getf toggle-options :indicator-type :some-of) :value (and default-supplied-p (member value default :test test ;;--- Should the value-key be used? :key value-key) t) - :id value))) + :id value + toggle-options))) button)) sequence)) - (check-box (make-pane-from-view 'check-box view - :label (and (stringp prompt) prompt) - :choices buttons - :client stream :id query-identifier - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier)))) - (values (outlining () check-box) check-box))))) + (check-box (apply #'make-pane 'check-box + (append (with-keywords-removed + (args (view-gadget-initargs view) '(:toggle-button-options)) + args) + (list :label (and (stringp prompt) prompt) + :choices buttons + :client stream + :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback stream query-identifier)))))) + (values (vertically () + (make-pane 'label-pane :label prompt) + (outlining () check-box)) + check-box))))) ;;; Boolean gadget @@ -462,6 +487,157 @@ (make-accept-values-value-changed-callback stream query-identifier)))) (values (outlining () slider) slider)))))) + + +(define-presentation-method accept-present-default + ((type t) stream (view text-field-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore default-supplied-p present-p)) + (flet ((update-gadget (record gadget text-field) + (declare (ignore record gadget)) + (setf (gadget-value text-field) (present-to-string default type)))) + (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) + (let ((text-field (make-pane-from-view 'text-field view + :label (and (stringp prompt) prompt) + :value (present-to-string default type) + :client stream :id query-identifier + :value-changed-callback + `(accept-values-string-field-changed-callback ,stream ,query-identifier)))) + (values text-field text-field))))) + +;;;--- This is mostly nonsense. If we enter something that is an error then +;;;--- the field value is unchanged. What is the right thing to do? + +(defmethod accept-values-string-field-changed-callback ((gadget text-field) new-value stream query) + (when (accept-values-query-valid-p query (accept-values-query-presentation query)) + ;; Only call the callback if the query is still valid + (handler-case (multiple-value-bind (object type index) + (accept-from-string (accept-values-query-type query) new-value) + (declare (ignore type)) + (assert (= index (length new-value))) + object) + (error ()) + (:no-error (object) + (do-avv-command object stream query))))) + +;;; The string case is straightforward + + +(define-presentation-method decode-indirect-view + ((type string) (view gadget-dialog-view) (framem standard-frame-manager)) + +text-field-view+) + +(define-presentation-method accept-present-default + ((type string) stream (view text-field-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore default-supplied-p present-p)) + (flet ((update-gadget (record gadget button) + (declare (ignore record gadget)) + (setf (gadget-value button) default))) + (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) + (let ((text-field (make-pane-from-view 'text-field view + :label (and (stringp prompt) prompt) + :value default + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier)))) + (values text-field text-field))))) + +;;;; Text-editor + +(define-presentation-method accept-present-default + ((type string) stream (view text-editor-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore default-supplied-p present-p)) + (flet ((update-gadget (record gadget button) + (declare (ignore record gadget)) + (setf (gadget-value button) default))) + (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) + (let ((text-field (make-pane-from-view 'text-editor view + :label (and (stringp prompt) prompt) + :value default + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier)))) + (values (scrolling () text-field) text-field))))) + +;;;; List-pane + +(define-presentation-method accept-present-default + ((type completion) stream (view list-pane-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore present-p default-supplied-p prompt)) + (make-list/option-pane-for-ptype 'list-pane + stream view sequence name-key value-key + test default query-identifier type + printer + :exclusive)) + +(define-presentation-method accept-present-default + ((type subset-completion) stream (view list-pane-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore present-p default-supplied-p prompt)) + (make-list/option-pane-for-ptype 'list-pane stream view sequence name-key value-key + test default query-identifier type printer :nonexclusive)) + +(defun make-list/option-pane-for-ptype (pane-type stream view sequence name-key + value-key test default + query-identifier type printer mode) + (flet ((update-gadget (record gadget list-pane) + (declare (ignore gadget record)) + (setf (gadget-value list-pane) default) + list-pane)) + (with-output-as-gadget (stream :cache-value type :update-gadget #'update-gadget) + (let* ((pane (if (eq pane-type 'option-pane) + (make-pane-from-view pane-type view + :items sequence + :name-key name-key + :value-key value-key + :test test + :printer printer + :value default + :client stream :id query-identifier + :mode mode + :visible-items (min 10 (length sequence)) + :value-changed-callback + (make-accept-values-value-changed-callback + stream + query-identifier)) + + (make-pane-from-view pane-type view + :items sequence + :name-key name-key + :value-key value-key + :test test + :value default + :client stream :id query-identifier + :mode mode + :visible-items (min 10 (length sequence)) + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) + (values (if (eq pane-type 'list-pane) (scrolling () pane) pane) + pane))))) + +(define-presentation-method accept-present-default + ((type completion) stream (view option-pane-view) + default default-supplied-p present-p query-identifier + &key (prompt t)) + (declare (ignore present-p default-supplied-p prompt)) + (make-list/option-pane-for-ptype 'option-pane + stream view sequence name-key value-key + test default query-identifier type + printer + :exclusive)) + +;;;; Option-menu-view ;;--- These should be defined in the standard DEFOPERATION way... diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index 3f8824f4f1dfe1b6f1203237c475ff5b03d68880..fd48ff4cac91970973820e322ead780aeaf0be57 100644 --- a/clim/interactive-defs.lisp +++ b/clim/interactive-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: interactive-defs.lisp,v 1.12 92/07/27 11:02:35 cer Exp $ +;; $fiHeader: interactive-defs.lisp,v 1.13 92/08/18 17:25:11 cer Exp Locker: cer $ (in-package :clim-internals) @@ -245,6 +245,27 @@ (when subhelp-clauses (display-help-clauses subhelp-clauses)))))) +(defun display-input-editor-error (stream error) + ;;-- The reason for using *application-frame* instead of (pane-frame + ;;stream) is because for own-window nil avv the pane-frame is the + ;;calling frame rather than the accept-values frame + (frame-manager-display-input-editor-error + (frame-manager *application-frame*) + *application-frame* stream error)) + +(defmethod frame-manager-display-input-editor-error ((framem standard-frame-manager) + (frame t) stream error) + ;;--- Resignal the error so the user can handle it + ;;--- (in lieu of HANDLER-BIND-DEFAULT) + (beep stream) + (remove-activation-gesture stream) + (with-input-editor-typeout (stream :erase t) + (format stream "~A~%Please edit your input." error)) + ;; Now wait until the user forces a rescan by typing + ;; an input editing command + (loop (read-gesture :stream stream))) + + ;; OPTIONS is a list of a help type followed by a help string (or a function ;; of two arguments, a stream and the help string so far) A "help type" is ;; either a single keyword (either :TOP-LEVEL-HELP or :SUBHELP), or a list diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 190b002b09b55bffff9151249dbf4dc1c5468c35..19abb05eb455aa115b0bb6a68bf78dc5b6e23e8b 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.14 92/08/18 17:25:13 cer Exp Locker: cer $ +;; $fiHeader: interactive-protocol.lisp,v 1.15 92/08/21 16:33:56 cer Exp Locker: cer $ (in-package :clim-internals) @@ -874,16 +874,8 @@ (reset-scan-pointer stream) (handler-bind ((parse-error - #'(lambda (error) - ;;--- Resignal the error so the user can handle it - ;;--- (in lieu of HANDLER-BIND-DEFAULT) - (beep stream) - (remove-activation-gesture stream) - (with-input-editor-typeout (stream :erase t) - (format stream "~A~%Please edit your input." error)) - ;; Now wait until the user forces a rescan by typing - ;; an input editing command - (loop (read-gesture :stream stream))))) + #'(lambda (error) + (display-input-editor-error stream error)))) (return (let #+Genera ((sys:rubout-handler :read)) #-Genera () (with-input-context (context) () diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 01925143fae5a0373b6541c929e1b41d136d1874..cd75c8bd6fe0b04816486983376b5a02331acbb3 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.18 92/08/18 17:25:17 cer Exp Locker: cer $ +;; $fiHeader: output-protocol.lisp,v 1.19 92/08/19 18:04:58 cer Exp Locker: cer $ (in-package :clim-internals) @@ -373,7 +373,8 @@ (* 4 (stream-character-width stream #\0)))))))) ;; If the cursor moves outside the current region, expand ;; it to include the new cursor position. - (when (> cy (bounding-rectangle-height stream)) + (when (and viewport + (> cy (bounding-rectangle-height stream))) (multiple-value-bind (sx sy) (bounding-rectangle-position stream) (update-region stream sx sy cx cy diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index 679157cd5cf0a37039ba92442a6500410d702a5a..7f6853cbce4536b132c3bf0ac9967346f4982646 100644 --- a/clim/recording-protocol.lisp +++ b/clim/recording-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: recording-protocol.lisp,v 1.18 92/07/27 11:02:54 cer Exp $ +;; $fiHeader: recording-protocol.lisp,v 1.19 92/08/18 17:25:32 cer Exp Locker: cer $ (in-package :clim-internals) @@ -1035,8 +1035,8 @@ (let* ((stream (output-record-stream record)) (viewport (pane-viewport stream))) (when viewport - (update-scroll-bars viewport)) - (update-region stream nleft ntop nright nbottom)))))) + (update-scroll-bars viewport) + (update-region stream nleft ntop nright nbottom))))))) ;;; DEFCLASS of OUTPUT-RECORDING-MIXIN, etc. is in STREAM-CLASS-DEFS (defmethod initialize-instance :after ((stream output-recording-mixin) &rest args) diff --git a/clim/view-defs.lisp b/clim/view-defs.lisp index 96469943a6fc09c1bfae1d25904e19f8fc7a9fc9..98e216733faa7cd45943e6edef098c6a1980bb8f 100644 --- a/clim/view-defs.lisp +++ b/clim/view-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: view-defs.lisp,v 1.8 92/07/27 11:03:04 cer Exp $ +;; $fiHeader: view-defs.lisp,v 1.9 92/08/18 17:25:47 cer Exp Locker: cer $ (in-package :clim-internals) @@ -62,11 +62,13 @@ ',name))) (define-gadget-view toggle-button) - (define-gadget-view radio-box) (define-gadget-view check-box) - (define-gadget-view slider) +(define-gadget-view text-field) +(define-gadget-view list-pane) +(define-gadget-view option-pane) +(define-gadget-view text-editor) ;;--- These three methods are the result of not including the ;;--- gadget class as a superclass of view class... diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index 7e57f7b08f1004f67b448af8505c5866ec71267c..f326db47e0847867f0f1eacb7c11e07021972604 100644 --- a/demo/cad-demo.lisp +++ b/demo/cad-demo.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cad-demo.lisp,v 1.14 92/07/24 10:54:44 cer Exp $ +;; $fiHeader: cad-demo.lisp,v 1.15 92/08/18 17:26:16 cer Exp Locker: cer $ (in-package :clim-demo) diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp index b93eef71a95a332ade6682a41436abec859e05c8..33023f764698df257a5c99092e6b1720d77bcf82 100644 --- a/demo/graphics-editor.lisp +++ b/demo/graphics-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-editor.lisp,v 1.4 92/08/19 10:24:14 cer Exp Locker: cer $ +;; $fiHeader: graphics-editor.lisp,v 1.5 92/08/21 16:34:09 cer Exp Locker: cer $ (in-package :clim-graphics-editor) @@ -220,31 +220,66 @@ ;;; The application itself +(define-command-table graphics-editor-file-commands) +(define-command-table graphics-editor-edit-commands) +(define-command-table graphics-editor-option-commands) + (define-application-frame graphics-editor (selected-object-mixin) - ((objects :initform nil) - (counter :initform 0) - (last-box :initform nil) - (style :initform (make-line-style :thickness 1 :dashes nil)) - (shape :initform :rectangle)) + ((objects :initform nil) + (counter :initform 0) + (last-box :initform nil) + (style :initform (make-line-style :thickness 1 :dashes nil)) + (shape :initform :rectangle)) (:command-definer define-graphics-editor-command) - (:command-table (graphics-editor :inherit-from (accept-values-pane))) + (:command-table (graphics-editor :inherit-from (accept-values-pane + graphics-editor-file-commands + graphics-editor-edit-commands + graphics-editor-option-commands + ) + ;;-- Should be inherit-keystrokes. + ;; :inherit-menu t + :menu (("File" :menu graphics-editor-file-commands :mnemonic #\F) + ("Edit" :menu graphics-editor-edit-commands :mnemonic #\E ) + ("Options" :menu graphics-editor-option-commands :mnemonic #\O)))) (:pointer-documentation t) ;; Three panes: a display pane, and command menu, and a modeless ;; dialog containing the line style options (:panes - (display :application - :incremental-redisplay t - :display-after-commands t - :display-function 'display-objects - :scroll-bars :both) - (options :accept-values - :display-function '(accept-values-pane-displayer - :displayer accept-graphics-editor-options))) + (display :application + :incremental-redisplay t + :display-after-commands t + :display-function 'display-objects + :scroll-bars :both) + (horizontal-options :accept-values + :width :compute + :display-function '(accept-values-pane-displayer + :displayer (lambda (frame stream) + (accept-graphics-editor-options frame stream + :direction :horizontal)))) + (vertical-options :accept-values + :display-function '(accept-values-pane-displayer + :displayer (lambda (frame stream) + (accept-graphics-editor-options + frame stream + :direction :vertical))))) (:layouts - (default - (vertically () - (1/5 options) - (:fill display))))) + (default + (vertically () + (1/5 horizontal-options) + (:fill display))) + (other + (horizontally () + (1/5 vertical-options) + (:fill display))))) + +(defmethod read-frame-command ((frame graphics-editor) + &key (stream *query-io*) ;frame-query-io? + ;; should the rest of the *command-parser* + ;; etc. variables be passed as keywords or bound? + ) + (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) + +;;; Presentation types (define-presentation-type-abbreviation line-thickness () '((member 1 2 3 4) :name-key identity @@ -261,47 +296,101 @@ :line-thickness object)))) (defun highlight-line-thickness (continuation object stream) + (surrounding-output-with-border (stream) + (funcall continuation object stream))) + + +(define-presentation-type-abbreviation line-style-type () + '((member :solid :dashed) :name-key identity + :printer present-line-style + :highlighter highlight-line-style)) + +(defun present-line-style (object stream &key acceptably) + (declare (ignore acceptably)) + (let ((y (stream-line-height stream))) + (with-room-for-graphics (stream) + (draw-rectangle* stream 0 2 16 (- y 2) + :filled nil :ink +background-ink+) + (draw-line* stream 0 (floor y 2) 16 (floor y 2) + :line-dashes (eq object :dashed))))) + +(defun highlight-line-style (continuation object stream) + (surrounding-output-with-border (stream) + (funcall continuation object stream))) + + + +(define-presentation-type-abbreviation object-shape () + '((member :oval :rectangle) :name-key identity + :printer present-object-shape + :highlighter highlight-object-shape)) + +(defun present-object-shape (object stream &key acceptably) + (declare (ignore acceptably)) + (let ((y (stream-line-height stream))) + (multiple-value-bind (left top bottom right) + (values 0 2 16 (- y 2)) + (with-room-for-graphics (stream) + (ecase object + (:rectangle + (draw-rectangle* stream left top (* 2 bottom) (* 2 right) :filled nil)) + (:oval + (draw-oval* stream + (/ (+ left right) 2) + (/ (+ top bottom) 2) + (/ (abs (- right left)) 2) + (/ (abs (- bottom top)) 2) :filled nil))))))) + +(defun highlight-object-shape (continuation object stream) (surrounding-output-with-border (stream) (funcall continuation object stream))) -(defmethod accept-graphics-editor-options ((frame graphics-editor) stream) + +;;; +(defmethod accept-graphics-editor-options ((frame graphics-editor) stream &key (direction :horizontal)) (with-slots (style shape) frame (flet ((accept (type default prompt query-id &optional (view (stream-default-view stream))) (let (object ignore changed) - (formatting-cell (stream :align-x :center) - (multiple-value-setq (object ignore changed) - (accept type - :stream stream :default default - :query-identifier query-id :prompt prompt - :view view))) + (formatting-cell (stream :align-x (ecase direction + (:horizontal :center) + (:vertical :left))) + (multiple-value-setq (object ignore changed) + (accept type + :stream stream :default default + :query-identifier query-id :prompt prompt + :view view))) (values object changed)))) (declare (dynamic-extent #'accept)) (terpri stream) (terpri stream) (formatting-table (stream :x-spacing '(3 :character)) - (formatting-row (stream) - (let ((thickness (line-style-thickness style)) - (dashes (line-style-dashes style))) - (multiple-value-bind (thickness thickness-changed) - (accept 'line-thickness thickness "Thickness" 'thickness) - (declare (ignore ignore)) - (multiple-value-bind (dashes dashes-changed) - (accept 'boolean dashes "Dashed" 'dashes) - (declare (ignore ignore)) - (multiple-value-bind (new-shape shape-changed) - (accept '(member :oval :rectangle) shape "Shape" 'shape) - (when (or thickness-changed dashes-changed shape-changed) - (setq style (make-line-style :thickness thickness - :dashes dashes)) - (setq shape new-shape) - (when (frame-selected-object frame) - (setf (object-style (frame-selected-object frame)) - (slot-value frame 'style)) - (setf (box-shape (frame-selected-object frame)) - (slot-value frame 'shape)) - (tick-object (frame-selected-object frame)) - (redisplay-frame-pane frame 'display)))))))))))) + (flet ((do-body (stream) + (let ((thickness (line-style-thickness style)) + (dashes (line-style-dashes style))) + (multiple-value-bind (thickness thickness-changed) + (accept 'line-thickness thickness "Thickness" 'thickness) + (declare (ignore ignore)) + (multiple-value-bind (dashes dashes-changed) + (accept 'line-style-type (if dashes :dashed :solid) "Line Style" 'dashes) + (declare (ignore ignore)) + (setq dashes (eq dashes :dashed)) + (multiple-value-bind (new-shape shape-changed) + (accept 'object-shape shape "Shape" 'shape) + (when (or thickness-changed dashes-changed shape-changed) + (setq style (make-line-style :thickness thickness + :dashes dashes)) + (setq shape new-shape) + (when (frame-selected-object frame) + (setf (object-style (frame-selected-object frame)) + (slot-value frame 'style)) + (setf (box-shape (frame-selected-object frame)) + (slot-value frame 'shape)) + (tick-object (frame-selected-object frame)) + (redisplay-frame-pane frame 'display))))))))) + (ecase direction + (:horizontal (formatting-row (stream) (do-body stream))) + (:vertical (formatting-column (stream) (do-body stream))))))))) (defmethod display-objects ((frame graphics-editor) stream) (dolist (object (slot-value frame 'objects)) @@ -381,16 +470,17 @@ ;; Select an object by clicking "select" (Mouse-Left) on it. (define-graphics-editor-command com-select-object - ((object 'basic-object :gesture :select)) + ((object 'box :gesture :select)) (select-object *application-frame* object) (setf (slot-value *application-frame* 'style) (object-style object) (slot-value *application-frame* 'shape) (box-shape object))) ;; Deselect an object by clicking the Deselect menu button, or by ;; clicking over blank area without moving the mouse. -(define-graphics-editor-command (com-deselect-object :menu "Deselect") () - (when (frame-selected-object *application-frame*) - (deselect-object *application-frame* (frame-selected-object *application-frame*)))) + +(define-command (com-deselect-object :command-table graphics-editor-edit-commands :menu "Deselect") nil + (when (frame-selected-object *application-frame*) + (deselect-object *application-frame* (frame-selected-object *application-frame*)))) ;; Move an object by clicking Mouse-Middle on it and dragging the mouse. (define-graphics-editor-command com-move-object @@ -448,25 +538,42 @@ (move-handle handle (- x dx) (- y dy)))))) ;; OK, I added a menu button to clear the window. -(define-graphics-editor-command (com-clear :menu t) () - (with-slots (objects selected-object last-box) *application-frame* - (setq objects nil - selected-object nil - last-box nil) - (window-clear (get-frame-pane *application-frame* 'display)))) + +(define-command (com-clear :command-table graphics-editor-edit-commands :menu t) nil + (with-slots (objects selected-object last-box) *application-frame* + (setq objects nil selected-object nil last-box nil) + (window-clear (get-frame-pane + *application-frame* 'display)))) + ;; OK, I added a menu button to redisplay the window, too, although ;; it's only here for debugging. -(define-graphics-editor-command (com-redisplay :menu t) () + +(define-command (com-redisplay :command-table + graphics-editor-edit-commands + :keystroke (:r :meta) + :menu t) + nil (redisplay-frame-pane *application-frame* 'display :force-p t)) -(define-graphics-editor-command (com-quit :menu t) () +(define-command (com-quit :command-table graphics-editor-file-commands + :keystroke (:x :meta) + :menu t) () (frame-exit *application-frame*)) +(define-command (com-change-layout :command-table + graphics-editor-option-commands + :keystroke (:l :meta) + :menu t) () + (let ((layouts (frame-all-layouts *application-frame*))) + (setf (frame-current-layout *application-frame*) + (or (second (member (frame-current-layout *application-frame*) layouts)) + (car layouts))))) + (defvar *graphics-editors* nil) -(defun do-graphics-editor (&key (port (find-port)) (force nil)) +(defun do-graphics-editor (&key (port (find-port)) (force t)) (let* ((framem (find-frame-manager :port port)) (frame (let* ((entry (assoc port *graphics-editors*)) diff --git a/demo/plot.lisp b/demo/plot.lisp index 8f2f4ff5d49fe868b577f6491cb490ed6ffe446a..65a5a072fdae53a4cd87d537f3e88f85815817dc 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.5 92/07/27 11:03:34 cer Exp $ +;; $fiHeader: plot.lisp,v 1.6 92/08/18 17:26:23 cer Exp Locker: cer $ (in-package :clim-demo) @@ -551,6 +551,19 @@ (accept 'string :default (nth i (slot-value frame 'x-labels)))))) + +#+allegro +(define-plot-demo-command (com-print-graph :name t :menu t) + ((printer '(member :lw :lw2 :lw3) + :display-default t + :default :lw2)) + (with-open-stream (pipe (excl:run-shell-command (format nil "lpr -P~A" printer) + :input :stream :wait nil)) + (with-output-to-postscript-stream (stream pipe :multi-page t) + (display-graph *application-frame* stream)))) + + + (define-plot-demo-command (com-edit-y-label :name t :menu t) ((i 'y-label :gesture :select)) (with-application-frame (frame) diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp index f6f4097439e4786e67c314d3083768ad4fe5a4b7..22bdcc3f1505d6ee0c8b2287ee8f93f0bfb71892 100644 --- a/demo/sysdcl.lisp +++ b/demo/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.14 92/07/27 11:03:36 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.15 92/08/18 17:26:25 cer Exp Locker: cer $ (in-package #-ansi-90 :user #+ansi-90 :common-lisp-user) @@ -33,7 +33,11 @@ ("graphics-editor" :load-before-compile ("demo-driver" "packages")) ("ico" :load-before-compile ("demo-driver" "packages")) ("browser" :load-before-compile ("demo-driver" "packages")) - ("demo-prefill" :features (or Genera Cloe-Runtime))) + #+Allegro + ("process-browser" :load-before-compile ("demo-driver" "packages")) + ("bitmap-editor" :load-before-compile ("demo-driver" "packages")) + + ("demo-prefill" :features (or Genera Cloe-Runtime))) #+Genera (clim-defsys:import-into-sct 'clim-demo diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 5262f8b6ff2e0370705ffcf4615fcfa3022c061c..fffd789b33f36d5bfe4cd408a2d01575cb48dd74 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.8 92/07/01 15:47:55 cer Exp Locker: cer $ +;; $fiHeader: compile-1.lisp,v 1.9 92/08/21 16:34:17 cer Exp Locker: cer $ (in-package :user) @@ -28,6 +28,13 @@ ;;;; (setq *ignore-package-name-case* t) (set-case-mode :case-insensitive-lower) + +#+ignore +(progn + (compile-file "~/stuff/misc/new-slot-opt.cl") + (load "~/stuff/misc/new-slot-opt.fasl") + ) + (setf (sys:gsgc-switch :print) t) (setf (sys:gsgc-switch :stats) t) @@ -59,6 +66,7 @@ (clim-defsys::load-system sys)) (load "postscript/sysdcl") (clim-defsys::compile-system 'postscript-clim :propagate t) + (clim-defsys::load-system 'postscript-clim) (compile-file-if-needed "test/test-suite") (load "demo/sysdcl") (clim-defsys::compile-system 'clim-demo :propagate t)) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 53d189d1aeb7fd2e3ae022c52ce516ec250c5fb7..f5f8e974e967c88533e4bcb8d288ad16a4f879cb 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,13 +20,20 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.9 92/07/27 19:30:16 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.10 92/08/21 16:34:21 cer Exp Locker: cer $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) (set-case-mode :case-insensitive-lower) + +#+ignore +(progn +(compile-file "~/stuff/misc/new-slot-opt.cl") +(load "~/stuff/misc/new-slot-opt.fasl") +) + (tenuring (let ((*load-source-file-info* t) (*load-xref-info* nil)) @@ -56,8 +63,7 @@ ;;-- been loaded (tenuring - (load "postscript/sysdcl") - (clim-defsys::load-system 'postscript-clim)) + (load "climps.fasl")) (compile-file-if-needed "test/test-suite") @@ -72,6 +78,7 @@ #-ignore (clim-defsys::load-system 'clim-demo))) + (when (probe-file "/scm/4.1/sparc/src/code/") (let ((sys::*require-search-list* (cons (make-pathname :directory "/scm/4.1/sparc/src/code/" @@ -83,7 +90,7 @@ sys::*load-search-list*))) (tenuring (require :composer))) - (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/") + (set (intern :*clm-binary-directory* ':xtk) "/scm/4.1/sparc/src/")) - (tenuring - (load "misc/clos-preload.fasl" :if-does-not-exist nil)))) + (tenuring + (load "misc/clos-preload.fasl" :if-does-not-exist nil))) diff --git a/postscript/sysdcl.lisp b/postscript/sysdcl.lisp index 9eeecd047d273dc3707121b2236982ebe8e25bd4..1143acf42e30fe37f348055ed5ce347f64da5ca0 100644 --- a/postscript/sysdcl.lisp +++ b/postscript/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;;; $fiHeader$ +;;; $fiHeader: sysdcl.lisp,v 1.1 92/08/19 10:28:02 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -11,7 +11,7 @@ #-Genera (frob-pathname "postscript") :default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;" #-Genera (frob-pathname "postscript") - :needed-systems (clim-standalone) + #+ignore :needed-systems #+ignore (clim-standalone) :load-before-compile (clim-standalone)) ("pkgdcl") ("postscript-port") diff --git a/silica/db-border.lisp b/silica/db-border.lisp index 4862ee22fedbcc508f0a56167c0e72ddb1188ae8..7ced74484849b0367fcfd4e0248da5677752e198 100644 --- a/silica/db-border.lisp +++ b/silica/db-border.lisp @@ -5,7 +5,7 @@ (in-package :silica) -;; $fiHeader: db-border.lisp,v 1.9 92/07/20 15:59:04 cer Exp $ +;; $fiHeader: db-border.lisp,v 1.10 92/08/18 17:23:25 cer Exp Locker: cer $ ;;; Border Panes @@ -77,7 +77,9 @@ ;;; Label panes (defparameter *default-label-text-style* - (make-text-style :sans-serif :italic :small)) + ;;--- This defeats the resource mechanism + #-ignore nil + #+ignore (make-text-style :sans-serif :italic :small)) (defclass label-pane (foreground-background-and-text-style-mixin labelled-gadget-mixin) () diff --git a/silica/db-box.lisp b/silica/db-box.lisp index d33ffd3fcf6e34842f8b297cd3960c8decfc6e24..821999d8ac33168b493fb848d69ee9897118b61a 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-box.lisp,v 1.19 92/07/20 15:59:05 cer Exp $ +;; $fiHeader: db-box.lisp,v 1.20 92/08/18 17:23:26 cer Exp Locker: cer $ (in-package :silica) @@ -102,16 +102,16 @@ '(:width :max-width :min-width :height :max-height :min-height))) (defmethod allocate-space ((box-pane hbox-pane) width height) - (with-slots (contents space space-requirement) box-pane - (unless space-requirement - (compose-space box-pane :width width :height height)) - (flet ((compose (x) - (cond ((atom x) (compose-space x :height height)) - ((eq (car x) :fill) :fill) - (t (make-space-requirement :height 0 :width (* (car x) width)))))) - (declare (dynamic-extent #'compose)) - (let ((sizes - (allocate-space-to-items + (with-slots (contents space) box-pane + (let ((space-requirement + (compose-space box-pane :width width :height height))) + (flet ((compose (x) + (cond ((atom x) (compose-space x :height height)) + ((eq (car x) :fill) :fill) + (t (make-space-requirement :height 0 :width (* (car x) width)))))) + (declare (dynamic-extent #'compose)) + (let ((sizes + (allocate-space-to-items width space-requirement contents @@ -119,16 +119,16 @@ #'space-requirement-width #'space-requirement-max-width #'compose)) - (x 0)) - (mapc #'(lambda (sheet size) - (when (or (panep sheet) - (and (consp sheet) - (panep (second sheet)) - (setq sheet (second sheet)))) - (move-and-resize-sheet - sheet x 0 (frob-size size width x) height)) - (incf x size)) - contents sizes))))) + (x 0)) + (mapc #'(lambda (sheet size) + (when (or (panep sheet) + (and (consp sheet) + (panep (second sheet)) + (setq sheet (second sheet)))) + (move-and-resize-sheet + sheet x 0 (frob-size size width x) height)) + (incf x size)) + contents sizes)))))) (defclass vbox-pane (box-pane) ()) @@ -146,16 +146,16 @@ `(:height :max-height :min-height :width :max-width :min-width))) (defmethod allocate-space ((box-pane vbox-pane) width height) - (with-slots (contents space space-requirement) box-pane - (unless space-requirement - (compose-space box-pane :width width :height height)) - (flet ((compose (x) - (cond ((atom x) (compose-space x :width width)) - ((eq (car x) :fill) :fill) - (t (make-space-requirement :width 0 :height (* (car x) height)))))) - (declare (dynamic-extent #'compose)) - (let ((sizes - (allocate-space-to-items + (with-slots (contents space) box-pane + (let ((space-requirement + (compose-space box-pane :width width :height height))) + (flet ((compose (x) + (cond ((atom x) (compose-space x :width width)) + ((eq (car x) :fill) :fill) + (t (make-space-requirement :width 0 :height (* (car x) height)))))) + (declare (dynamic-extent #'compose)) + (let ((sizes + (allocate-space-to-items height space-requirement contents @@ -163,16 +163,16 @@ #'space-requirement-height #'space-requirement-max-height #'compose)) - (y 0)) - (mapc #'(lambda (sheet size) - (when (or (panep sheet) - (and (consp sheet) - (panep (second sheet)) - (setq sheet (second sheet)))) - (move-and-resize-sheet - sheet 0 y width (frob-size size height y))) - (incf y size)) - contents sizes))))) + (y 0)) + (mapc #'(lambda (sheet size) + (when (or (panep sheet) + (and (consp sheet) + (panep (second sheet)) + (setq sheet (second sheet)))) + (move-and-resize-sheet + sheet 0 y width (frob-size size height y))) + (incf y size)) + contents sizes)))))) ;;--- In theory this should work OK. (defun frob-size (wanted-size available where-we-are-now) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 6135d3f3cfb74c0af77b33d093101b414be4d142..556f673d8fec1cd72cba78a34835558617204c73 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-layout.lisp,v 1.22 92/07/20 15:59:09 cer Exp $ +;; $fiHeader: db-layout.lisp,v 1.23 92/08/18 17:23:30 cer Exp Locker: cer $ (in-package :silica) @@ -411,13 +411,13 @@ ;;; (defclass space-requirement-cache-mixin (layout-mixin) - ((space-requirement :initform nil))) + ((space-requirement-cache :initform nil))) (defmethod compose-space :around ((pane space-requirement-cache-mixin) &key width height) (declare (ignore width height)) - (with-slots (space-requirement) pane - (or space-requirement - (setf space-requirement (call-next-method))))) + (with-slots (space-requirement-cache) pane + (or space-requirement-cache + (setf space-requirement-cache (call-next-method))))) (defmethod clear-space-requirement-cache ((pane layout-mixin)) nil) @@ -426,8 +426,8 @@ nil) (defmethod clear-space-requirement-cache ((pane space-requirement-cache-mixin)) - (with-slots (space-requirement) pane - (setf space-requirement nil))) + (with-slots (space-requirement-cache) pane + (setf space-requirement-cache nil))) (defmethod change-space-requirements :before ((pane space-requirement-cache-mixin) &key) (clear-space-requirement-cache pane)) @@ -651,6 +651,7 @@ (defclass layout-pane (sheet-mute-input-mixin pane-background-mixin space-requirement-cache-mixin + space-requirement-mixin sheet-permanently-enabled-mixin composite-pane) ()) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index fa4ff795a01ea80b05ac8c6dbb93a659c5bf35fc..dc57c29c01ff4c3dcd206524f006ad102b96d1ef 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.28 92/08/18 17:23:31 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.29 92/08/19 18:04:15 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -161,6 +161,10 @@ ;;--- In the case where the viewport is bigger than the window this ;;--- code gets things wrong. Check out the thinkadot demo. It's ;;--- because (- (--) (- vmin)) is negative. + +(defmethod note-sheet-grafted :before ((sheet scroll-bar)) + (setf (scroll-bar-current-size sheet) nil)) + (defun update-scroll-bar (scroll-bar min max vmin vmax) (declare (optimize (safety 0) (speed 3))) (let ((current-size (scroll-bar-current-size scroll-bar)) diff --git a/silica/db-table.lisp b/silica/db-table.lisp index 2cbb512820781246b3bc811180538e95183145af..01931efeb2e56231ea59647ec3114753b7dcc900 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.13 92/07/20 15:59:14 cer Exp $ +;; $fiHeader: db-table.lisp,v 1.14 92/08/18 17:23:35 cer Exp Locker: cer $ (in-package :silica) @@ -104,28 +104,28 @@ :min-height omin-h :height oh :max-height omax-h))) (defmethod allocate-space ((table table-pane) width height) - (with-slots (space-requirement column-space-requirements row-space-requirements) table - (unless space-requirement - (compose-space table :width width :height height)) - (let* ((contents (slot-value table 'contents)) + (with-slots (column-space-requirements row-space-requirements) table + (let* ((space-requirement + (compose-space table :width width :height height)) + (contents (slot-value table 'contents)) (row-heights - (allocate-space-to-items - height - space-requirement - row-space-requirements - #'space-requirement-min-height - #'space-requirement-height - #'space-requirement-max-height - #'identity)) + (allocate-space-to-items + height + space-requirement + row-space-requirements + #'space-requirement-min-height + #'space-requirement-height + #'space-requirement-max-height + #'identity)) (column-widths - (allocate-space-to-items - width - space-requirement - column-space-requirements - #'space-requirement-min-width - #'space-requirement-width - #'space-requirement-max-width - #'identity)) + (allocate-space-to-items + width + space-requirement + column-space-requirements + #'space-requirement-min-width + #'space-requirement-width + #'space-requirement-max-width + #'identity)) (y 0)) (dotimes (row (array-dimension contents 0)) (let ((row-height (pop row-heights)) @@ -137,8 +137,8 @@ (when (and item (sheet-enabled-p item)) (move-and-resize-sheet - item x y - (min column-width (1- (- width x))) - (min row-height (1- (- height y))))) + item x y + (min column-width (1- (- width x))) + (min row-height (1- (- height y))))) (incf x column-width))) (incf y row-height)))))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 531cf7dfc6f9fbc7bcebfcdc677a2a1e492dae81..5613a52e8eba7f6c2e39a2e1ad087ff324c861cb 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.31 92/08/18 17:23:42 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.32 92/08/19 18:04:24 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -21,6 +21,7 @@ (with-slots (text-style) pane ;; Convert the text style if necesary (etypecase text-style + (null) (cons (setq text-style (parse-text-style text-style))) (text-style nil)))) @@ -227,6 +228,10 @@ (defparameter *default-slider-range-label-text-style* (make-text-style :sans-serif :bold :very-small)) +;;; Separator + +(defclass separator (oriented-gadget-mixin) ()) + ;;; Slider (defclass slider (value-gadget oriented-gadget-mixin range-gadget-mixin labelled-gadget-mixin) @@ -415,11 +420,12 @@ ()) (defclass text-editor (text-field) - ((ncolumns :initarg :ncolumns - :accessor gadget-columns) - (nlines :initarg :nlines - :accessor gadget-lines)) - (:default-initargs :ncolumns 1 :nlines 1)) + ((ncolumns :initarg :ncolumns + :accessor gadget-columns) + (nlines :initarg :nlines + :accessor gadget-lines) + (editable-p :initarg :editable-p :accessor silica::gadget-editable-p)) + (:default-initargs :ncolumns 1 :nlines 1 :editable-p t)) ;;; Viewport @@ -588,8 +594,9 @@ (defclass list-pane (set-gadget-mixin value-gadget) ;;--- Should this be :ONE-OF/:SOME-OF, as radio boxes are? ((mode :initarg :mode :type (member :exclusive :nonexclusive) - :accessor list-pane-mode)) - (:default-initargs :mode :exclusive)) + :accessor list-pane-mode) + (visible-items :initarg :visible-items :reader gadget-visible-items)) + (:default-initargs :mode :exclusive :visible-items nil)) (defun compute-list-pane-selected-items (sheet value) (with-accessors ((items set-gadget-items) @@ -624,7 +631,8 @@ (defclass option-pane (set-gadget-mixin labelled-gadget-mixin value-gadget) - ()) + ((printer :initarg :printer :reader option-pane-printer)) + (:default-initargs :printer nil)) ;; Callbacks on widgets generate these events diff --git a/silica/pixmaps.lisp b/silica/pixmaps.lisp index f743d45b0deecf592cffedc186435940e85b1eed..caec018a37368ab17ecd940b1fad89ba0a385bee 100644 --- a/silica/pixmaps.lisp +++ b/silica/pixmaps.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: pixmaps.lisp,v 1.6 92/08/19 10:23:43 cer Exp Locker: cer $ +;; $fiHeader: pixmaps.lisp,v 1.7 92/08/21 16:33:34 cer Exp Locker: cer $ (in-package :silica) @@ -118,8 +118,9 @@ :port (port sheet) :medium pixmap-medium :width width :height height))) - (setf (medium-foreground pixmap-medium) (medium-foreground stream) - (medium-background pixmap-medium) (medium-background stream)) + (with-sheet-medium (medium sheet) + (setf (medium-foreground pixmap-medium) (medium-foreground medium) + (medium-background pixmap-medium) (medium-background medium))) (funcall continuation pixmap-sheet) (slot-value pixmap-medium 'pixmap))) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index bc4eb427a9b2c47afc3f23f042879983b1c9c947..66d50bb6736441a884f83c34f334891b4475a09a 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.22 92/08/18 17:54:12 cer Exp $ +;; $fiHeader: sysdcl.lisp,v 1.23 92/08/21 16:34:02 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -130,6 +130,7 @@ ("lisp-utilities") ("processes") ("queue") + ("timers" :load-before-compile ("queue" "processes")) ("protocols") ("autoconstructor") @@ -421,6 +422,7 @@ ("image") ("xt-frames") ("xm-frames") + ("xm-dialogs") ("xt-gadgets") ("xm-gadgets") ("xm-menus") diff --git a/test/chess.lisp b/test/chess.lisp index be49c0ca79be0248e6b21972230202026d990e38..5e8fd0c26ad9f312031d9c39ea13d83ac7555d94 100644 --- a/test/chess.lisp +++ b/test/chess.lisp @@ -20,27 +20,37 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: chess.lisp,v 1.6 92/05/22 19:28:47 cer Exp $ +;; $fiHeader: chess.lisp,v 1.7 92/07/01 15:47:18 cer Exp Locker: cer $ (in-package :clim-user) (define-application-frame chess-board () - ((board :initform (make-array '(8 8) - :initial-contents - (make-chess-board-initial-state))) - (bitmaps :initform nil :allocation :class) - (subprocess :initform (create-chess-subprocess))) + ((board :initform (make-array '(8 8) + :initial-contents + (make-chess-board-initial-state))) + (bitmaps :initform nil :allocation :class) + (subprocess :initform (create-chess-subprocess))) (:command-table chess-commands) (:panes - (board :application - :incremental-redisplay t - :scroll-bars :dynamic - :width :compute :height :compute - :max-width :compute :max-height :compute - :display-function 'draw-chess-board)) + (board :application + :incremental-redisplay '(t :check-overlapping nil) + :scroll-bars :dynamic + :width :compute :height :compute + :max-width :compute :max-height :compute + :display-function 'draw-chess-board) + (status :application :scroll-bars nil :height '(1 :line))) (:layouts - (:default board))) + (:default (vertically () status board)))) + +(defmethod update-status (frame message) + (let ((pane (get-frame-pane frame 'status))) + (window-clear pane) + (with-text-face (pane :bold) + (write-string message pane)))) + +(defmethod read-frame-command :before ((frame chess-board) &key) + (update-status frame "Your move")) (define-presentation-type chess-square ()) @@ -84,6 +94,7 @@ (apply #'aref board from) (apply #'aref board from) nil) (redisplay-frame-pane *application-frame* (frame-standard-output *application-frame*)) + (update-status *application-frame* "My Move......") (let ((res (read-chess-move-from-subprocess subprocess))) (multiple-value-bind (from to) @@ -127,6 +138,7 @@ (list object *unsupplied-argument-marker*)) (defmethod draw-chess-board (frame stream &key &allow-other-keys) + (stream-set-cursor-position stream 0 0) (formatting-table (stream) (dotimes (row 8) (formatting-row (stream) diff --git a/test/test-suite.lisp b/test/test-suite.lisp index e6f065bc041e2a6691aa0a3e7133833c786eb07c..0b90e4752eca9d7f6a778f3146f3deeb4ecac385 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.30 92/08/19 10:24:06 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.31 92/08/21 16:34:04 cer Exp Locker: cer $ (in-package :clim-user) @@ -523,13 +523,17 @@ people, shall not perish from the earth. (stream `(region-intersects-region-p ,region1 ,region2) 'form :single-box t) (formatting-cell (stream :align-x :center) - (let ((res (lookup-result region1 region2)) + (handler-case + (let ((res (lookup-result region1 region2)) (result (region-intersects-region-p (eval region1) (eval region2)))) (if (eq res :none) (write-char #\space stream) ;the presentation demands some ink (with-text-face (stream (if (eq res result) nil :bold)) - (format stream "~A" result))))))))))) + (format stream "~A" result)))) + (error () + (with-text-face (stream :bold) + (write-string "Error signalled"))))))))))) (region-test-comment stream))) @@ -1645,62 +1649,72 @@ Luke Luck licks the lakes Luke's duck likes.")) (line-thickness 1) (line-thickness-units :normal)) (accepting-values (stream :own-window own-window) - (setq square-dimension - (accept 'number :stream stream - :prompt "Size of square" :default square-dimension)) - (terpri stream) - (setq draw-circle - (accept 'boolean :stream stream - :prompt "Draw the circle" :default draw-circle)) - (terpri stream) - (setq draw-square - (accept 'boolean :stream stream - :prompt "Draw the square" :default draw-square)) - (terpri stream) - (setq draw-point - (accept 'boolean :stream stream - :prompt "Draw point" :default draw-point)) - (terpri stream) - (setq draw-/-diagonal - (accept 'boolean :stream stream - :prompt "Draw / diagonal" :default draw-/-diagonal)) - (terpri stream) - (setq draw-\\-diagonal - (accept 'boolean :stream stream - :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) - (terpri stream) - (setq line-thickness - (accept 'number :stream stream - :prompt "Line thickness" :default line-thickness)) - (terpri stream) - (setq line-thickness-units - (accept '(member :normal :point) :stream stream - :prompt "Line style units" :default line-thickness-units)) - (terpri stream) - (with-room-for-graphics (stream) - (let ((radius (/ square-dimension 2))) - (with-drawing-options (stream :line-unit line-thickness-units - :line-thickness line-thickness) - (when draw-square - (draw-polygon* stream (list 0 0 - 0 square-dimension - square-dimension square-dimension - square-dimension 0) - :line-joint-shape :miter - :filled nil)) - (when draw-circle - (draw-circle* stream radius radius radius - :filled nil)) - (when draw-point - (draw-point* stream - (/ square-dimension 4) - (/ square-dimension 2))) - (when draw-/-diagonal - (draw-line* stream 0 square-dimension square-dimension 0 - :line-cap-shape :round)) - (when draw-\\-diagonal - (draw-line* stream 0 0 square-dimension square-dimension - :line-cap-shape :round)))))))) + (formatting-item-list (stream :n-columns 2) + (formatting-cell (stream) + (setq square-dimension + (accept 'number :stream stream + :prompt "Size of square" :default square-dimension)) + (terpri stream) + (setq draw-circle + (accept 'boolean :stream stream + :prompt "Draw the circle" :default draw-circle)) + (terpri stream) + (setq draw-square + (accept 'boolean :stream stream + :prompt "Draw the square" :default draw-square)) + (terpri stream) + (setq draw-point + (accept 'boolean :stream stream + :prompt "Draw point" :default draw-point)) + (terpri stream) + (setq draw-/-diagonal + (accept 'boolean :stream stream + :prompt "Draw / diagonal" :default draw-/-diagonal)) + (terpri stream) + (setq draw-\\-diagonal + (accept 'boolean :stream stream + :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) + (terpri stream) + (setq line-thickness + (accept 'number :stream stream + :prompt "Line thickness" :default line-thickness)) + (terpri stream) + (setq line-thickness-units + (accept '(member :normal :point) :stream stream + :prompt "Line style units" :default line-thickness-units)) + (terpri stream)) + (formatting-cell (stream) + (let (s) + (with-output-as-gadget (stream) + (multiple-value-bind (sheets stream) + (make-clim-application-pane :scroll-bars :both :width 150 :height 150) + (setq s stream) + sheets)) + (let ((stream s)) + (with-room-for-graphics (stream :move-cursor nil) + (let ((radius (/ square-dimension 2))) + (with-drawing-options (stream :line-unit line-thickness-units + :line-thickness line-thickness) + (when draw-square + (draw-polygon* stream (list 0 0 + 0 square-dimension + square-dimension square-dimension + square-dimension 0) + :line-joint-shape :miter + :filled nil)) + (when draw-circle + (draw-circle* stream radius radius radius + :filled nil)) + (when draw-point + (draw-point* stream + (/ square-dimension 4) + (/ square-dimension 2))) + (when draw-/-diagonal + (draw-line* stream 0 square-dimension square-dimension 0 + :line-cap-shape :round)) + (when draw-\\-diagonal + (draw-line* stream 0 0 square-dimension square-dimension + :line-cap-shape :round)))))))))))) ;;;; Benchmarks @@ -1845,11 +1859,13 @@ Luke Luck licks the lakes Luke's duck likes.")) (let ((time (funcall function :careful t))) (push (list (first benchmark) time) data)))) (setq data (reverse data)) - (with-open-file (s pathname :direction :output) - (format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) - (format s "~%;on ~A ~A.~%" (machine-type) (machine-instance)) - (when comment (format s ";~A~%" comment)) - (print data s)))) + (let ((*package* (or (find-package :common-lisp-user) + (error "Package COMMON-LISP-USER not found")))) + (with-open-file (s pathname :direction :output) + (format s ";Speed of ~A ~A" (lisp-implementation-type) (lisp-implementation-version)) + (format s "~%;on ~A ~A.~%" (machine-type) (machine-instance)) + (when comment (format s ";~A~%" comment)) + (print data s))))) (define-command (generate-report :command-table benchmarks :menu t) () @@ -1914,16 +1930,25 @@ Luke Luck licks the lakes Luke's duck likes.")) (flet ((print-out (description results) (when results (format s "~2%~A" description) - (do ((name-and-number results (cdr name-and-number)) - (column 0 (1+ column))) - ((null name-and-number)) - (let ((short-name (first (car name-and-number))) - (number (second (car name-and-number)))) - (when (zerop (mod column 4)) - (format s "~% ")) - (if number - (format s "~22@<~A ~2$ ~>" short-name number) - (format s "~22@T"))))))) + (let ((min nil)) + (do ((name-and-number results (cdr name-and-number))) + ((null name-and-number)) + (let ((number (second (car name-and-number)))) + (when number + (setq min (if min (min number min) number))))) + (do ((name-and-number results (cdr name-and-number)) + (column 0 (1+ column))) + ((null name-and-number)) + (let ((short-name (first (car name-and-number))) + (number (second (car name-and-number)))) + (when (zerop (mod column 4)) + (format s "~% ")) + (if number + (format s "~22@<~A ~2$ (~2$)~>" + short-name + number + (float (/ number min))) + (format s "~22@T")))))))) ;; Print out the summaries (format s "~&~%Summary results (geometric means of a number of relevant tests):~%~%Category~28T") (dolist (short-name data) diff --git a/test/test.lisp b/test/test.lisp index 2623746e88d9433530608342c750b7faf0343cb2..11fdb305224703fb54db12eadf48af75928f83f5 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.36 92/07/24 10:54:39 cer Exp $ +;; $fiHeader: test.lisp,v 1.37 92/08/18 17:25:55 cer Exp Locker: cer $ (in-package :clim-user) @@ -823,9 +823,14 @@ (:layouts (:default c))) - (define-application-frame tf106 () - ((square-dimension :initform 100) + ( + (s :initform "hello") + (r :initform "hello") + (w :initform :oval) + (v :initform nil) + (u :initform :xxx) + (square-dimension :initform 100) (draw-circle :initform t) (draw-square :initform t) (draw-/-diagonal :initform t) @@ -841,9 +846,13 @@ :height :compute :width :compute :display-function `(accept-values-pane-displayer :resynchronize-every-pass t - :displayer display-frame-c))) + :displayer display-frame-c)) + (e :accept-values + :height :compute :width :compute + :display-function `(accept-values-pane-displayer + :displayer display-frame-e))) (:layouts - (:default (vertically () c d)))) + (:default (vertically () c d e)))) (defun display-frame-b (frame stream &key max-width max-height) (declare (ignore max-width max-height)) @@ -912,3 +921,35 @@ (accept '(member :normal :point) :stream stream :prompt "Line style units" :default line-thickness-units)) (terpri stream))) + + +(defun display-frame-e (frame stream) + (with-slots (s r w v u) frame + (setq s (accept 'string :stream stream + :prompt "bar" + :default s)) + (terpri stream) + (setq r (accept 'string :stream stream + :prompt "foo" + :view '(clim-internals::text-editor-view + :ncolumns 30 + :nlines 5) + :default r)) + (terpri stream) + (setq u (accept '(member :xxx :yyy :zyy) + :view clim-internals::+list-pane-view+ + :stream stream + :prompt "baz" + :default u)) + (terpri stream) + (setq w (accept '(member :oval :rectangle) + :view clim-internals::+option-pane-view+ + :stream stream + :prompt "bazzy" + :default w)) + (terpri stream) + (setq v (accept '(subset :x :y :z) + :view clim-internals::+list-pane-view+ + :stream stream + :prompt "barf" + :default v)))) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index 7f1862608fd40b1f2355ecfea03364a900763c26..435e3e330a0a12cef8f23253a8ea442047554ae8 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.26 92/08/19 18:05:33 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.27 92/08/21 16:34:29 cer Exp Locker: cer $ (in-package :xm-silica) @@ -58,6 +58,9 @@ (list :orientation :horizontal)) (values 'tk::xm-menu-bar + ;;---- This seems important but why + ;;---- At a guess I would say its because the query-geometry gets + ;;---- all stupid if these resources are NIL (list :resize-height t :resize-width t)))) @@ -101,35 +104,47 @@ (pane-frame sheet) commands-and-buttons)))) (make-submenu (parent menu item) - (let* ((submenu (make-instance - 'tk::xm-pulldown-menu - :managed nil - :parent parent)) + (let* ((shell (make-instance 'xt::xm-menu-shell + :width 5 ; This widget is + ; realized when + ; it is created + ; so we have to + ; specify a size! + :height 5 + :allow-shell-resize t + :override-redirect t + :parent parent)) + + (submenu (make-instance 'xt::xm-row-column + :managed nil + :parent shell + :row-column-type :menu-pulldown)) (cb (make-instance 'xt::xm-cascade-button-gadget :parent parent :label-string menu :sub-menu-id submenu))) (declare (ignore cb)) - ;;-- At this point should write the code to lazily - ;;-- create menus and update them if the table has - ;;-- changed. + (let ((mnem (getf (command-menu-item-options item) :mnemonic))) + (when mnem (tk::set-values cb :mnemonic mnem))) (let* ((ct (find-command-table (second item))) (tick (slot-value ct 'clim-internals::menu-tick))) - (tk::add-callback (tk::widget-parent submenu) - :popup-callback - #'(lambda (ignore) - (declare (ignore ignore)) - (let ((children - (tk::widget-children submenu))) - (when (or (null children) - (/= tick - (setq tick - (slot-value ct 'clim-internals::menu-tick)))) - (mapc #'tk::destroy-widget children) - (make-menu-for-command-table - ct - submenu - nil)))))))) + (make-menu-for-command-table ct submenu nil) + ;;-- This is what we wanted to do but looses + ;;-- because of the shared shell + (setf (tk::widget-create-popup-child-proc shell) + #'(lambda (shell) + (declare (ignore shell)) + (let ((children + (tk::widget-children submenu))) + (when (or (null children) + (/= tick + (setq tick + (slot-value ct 'clim-internals::menu-tick)))) + (mapc #'tk::destroy-widget children) + (make-menu-for-command-table + ct + submenu + nil)))))))) (make-menu-for-command-table-1 (command-table parent top) ;; Unless we are at the top level we want to have a ;; map-before callback that sets the sensitivity of @@ -171,10 +186,13 @@ (push (list item button) commands-and-buttons) - (set-button-accelerator-from-keystroke button keystroke) - - (when (getf (command-menu-item-options - item) :documentation) + (set-button-accelerator-from-keystroke + button keystroke) + + (let ((mnem (getf (command-menu-item-options item) :mnemonic))) + (when mnem (tk::set-values button :mnemonic mnem))) + + (when (getf (command-menu-item-options item) :documentation) (tk::add-callback button :help-callback @@ -380,3 +398,5 @@ (defmethod framem-menu-active-p ((framem motif-frame-manager) menu) (tk::is-managed-p menu)) +;;;; + diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index fbdeac0608a9fcd81725961d5ca0b818edb8b07d..2bf5cee5737aa1e12abd6ab5c14d7492000e8494 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.43 92/08/19 10:24:22 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.44 92/08/21 16:34:30 cer Exp Locker: cer $ (in-package :xm-silica) @@ -28,6 +28,7 @@ ;; Another experiment ;; experiment (outlined-pane motif-frame-pane) + (silica::separator motif-separator) ;; (scroll-bar motif-scroll-bar) (slider motif-slider) @@ -68,7 +69,8 @@ (declare (ignore invoke-callback)) (let ((m (sheet-direct-mirror gadget))) (when (and m (not (equal nv (tk::get-values m :value)))) - (tk::set-values m :value nv)))) + (let ((*dont-invoke-callbacks* t)) + (tk::set-values m :value nv))))) ;; Gadgets that have a :label initarg @@ -252,10 +254,23 @@ (multiple-value-bind (mmin mmax) (tk::get-values mirror :minimum :maximum) - (tk::set-values mirror - :value (fix-coordinate - (compute-symmetric-value - smin smax nv mmin mmax)))))))) + (let ((*dont-invoke-callbacks* t)) + (tk::set-values mirror + :value (fix-coordinate + (compute-symmetric-value + smin smax nv mmin mmax))))))))) + +;;; + +(defclass motif-separator (motif-oriented-gadget + xt-leaf-pane + silica::separator) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) + (parent t) + (sheet motif-separator)) + (values 'tk::xm-separator nil)) ;;; Slider @@ -513,14 +528,20 @@ motif-text-editor)) (with-accessors ((value gadget-value) (ncolumns silica::gadget-columns) + (editable silica::gadget-editable-p) (nlines silica::gadget-lines)) sheet (values 'tk::xm-text (append + (list :editable editable) (list :edit-mode :multi-line) (and ncolumns (list :columns ncolumns)) (and nlines (list :rows nlines)) (and value `(:value ,value)))))) +(defmethod (setf gadget-editable-p) :after (nv (te motif-text-editor)) + (let ((m (sheet-direct-mirror m))) + (tk::set-values m :editable nv))) + ;(defmethod compute-initial-mirror-geometry (parent (sheet motif-text-editor) initargs) ; (multiple-value-bind (left top right bottom) ; (sheet-actual-native-edges* sheet) @@ -535,6 +556,7 @@ ; (getf initargs :y) (floor top)) ; initargs)) +#+ignore (defmethod compose-space ((te motif-text-editor) &key width height) (declare (ignore width height)) (let ((sr (call-next-method))) @@ -547,7 +569,20 @@ :width width :min-width min-width :max-width +fill+ :height height :min-height min-height :max-height +fill+)))) - +(defmethod compose-space ((te motif-text-editor) &key width height) + (declare (ignore width height)) + (multiple-value-bind (font-list margin-height margin-width) + (tk::get-values (sheet-direct-mirror te) :font-list + :margin-height :margin-width) + (let* ((max-width most-negative-fixnum) + (max-height most-negative-fixnum)) + (assert font-list) + (dolist (font font-list) + (let ((font (second font))) + (maxf max-height (tk::font-height font)) + (maxf max-width (tk::font-width font)))) + (make-space-requirement :width (+ (* 2 margin-width) (* max-width (silica::gadget-columns te))) + :height (+ (* 2 margin-height) (* max-height (silica::gadget-lines te))))))) ;;; Toggle button (defclass motif-toggle-button (motif-labelled-gadget @@ -563,10 +598,11 @@ (indicator-type gadget-indicator-type)) sheet (values 'xt::xm-toggle-button (append (list :set set) - (list :indicator-type - (ecase indicator-type - (:one-of :one-of-many) - (:some-of :n-of-many))))))) + (ecase indicator-type + ;;--- How can we deal with this portably + ((nil) (list :indicator-on nil :shadow-thickness 2)) + (:one-of (list :indicator-type :one-of-many)) + (:some-of (list :indicator-type :n-of-many))))))) (defmethod gadget-value ((gadget motif-toggle-button)) (if (sheet-direct-mirror gadget) @@ -577,7 +613,8 @@ (declare (ignore invoke-callback)) (let ((m (sheet-direct-mirror gadget))) (when (and m (not (equal nv (tk::get-values m :set)))) - (tk::set-values m :set nv)))) + (let ((*dont-invoke-callbacks* t)) + (tk::set-values m :set nv))))) #+ignore (defmethod add-sheet-callbacks :after ((port motif-port) @@ -836,6 +873,7 @@ (value-key set-gadget-value-key) (test set-gadget-test) (mode list-pane-mode) + (visible-items silica::gadget-visible-items) (name-key set-gadget-name-key)) sheet (let ((selected-items (compute-list-pane-selected-items sheet value))) @@ -848,6 +886,7 @@ ,(ecase mode (:exclusive :single-select) (:nonexclusive :multiple-select)) + ,@(and visible-items `(:visible-item-count ,visible-items)) :items ,(mapcar name-key items) :item-count ,(length items)))))) @@ -885,9 +924,10 @@ (when (sheet-direct-mirror l) (let ((selected-items (compute-list-pane-selected-items l nv))) - (tk::set-values (sheet-direct-mirror l) - :selected-item-count (length selected-items) - :selected-items selected-items)))) + (let ((*dont-invoke-callbacks* t)) + (tk::set-values (sheet-direct-mirror l) + :selected-item-count (length selected-items) + :selected-items selected-items))))) ;;; Option buttons @@ -899,14 +939,24 @@ (sheet motif-option-pane)) (with-accessors ((items set-gadget-items) (name-key set-gadget-name-key) + (printer silica::option-pane-printer) (value-key set-gadget-value-key)) sheet (let ((pdm (make-instance 'xt::xm-pulldown-menu :managed nil :parent parent))) (setf (motif-option-menu-buttons sheet) (mapcar #'(lambda (item) - (let ((button - (make-instance 'tk::xm-push-button - :label-string (funcall name-key item) - :parent pdm))) + (let* ((name (funcall name-key item)) + (pixmap (unless (or (null printer) (eq printer #'write-token)) + (clim-internals::pixmap-from-menu-item + sheet name printer nil))) + (button + (if (null pixmap) + (make-instance 'tk::xm-push-button + :label-string name + :parent pdm) + (make-instance 'tk::xm-push-button + :label-pixmap pixmap + :label-type :pixmap + :parent pdm)))) (tk::add-callback button :activate-callback @@ -924,7 +974,8 @@ (defmethod (setf gadget-value) :after (nv (gadget motif-option-pane) &key invoke-callback) (declare (ignore invoke-callback)) - (set-option-menu-value gadget nv)) + (let ((*dont-invoke-callbacks* t)) + (set-option-menu-value gadget nv))) (defmethod realize-mirror :around ((port motif-port) (pane motif-option-pane)) (prog1 (call-next-method) @@ -934,14 +985,21 @@ (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) (let* ((x (position nv items :test test :key value-key)) (widget (sheet-direct-mirror gadget))) (when x (tk::set-values widget :menu-history (nth x (motif-option-menu-buttons gadget))) - (tk::set-values (tk::intern-widget (tk::xm_option_button_gadget widget)) - :label-string (funcall name-key (nth x items)))))))) + (let* ((name (funcall name-key (nth x items))) + (pixmap (unless (or (null printer) (eq printer #'write-token)) + (clim-internals::pixmap-from-menu-item + gadget name printer nil))) + (widget (tk::intern-widget (tk::xm_option_button_gadget widget)))) + (if pixmap + (tk::set-values widget :label-pixmap pixmap :label-type :pixmap) + (tk::set-values widget :label-string name)))))))) (defmethod frame-manager-notify-user ((framem motif-frame-manager) message-string @@ -1227,15 +1285,14 @@ (when m (tk::set-values m - :width width - :height (fix-coordinate (space-requirement-height csr)) :pane-minimum (fix-coordinate (space-requirement-min-height csr)) :pane-maximum (fix-coordinate (space-requirement-max-height csr))))))) (defmethod allocate-space ((fr motif-paned-pane) width height) (declare (ignore height)) (dolist (child (sheet-children fr)) - (tk::set-values (sheet-direct-mirror child) :width (fix-coordinate width)))) + (let ((m (sheet-direct-mirror child))) + (when m (tk::set-values m :width (fix-coordinate width)))))) ;; If one of these gadgets tries to change its size the drawing area ;; might very well let it. @@ -1283,7 +1340,8 @@ sheet-permanently-enabled-mixin layout-mixin pane) - ((attachments :initform nil :initarg :attachments))) + ((attachments :initform nil :initarg :attachments) + (fraction-base :initform nil :initarg :fraction-base))) (defmethod initialize-instance :after ((pane motif-form-pane) &key frame-manager frame @@ -1302,7 +1360,9 @@ (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet motif-form-pane)) - (values 'xt::xm-form nil)) + (with-slots (fraction-base) sheet + (values 'xt::xm-form + (and fraction-base (list :fraction-base fraction-base ))))) (defmethod (setf port) :around ((port motif-port) (sheet motif-form-pane) &key graft) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 4b3a729ac444cd13ac854ffb5298ea81ec4c5f9e..70002a05d809c2141ff46488ad69b84b6c532d4c 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.15 92/07/24 10:55:01 cer Exp Locker: cer $ +;; $fiHeader: xt-frames.lisp,v 1.16 92/08/21 16:34:32 cer Exp Locker: cer $ (in-package :xm-silica) @@ -66,13 +66,9 @@ ;;; (defun command-button-callback (button dunno frame command-table item) - (distribute-event - (port frame) - (allocate-event 'presentation-event - :frame frame - :sheet (frame-top-level-sheet frame) - :presentation-type `(command :command-table ,command-table) - :value (second item)))) + (execute-command-in-frame + frame (second item) + :presentation-type `(command :command-table ,command-table))) (defun frame-wm-protocol-callback (widget frame) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 985b26de2557eeb334c78d1f7d271f606e826845..c55c25ecff5338cc811f74f03483ff45fed8a04d 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.17 92/07/24 10:55:03 cer Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.18 92/08/18 17:26:38 cer Exp Locker: cer $ (in-package :xm-silica) @@ -100,8 +100,20 @@ (let ((pixel (decode-color medium ink))) (list :foreground pixel))) -(defclass xt-pane (pane) ()) +(defclass xt-pane (pane) + ;;--- Is this useful a hack enabling things to be passed through + ;;--- to the mirror + ((silica::mirror-initargs :initarg :mirror-initargs)) + (:default-initargs :mirror-initargs nil)) +(defmethod find-widget-class-and-initargs-for-sheet :around ((port xt-port) + (parent t) + (sheet xt-pane)) + (multiple-value-bind + (class initargs) + (call-next-method) + (values class (append (slot-value sheet 'silica::mirror-initargs) initargs)))) + (defmethod note-gadget-activated :after ((client t) (gadget xt-pane)) (let (m) (when (setq m (sheet-direct-mirror gadget)) @@ -121,6 +133,8 @@ xt-pane) ()) + + ;;--- This isn't really right. Genera and CLX ports have kludges ;;--- for the time being, too. (defmethod sheet-shell (sheet) @@ -151,8 +165,19 @@ (defun set-button-accelerator-from-keystroke (button keystroke) - ;;-- Somehow we have to convert the keystroke into some text and - ;;-- some character so that pressing it will have an effect (when keystroke - (tk::set-values button - :accelerator-text (princ-to-string keystroke)))) + (let ((accel (format nil "<Key>~A" (car keystroke))) + (accel-text (format nil "~A" (car keystroke)))) + (dolist (modifier (cdr keystroke)) + (setq accel-text + (concatenate 'string + (case modifier (:control "Ctrl+") (:meta "Alt+") (t "")) + accel-text)) + (setq accel + (concatenate 'string + (case modifier (:control "Ctrl") (:meta "Mod1") (t "")) + accel))) + (tk::set-values button + :accelerator accel + :accelerator-text accel-text)))) + diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index c3bb57fbc4ebbf0a2c077a6b9801627f26371bfc..2cad575aa2911f90311a781a77d410664f7c6448 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.34 92/08/18 17:54:32 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.35 92/08/19 10:24:25 cer Exp Locker: cer $ (in-package :tk-silica) @@ -173,6 +173,7 @@ (defparameter *use-color* t) ; For debugging monochrome (defun color-medium-p (medium) + ;;-- This should just look at this port (and *use-color* (let ((display (port-display (port (medium-sheet medium))))) (> (x11:xdefaultdepth display (tk::display-screen-number display)) 2)))) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index fdba30a16ccebac97905829235ff1cbed6956961..34bdf55c9d05ee2dd8d63f043d9019e805be16dd 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.40 92/08/18 17:26:44 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.41 92/08/18 17:54:34 cer Exp Locker: cer $ (in-package :xm-silica) @@ -626,7 +626,11 @@ (let ((frame (pane-frame sheet))) (when frame (setf (getf initargs :name) (string (frame-name frame))))) (apply #'make-instance class :parent (find-shell-parent port sheet) initargs)) - (sheet-mirror ma)))) + (sheet-mirror-for-parenting ma)))) + +(defmethod sheet-mirror-for-parenting ((sheet sheet)) + ;; There might be a situation where a sheet is mirrored by a whil + (sheet-mirror sheet)) (defmethod find-shell-of-calling-frame ((sheet sheet)) (find-shell-of-calling-frame (pane-frame sheet))) @@ -1208,13 +1212,16 @@ the geometry of the children. Instead the parent has control. ")) |# +(defvar *dont-invoke-callbacks* nil) + (defmethod queue-value-changed-event (widget sheet &optional (value (gadget-value sheet))) (declare (ignore widget)) - (distribute-event - (port sheet) - (allocate-event 'value-changed-gadget-event - :gadget sheet - :value value))) + (unless *dont-invoke-callbacks* + (distribute-event + (port sheet) + (allocate-event 'value-changed-gadget-event + :gadget sheet + :value value)))) (defmethod queue-drag-event (widget sheet &optional (value (gadget-value sheet))) @@ -1244,18 +1251,34 @@ the geometry of the children. Instead the parent has control. ")) silica::*ports*)) -(defmethod port-canonicalize-gesture-spec ((port xt-port) keysym &optional shifts) +;(defmethod port-canonicalize-gesture-spec ((port xt-port) keysym &optional shifts) +; (declare (optimize (speed 3) (safety 0))) +; ;; Here, we must take the gesture spec, turn it back into +; ;; a keycode, then see what the keysyms are for that keycode +; (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) +; (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) +; (keysym->xt-keysym keysym))) +; (x-keycode nil)) +; (unless x-keysym +; (return-from port-canonicalize-gesture-spec nil)) +; (cons keysym shifts))) + +(defmethod port-canonicalize-gesture-spec + ((port xt-port) gesture-spec &optional modifier-state) (declare (optimize (speed 3) (safety 0))) - ;; Here, we must take the gesture spec, turn it back into - ;; a keycode, then see what the keysyms are for that keycode - (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) - (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) - (keysym->xt-keysym keysym))) - (x-keycode nil)) - (unless x-keysym - (return-from port-canonicalize-gesture-spec nil)) - (cons keysym shifts))) - + (multiple-value-bind (keysym shifts) + (if modifier-state + (values gesture-spec modifier-state) + (parse-gesture-spec gesture-spec)) + ;; Here, we must take the gesture spec, turn it back into + ;; a keycode, then see what the keysyms are for that keycode + (let ((x-keysym (if (and (characterp keysym) (standard-char-p keysym)) + (keysym->xt-keysym (xt-keysym->keysym (char-code keysym))) + (keysym->xt-keysym keysym))) + (x-keycode nil)) + (unless x-keysym + (return-from port-canonicalize-gesture-spec nil)) + (cons keysym shifts)))) (defmethod port-set-pointer-position ((port xt-port) pointer x y) (let* ((sheet (pointer-sheet pointer)) diff --git a/tk/callbacks.lisp b/tk/callbacks.lisp index ad05a653df7fd0899ca81d98fb506f4e36fff50d..92576c8dc854fae102042ba7967dea6f754eefcb 100644 --- a/tk/callbacks.lisp +++ b/tk/callbacks.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: callbacks.lisp,v 1.15 92/06/16 15:01:05 cer Exp Locker: cer $ +;; $fiHeader: callbacks.lisp,v 1.16 92/06/23 08:19:06 cer Exp Locker: cer $ (in-package :tk) @@ -65,6 +65,27 @@ (list (new-callback-id) (cons function args) type) (widget-callback-data widget)))))) + +(defun-c-callable create-popup-child-proc-function ((widget :unsigned-long)) + (create-popup-child-proc-function-1 widget)) + +(defun create-popup-child-proc-function-1 (widget) + (let* ((widget (find-object-from-address widget)) + (function (or (cdr (assoc :create-popup-child-proc (widget-callback-data widget))) + (error "cannot find create-popup-childp-proc ~S" widget)))) + (funcall function widget))) + + +(defvar *create-popup-child-proc-function-address* + (ff:register-function 'create-popup-child-proc-function)) + +(defun (setf widget-create-popup-child-proc) (function widget) + (push + (cons :create-popup-child-proc function) + (widget-callback-data widget)) + (set-values widget :create-popup-child-proc *create-popup-child-proc-function-address*) + function) + (defun remove-all-callbacks (widget callback-name) (xt_remove_all_callbacks widget (convert-callback-name callback-name))) @@ -81,7 +102,7 @@ (defparameter *callback-name-alist* (mapcar #'process-callback-alist-component - '( + '( ("activateCallback" :activate) ("armCallback") ("disarmCallback") @@ -144,3 +165,5 @@ (values (x-drawing-area-callback-window call-data) (x-drawing-area-callback-event call-data))) + + diff --git a/tk/load-ol.lisp b/tk/load-ol.lisp index 5b9c796ff04e873279a6a18e44cc2b1ab9bc7be3..d4298fa49cae7544d3bde51830f8d536ecf40666 100644 --- a/tk/load-ol.lisp +++ b/tk/load-ol.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-ol.lisp,v 1.15 92/08/19 10:23:33 cer Exp $ +;; $fiHeader: load-ol.lisp,v 1.16 92/08/21 16:33:32 cer Exp Locker: cer $ (in-package :user) @@ -40,7 +40,7 @@ sys::*libx11-pathname*) :print t)) -(unless (ff:get-entry-point (ff:convert-to-lang "_XtAppIntervalNextTimer")) +(unless (ff:get-entry-point (ff:convert-to-lang "XtAppIntervalNextTimer")) (load "xtsupport.o" :system-libraries (list sys::*libxt-pathname* sys::*libx11-pathname*) diff --git a/tk/load-xm.lisp b/tk/load-xm.lisp index c6aaee3cd0ab820180ba7a8a1b12f0cfcb945358..38f5f3223cda52edb8db0f0c9a92a8419633a30d 100644 --- a/tk/load-xm.lisp +++ b/tk/load-xm.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: load-xm.lisp,v 1.18 92/08/18 17:53:36 cer Exp Locker: cer $ +;; $fiHeader: load-xm.lisp,v 1.19 92/08/19 10:23:34 cer Exp Locker: cer $ (in-package :user) @@ -41,7 +41,7 @@ sys::*libx11-pathname*) :print t)) -(unless (ff:get-entry-point (ff:convert-to-lang "_XtAppIntervalNextTimer")) +(unless (ff:get-entry-point (ff:convert-to-lang "XtAppIntervalNextTimer")) (load "xtsupport.o" :system-libraries (list sys::*libxt-pathname* sys::*libx11-pathname*) diff --git a/tk/resources.lisp b/tk/resources.lisp index dce12bb55bd632dc16ffd2755ac436965866a0d8..626f10c9aa14a9d7ecd2ca837cccb9c10d42ef94 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.28 92/07/08 16:28:50 cer Exp $ +;; $fiHeader: resources.lisp,v 1.29 92/08/18 17:53:44 cer Exp Locker: cer $ (in-package :tk) @@ -73,6 +73,13 @@ :column :none)) +(define-enumerated-resource row-column-type (:work-area + :menu-bar + :menu-pulldown + :menu-popup + :menu-option)) + + (define-enumerated-resource edit-mode (:multi-line :single-line)) (define-enumerated-resource visual-policy (:variable :constant)) @@ -597,4 +604,11 @@ (defmethod convert-resource-out ((parent t) (typep (eql 'pointer)) value) value) - + +;;; + +(defmethod convert-resource-out ((parent t) (typep (eql 'key-sym)) value) + (char-int value)) + +(defmethod convert-resource-in ((parent t) (typep (eql 'key-sym)) value) + (cltl1:int-char value)) diff --git a/tk/widget.lisp b/tk/widget.lisp index b2af6fca569614ddd7ee8e9c4162f466b6ff6f82..eb8a8a4676f94a4924524fcb6eb85316deb22c13 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.23 92/07/27 19:29:18 cer Exp $ +;; $fiHeader: widget.lisp,v 1.24 92/08/18 17:53:46 cer Exp Locker: cer $ (in-package :tk) @@ -240,12 +240,16 @@ (defun describe-widget (w) - (dolist (r (class-resources (class-of w))) - (format t "~S : ~S~%" - (resource-name r) - (handler-case - (get-values w (intern (resource-name r) :keyword)) - (error (c) c "Get-values failed!"))))) + (flet ((describe-resources (resources) + (dolist (r resources) + (format t "~S : ~S~%" + (resource-name r) + (handler-case + (get-values w (intern (resource-name r) :keyword)) + (error (c) c "Get-values failed!")))))) + (describe-resources (class-resources (class-of w))) + (when (tk::widget-parent w) + (describe-resources (class-constraint-resources (class-of (tk::widget-parent w))))))) (defun set-sensitive (widget value) (xt_set_sensitive widget (if value 1 0))) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index a49677343db5ce91c054e8a0ca1d51ab725e5a7c..46b9bd0c6c7c10f396a15070b836e7dd66698da4 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.23 92/07/24 10:53:40 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.24 92/08/18 17:53:48 cer Exp Locker: cer $ (in-package :tk) @@ -579,3 +579,14 @@ (values-list (cdr result))) (x11:xungrabserver .display.) (x11:xflush .display.)))) + +;;; Visuals + +(defun screen-root-visual-class (screen) + (ecase (x11::visual-class (x11::screen-root-visual screen)) + (0 :static-gray) + (2 :static-color) + (4 :true-color) + (1 :gray-scale) + (3 :pseudo-color) + (5 :direct-color))) diff --git a/tk/xm-widgets.lisp b/tk/xm-widgets.lisp index 32293900e040978e527a87c09af4f177fb83a0f4..1885080dde526a47dcfb3807c620bd2c883f9b9b 100644 --- a/tk/xm-widgets.lisp +++ b/tk/xm-widgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-widgets.lisp,v 1.7 92/07/27 19:29:20 cer Exp $ +;; $fiHeader: xm-widgets.lisp,v 1.8 92/08/18 17:53:51 cer Exp Locker: cer $ (in-package :tk) @@ -52,6 +52,14 @@ (string-to-char* "deleteResponse"))) +(tk::add-resource-to-class (find-class 'xm-text) + (make-instance 'resource + :name :font-list + :type 'font-list + :original-name + (string-to-char* + "fontList"))) + (tk::add-resource-to-class (find-class 'vendor-shell) (make-instance 'resource @@ -61,6 +69,14 @@ (string-to-char* "keyboardFocusPolicy"))) +(tk::add-resource-to-class (find-class 'xm-cascade-button-gadget) + (make-instance 'resource + :name :label-type + :type 'tk::label-type + :original-name + (string-to-char* + "labelType"))) + ;; Moved here as to be after loading xm-funs. diff --git a/utils/packages.lisp b/utils/packages.lisp index f7413a71f730d77addd370cd66dd9c015efbfd56..68606c88374a46abc89cdc0e14cb975dcf237759 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.24 92/07/27 11:01:52 cer Exp $ +;; $fiHeader: packages.lisp,v 1.25 92/08/18 17:24:11 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2287,13 +2287,21 @@ ;; Presentation types *input-context* *null-presentation* + +check-box-view+ +gadget-dialog-view+ +gadget-menu-view+ +gadget-view+ + +list-pane-view+ + +option-pane-view+ +pointer-documentation-view+ + +radio-box-view+ + +slider-view+ + +text-field-view+ + +text-editor-view+ +textual-dialog-view+ +textual-menu-view+ +textual-view+ + +toggle-button-view+ accept accept-from-string accept-1 @@ -2629,6 +2637,7 @@ interactor-pane layout-frame make-application-frame + make-command-timer note-command-disabled note-command-enabled note-frame-disabled @@ -2741,6 +2750,7 @@ check-box-current-selection check-box-pane check-box-selections + check-box-view deactivate-gadget disarmed-callback drag-callback @@ -2768,6 +2778,7 @@ labelled-gadget-mixin list-pane list-pane-mode + list-pane-view menu-bar menu-bar-command-table menu-button @@ -2775,6 +2786,7 @@ note-gadget-activated note-gadget-deactivated option-pane + option-pane-view oriented-gadget-mixin push-button push-button-pane @@ -2783,11 +2795,13 @@ radio-box-current-selection radio-box-pane radio-box-selections + radio-box-view scroll-bar scroll-bar-current-size scroll-bar-current-value scroll-bar-drag-callback scroll-bar-pane + separator set-gadget-items set-gadget-name-key set-gadget-test @@ -2795,13 +2809,17 @@ slider slider-decimal-places slider-pane + slider-view text-editor text-editor-pane + text-editor-view text-field text-field-pane + text-field-view toggle-button toggle-button-indicator-type toggle-button-pane + toggle-button-view value-changed-callback value-gadget with-output-as-gadget diff --git a/utils/processes.lisp b/utils/processes.lisp index 3fef3f56bce1ec8d65762558b7dbd8cd1df55c98..9b7d9bbd9a8e11e84259b2e3b6fa38ae9b921cf9 100644 --- a/utils/processes.lisp +++ b/utils/processes.lisp @@ -1,11 +1,13 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: processes.lisp,v 1.7 92/07/24 10:54:08 cer Exp $ +;; $fiHeader: processes.lisp,v 1.8 92/08/18 17:24:14 cer Exp Locker: cer $ (in-package :clim-utils) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. - Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." + Portions copyright (c) 1988, 1989, 1990 International Lisp Associates. + Portions copyright (c) 1992, Franz Inc" + ;;; Locks @@ -312,3 +314,4 @@ 'process-interrupt process closure)) } ) +