diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index bdb1d52889574e5e334d62c7f7bc0c1c07e87208..7bfaf9895f20d1b78969123c76f6034ffd603340 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.39 92/10/28 08:19:20 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.40 92/10/28 11:31:22 cer Exp $ (in-package :clim-internals) @@ -98,13 +98,31 @@ (call-next-method)) query-identifier) -(defmethod stream-accept ((stream accept-values-stream) ptype - &key query-identifier (prompt t) (default nil default-supplied-p) +(defmethod stream-accept ((stream accept-values-stream) type + &rest accept-args + &key (prompt t) (default nil default-supplied-p) (view (stream-default-view stream)) (active-p t) &allow-other-keys) + (declare (dynamic-extent accept-args)) ;;--- When ACTIVE-P is NIL, this should do some sort of "graying out" - (let ((query (find-or-add-query stream query-identifier ptype prompt - default default-supplied-p view active-p))) + (let ((align-prompts (slot-value (slot-value stream 'avv-frame) 'align-prompts)) + query-identifier query) + (cond (align-prompts + ;; The user has asked to line up the labels, so oblige him + (formatting-row (stream) + (formatting-cell (stream :align-x align-prompts) + (setq query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) type view accept-args))) + (formatting-cell (stream :align-x :left) + (setq query (find-or-add-query stream query-identifier type prompt + default default-supplied-p view active-p))))) + (t + (setq query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) type view accept-args)) + (setq query (find-or-add-query stream query-identifier type prompt + default default-supplied-p view active-p)))) (values (accept-values-query-value query) (accept-values-query-type query) ;; Set this to NIL so that it appears that nothing has @@ -188,41 +206,29 @@ :initform nil :initarg :initially-select-query-identifier) (resynchronize-every-pass :initform nil :initarg :resynchronize-every-pass) (check-overlapping :initform t :initarg :check-overlapping) - (own-window :initform nil :initarg :own-window)) + (align-prompts :initform nil :initarg :align-prompts) + (own-window :initform nil :initarg :own-window) + (own-window-properties :initform nil :initarg :own-window-properties)) (:top-level (accept-values-top-level)) (:command-definer t)) -;; Ignore extra initargs... -(defmethod initialize-instance :after ((frame accept-values) - &key own-window - x-position y-position width height - right-margin bottom-margin) - (declare (ignore own-window - x-position y-position width height - right-margin bottom-margin))) - ;;--- These frames should be resourced (define-application-frame accept-values-own-window (accept-values) - ((own-window :initarg :own-window) - (own-window-x-position :initform nil :initarg :x-position) - (own-window-y-position :initform nil :initarg :y-position) - (own-window-width :initform nil :initarg :width) - (own-window-height :initform nil :initarg :height) - (own-window-right-margin :initform nil :initarg :right-margin) - (own-window-bottom-margin :initform nil :initarg :bottom-margin) - (help-window :initform nil)) + ((help-window :initform nil) + (scroll-bars :initform nil :initarg :scroll-bars)) (:pane - (with-slots (stream own-window exit-button-stream) *application-frame* + (with-slots (stream own-window exit-button-stream scroll-bars) *application-frame* (vertically () (outlining () - (scrolling (:scroll-bars :dynamic) - (progn - (setq stream - (make-instance 'accept-values-stream - :stream (setf own-window - (make-pane 'clim-stream-pane - :initial-cursor-visibility :off)))) - own-window))) + (progn + (setq stream (make-instance 'accept-values-stream + :stream (setq own-window + (make-pane 'clim-stream-pane + :initial-cursor-visibility :off + :end-of-page-action :allow)))) + (if scroll-bars + (scrolling (:scroll-bars scroll-bars) own-window) + own-window))) (outlining () (setf exit-button-stream (make-pane 'clim-stream-pane @@ -252,17 +258,22 @@ (exit-boxes (frame-manager-default-exit-boxes (frame-manager stream))) - (resize-frame nil) + (resize-frame nil) (scroll-bars nil) (initially-select-query-identifier nil) - (modify-initial-query nil) + (modify-initial-query nil) align-prompts (resynchronize-every-pass nil) (check-overlapping t) label x-position y-position width height) (incf *accept-values-tick*) + (setq align-prompts (ecase align-prompts + ((t :right) :right) + ((:left) :left) + ((nil) nil))) (let ((frame-manager (frame-manager stream)) (*current-accept-values-tick* *accept-values-tick*) (the-own-window nil) (right-margin 10) (bottom-margin 10)) + ;; Create the AVV, run it, and return its values (if own-window (let ((frame (make-application-frame (or frame-class @@ -274,59 +285,70 @@ :continuation continuation :exit-boxes exit-boxes :own-window the-own-window - :width width :height height - :x-position x-position - :y-position y-position - :right-margin right-margin - :bottom-margin bottom-margin - :initially-select-query-identifier - (and initially-select-query-identifier - (cons initially-select-query-identifier modify-initial-query)) - :resynchronize-every-pass resynchronize-every-pass - :check-overlapping check-overlapping - :resize-frame resize-frame))) - (when command-table - (setf (frame-command-table frame) command-table)) - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame))) - (using-resource (avv-stream accept-values-stream (or the-own-window stream)) - ;;--- This should resource the AVV application frame, too - (let ((frame (make-application-frame (or frame-class 'accept-values) - :calling-frame *application-frame* - :stream avv-stream - :continuation continuation - :exit-boxes exit-boxes + :own-window-properties (list x-position y-position + width height + right-margin bottom-margin) :initially-select-query-identifier (and initially-select-query-identifier (cons initially-select-query-identifier modify-initial-query)) :resynchronize-every-pass resynchronize-every-pass :check-overlapping check-overlapping - ;; This frame won't necessarily be adopted, so make - ;; sure that we share the sheet with the parent frame - ;; in the case of "inlined" dialogs - :top-level-sheet (frame-top-level-sheet *application-frame*)))) + :align-prompts align-prompts + :resize-frame resize-frame + :scroll-bars scroll-bars))) (when command-table (setf (frame-command-table frame) command-table)) - ;; Run the AVV and return its values - (let ((*avv-calling-frame* *application-frame*)) - (run-frame-top-level frame))))))) + (unwind-protect + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame)) + ;; Flush it so the GC can get rid of it + (disown-frame (frame-manager frame) frame))) + (using-resource (avv-stream accept-values-stream (or the-own-window stream)) + (let ((frame (make-application-frame (or frame-class 'accept-values) + :calling-frame *application-frame* + :stream avv-stream + :continuation continuation + :exit-boxes exit-boxes + :initially-select-query-identifier + (and initially-select-query-identifier + (cons initially-select-query-identifier modify-initial-query)) + :resynchronize-every-pass resynchronize-every-pass + :check-overlapping check-overlapping + :align-prompts align-prompts + ;; This frame won't necessarily be adopted, so make + ;; sure that we share the sheet with the parent frame + ;; in the case of "inlined" dialogs + :top-level-sheet (frame-top-level-sheet *application-frame*)))) + (when command-table + (setf (frame-command-table frame) command-table)) + (unwind-protect + (let ((*avv-calling-frame* *application-frame*)) + (run-frame-top-level frame)) + ;; Since this frame isn't really adopted, we don't really want + ;; to disown it since that will end up disowning the calling + ;; frame. Flush it from the frame manager manually. Barf. + (let ((framem (frame-manager frame))) + (setf (frame-manager-frames framem) + (delete frame (frame-manager-frames framem)) + (slot-value frame 'frame-manager) nil)))))))) (defmethod accept-values-top-level ((frame accept-values) &rest args) (declare (ignore args)) - ;; this might want to use table-formatting or equivalent - ;; to make sure that the rows line up properly. - ;; This requires formatting-table and friends to return their bodies' values properly. (with-slots (stream continuation resynchronize-every-pass check-overlapping - selected-item initially-select-query-identifier - own-window own-window-x-position own-window-y-position - own-window-width own-window-height - own-window-right-margin own-window-bottom-margin - exit-button-stream) frame + align-prompts selected-item initially-select-query-identifier + own-window own-window-properties exit-button-stream) frame (let* ((original-view (stream-default-view stream)) (return-values nil) (initial-query nil) exit-button-record - avv avv-record) + avv avv-record + (properties own-window-properties) + (own-window-x-position (pop properties)) + (own-window-y-position (pop properties)) + (own-window-width (pop properties)) + (own-window-height (pop properties)) + (own-window-right-margin (pop properties)) + (own-window-bottom-margin (pop properties))) (letf-globally (((stream-default-view stream) (frame-manager-dialog-view (frame-manager frame))) ((cursor-state (stream-text-cursor stream)) nil)) @@ -334,9 +356,19 @@ (setf (slot-value stream 'avv-record) avv-record) (setf (slot-value stream 'avv-frame) frame) (with-output-recording-options (stream :draw nil :record t) - (setq return-values (multiple-value-list - (let ((*application-frame* *avv-calling-frame*)) - (funcall continuation stream)))) + (let ((*application-frame* *avv-calling-frame*)) + (if align-prompts + ;; Use of FORMATTING-TABLE here implies that + ;; no output should be done by the user code + ;; outside of calls to FORMATTING-ROW and + ;; FORMATTING-CELL. Too bad. + (formatting-table (stream) + (setq return-values + (multiple-value-list + (funcall continuation stream)))) + (setq return-values + (multiple-value-list + (funcall continuation stream))))) (unless own-window (display-exit-boxes frame stream (stream-default-view stream))))) @@ -404,7 +436,12 @@ :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") + (handler-bind ((frame-exit + #'(lambda (condition) + (let ((exit-frame (frame-exit-frame condition))) + (when (eq frame exit-frame) + (return-from accept-values-top-level + (values-list return-values))))))) (setq avv (updating-output (stream) (setq avv-record @@ -432,7 +469,7 @@ y own-window-y-position)) (position-sheet-carefully (frame-top-level-sheet (pane-frame own-window)) x y)) - (window-expose own-window) + (setf (window-visibility own-window) t) (with-input-focus (own-window) (when exit-button-record (replay exit-button-record exit-button-stream)) @@ -446,11 +483,10 @@ (stream-ensure-cursor-visible stream) (replay avv stream) (run-avv))) - (unless own-window (deactivate-all-gadgets avv-record)) (unless own-window + (deactivate-all-gadgets avv-record) (move-cursor-beyond-output-record - (encapsulating-stream-stream stream) avv)))) - (values-list return-values)))))) + (encapsulating-stream-stream stream) avv))))))))) (defmethod frame-manager-display-input-editor-error ((framem standard-frame-manager) (frame accept-values) stream error) @@ -489,7 +525,7 @@ (multiple-value-bind (x y) (bounding-rectangle-position own-window) (position-sheet-carefully (frame-top-level-sheet (pane-frame help-window)) x y)) - (window-expose help-window) + (setf (window-visibility help-window) t) (clear-input help-window) (unwind-protect (with-input-focus (help-window) @@ -515,9 +551,17 @@ (setf (slot-value (slot-value stream 'avv-record) 'resynchronize) t)) (defmethod accept-values-resize-window ((stream accept-values-stream)) - (with-slots (own-window own-window-right-margin own-window-bottom-margin) + (with-slots (own-window own-window-properties) (slot-value stream 'avv-frame) (when own-window + (let* ((own-window-x-position (pop own-window-properties)) + (own-window-y-position (pop own-window-properties)) + (own-window-width (pop own-window-properties)) + (own-window-height (pop own-window-properties)) + (own-window-right-margin (pop own-window-properties)) + (own-window-bottom-margin (pop own-window-properties))) + (declare (ignore own-window-x-position own-window-y-position + own-window-width own-window-height)) (multiple-value-bind (new-width new-height) (bounding-rectangle-size (slot-value stream 'avv-record)) (multiple-value-bind (width height) @@ -525,8 +569,8 @@ (when (or (> new-width width) (> new-height height)) (size-frame-from-contents own-window - :right-margin own-window-right-margin - :bottom-margin own-window-bottom-margin))))))) + :right-margin own-window-right-margin + :bottom-margin own-window-bottom-margin)))))))) (define-presentation-type accept-values-exit-box ()) @@ -738,7 +782,7 @@ (define-accept-values-command (com-exit-avv :keystroke :end) () - (invoke-restart 'frame-exit)) + (frame-exit *application-frame*)) (define-accept-values-command (com-abort-avv :keystroke :abort) () diff --git a/clim/accept.lisp b/clim/accept.lisp index fc9eef9fb671fb53bab989c2459c04d66a5d9551..7b36f4f8dd13a3e4d3a3054cf866d283ce28c950 100644 --- a/clim/accept.lisp +++ b/clim/accept.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept.lisp,v 1.15 92/10/28 08:19:24 cer Exp Locker: cer $ +;; $fiHeader: accept.lisp,v 1.16 92/10/28 11:31:25 cer Exp $ (in-package :clim-internals) @@ -57,7 +57,7 @@ ;; If the user wants a default, but provided none, go get it from the history (let ((history (if (typep history 'basic-history) history - (presentation-type-history history)))) + (presentation-type-history history)))) (when history (let ((element (yank-from-history history))) (when element @@ -80,20 +80,27 @@ (null) (symbol (setq view (make-instance view))) (cons (setq view (apply #'make-instance view)))) - (setq view (decode-indirect-view type view (frame-manager stream) :query-identifier query-identifier)) + (setq view (decode-indirect-view type view (frame-manager stream) + :query-identifier query-identifier)) - ;; Call methods to do the work + ;; Call STREAM-ACCEPT to do the work. It would be nice if we could + ;; call PROMPT-FOR-ACCEPT to generate the real query-id here, but we + ;; can't because we want to be able to decide exactly how it is called + ;; on a case-by-case basis. For example, within ACCEPTING-VALUES... (with-keywords-removed (accept-args accept-args '(:stream :view)) - (let ((query-identifier - (apply #'prompt-for-accept - (or *original-stream* stream) type view accept-args))) - (apply #'stream-accept (or *original-stream* stream) type - :view view :query-identifier query-identifier - accept-args)))) + (apply #'stream-accept (encapsulated-stream stream) type + :view view :query-identifier query-identifier + accept-args))) -(defmethod stream-accept ((stream input-protocol-mixin) type &rest accept-args) +(defmethod stream-accept ((stream input-protocol-mixin) type &rest accept-args + &key view &allow-other-keys) (declare (dynamic-extent accept-args)) - (apply #'accept-1 (or *original-stream* stream) type accept-args)) + (let ((query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) type view accept-args))) + (apply #'accept-1 (encapsulated-stream stream) type + :query-identifier query-identifier + accept-args))) (defmethod prompt-for-accept ((stream input-protocol-mixin) type (view view) &rest accept-args @@ -373,9 +380,15 @@ (check-type gesture character) (stream-unread-char stream gesture))) -(defmethod stream-accept ((stream t) type &rest accept-args) +(defmethod stream-accept ((stream t) type &rest accept-args + &key view &allow-other-keys) (declare (dynamic-extent accept-args)) - (apply #'accept-1 (or *original-stream* stream) type accept-args)) + (let ((query-identifier + (apply #'prompt-for-accept + (encapsulated-stream stream) type view accept-args))) + (apply #'accept-1 (encapsulated-stream stream) type + :query-identifier query-identifier + accept-args))) (defmethod prompt-for-accept ((stream t) type (view view) &key query-identifier &allow-other-keys) diff --git a/clim/activities.lisp b/clim/activities.lisp index af8c8aede4ee706654d06c13a25423b6138f42fb..b6b36cf11d1164c8f5fafe87a209d3e1a2462046 100644 --- a/clim/activities.lisp +++ b/clim/activities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: activities.lisp,v 1.3 92/10/02 15:19:17 cer Exp Locker: cer $ +;; $fiHeader: activities.lisp,v 1.4 92/10/29 15:02:39 cer Exp $ (in-package :clim-internals) @@ -32,7 +32,11 @@ (type-of activity)) (defmethod run-frame-top-level :around ((activity activity) &key) - (with-simple-restart (activity-exit "Exit activity ~A" (frame-pretty-name activity)) + (handler-bind ((frame-exit + #'(lambda (condition) + (let ((exit-frame (frame-exit-frame condition))) + (when (eq activity exit-frame) + (return-from run-frame-top-level nil)))))) (loop (with-simple-restart (nil "~A top level" (frame-pretty-name activity)) (loop @@ -54,8 +58,8 @@ (default-frame-top-level activity)) (setq top-level-process nil)))) -(defmethod activity-exit ((activity activity)) - (invoke-restart 'activity-exit)) +(defmethod frame-exit ((activity activity)) + (signal 'frame-exit :frame activity)) (defvar *activity* nil) @@ -95,7 +99,7 @@ (setf (activity-active-frame activity) (first (frame-manager-frames activity)))) (unless (activity-active-frame activity) - (activity-exit activity)) + (frame-exit activity)) (let* ((frame (activity-active-frame activity)) (*application-frame* frame) (top-level (frame-top-level frame))) @@ -108,6 +112,7 @@ (if (atom top-level) (funcall top-level frame) (apply (first top-level) frame (rest top-level)))) + ;;--- Well, what *are* we supposed to do here? (break "do something"))) (setf (slot-value frame 'top-level-process) nil))))))))) @@ -125,7 +130,7 @@ ((activity :initform nil :accessor frame-activity :initarg :activity))) (defmethod initialize-instance :after ((frame activity-frame) &key activity) - (assert activity () "An activity frame requires an activity")) + (assert activity () "The activity frame ~S requires an activity" frame)) ;; Starts an application frame and registers it in the activity (defmethod start-application-frame ((activity activity) frame-name &rest frame-options) @@ -150,7 +155,7 @@ (when (eq frame (activity-active-frame activity)) (if (frame-manager-frames activity) (setf (activity-active-frame activity) nil) - (activity-exit activity))) + (frame-exit activity))) (throw 'window-resynchronize :window-resynchronize)) ;; Starts the initial application, when the activity is started up. diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index 131b127226795719f43d18c1823ff03fc8fdd061..2680d4bf129943637fa894de3934a6fcc9624046 100644 --- a/clim/basic-translators.lisp +++ b/clim/basic-translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: basic-translators.lisp,v 1.8 92/08/19 10:23:53 cer Exp Locker: cer $ +;; $fiHeader: basic-translators.lisp,v 1.9 92/10/01 08:51:17 cer Exp $ (in-package :clim-internals) @@ -180,8 +180,7 @@ (formatting-cell (stream) (print-possibility possibility stream))))))) (declare (dynamic-extent #'print-possibility #'menu-choose-body)) - (with-menu (menu window) - (setf (window-label menu) "Menu of completions") + (with-menu (menu window :label "Menu of completions") (with-end-of-line-action (menu :allow) (let ((object (menu-choose-from-drawer menu type #'menu-choose-body))) diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index efed771c6e6802944508f7f0ff55cb90c018c033..b941ba6f078d6146ce0ff7f223a35a05ac0b12b1 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-defs.lisp,v 1.14 92/09/08 15:17:27 cer Exp $ +;; $fiHeader: clim-defs.lisp,v 1.15 92/09/24 09:38:28 cer Exp $ (in-package :clim-internals) @@ -91,10 +91,10 @@ `(,constructor ,@initargs)) (t `(construct-output-record-1 ,type ,@initargs))))) -(defmacro define-output-record-constructor (record-type arglist &rest initialization-arguments) +(defmacro define-output-record-constructor (record-type arglist &body initargs) (let ((constructor-name (fintern "~A-~A" record-type 'constructor))) `(progn - (define-constructor ,constructor-name ,record-type ,arglist ,@initialization-arguments) + (define-constructor ,constructor-name ,record-type ,arglist ,@initargs) (setf (gethash ',record-type *output-record-constructor-cache*) ',constructor-name)))) ) ;eval-when @@ -272,12 +272,13 @@ ;;; From MENUS.LISP ;;; For now, MENU-CHOOSE requires that you pass in a parent. -(defmacro with-menu ((menu &optional (associated-window nil aw-p)) &body body) +(defmacro with-menu ((menu &optional (associated-window nil aw-p) &key label) &body body) (let ((window '#:associated-window)) `(let ((,window ,(if aw-p associated-window `(frame-top-level-sheet *application-frame*)))) ;once-only - (using-resource (,menu menu (window-top-level-window ,window) (window-root ,window)) + (using-resource (,menu menu (window-top-level-window ,window) (window-root ,window) + :label ,label) (letf-globally (((stream-default-view ,menu) +textual-menu-view+)) ,@body))))) @@ -285,10 +286,10 @@ (defmacro accepting-values ((&optional stream &rest args) &body body) (declare (arglist (&optional stream &key frame-class command-table own-window - exit-boxes resize-frame + exit-boxes resize-frame align-prompts initially-select-query-identifier modify-initial-query resynchronize-every-pass (check-overlapping t) - label x-position y-position width height) + label x-position y-position width height (scroll-bars nil)) &body body)) #+Genera (declare (zwei:indentation 0 3 1 1)) (default-input-stream stream accepting-values) diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index c85da37a02143473ac86055b62be7edec7e5ea22..28988e5f863c2200f67e8b6127065ed52baa96bc 100644 --- a/clim/command-processor.lisp +++ b/clim/command-processor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command-processor.lisp,v 1.16 92/09/30 18:03:38 cer Exp $ +;; $fiHeader: command-processor.lisp,v 1.17 92/10/28 11:31:26 cer Exp $ (in-package :clim-internals) @@ -310,9 +310,12 @@ :end last-supplied :from-end t))) (command-type `(command :command-table ,command-table)) (for-context-type (least-specific-matching-context-type command-type))) - (cond ((or unsupplied-before-that for-accelerator) + (cond ((or unsupplied-before-that for-accelerator + (null (command-line-name-for-command + (command-name partial-command) command-table :errorp nil))) ;; If the unsupplied argument is not the last argument in the ;; command line, we go through the ACCEPTING-VALUES command parser. + ;; Ditto, if there is no command-line name for the command. (let ((command (with-input-editor-typeout (stream) (accept-values-command-parser diff --git a/clim/command.lisp b/clim/command.lisp index a48df96558b9b5ec89b56669868eb10ea2aa1457..da87bbd70baeb1c30b6a73ff729849c8ca983b9b 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.16 92/09/08 15:17:31 cer Exp $ +;; $fiHeader: command.lisp,v 1.17 92/09/24 09:38:32 cer Exp $ (in-package :clim-internals) @@ -575,7 +575,7 @@ n-rows n-columns x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) - (initial-spacing t) move-cursor) + (initial-spacing t) (row-wise nil) move-cursor) (unless (or max-width max-height) (multiple-value-bind (width height) (bounding-rectangle-size (sheet-region stream)) @@ -589,7 +589,7 @@ :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing :initial-spacing initial-spacing - :move-cursor move-cursor) + :row-wise row-wise :move-cursor move-cursor) (dovector (element menu) (cond ((eq (command-menu-item-type (third element)) :divider) (typecase (first element) @@ -623,15 +623,14 @@ (defun menu-execute-command-from-command-table (command-table &key (associated-window (frame-top-level-sheet *application-frame*)) - (default-style *command-table-menu-text-style*) label + (text-style *command-table-menu-text-style*) label cache (unique-id command-table) (id-test #'eql) cache-value (cache-test #'eql)) (setq command-table (find-command-table command-table)) (unless cache-value (setq cache-value (slot-value command-table 'menu-tick))) (let ((menu-items (slot-value command-table 'menu))) - (with-menu (menu associated-window) - (setf (window-label menu) label) - (with-text-style (menu default-style) + (with-menu (menu associated-window :label label) + (with-text-style (menu text-style) (flet ((menu-choose-body (stream type) (declare (ignore type)) (menu-choose-command-drawer stream menu-items nil))) @@ -647,15 +646,14 @@ (defun menu-choose-command-from-command-table (command-table &key (associated-window (frame-top-level-sheet *application-frame*)) - (default-style *command-table-menu-text-style*) label + (text-style *command-table-menu-text-style*) label cache (unique-id command-table) (id-test #'eql) cache-value (cache-test #'eql)) (setq command-table (find-command-table command-table)) (unless cache-value (setq cache-value (slot-value command-table 'menu-tick))) (let ((menu-items (slot-value command-table 'menu))) - (with-menu (menu associated-window) - (setf (window-label menu) label) - (with-text-style (menu default-style) + (with-menu (menu associated-window :label label) + (with-text-style (menu text-style) (flet ((menu-choose-body (stream type) (menu-choose-command-drawer stream menu-items type))) (declare (dynamic-extent #'menu-choose-body)) diff --git a/clim/db-menu.lisp b/clim/db-menu.lisp index 8950a3870419f06048dbd1828859f540c9e26a6b..f0342dac22f1f27048fc800bbd96b514e76aac57 100644 --- a/clim/db-menu.lisp +++ b/clim/db-menu.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-menu.lisp,v 1.2 92/09/08 15:17:38 cer Exp $ +;; $fiHeader: db-menu.lisp,v 1.3 92/09/24 09:38:38 cer Exp $ "Copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -274,8 +274,7 @@ ;;; Menu bars -(defclass menu-bar-pane - (menu-bar) +(defclass menu-bar-pane (menu-bar) ()) ;;--- What about when the command menu tick changes? diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 3f166ae7241082c657233983a39d3ad5f7b0b396..495bdcf96d09f8a075152682e0fcba77b4239a59 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.33 92/10/02 15:19:19 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.34 92/10/28 11:31:30 cer Exp $ (in-package :clim-internals) @@ -339,8 +339,9 @@ `(make-pane 'label-pane :label ,label :max-width +fill+) - `(apply #'make-pane 'label-pane - :max-width +fill+ ,label)))) + `(make-pane 'label-pane + :label ,(first label) + :max-width +fill+ ,@(rest label))))) (ecase label-alignment (:bottom (setq pane `(vertically () ,pane ,label))) @@ -360,6 +361,9 @@ ;;; "Window protocol" +(defun-inline window-stream-p (x) + (typep x 'clim-stream-sheet)) + (defmethod window-clear ((stream clim-stream-sheet)) (let ((medium (sheet-medium stream))) (letf-globally (((medium-transformation medium) +identity-transformation+)) @@ -434,6 +438,33 @@ (defmethod* (setf window-viewport-position) (x y (stream clim-stream-sheet)) (window-set-viewport-position stream x y)) +(defmethod window-inside-edges ((stream clim-stream-sheet)) + (bounding-rectangle* (sheet-region (or (pane-viewport stream) stream)))) + +(defun window-inside-left (stream) + (multiple-value-bind (left top right bottom) + (window-inside-edges stream) + (declare (ignore top right bottom)) + left)) + +(defun window-inside-top (stream) + (multiple-value-bind (left top right bottom) + (window-inside-edges stream) + (declare (ignore left right bottom)) + top)) + +(defun window-inside-right (stream) + (multiple-value-bind (left top right bottom) + (window-inside-edges stream) + (declare (ignore left top bottom)) + right)) + +(defun window-inside-bottom (stream) + (multiple-value-bind (left top right bottom) + (window-inside-edges stream) + (declare (ignore left top right)) + bottom)) + (defmethod window-inside-size ((stream clim-stream-sheet)) (bounding-rectangle-size (window-viewport stream))) @@ -446,15 +477,28 @@ (defmethod window-inside-height ((stream clim-stream-sheet)) (bounding-rectangle-width (window-viewport stream))) +(defmethod window-margins ((stream clim-stream-sheet)) + (values (coordinate 0) (coordinate 0) + (coordinate 0) (coordinate 0))) + (defun-inline window-parent (window) (sheet-parent window)) +(defun-inline window-children (window) + (sheet-children window)) + (defun window-root (window) (graft window)) (defun-inline window-top-level-window (window) (sheet-top-level-sheet window)) +(defmethod window-stack-on-bottom ((stream clim-stream-sheet)) + (bury-sheet (window-top-level-window stream))) + +(defmethod window-stack-on-top ((stream clim-stream-sheet)) + (raise-sheet (window-top-level-window stream))) + (defun beep (&optional (stream *standard-output*)) (typecase stream (sheet diff --git a/clim/db-text.lisp b/clim/db-text.lisp index b28d063a18d8aaf644b7507ee4d8fea335c548fe..826c4ad67248268bb5805a284d67116cebaaf3ba 100644 --- a/clim/db-text.lisp +++ b/clim/db-text.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-text.lisp,v 1.3 92/10/02 15:19:21 cer Exp $ +;; $fiHeader: db-text.lisp,v 1.4 92/10/28 11:31:32 cer Exp $ "Copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -20,7 +20,7 @@ (height (process-spacing-arg stream height 'pop-up-text-editor :height))) (window-set-inside-size stream width height)) (setf (stream-text-margin stream) (bounding-rectangle-width (window-viewport stream))) - (window-expose stream) + (setf (window-visibility stream) t) ;; Now edit the text (unwind-protect (do-text-editing stream diff --git a/clim/drag-and-drop.lisp b/clim/drag-and-drop.lisp index 647bc5749e35974e32a17e6c5f09fb626cd4f2b2..42aeebeb96fdb48042fe559aa8683738ec5e0a11 100644 --- a/clim/drag-and-drop.lisp +++ b/clim/drag-and-drop.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: drag-and-drop.lisp,v 1.4 92/07/08 16:30:06 cer Exp Locker: cer $ +;; $fiHeader: drag-and-drop.lisp,v 1.5 92/11/05 17:15:35 cer Exp $ (in-package :clim-internals) @@ -108,13 +108,17 @@ ,@body) function-name)))) +(defparameter *drag-and-drop-finish-on-release* nil) + ;; All the drag-and-drop translators that satisfy the current from-type, ;; to-type, and gesture will get here. However, the translator now being ;; run is not necessarily the right one. What we do here is to track the ;; pointer until the destination presentation has been reached, choose the ;; correct translator and run it. (defun invoke-drag-and-drop-translator (object presentation context-type - frame event window x y) + frame event window x y + &optional (finish-on-release + *drag-and-drop-finish-on-release*)) (let* ((command-table (frame-command-table frame)) (translators (let ((all-translators @@ -141,7 +145,9 @@ (and translators (presentation-translator-highlighting (first translators)))) (initial-x x) (initial-y y) - last-x last-y + (last-x nil) + (last-y nil) + (last-window nil) (from-presentation presentation) ;; The presentation we finally landed on, and the event used (destination nil) @@ -154,9 +160,9 @@ (unhighlight-highlighted-presentation window) (when (null translators) (return-from invoke-drag-and-drop-translator nil)) - (flet ((find-translator (destination) + (flet ((find-translator (destination-presentation window x y) (let* ((translator - (find (presentation-type destination) translators + (find (presentation-type destination-presentation) translators :key #'presentation-translator-destination-type :test #'presentation-subtypep)) (tester @@ -165,41 +171,68 @@ (funcall tester object presentation context-type frame event window x y - (presentation-object destination) destination)) + (presentation-object destination-presentation) + destination-presentation)) translator)))) (declare (dynamic-extent #'find-translator)) - (macrolet ((feedback (x y state) - `(funcall feedback frame from-presentation window + (macrolet ((feedback (window x y state) + `(funcall feedback frame from-presentation ,window initial-x initial-y ,x ,y ,state)) - (highlight (presentation state) + (highlight (presentation window state) `(when ,presentation - (funcall highlighting frame ,presentation window - ,state)))) + (funcall highlighting frame ,presentation ,window ,state)))) (block drag-presentation (tracking-pointer (window :context-type `((or ,@destination-types)) :multiple-window t :highlight nil) (:presentation-button-press (presentation event) - (highlight destination :unhighlight) - (setq destination presentation - destination-event event) - (return-from drag-presentation)) + (unless finish-on-release + (highlight destination last-window :unhighlight) + (setq destination presentation + destination-event event + last-window (event-sheet event) + last-x (pointer-event-x event) + last-y (pointer-event-y event)) + (return-from drag-presentation))) (:pointer-button-press (event) - (highlight destination :unhighlight) - (setq destination nil - destination-event event) - (return-from drag-presentation)) + (unless finish-on-release + (highlight destination last-window :unhighlight) + (setq destination nil + destination-event event + last-window (event-sheet event) + last-x (pointer-event-x event) + last-y (pointer-event-y event)) + (return-from drag-presentation))) + (:presentation-button-release (presentation event) + (when finish-on-release + (highlight destination last-window :unhighlight) + (setq destination presentation + destination-event event + last-window (event-sheet event) + last-x (pointer-event-x event) + last-y (pointer-event-y event)) + (return-from drag-presentation))) + (:pointer-button-release (event) + (when finish-on-release + (highlight destination last-window :unhighlight) + (setq destination nil + destination-event event + last-window (event-sheet event) + last-x (pointer-event-x event) + last-y (pointer-event-y event)) + (return-from drag-presentation))) (:presentation (presentation window x y) (when last-x - (feedback last-x last-y :unhighlight)) + (feedback last-window last-x last-y :unhighlight)) (setq last-x x - last-y y) - (feedback x y :highlight) + last-y y + last-window window) + (feedback window x y :highlight) (when (not (eq presentation destination)) - (highlight destination :unhighlight) + (highlight destination last-window :unhighlight) (setq destination presentation) - (highlight presentation :highlight) + (highlight presentation window :highlight) #+++ignore ;--- documentation - (let ((translator (find-translator destination))) + (let ((translator (find-translator destination window x y))) (when translator (let ((documentation (presentation-translator-real-documentation translator))) @@ -211,23 +244,24 @@ (presentation-object destination) destination doc-stream))))))) (:pointer-motion (window x y) - (highlight destination :unhighlight) + (highlight destination last-window :unhighlight) (setq destination nil) (when last-x - (feedback last-x last-y :unhighlight)) + (feedback last-window last-x last-y :unhighlight)) (setq last-x x - last-y y) - (feedback x y :highlight)))) + last-y y + last-window window) + (feedback window x y :highlight)))) (when last-x - (feedback last-x last-y :unhighlight))) + (feedback last-window last-x last-y :unhighlight))) ;; The user has put down the presentation, figure out what to do - ;; - (let ((translator (find-translator destination))) + ;;--- What if there is more than one translator? + (let ((translator (find-translator destination last-window last-x last-y))) (when translator (multiple-value-bind (result-object result-type options) (funcall (presentation-translator-real-body translator) object presentation context-type - frame event window x y + frame event last-window last-x last-y (presentation-object destination) destination) (setq result-type (or result-type (evacuate-list context-type))) ;; Find the tag to throw to, and do so diff --git a/clim/dragging-output.lisp b/clim/dragging-output.lisp index 5838b4ab82ac60f1386fc91671c98c74807273b8..be5ba99d95b7b6ad4fdaffe3e31da77c2c481a67 100644 --- a/clim/dragging-output.lisp +++ b/clim/dragging-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: dragging-output.lisp,v 1.7 92/04/15 11:46:27 cer Exp $ +;; $fiHeader: dragging-output.lisp,v 1.8 92/08/18 17:24:50 cer Exp $ (in-package :clim-internals) @@ -18,9 +18,11 @@ :repaint ,repaint :finish-on-release ,finish-on-release)))) +(defparameter *dragging-output-finish-on-release* nil) + (defun drag-output-record (stream output-record &key (repaint t) (erase #'erase-output-record) feedback - (finish-on-release nil)) + (finish-on-release *dragging-output-finish-on-release*)) (declare (values final-x final-y delta-x delta-y)) (let (last-x last-y (delta-x 0) diff --git a/clim/formatted-output-defs.lisp b/clim/formatted-output-defs.lisp index dbda914358ecd9f60c3ca546b333ebcb6429d8d5..d0cf622f88e47a93a541ba5b21f5d02d77f782e9 100644 --- a/clim/formatted-output-defs.lisp +++ b/clim/formatted-output-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: formatted-output-defs.lisp,v 1.5 92/09/24 09:38:45 cer Exp $ +;; $fiHeader: formatted-output-defs.lisp,v 1.6 92/10/02 15:19:24 cer Exp $ (in-package :clim-internals) @@ -57,11 +57,11 @@ n-columns n-rows max-width max-height stream-width stream-height - (move-cursor T)) + (row-wise t) (move-cursor t)) &body body) (declare (ignore x-spacing y-spacing initial-spacing record-type n-columns n-rows max-width max-height - stream-width stream-height move-cursor)) + stream-width stream-height row-wise move-cursor)) #+Genera (declare (zwei:indentation 0 3 1 1)) (default-output-stream stream formatting-item-list) `(flet ((formatting-item-list-body (,stream) ,@body)) diff --git a/clim/frames.lisp b/clim/frames.lisp index c7b03c90ab0834d258b43a32b0676cff4c719977..da21ecf5cda25463c404661f3b7640a70544c59b 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.47 92/10/12 17:54:23 cer Exp $ +;; $fiHeader: frames.lisp,v 1.48 92/10/28 11:31:36 cer Exp $ (in-package :clim-internals) @@ -67,9 +67,6 @@ (defmethod graft ((frame standard-application-frame)) (graft (frame-manager frame))) -(defmethod frame-palette ((frame standard-application-frame)) - (frame-manager-palette (frame-manager frame))) - ;;--- These should really be somewhere else (defmethod frame-manager ((stream standard-encapsulating-stream)) (frame-manager (encapsulating-stream-stream stream))) @@ -101,6 +98,16 @@ (when frame-manager (adopt-frame frame-manager frame)))) +(defmethod find-named-color (name (frame standard-application-frame) &key (errorp t)) + (find-named-color name (frame-palette frame) :errorp errorp)) + +(defmethod frame-palette ((frame standard-application-frame)) + (let ((framem (frame-manager frame))) + (if framem + (frame-manager-palette framem) + (and (port frame) + (port-default-palette (port frame)))))) + ;; Default method does nothing (defmethod generate-panes ((framem standard-frame-manager) (frame standard-application-frame)) @@ -704,11 +711,20 @@ nil) +(define-condition frame-exit (condition) + ((frame :initarg :frame :reader frame-exit-frame)) + (:report (lambda (condition stream) + (format stream "Exit from frame ~A" (frame-exit-frame condition))))) + (defgeneric run-frame-top-level (frame &key &allow-other-keys)) ;;--- It would be nice to have the CLIM 0.9 START-FRAME and STOP-FRAME functions (defmethod run-frame-top-level :around ((frame standard-application-frame) &key) - (with-simple-restart (frame-exit "Exit ~A" (frame-pretty-name frame)) + (handler-bind ((frame-exit + #'(lambda (condition) + (let ((exit-frame (frame-exit-frame condition))) + (when (eq frame exit-frame) + (return-from run-frame-top-level nil)))))) (unwind-protect (let (;; Reset the state of the input editor and the presentation ;; type system, etc., in case there is an entry into another @@ -759,6 +775,8 @@ ;; top-level function to enable the frame. For example, if we ;; called ENABLE-FRAME here, ACCEPTING-VALUES would disable the ;; wrong frame. Sigh. + (queue-flush (frame-command-queue frame)) + (queue-flush (sheet-event-queue (frame-top-level-sheet frame))) (disable-frame frame)))) (defmethod run-frame-top-level ((frame standard-application-frame) &rest args) @@ -854,7 +872,7 @@ ;; Generic because someone might want :BEFORE or :AFTER (defmethod frame-exit ((frame standard-application-frame)) - (invoke-restart 'frame-exit)) + (signal 'frame-exit :frame frame)) ;;; Sizing and moving of frames diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 7411fc43ee134801428dd2d7508dae671d20b79b..44714f976848152ac7d7e0fd10c6499901a37e2c 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.34 92/10/28 11:31:38 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.35 92/10/29 15:02:40 cer Exp $ (in-package :clim-internals) @@ -240,6 +240,13 @@ (defmethod note-output-record-detached :after ((record gadget-output-record)) (update-output-record-gadget-state record nil)) +(defun move-cursor-to-view-position (stream view) + (let* ((initargs (view-gadget-initargs view)) + (x (getf initargs :x)) + (y (getf initargs :y))) + (when (and x y) + (stream-set-cursor-position stream x y)))) + (defvar *with-deferred-gadget-updates* nil) @@ -271,7 +278,8 @@ ;;; Completion gadget (define-presentation-method decode-indirect-view - ((type completion) (view gadget-dialog-view) (framem standard-frame-manager) &key) + ((type completion) (view gadget-dialog-view) + (framem standard-frame-manager) &key) ;;--- We can be clever and return different views depending on the ;;--- number of items, etc. +radio-box-view+) @@ -352,8 +360,8 @@ ;;; Subset completion gadget (define-presentation-method decode-indirect-view - ((type subset-completion) (view - gadget-dialog-view) (framem standard-frame-manager) &key) + ((type subset-completion) (view gadget-dialog-view) + (framem standard-frame-manager) &key) +check-box-view+) (define-presentation-method gadget-includes-prompt-p @@ -436,7 +444,7 @@ (define-presentation-method decode-indirect-view ((type boolean) (view gadget-dialog-view) - (framem standard-frame-manager) &key) + (framem standard-frame-manager) &key) +toggle-button-view+) (define-presentation-method gadget-includes-prompt-p @@ -497,13 +505,6 @@ stream query-identifier)))) (values (outlining () slider) slider)))))) - -(defun move-cursor-to-view-position (stream view) - (let* ((initargs (view-gadget-initargs view)) - (x (getf initargs :x)) - (y (getf initargs :y))) - (when (and x y) (stream-set-cursor-position stream x y)))) - (define-presentation-method accept-present-default ((type integer) stream (view slider-view) default default-supplied-p present-p query-identifier @@ -572,7 +573,8 @@ ;; The string case is straightforward (define-presentation-method decode-indirect-view - ((type string) (view gadget-dialog-view) (framem standard-frame-manager) &key) + ((type string) (view gadget-dialog-view) + (framem standard-frame-manager) &key) +text-field-view+) (define-presentation-method accept-present-default @@ -640,8 +642,7 @@ (defun make-list/option-pane-for-ptype (pane-type stream view sequence name-key value-key test - default query-identifier type - printer mode) + default query-identifier type printer mode) (move-cursor-to-view-position stream view) (flet ((update-gadget (record gadget list-pane) (declare (ignore gadget record)) diff --git a/clim/gestures.lisp b/clim/gestures.lisp index 13b9ce010cc9f637069b05a9cee457f08c69af1b..ac21a8fc7ce638b00f35fad6b027e957e04b8277 100644 --- a/clim/gestures.lisp +++ b/clim/gestures.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gestures.lisp,v 1.15 92/10/02 15:19:30 cer Exp $ +;; $fiHeader: gestures.lisp,v 1.16 92/10/28 11:31:40 cer Exp $ (in-package :clim-internals) @@ -17,12 +17,14 @@ (eval-when (compile load eval) +;; Button indices are 0, 1, or 2 (defun-inline button-index (name) #+Genera (declare lt:(side-effects simple reducible)) (position name *pointer-buttons*)) (defun-inline button-index-name (index) (aref *pointer-buttons* index)) +;; Modifier key indices are 0, 1, 2, 3, or 4 (defun-inline modifier-key-index (name) #+Genera (declare lt:(side-effects simple reducible)) (position name *modifier-keys*)) @@ -87,7 +89,8 @@ (do-button-and-modifier-state (button modifier-state bucket) (when (member gesture-name bucket) (return-from gesture-name-button-and-modifiers - (values button modifier-state)))) + (values (ash 1 (+ (1- (integer-length +pointer-left-button+)) button)) + modifier-state)))) nil) (defun gesture-name-keysym-and-modifiers (gesture-name) @@ -297,7 +300,8 @@ (#\Escape . :escape))))) (cond (entry (setq keysym (cdr entry))) - ((standard-char-p keysym) + ((and (characterp keysym) + (standard-char-p keysym)) (setq keysym (svref #(:space :\! :\" :\# :\$ :\% :\& :\' :\( :\) :\* :\+ :\, :\- :\. :\/ :\0 :\1 :\2 :\3 :\4 :\5 :\6 :\7 :\8 :\9 diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index 4a84733b141e95083a4b0db4410b6666c76ca8da..aaa84c482b5c59dc24a5e6fc8b27212eb699f4cf 100644 --- a/clim/graph-formatting.lisp +++ b/clim/graph-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graph-formatting.lisp,v 1.16 92/10/02 15:19:32 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.17 92/10/28 11:31:42 cer Exp $ (In-package :clim-internals) @@ -31,13 +31,14 @@ (defun make-graph-node-table (&key (test 'eql) (size 50)) (let ((table - (and (or (member test '(eq eql equal equalp + (and (or (member test '(eq eql equal + #-Cloe-Runtime equalp #+Genera string-equal #+Genera string= #+Genera char-equal #+Genera char=)) (eq test (load-time-value #'eq)) (eq test (load-time-value #'eql)) (eq test (load-time-value #'equal)) - (eq test (load-time-value #'equalp))) + #-Cloe-Runtime (eq test (load-time-value #'equalp))) (make-hash-table :test test :size size)))) (make-instance 'graph-node-table :test test :table table))) @@ -227,6 +228,38 @@ (declare (ignore from-node to-node)) (apply #'draw-line* stream x1 y1 x2 y2 drawing-options)) +(defun-inline call-arc-drawer (stream arc-drawer from-node to-node + parent parent-x parent-y child child-x child-y + arc-drawing-options) + (declare (dynamic-extent arc-drawer)) + (if (or (stream-redisplaying-p stream) + (stream-current-redisplay-record stream)) + (call-arc-drawer-1 stream arc-drawer from-node to-node + parent parent-x parent-y child child-x child-y + arc-drawing-options) + (apply arc-drawer stream from-node to-node + parent-x parent-y child-x child-y + arc-drawing-options))) + +;; Split out to avoid consing a closure environment +(defun call-arc-drawer-1 (stream arc-drawer from-node to-node + parent parent-x parent-y child child-x child-y + arc-drawing-options) + (declare (dynamic-extent arc-drawer)) + #---ignore ;--- this is the wrong thing... + (apply arc-drawer stream from-node to-node + parent-x parent-y child-x child-y + arc-drawing-options) + #+++ignore ;--- ...but the right thing doesn't work either + (updating-output (stream :unique-id (list parent child) + :id-test #'equal + :cache-value (list parent-x parent-y + child-x child-y) + :cache-test #'equal) + (apply arc-drawer stream from-node to-node + parent-x parent-y child-x child-y + arc-drawing-options))) + ;;; Tree graphs @@ -364,10 +397,12 @@ (child-attachment-position child) (translate-coordinates xoff yoff parent-x parent-y child-x child-y) - (apply arc-drawer stream - nil nil ;--- should be from-node and to-node - parent-x parent-y child-x child-y - arc-drawing-options)))))) + (call-arc-drawer stream arc-drawer + ;;--- Should be from- and to-node + nil nil + parent parent-x parent-y + child child-x child-y + arc-drawing-options)))))) (declare (dynamic-extent #'draw-edges)) (draw-edges root-node)))))))))) @@ -598,10 +633,12 @@ (funcall child-attach child) (translate-coordinates xoff yoff parent-x parent-y child-x child-y) - (apply arc-drawer stream - nil nil ;--- should be from-node and to-node - parent-x parent-y child-x child-y - arc-drawing-options)))))) + (call-arc-drawer stream arc-drawer + ;;--- Should be from- and to-node + nil nil + parent parent-x parent-y + child child-x child-y + arc-drawing-options)))))) (declare (dynamic-extent #'draw-edge)) (traverse-graph root-nodes #'inferior-mapper hash-table #'identity diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 493c4318072415aacbb462c6763f6e855a97e2d5..4c573fb0e10cac0b7dd39b0c948ba234446a595a 100644 --- a/clim/graphics-recording.lisp +++ b/clim/graphics-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-recording.lisp,v 1.13 92/08/19 10:24:02 cer Exp $ +;; $fiHeader: graphics-recording.lisp,v 1.14 92/09/08 15:17:51 cer Exp $ (in-package :clim-internals) @@ -47,12 +47,14 @@ (remove 'filled (append medium-components function-args))) (slot-descs (mapcar #'(lambda (x) - (list x :initarg (intern (symbol-name x) *keyword-package*))) - slots))) + (let ((keyword (intern (symbol-name x) *keyword-package*))) + (if (eq keyword :ink) + `(,x :initarg ,keyword :accessor displayed-output-record-ink) + `(,x :initarg ,keyword)))) + slots))) `(progn (defclass ,class ,superclasses ,slot-descs) - (define-constructor-using-prototype-instance - ,constructor ,class ,slots + (define-constructor-using-prototype-instance ,constructor ,class ,slots ,@(mapcar #'(lambda (arg) `(,arg ,(intern (symbol-name arg) *keyword-package*) ,arg)) slots)) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 53280f69aa1fab467ede044f164c63dbcefad386..89723f9f6df33cf70486fbdf260f4b9652a18885 100644 --- a/clim/input-editor-commands.lisp +++ b/clim/input-editor-commands.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-editor-commands.lisp,v 1.20 92/10/28 11:31:43 cer Exp Locker: cer $ +;; $fiHeader: input-editor-commands.lisp,v 1.21 92/10/29 15:02:42 cer Exp $ (in-package :clim-internals) @@ -31,19 +31,19 @@ (when keysym (if (zerop modifier-state) ;;--- What a kludge! What should this really be? - (member keysym '(:rubout :clear-input :escape - :scroll :refresh :suspend :resume)) + (member keysym '(:rubout :clear-input :escape :scroll :refresh :suspend + :resume :page-up :page-down :clear :backspace)) (logtest modifier-state (make-modifier-state :control :meta :super :hyper))))))) (declare (dynamic-extent #'add-aarray-entry #'bucky-char-p)) (cond ((atom gestures) (assert (bucky-char-p gestures) (gestures) - "~S does not correspond to a gesture" gestures) + "~S does not correspond to non-printing gesture" gestures) (add-aarray-entry gestures function *input-editor-command-aarray*)) (t (assert (> (length gestures) 1)) (assert (bucky-char-p (first gestures)) (gestures) - "~S does not correspond to a gesture" gestures) + "~S does not correspond to non-printing gesture" gestures) ;; We've got a command that wil be bound to a sequence of gestures, ;; so set up the prefix tables. (let ((aarray *input-editor-command-aarray*)) @@ -1232,6 +1232,17 @@ (:ie-show-value :v :meta :shift) (:ie-show-documentation :d :meta :shift)) +#+Cloe-Runtime +(define-input-editor-gestures + (:ie-rubout-character :backspace) + (:ie-rubout-word :backspace :meta) + (:ie-rubout-sexp :backspace :control :meta) + (:ie-clear-input :clear) + (:ie-scroll-forward :page-down) + (:ie-scroll-backward :page-up) + (:ie-scroll-left :page-up :super) + (:ie-scroll-right :page-down :super)) + (defmacro assign-input-editor-key-bindings (&body functions-and-gestures) (let ((forms nil)) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 4e157eac7f98de24187d47d8025b57ae8b54b20c..aa37e7b2a8f13792a672dfdf52b13f05244abe08 100644 --- a/clim/input-protocol.lisp +++ b/clim/input-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-protocol.lisp,v 1.29 92/10/28 11:31:46 cer Exp Locker: cer $ +;; $fiHeader: input-protocol.lisp,v 1.30 92/10/28 13:17:22 cer Exp $ (in-package :clim-internals) @@ -53,10 +53,9 @@ ;; A "normal" gesture (return-from stream-read-gesture (values gesture flag))) - ;; If we're looping when PEEK-P is T, we have to eat the - ;; gesture. - ;;--- what if peek-p is t and another gesture has arrived - ;; between the last call-next-method and this one??? (cim) + ;; If we're looping when PEEK-P is T, we have to eat the gesture. + ;;--- What if PEEK-P is T and another gesture has arrived + ;;--- between the last call-next-method and this one? (cim) (call-next-method stream :timeout 0 :peek-p nil)))) ;;; Our implementation of the extended-input protocol. @@ -101,8 +100,8 @@ (cursor-set-position cursor x y t)))) -(defmethod initialize-menu :before (port (menu input-protocol-mixin) associated-window) - (declare (ignore port associated-window)) +(defmethod initialize-menu :before (port (menu input-protocol-mixin) &key label) + (declare (ignore port label)) (let ((cursor (stream-text-cursor menu))) (when cursor (setf (cursor-active cursor) nil)))) @@ -153,7 +152,9 @@ (defmethod queue-event ((stream input-protocol-mixin) (event key-press-event)) (let ((char (keyboard-event-character event)) (keysym (keyboard-event-key-name event))) - (cond ((and (characterp char) (ordinary-char-p char)) + (cond ((and (characterp char) + (or (ordinary-char-p char) + (diacritic-char-p char))) (queue-put (stream-input-buffer stream) char)) ((and keysym (not (typep keysym 'modifier-keysym))) (queue-put (stream-input-buffer stream) (copy-event event))) @@ -257,7 +258,7 @@ (new-gesture (receive-gesture (if (or (null sheet) (eq sheet stream)) - (or *original-stream* stream) + (encapsulated-stream stream) sheet) gesture))) (when new-gesture @@ -411,15 +412,17 @@ (loop ;; Don't pass off a pointer-button-press-handler that ignores clicks, ;; we want this to be runnable inside a WITH-INPUT-CONTEXT. - (setq gesture (stream-read-gesture (or *original-stream* stream))) - (when (and (characterp gesture) (ordinary-char-p gesture)) + (setq gesture (stream-read-gesture (encapsulated-stream stream))) + (when (and (characterp gesture) + (or (ordinary-char-p gesture) + (diacritic-char-p gesture))) (return-from stream-read-char gesture)) ;;--- Probably wrong. It prevents the input editor from ever seeing ;;--- mouse clicks, for example. (beep stream)))) (defmethod stream-unread-char ((stream input-protocol-mixin) character) - (stream-unread-gesture (or *original-stream* stream) character)) + (stream-unread-gesture (encapsulated-stream stream) character)) ;;; Again, we only need this function (as opposed to using :timeout) ;;; because the X3J13 proposal includes it explicitly. @@ -428,16 +431,18 @@ (loop ;; Don't pass off a pointer-button-press-handler that ignores clicks, ;; we want this to be runnable inside a WITH-INPUT-CONTEXT. - (setq gesture (stream-read-gesture (or *original-stream* stream) :timeout 0)) + (setq gesture (stream-read-gesture (encapsulated-stream stream) :timeout 0)) (when (or (null gesture) - (and (characterp gesture) (ordinary-char-p gesture))) + (and (characterp gesture) + (or (ordinary-char-p gesture) + (diacritic-char-p gesture)) )) (return-from stream-read-char-no-hang gesture))))) (defmethod stream-peek-char ((stream input-protocol-mixin)) ;; stream-listen used to return the char, but Hornig says it has to return T (or nil ;(stream-listen stream) - (let ((char (stream-read-char (or *original-stream* stream)))) - (prog1 char (stream-unread-gesture (or *original-stream* stream) char))))) + (let ((char (stream-read-char (encapsulated-stream stream)))) + (prog1 char (stream-unread-gesture (encapsulated-stream stream) char))))) ;;; We think that the "standard" demands that this only see characters. ;;; However, it does not want to flush any pending action elements that @@ -450,7 +455,9 @@ ;; map over the input buffer looking for characters. ;; If we find one, return true (flet ((find-char (gesture) - (when (and (characterp gesture) (ordinary-char-p gesture)) + (when (and (characterp gesture) + (or (ordinary-char-p gesture) + (diacritic-char-p gesture))) (return-from stream-listen t)))) (declare (dynamic-extent #'find-char)) (map-over-queue #'find-char input-buffer)) @@ -473,7 +480,8 @@ (evacuate-temporary-string result))) (t ;; Be robust against weird characters - (if (ordinary-char-p ch) + (if (or (ordinary-char-p ch) + (diacritic-char-p ch)) (vector-push-extend ch result) (beep stream)))) (setq ch (stream-read-char stream))))))) @@ -553,7 +561,7 @@ #+Genera (defun stream-compatible-any-tyi-1 (stream timeout eof) - (let ((character (stream-read-gesture (or *original-stream* stream) :timeout timeout))) + (let ((character (stream-read-gesture (encapsulated-stream stream) :timeout timeout))) (cond ((null character) nil) ((eq character *end-of-file-marker*) (and eof (error "~a" eof))) diff --git a/clim/interactive-defs.lisp b/clim/interactive-defs.lisp index e07d8de3c189cab21d2fdcdaa088a6a7e1b47846..052e4b19473b69fe82bdf3a7beb341eb621fbbe4 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.16 92/09/24 09:39:06 cer Exp $ +;; $fiHeader: interactive-defs.lisp,v 1.17 92/10/02 15:19:40 cer Exp $ (in-package :clim-internals) @@ -166,7 +166,8 @@ ((delimiter-gesture-p gesture) ;; ditto? (return-token gesture)) - ((ordinary-char-p gesture) + ((or (ordinary-char-p gesture) + (diacritic-char-p gesture)) (vector-push-extend gesture string) ;;--- haven't updated WRITE-CHAR yet #+++ignore (write-char gesture stream)) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index 64fa3b1abb3993260c1f58b18a51e298fc30b741..c0befe358e95d469d3d0efbfa7e62f4e81296e86 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.19 92/10/02 15:19:42 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.20 92/10/28 11:31:47 cer Exp $ (in-package :clim-internals) @@ -221,24 +221,29 @@ (write-string (noise-string-display-string noise-string) istream)) (noise-string-unique-id noise-string))))))) -(defmethod stream-accept ((istream input-editing-stream-mixin) - type &rest args &key query-identifier &allow-other-keys) - (declare (dynamic-extent args)) +(defmethod stream-accept ((istream input-editing-stream-mixin) type &rest accept-args + &key view &allow-other-keys) + (declare (dynamic-extent accept-args)) (with-slots (input-buffer scan-pointer insertion-pointer previous-history previous-insertion-pointer) istream - (unless (stream-rescanning-p istream) - ;; If we're not rescanning, reset these so that m-Y will not work - ;; until the user types c-Y or c-m-Y. - (setq previous-history nil - previous-insertion-pointer nil)) - (let ((next-char (and (< scan-pointer insertion-pointer) - (aref input-buffer scan-pointer)))) - (cond ((and (typep next-char 'accept-result) - (eql (noise-string-unique-id next-char) query-identifier)) - (incf scan-pointer) - (values (accept-result-presentation-object next-char) - (accept-result-presentation-type next-char))) - (t (apply #'accept-1 (or *original-stream* istream) type args)))))) + (let ((query-identifier + (apply #'prompt-for-accept + (encapsulated-stream istream) type view accept-args))) + (unless (stream-rescanning-p istream) + ;; If we're not rescanning, reset these so that m-Y will not work + ;; until the user types c-Y or c-m-Y. + (setq previous-history nil + previous-insertion-pointer nil)) + (let ((next-char (and (< scan-pointer insertion-pointer) + (aref input-buffer scan-pointer)))) + (cond ((and (typep next-char 'accept-result) + (eql (noise-string-unique-id next-char) query-identifier)) + (incf scan-pointer) + (values (accept-result-presentation-object next-char) + (accept-result-presentation-type next-char))) + (t (apply #'accept-1 (encapsulated-stream istream) type + :query-identifier query-identifier + accept-args))))))) (defmethod input-buffer-input-position->cursor-position ((istream input-editing-stream-mixin) &optional position) @@ -487,7 +492,8 @@ (stream-process-gesture istream thing type) (when (and (characterp new-thing) ;; Don't put things in the buffer that we can't echo later - (ordinary-char-p new-thing) + (or (ordinary-char-p new-thing) + (diacritic-char-p new-thing)) (not (activation-gesture-p new-thing))) ;; If we are inserting multiple copies of this character ;; we'll need to do a rescan in order to keep user-level @@ -534,7 +540,8 @@ (t (setf insertion-pointer (fill-pointer input-buffer)) (setf activation-gesture new-thing)))) ((or (not (characterp new-thing)) - (ordinary-char-p new-thing)) + (ordinary-char-p new-thing) + (diacritic-char-p new-thing)) ;; There might be some queued up rescans from destructive ;; input editing commands, so take care of them now (rescan-if-necessary istream t) diff --git a/clim/menus.lisp b/clim/menus.lisp index e684a442e08b226c98e23025333dfc6a4a7beb17..0212b0d096aa2716c64084ee139f79976cb51e45 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.33 92/10/28 11:31:49 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.34 92/10/28 13:17:24 cer Exp $ (in-package :clim-internals) @@ -9,14 +9,22 @@ (defvar *abort-menus-when-buried* t) +(defparameter *default-menu-text-style* (make-text-style :fix :roman :normal)) +(defparameter *default-menu-label-text-style* (make-text-style :fix :italic :normal)) + (define-application-frame menu-frame () - (menu) + (menu label) (:pane - (with-slots (menu) *application-frame* + (with-slots (menu label) *application-frame* (outlining () - (scrolling () - (setq menu (make-pane 'clim-stream-pane - :initial-cursor-visibility nil)))))) + (vertically () + (setq label (make-pane 'label-pane + :label "" + :text-style *default-menu-label-text-style*)) + (scrolling () + (setq menu (make-pane 'clim-stream-pane + :initial-cursor-visibility nil))))))) + (:menu-bar nil)) (defmethod frame-calling-frame ((frame menu-frame)) @@ -33,18 +41,23 @@ (setf (getf (frame-properties frame) :menu-frame) t) (values (slot-value frame 'menu) frame))) -(defresource menu (associated-window root) +(defresource menu (associated-window root &key label) :constructor (let* ((port (if (null root) (find-port) (port root)))) (get-menu :port port)) :deinitializer (window-clear menu) - :initializer (initialize-menu (port menu) menu associated-window) + :initializer (initialize-menu (port menu) menu :label label) ;; Horrible kludge in the case where no associated window is passed in. :matcher (eq (port menu) (port root))) -(defmethod initialize-menu ((port basic-port) menu associated-window) - (declare (ignore menu associated-window)) +(defmethod initialize-menu ((port basic-port) menu &key label) ;;--- Should this flush the menu's event queue? - ) + (let ((text-style (if (listp label) + (getf (rest label) :text-style *default-menu-label-text-style*) + *default-menu-label-text-style*)) + (label (if (listp label) (first label) label)) + (label-pane (slot-value (pane-frame menu) 'label))) + (setf (gadget-label label-pane) (or label "") + (pane-text-style label-pane) (parse-text-style text-style)))) ;; items := (item*) @@ -67,8 +80,8 @@ ((atom (setq rest (cdr menu-item))) default) (t (getf rest indicator default))))) -(defun menu-item-style (menu-item) - (menu-item-getf menu-item :style)) +(defun menu-item-text-style (menu-item) + (menu-item-getf menu-item :text-style)) (defun menu-item-documentation (menu-item) (menu-item-getf menu-item :documentation)) @@ -132,13 +145,13 @@ (defun draw-standard-menu (menu presentation-type items default-item &key (item-printer #'print-menu-item) max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) &aux default-presentation) (formatting-item-list (menu :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing - :move-cursor nil) + :row-wise row-wise :move-cursor nil) (flet ((format-item (item) (let ((type (menu-item-type item))) (flet ((print-item () @@ -177,7 +190,7 @@ (defun print-menu-item (menu-item &optional (stream *standard-output*)) (let ((display (menu-item-display menu-item)) (string nil) - (style (menu-item-style menu-item))) + (style (menu-item-text-style menu-item))) (cond ((stringp display) (setq string display)) ;; This is a [horrible] kludge to get around the fact @@ -198,13 +211,13 @@ ;; In case we need to "compile" the menu on the fly (items :initarg :items) (default-item :initarg :default-item) - (default-style :initarg :default-style) + (text-style :initarg :text-style) (printer :initarg :printer) (presentation-type :initarg :presentation-type) (drawer-args :initarg :drawer-args))) (defgeneric menu-choose (items &rest keys - &key associated-window default-item default-style + &key associated-window text-style default-item label printer presentation-type cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns @@ -215,21 +228,21 @@ ;; Are these reasonable defaults for UNIQUE-ID, CACHE-VALUE, ID-TEST, and CACHE-TEST? (defmethod menu-choose ((items t) &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type (cache nil) (unique-id items) (id-test #'equal) (cache-value items) (cache-test #'equal) max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) pointer-documentation) (declare (values value chosen-item gesture)) (declare (ignore associated-window - default-item default-style + text-style default-item label printer presentation-type cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns - x-spacing y-spacing cell-align-x cell-align-y + x-spacing y-spacing row-wise cell-align-x cell-align-y pointer-documentation)) (declare (dynamic-extent keys)) (unless (zerop (length items)) @@ -241,12 +254,12 @@ ((framem standard-frame-manager) items &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type (cache nil) (unique-id items) (id-test #'equal) (cache-value items) (cache-test #'equal) max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) pointer-documentation) (declare (values value chosen-item gesture)) @@ -260,10 +273,9 @@ ;; Lucid production compiler tries to use an undefined internal ;; variable if this LET isn't done. #+Lucid (items items)) - (with-menu (menu associated-window) - (setf (window-label menu) label) + (with-menu (menu associated-window :label label) (reset-frame (pane-frame menu) :title label) - (with-text-style (menu default-style) + (with-text-style (menu text-style) (with-end-of-line-action (menu :allow) (loop (multiple-value-bind (item gesture) @@ -273,6 +285,7 @@ :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing + :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) (declare (dynamic-extent #'menu-choose-body)) @@ -383,7 +396,7 @@ (with-menu-as-popup (menu) (position-sheet-near-pointer (frame-top-level-sheet (pane-frame menu)) x-position y-position) - (window-expose menu) + (setf (window-visibility menu) t) ;;--- If we have windows with backing store then we dont get ;;--- exposure event and so nothing appears #+Allegro (replay (stream-output-history menu) menu) @@ -398,16 +411,12 @@ (with-input-context (presentation-type :override T) (object type gesture) (labels ((input-wait-test (menu) - ;; Wake up if the menu becomes buried, or - ;; if highlighting is needed - ;; this screws up in Allegro because - ;; querying the server in the wait - ;; function screws event handling. + ;; Wake up if the menu becomes buried, or if highlighting + ;; is needed. + ;;--- This screws up in Allegro because querying the server + ;;--- in the wait function screws event handling. (or #-Allegro (and *abort-menus-when-buried* - #+Cloe-Runtime - (not (stream-has-input-focus menu)) - #-Cloe-Runtime (not (window-visibility menu))) (pointer-motion-pending menu))) (input-wait-handler (menu) @@ -437,14 +446,14 @@ (defun hierarchical-menu-choose (items &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type x-position y-position (cache nil) (unique-id items) (id-test #'equal) (cache-value items) (cache-test #'equal) max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top)) (declare (values value chosen-item gesture)) (flet ((present-item (item stream) @@ -453,9 +462,8 @@ (let ((item-printer (cond (presentation-type #'present-item) (printer printer) (t #'print-menu-item)))) - (with-menu (menu associated-window) - (setf (window-label menu) label) - (with-text-style (menu default-style) + (with-menu (menu associated-window :label label) + (with-text-style (menu text-style) (multiple-value-bind (item gesture) (flet ((menu-choose-body (stream presentation-type) (draw-standard-menu stream presentation-type items default-item @@ -463,6 +471,7 @@ :max-width max-width :max-height max-height :n-rows n-rows :n-columns n-columns :x-spacing x-spacing :y-spacing y-spacing + :row-wise row-wise :cell-align-x cell-align-x :cell-align-y cell-align-y))) (declare (dynamic-extent #'menu-choose-body)) @@ -480,7 +489,7 @@ (hierarchical-menu-choose (menu-item-items item) :associated-window associated-window - :default-style default-style + :text-style text-style :x-position mr :y-position mt :cache cache :unique-id unique-id :id-test id-test @@ -497,29 +506,29 @@ (defmacro define-static-menu (name root-window items &rest keys - &key default-item default-style + &key text-style default-item printer presentation-type max-width max-height n-rows n-columns - x-spacing y-spacing + x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top)) (declare (ignore max-width max-height n-rows n-columns - x-spacing y-spacing cell-align-x cell-align-y)) + x-spacing y-spacing row-wise cell-align-x cell-align-y)) (with-keywords-removed (drawer-keys keys - '(:default-item :default-style :printer :presentation-type)) + '(:text-style :default-item :printer :presentation-type)) `(defvar ,name (define-static-menu-1 ',name ,root-window ',items :default-item ',default-item - :default-style ',default-style + :text-style ',text-style :presentation-type ',presentation-type :printer ',printer :drawer-args ,(copy-list drawer-keys))))) (defun define-static-menu-1 (name root-window items - &key default-item default-style + &key text-style default-item printer presentation-type drawer-args) (let ((menu-contents nil) (default-presentation nil)) - (when (typep root-window 'window-mixin) + (when (windowp root-window) ;; Build the static menu if we can (flet ((present-item (item stream) (present item presentation-type :stream stream))) @@ -528,7 +537,7 @@ (printer printer) (t #'print-menu-item)))) (with-menu (menu root-window) - (with-text-style (menu default-style) + (with-text-style (menu text-style) (with-end-of-line-action (menu :allow) (with-output-recording-options (menu :draw nil :record t) (setq menu-contents @@ -546,7 +555,7 @@ ;; Save this in case we have to rebuild the menu :items items :default-item default-item - :default-style default-style + :text-style text-style :printer printer :presentation-type presentation-type :drawer-args drawer-args))) @@ -555,7 +564,7 @@ (defmethod menu-choose ((static-menu static-menu) &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) - label default-style pointer-documentation + label text-style pointer-documentation &allow-other-keys) (declare (values value chosen-item gesture)) (declare (dynamic-extent keys)) @@ -566,20 +575,19 @@ (null menu-contents)) ;; If the root for the static menu is not the current root or the static ;; menu has never been filled in, then we have to recompute its contents. - (with-slots (default-item default-style printer presentation-type drawer-args) + (with-slots (default-item text-style printer presentation-type drawer-args) static-menu (let ((new-menu (define-static-menu-1 name this-root items :default-item default-item - :default-style default-style + :text-style text-style :printer printer :presentation-type presentation-type :drawer-args drawer-args))) (setq menu-contents (slot-value new-menu 'menu-contents) default-presentation (slot-value new-menu 'default-presentation) root-window this-root))))) - (with-menu (menu associated-window) - (setf (window-label menu) label) - (with-text-style (menu default-style) + (with-menu (menu associated-window :label label) + (with-text-style (menu text-style) (multiple-value-bind (item gesture) (menu-choose-from-drawer menu 'menu-item #'false ;the drawer never gets called diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 205caa51e3ef820c7d759d2ba3a06374dfd477b3..14e4490f8f34cc73ac8d9f5b5c3d90b54a894480 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.25 92/10/02 15:19:46 cer Exp $ +;; $fiHeader: output-protocol.lisp,v 1.26 92/10/28 11:31:51 cer Exp $ (in-package :clim-internals) @@ -239,11 +239,6 @@ ;;--- It would be nice to put them on something a bit more specific, ;;--- but OUTPUT-PROTOCOL-MIXIN is too specific. Sigh. -;;; For "normal" output streams, there are no margins. -(defmethod window-margins ((stream t)) - (values (coordinate 0) (coordinate 0) - (coordinate 0) (coordinate 0))) - ;;; "Normal" output streams are never recording. (defmethod stream-recording-p ((stream t)) nil) @@ -667,6 +662,7 @@ ((eql write-char #\Tab) (setf cursor-x (stream-next-tab-column stream cursor-x style)) (maxf largest-x cursor-x)) + ((diacritic-char-p write-char)) (t (multiple-value-bind (new-cursor-x new-cursor-y new-baseline new-height) (stream-draw-lozenged-character @@ -755,14 +751,14 @@ (wrap-p (unless brief-p (eq (stream-end-of-line-action stream) ':wrap)))) (if brief-p (values cursor-x cursor-y baseline line-height) - (values cursor-x cursor-y baseline line-height - (medium-merged-text-style stream) - (cond ((and wrap-p - (stream-text-margin stream))) - (t +largest-coordinate+)) - (stream-recording-p stream) - (stream-drawing-p stream) - (stream-output-glyph-buffer stream)))))) + (values cursor-x cursor-y baseline line-height + (medium-merged-text-style stream) + (cond ((and wrap-p + (stream-text-margin stream))) + (t +largest-coordinate+)) + (stream-recording-p stream) + (stream-drawing-p stream) + (stream-output-glyph-buffer stream)))))) (defmethod encode-stream-after-writing ((stream output-protocol-mixin) cursor-x cursor-y baseline line-height) @@ -817,7 +813,9 @@ (declare (type coordinate origin-y bb-y)) (when fixed-width-font-p (let* ((room-left (- ,max-x ,cursor-x *character-wrap-indicator-width*)) - (spaces-left (floor room-left escapement-x)) + (spaces-left (if (zerop escapement-x) + room-left ;diacritic chars have no width + (floor room-left escapement-x))) (chars-left (- ,end ,start)) (glyphs-left (if max-glyph (- max-glyph next-glyph) most-positive-fixnum)) @@ -830,7 +828,7 @@ (dotimes (i chars-to-do) (let* ((char (aref ,string (the fixnum (+ ,start i))))) ;; Stop when we get to an unusual character (e.g. Newline) - (unless (or (graphic-char-p char) (diacritic-char-p char)) + (unless (graphic-char-p char) ;excludes diacritics (return-from scan-for-newlines-etc)) ;; When a glyph-buffer was supplied, store the glyph index into it (when max-glyph @@ -1045,7 +1043,7 @@ ;;; Input Editor support. This does STREAM-SCAN-STRING-FOR-WRITING and ;;; other stuff, and calls the continuation so the Input Editor can know ;;; where its strings are on the screen. -(defmethod do-text-screen-real-estate ((stream output-protocol-mixin) continuation +(Defmethod do-text-screen-real-estate ((stream output-protocol-mixin) continuation string start end cursor-x cursor-y height baseline style max-x) ;; Continuation is a function which takes L T R B Baseline @@ -1097,5 +1095,7 @@ new-cursor-x (+ cursor-y height vsp) baseline) (setf cursor-x new-cursor-x) (incf start))) + ((diacritic-char-p write-char) + (incf start)) (t (error "~S found char ~A, and doesn't know what to do." ; ?? 'do-text-screen-real-estate write-char))))))) diff --git a/clim/prefill.lisp b/clim/prefill.lisp index 921381a4b51ac0827b8320f5559ea91bf481be8d..8dc500ec5ca14cb051d1568c6947b308fb38a99c 100644 --- a/clim/prefill.lisp +++ b/clim/prefill.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: prefill.lisp,v 1.11 92/10/02 15:19:48 cer Exp $ +;; $fiHeader: prefill.lisp,v 1.12 92/10/28 11:31:53 cer Exp $ (in-package :clim-internals) @@ -3158,8 +3158,6 @@ (application-pane)) (window-expose (clim-stream-pane)) - ((setf window-label) - (t clim-stream-pane)) (window-modifier-state (command-menu-pane) (interactor-pane) @@ -3615,7 +3613,6 @@ (window-clear) (window-erase-viewport) (window-expose) - ((setf window-label)) (window-modifier-state) (window-refresh) (window-set-inside-size) diff --git a/clim/present.lisp b/clim/present.lisp index 82ee5ea061059a5ef5002f6bbe4927a1939c9907..67ace546bc5a0ba827cf143d349b5ea016775469 100644 --- a/clim/present.lisp +++ b/clim/present.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: present.lisp,v 1.8 92/10/02 15:19:52 cer Exp $ +;; $fiHeader: present.lisp,v 1.9 92/10/28 11:31:57 cer Exp $ (in-package :clim-internals) @@ -91,12 +91,12 @@ ;; to special-case them all for string streams. Result is a string ;; representation of the output. STREAM must be an actual window; the ;; formatting of the string will match the dimensions of the window. -(defmacro with-presentations-to-string ((stream &optional string - &rest options - &key (element-type ''character) - (end-of-line-action ':allow) - (end-of-page-action ':allow)) - &body body) +(defmacro with-presentations-to-string + ((stream &optional string + &rest options + &key (element-type #+ANSI-90 ''character #-ANSI-90 ''string-char) + (end-of-line-action ':allow) (end-of-page-action ':allow)) + &body body) (declare (ignore element-type end-of-line-action end-of-page-action)) (default-output-stream stream with-presentations-to-string) `(flet ((with-presentations-to-string-body (,stream) ,@body)) @@ -104,10 +104,10 @@ (invoke-with-presentations-to-string ,stream #'with-presentations-to-string-body ,string ,@options))) -(defun invoke-with-presentations-to-string (stream continuation string - &key (element-type 'character) - (end-of-line-action ':allow) - (end-of-page-action ':allow)) +(defun invoke-with-presentations-to-string + (stream continuation string + &key (element-type #+ANSI-90 'character #-ANSI-90 'string-char) + (end-of-line-action ':allow) (end-of-page-action ':allow)) (let ((record (with-end-of-line-action (stream end-of-line-action) (with-end-of-page-action (stream end-of-page-action) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index 5df5d9da7b6519f5d1e80b21d3bd2635b4e77779..ed89baa036eb217bfb3c27d7517b97e16bc8939f 100644 --- a/clim/ptypes1.lisp +++ b/clim/ptypes1.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes1.lisp,v 1.17 92/10/28 08:19:31 cer Exp Locker: cer $ +;; $fiHeader: ptypes1.lisp,v 1.18 92/10/28 11:31:59 cer Exp $ (in-package :clim-internals) @@ -338,32 +338,36 @@ #+CCL-2 (defvar *presentation-class-type-table* (make-hash-table)) -;;; Find the class corresponding to the presentation type named name +;;; Find the class corresponding to the presentation type named NAME (defun find-presentation-type-class (name &optional (errorp t) environment) #+Genera (declare (inline compile-file-environment-p)) #+Allegro (setq environment (compile-file-environment-p environment)) - (typecase name - (symbol - (let ((compile-file-environment-p (compile-file-environment-p environment))) - (or (and (eq name (first *presentation-type-being-defined*)) - (second *presentation-type-being-defined*)) - (if compile-file-environment-p - (compile-time-property name 'presentation-type-class) - (gethash name *presentation-type-class-table*)) - (let ((class (find-class name nil environment))) - (and (acceptable-presentation-type-class class) - class)) - (when compile-file-environment-p - ;; compile-file environment inherits from the run-time environment - (or (gethash name *presentation-type-class-table*) - (let ((class (find-class name nil nil))) - (and (acceptable-presentation-type-class class) - class)))) - (and errorp (error "~S is not the name of a presentation type" name))))) - ((satisfies acceptable-presentation-type-class) - name) - (otherwise ;a type error should complain even if errorp is nil - (error "~S is not the name of a presentation type" name)))) + (macrolet ((not-found (name) + `(if (gethash name *presentation-type-abbreviation-table*) + (error "~S is a presentation type abbreviation, not the name of a presentation type" ,name) + (error "~S is not the name of a presentation type" ,name)))) + (typecase name + (symbol + (let ((compile-file-environment-p (compile-file-environment-p environment))) + (or (and (eq name (first *presentation-type-being-defined*)) + (second *presentation-type-being-defined*)) + (if compile-file-environment-p + (compile-time-property name 'presentation-type-class) + (gethash name *presentation-type-class-table*)) + (let ((class (find-class name nil environment))) + (and (acceptable-presentation-type-class class) + class)) + (when compile-file-environment-p + ;; compile-file environment inherits from the run-time environment + (or (gethash name *presentation-type-class-table*) + (let ((class (find-class name nil nil))) + (and (acceptable-presentation-type-class class) + class)))) + (and errorp (not-found name))))) + ((satisfies acceptable-presentation-type-class) + name) + (otherwise ;a type error should complain even if errorp is nil + (not-found name))))) ;;; Return the presentation type name corresponding to a class ;;; This is essentially the inverse of find-presentation-type-class @@ -1632,7 +1636,7 @@ (define-presentation-generic-function decode-indirect-view-method decode-indirect-view - (type-key parameters options type view frame-manager &key)) + (type-key parameters options type view frame-manager &key &allow-other-keys)) (define-presentation-generic-function presentation-refined-position-test-method presentation-refined-position-test diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index df64bee717e397be65d17e91a83f7575453b7e8d..beae1b18fa204b5e1f9f4d4a4497a9a8baca05f6 100644 --- a/clim/ptypes2.lisp +++ b/clim/ptypes2.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ptypes2.lisp,v 1.15 92/10/28 11:32:03 cer Exp Locker: cer $ +;; $fiHeader: ptypes2.lisp,v 1.16 92/11/05 17:15:39 cer Exp $ (in-package :clim-internals) @@ -488,9 +488,10 @@ view) (defun decode-indirect-view (type view frame-manager &rest args &key query-identifier) + (declare (dynamic-extent args)) (declare (ignore query-identifier)) (apply-presentation-generic-function decode-indirect-view - type view frame-manager args)) + type view frame-manager args)) ;;;; Refined position test and highlighting diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index 52af631ac2cb738a30935b0ea42529fb5a3fb5d5..996f38039cef5c790cd3a12cfba48eeff841b73d 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.24 92/10/28 11:32:05 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.25 92/10/28 13:17:26 cer Exp $ (in-package :clim-internals) @@ -546,6 +546,11 @@ (if new-output-record (copy-display-state new-output-record nil) (setq new-output-record + ;; Note that we set the x- and y-positions to 0. We + ;; do this because setting the cursor position to (x,y) + ;; has the appropriate effect, and setting the other + ;; positions can cause the record to be mis-positioned + ;; if we don't actually do any output into it. (if constructor (apply constructor :x-position 0 :y-position 0 initargs) @@ -553,7 +558,7 @@ :x-position 0 :y-position 0 initargs)))) (output-record-set-start-cursor-position new-output-record x y) (with-output-record-1 continuation - stream new-output-record cursor-x cursor-y) + stream new-output-record cursor-x cursor-y) (when (stream-redisplaying-p stream) (recompute-contents-ok new-output-record)) ;; We set the parent after doing everything else so that calls @@ -574,7 +579,7 @@ (defun with-output-record-1 (continuation stream record abs-x abs-y) ;; Close the text record before and after - (stream-close-text-output-record (or *original-stream* stream)) + (stream-close-text-output-record (encapsulated-stream stream)) (let ((current-output-position (stream-output-history-position stream))) (letf-globally (((point-x current-output-position) abs-x) @@ -585,8 +590,8 @@ (stream-cursor-position stream) (declare (type coordinate end-x end-y)) (output-record-set-end-cursor-position - record (- end-x abs-x) (- end-y abs-y))) - (stream-close-text-output-record (or *original-stream* stream))))) + record (- end-x abs-x) (- end-y abs-y))) + (stream-close-text-output-record (encapsulated-stream stream))))) (defun invoke-with-room-for-graphics (stream continuation record-type move-cursor &key height (first-quadrant t)) @@ -657,6 +662,14 @@ (declare (ignore stream region x-offset y-offset)) nil) +(defun change-output-record-ink (record ink) + (labels ((change-ink (record) + (if (output-record-p record) + (map-over-output-records #'change-ink record) + (setf (displayed-output-record-ink record) ink)))) + (declare (dynamic-extent #'change-ink)) + (change-ink record))) + (defun move-cursor-beyond-output-record (stream record &optional (y-offset 0)) (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 9a5c3bf3879180bdaffb0c1eeb7f4e456c651736..e9e31d5c3719ec23e8542bec59344db009adfbca 100644 --- a/clim/standard-types.lisp +++ b/clim/standard-types.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: standard-types.lisp,v 1.16 92/10/02 15:20:01 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.17 92/10/28 11:32:07 cer Exp $ (in-package :clim-internals) @@ -562,14 +562,22 @@ stream :acceptably acceptably)) (define-presentation-method accept ((type completion) stream (view textual-view) &key) - (values - (completing-from-suggestions - (stream :partial-completers partial-completers - :help-displays-possibilities (<= (length sequence) 10)) - (flet ((suggest-item (item) - (suggest (funcall name-key item) (funcall value-key item)))) - (declare (dynamic-extent #'suggest-item)) - (map nil #'suggest-item sequence))))) + (flet ((possibility-printer (possibility type stream) + (declare (ignore type)) + (funcall printer + (funcall name-key (find (second possibility) sequence + :key value-key :test test)) + stream))) + (declare (dynamic-extent #'possibility-printer)) + (values + (completing-from-suggestions + (stream :partial-completers partial-completers + :possibility-printer #'possibility-printer + :help-displays-possibilities (<= (length sequence) 10)) + (flet ((suggest-item (item) + (suggest (funcall name-key item) (funcall value-key item)))) + (declare (dynamic-extent #'suggest-item)) + (map nil #'suggest-item sequence)))))) (define-presentation-method accept-present-default ((type completion) stream (view dialog-view-mixin) @@ -736,33 +744,38 @@ (if (eql separator #\space) " " (make-array 2 :initial-contents (list separator #\space))))) - (loop - (let ((element - (with-delimiter-gestures (separators) - (completing-from-suggestions - (stream :partial-completers partial-completers - :possibility-printer - #'(lambda (object type stream) - (present (list (second object)) type :stream stream)) - :help-displays-possibilities (<= (length sequence) 10)) - (flet ((suggest-item (item) - (suggest (funcall name-key item) - (funcall value-key item)))) - (declare (dynamic-extent #'suggest-item)) - (map nil #'suggest-item sequence)))))) - (push element list)) + (flet ((possibility-printer (possibility type stream) + (declare (ignore type)) + (funcall printer + (funcall name-key (find (second possibility) sequence + :key value-key :test test)) + stream))) + (declare (dynamic-extent #'possibility-printer)) (loop - (multiple-value-bind (more-to-come object) - (accept-comma stream element-type view - :delimiter-character separator - :echo-space echo-space :echo-string-before-blip echo-string) - (ecase more-to-come - ((nil) - (return-from accept - (nreverse list))) - ((t) (return)) ;return to outer loop, call completing-from-suggestions again - ((:accepted) - (push object list)))))))) + (let ((element + (with-delimiter-gestures (separators) + (completing-from-suggestions + (stream :partial-completers partial-completers + :possibility-printer #'possibility-printer + :help-displays-possibilities (<= (length sequence) 10)) + (flet ((suggest-item (item) + (suggest (funcall name-key item) + (funcall value-key item)))) + (declare (dynamic-extent #'suggest-item)) + (map nil #'suggest-item sequence)))))) + (push element list)) + (loop + (multiple-value-bind (more-to-come object) + (accept-comma stream element-type view + :delimiter-character separator + :echo-space echo-space :echo-string-before-blip echo-string) + (ecase more-to-come + ((nil) + (return-from accept + (nreverse list))) + ((t) (return)) ;return to outer loop, call completing-from-suggestions again + ((:accepted) + (push object list))))))))) ;;; A handy routine for accepting comma-separated lists in textual views. ;;; If the next character is a comma, absorbs it and any following space and returns T. @@ -1496,7 +1509,8 @@ (return)) ((and (delimiter-gesture-p char) (not desired-delimiter)) (beep stream)) - ((not (ordinary-char-p char)) + ((not (or (ordinary-char-p char) + (diacritic-char-p char))) (beep stream)) ((and (zerop (fill-pointer input-buffer)) ;ignore leading space (whitespace-char-p char))) diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp index df71f125893c8fe443c67c865e3b1b811b00ef79..510fa2f8b949611ba8a39596799a5c07084bb34c 100644 --- a/clim/table-formatting.lisp +++ b/clim/table-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: table-formatting.lisp,v 1.13 92/10/02 15:20:04 cer Exp $ +;; $fiHeader: table-formatting.lisp,v 1.14 92/10/28 11:32:09 cer Exp $ (in-package :clim-internals) @@ -110,7 +110,7 @@ (defmethod map-over-table-elements-helper (function (record output-record-mixin) type) (declare (dynamic-extent function)) - ;; recurse into this guy + ;; Recurse into this guy (map-over-table-elements function record type)) (defmethod map-over-table-elements-helper @@ -159,12 +159,12 @@ (defmethod tree-recompute-extent-1 ((record output-record-element-mixin)) (bounding-rectangle* record)) -;;; Cells have been positioned manually, probably. -;;; Also, this should probably be an :around method so that we can -;;; drag the circle inside a cell and have the cell get updated automatically. -;;; Some extra bit will be needed. -;;; Until we do this, only table formatting really works (and arbitrary dragging -;;; of things above cells. +;; Cells have been positioned manually, probably. +;; Also, this should probably be an :around method so that we can +;; drag the circle inside a cell and have the cell get updated automatically. +;; Some extra bit will be needed. +;; Until we do this, only table formatting really works (and arbitrary dragging +;; of things above cells. (defmethod tree-recompute-extent-1 ((record standard-cell-output-record)) (bounding-rectangle* record)) @@ -222,7 +222,7 @@ ) (defun compute-row-table-p (table) - ;; find the first thing. + ;; Find the first thing (flet ((find-row-or-column (row-or-column) (return-from compute-row-table-p (values (row-output-record-p row-or-column))))) @@ -234,7 +234,7 @@ (cond ((not (eq row-table-p ':unknown)) row-table-p) (t - (setf row-table-p (compute-row-table-p table)))))) + (setq row-table-p (compute-row-table-p table)))))) ;; How can we make compute-output-size work without saving both an ink-rectangle ;; and a whitespace rectangle for each output record? @@ -264,7 +264,7 @@ (assert (cell-output-record-p cell)) (incf cells))) (declare (dynamic-extent #'count-rows #'count-cells)) - ;; calculate nrows & ncells (= ncells per row) + ;; Calculate nrows & ncells (= ncells per row) (funcall table-mapper #'count-rows table)) ;; If there are no rows, COUNT-ROWS won't get invoked and NCELLS ;; will be NIL. If all the rows and columns are empty, NCELLS will @@ -332,7 +332,7 @@ (let ((this-row-height (row-max-height row-count)) (this-column-width (column-max-width column-count))) (declare (type coordinate this-row-height this-column-width)) - ;; all numbers are in (output-record-parent table) coordinates + ;; All numbers are in (output-record-parent table) coordinates (if row-table-p (setq column-count -1) (setq row-count -1)) (setq total-width x-pos total-height y-pos) @@ -382,7 +382,7 @@ (funcall table-mapper #'row-mapper table))))))) (tree-recompute-extent table)) -;;; Table has already been laid out. +;; Table has already been laid out. (defmethod adjust-multiple-columns ((table standard-table-output-record) stream &optional n-columns x-spacing) (let ((row-count 0)) @@ -537,7 +537,7 @@ ;; of a slow MAKE-INSTANCE. If this body was just expanded inline in ;; FORMATTING-CELL, it would just work to slip the IF and simply call ;; INVOKE-WITH-NEW-OUTPUT-RECORD... Too bad. - (let ((stream (or *original-stream* stream))) + (let ((stream (encapsulated-stream stream))) (multiple-value-bind (x y) (stream-cursor-position stream) (prog1 (if (eq record-type 'standard-cell-output-record) @@ -572,26 +572,27 @@ (max-width :initarg :max-width) (max-height :initarg :max-height) (stream-width :initarg :stream-width) - (stream-height :initarg :stream-height)) + (stream-height :initarg :stream-height) + (row-wise :initarg :row-wise)) (:default-initargs :size 25 :n-columns nil :n-rows nil :max-width nil :max-height nil - :stream-width nil :stream-height nil)) + :stream-width nil :stream-height nil + :row-wise t)) (define-output-record-constructor standard-item-list-output-record (&key x-position y-position x-spacing y-spacing initial-spacing n-columns n-rows max-width max-height stream-width stream-height - (size 25)) + (row-wise t) (size 25)) :x-position x-position :y-position y-position :x-spacing x-spacing :y-spacing y-spacing :initial-spacing initial-spacing :n-columns n-columns :n-rows n-rows :max-width max-width :max-height max-height - :stream-width stream-width :stream-height stream-height :size size) + :stream-width stream-width :stream-height stream-height :row-wise row-wise :size size) (defmethod children-never-overlap-p ((record standard-item-list-output-record)) t) -;;; map-over-TABLE-cells?? -#+Genera (zwei:defindentation (map-over-menu-cells 1 1)) -(defmethod map-over-menu-cells ((menu standard-item-list-output-record) function) +#+Genera (zwei:defindentation (map-over-item-list-cells 1 1)) +(defmethod map-over-item-list-cells ((menu standard-item-list-output-record) function) (declare (dynamic-extent function)) (map-over-table-elements function menu 'cell)) @@ -610,8 +611,9 @@ (x-spacing (slot-value menu 'x-spacing)) (y-spacing (slot-value menu 'y-spacing)) (initial-spacing (slot-value menu 'initial-spacing)) - (max-width (slot-value menu 'max-width)) ;don't make menu - (max-height (slot-value menu 'max-height)) ;exceed these bounds + (max-width (slot-value menu 'max-width)) ;don't make the menu + (max-height (slot-value menu 'max-height)) ; exceed these bounds + (row-wise (slot-value menu 'row-wise)) (constrain t) (preferred-geometry 'column) ;vertical menu (golden-ratio 1.6)) @@ -624,29 +626,27 @@ (maxf max-cell-height height) (incf ncells)))) (declare (dynamic-extent #'count-cells)) - (map-over-menu-cells menu #'count-cells)) + (map-over-item-list-cells menu #'count-cells)) ;;--- Perhaps we should check that NCELLS is not zero? ;;--- PREFERRED-GEOMETRY isn't used yet ;; What's the preferred orientation of the menu? (unless (or nrows ncolumns) - ;; anything explicit overrides - (when constrain ;orientation like window orientation. + ;; Anything explicit overrides + (when constrain ;orientation like window orientation (let ((swidth (slot-value menu 'stream-width)) (sheight (slot-value menu 'stream-height))) (when (and swidth sheight) (when (> (/ swidth sheight) golden-ratio) - ;; when the stream is wider than it is high by more than the golden + ;; When the stream is wider than it is high by more than the golden ;; ratio, make the preferred ordering 'row (setq preferred-geometry 'row)))))) - ;; compute geometry + ;; Compute geometry (cond (ncolumns - (setq nrows (max 1 (ceiling (/ ncells ncolumns)))) - ;; - ) + (setq nrows (max 1 (ceiling (/ ncells ncolumns))))) (nrows (setq ncolumns (max 1 (ceiling (/ ncells nrows))))) (max-height - ;; could compute this better + ;; Could compute this better (setq nrows (max 1 (let ((acc-height (coordinate 0)) @@ -668,7 +668,7 @@ (when (> acc-width max-width) (return-from try-one-row nil)))) (declare (dynamic-extent #'sum-width)) - (map-over-menu-cells menu #'sum-width)) + (map-over-item-list-cells menu #'sum-width)) (max ncells 1))) ;; Won't fit in one row, use a more conservative computation ;; that uses max-cell-width instead of the actual widths @@ -682,8 +682,8 @@ (incf count)))))) (setq nrows (max 1 (ceiling (/ ncells ncolumns)))))) (t - ;; try to make this a golden-ratio menu - ;; deduce golden ratio from other parameters + ;; Try to make this a golden-ratio menu + ;; Deduce golden ratio from other parameters (setq ncolumns (max 1 (floor (sqrt (/ (* ncells max-cell-width max-cell-height) @@ -712,9 +712,9 @@ (incf column-count) (when (= column-count ncolumns) (incf row-count) - (setf column-count 0)))) + (setq column-count 0)))) (declare (dynamic-extent #'size-cells)) - (map-over-menu-cells menu #'size-cells)) + (map-over-item-list-cells menu #'size-cells)) ;; Now default the x-spacing to a spacing that spreads the ;; columns evenly over the entire width of the menu (unless x-spacing @@ -770,21 +770,32 @@ cell (+ x-offset left-margin accumulated-width x-alignment-adjust) (+ y-offset top-margin accumulated-height y-alignment-adjust)))) - (incf accumulated-width (column-width column-count)) - (incf accumulated-width x-spacing) - (incf column-count) - (when (= column-count ncolumns) - (setf accumulated-width - (if (or (stream-redisplaying-p stream) - (not initial-spacing)) - (coordinate 0) - (coordinate x-spacing))) - (incf accumulated-height (row-height row-count)) - (incf accumulated-height y-spacing) - (setf column-count 0) - (incf row-count)))) + (cond (row-wise + (incf accumulated-width (column-width column-count)) + (incf accumulated-width x-spacing) + (incf column-count) + (when (= column-count ncolumns) + (setq accumulated-width + (if (or (stream-redisplaying-p stream) + (not initial-spacing)) + (coordinate 0) + (coordinate x-spacing))) + (incf accumulated-height (row-height row-count)) + (incf accumulated-height y-spacing) + (setq column-count 0) + (incf row-count))) + (t + (incf accumulated-height (row-height row-count)) + (incf accumulated-height y-spacing) + (incf row-count) + (when (= row-count nrows) + (setq accumulated-height 0) + (incf accumulated-width (column-width column-count)) + (incf accumulated-width x-spacing) + (setq row-count 0) + (incf column-count)))))) (declare (dynamic-extent #'adjust-cells)) - (map-over-menu-cells menu #'adjust-cells))))))))) + (map-over-item-list-cells menu #'adjust-cells))))))))) (tree-recompute-extent menu)) ;; FORMATTING-ITEM-LIST macro in FORMATTED-OUTPUT-DEFS @@ -792,7 +803,7 @@ &key x-spacing y-spacing initial-spacing n-columns n-rows max-width max-height stream-width stream-height - (move-cursor T) + (row-wise t) (move-cursor t) (record-type 'standard-item-list-output-record)) (let ((menu (with-output-recording-options (stream :draw nil :record t) @@ -812,7 +823,8 @@ 'formatting-item-list ':y-spacing) (stream-vertical-spacing stream)) - :initial-spacing initial-spacing) + :initial-spacing initial-spacing + :row-wise row-wise) (funcall continuation stream))))))) (adjust-table-cells menu stream) (replay menu stream) @@ -821,7 +833,7 @@ menu)) (defun format-items (items &key (stream *standard-output*) printer presentation-type - x-spacing y-spacing initial-spacing + x-spacing y-spacing initial-spacing (row-wise t) n-rows n-columns max-width max-height (record-type 'standard-item-list-output-record) (cell-align-x ':left) (cell-align-y ':top)) @@ -833,7 +845,8 @@ :n-rows n-rows :n-columns n-columns :max-width max-width :max-height max-height :x-spacing x-spacing :y-spacing y-spacing - :initial-spacing initial-spacing) + :initial-spacing initial-spacing + :row-wise row-wise) (flet ((format-item (item) (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) (cond (printer diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp index 8d786ce7141bd10659fc7153fa7a01d936a86eb6..d45f75230520fb5347ea1251b5ab8db5e67eaa8b 100644 --- a/clim/text-formatting.lisp +++ b/clim/text-formatting.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-formatting.lisp,v 1.9 92/07/01 15:47:05 cer Exp $ +;; $fiHeader: text-formatting.lisp,v 1.10 92/09/08 15:18:37 cer Exp $ (in-package :clim-internals) @@ -158,7 +158,7 @@ (when (> (stream-cursor-position stream) fill-width) (stream-terpri stream) (filling-stream-handle-line-break filling-stream)) - (let ((*original-stream* (or *original-stream* filling-stream))) + (let ((*original-stream* (encapsulated-stream filling-stream))) (apply continuation stream continuation-args)))) (defmethod invoke-with-text-style ((filling-stream filling-stream) @@ -184,10 +184,11 @@ #'stream-close-text-output-record wrapped)) (defresource filling-stream (stream fill-width break-characters prefix prefix-width) - :constructor (make-instance 'filling-stream - :buffer (make-array 100 :element-type 'character - :fill-pointer 0 - :adjustable t)) + :constructor + (make-instance 'filling-stream + :buffer (make-array 100 :element-type #+ANSI-90 'character #-ANSI-90 'string-char + :fill-pointer 0 + :adjustable t)) :matcher 't :initializer (progn diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index 833e5d83ced1e805e7672610650d6f583f69e5e8..130184df5d58c8047e83462e5190485c96c9f997 100644 --- a/clim/text-recording.lisp +++ b/clim/text-recording.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-recording.lisp,v 1.13 92/09/24 09:39:28 cer Exp $ +;; $fiHeader: text-recording.lisp,v 1.14 92/10/02 15:20:06 cer Exp $ (in-package :clim-internals) @@ -32,7 +32,7 @@ ((string :initarg :string :reader text-displayed-output-record-string) (wrapped-p :initform nil :initarg :wrapped-p) - (ink :initarg :ink) + (ink :initarg :ink :accessor displayed-output-record-ink) (clipping-region :initarg :clipping-region))) (defclass styled-text-output-record @@ -42,16 +42,15 @@ (current-text-style :initform nil :initarg :current-style) (baseline :initform (coordinate 0) :initarg :baseline))) -(define-constructor make-standard-text-output-record - standard-text-output-record (string ink clipping-region) - :ink ink :string string :clipping-region clipping-region) +(define-constructor make-standard-text-output-record standard-text-output-record + (string ink clipping-region) + :ink ink :string string :clipping-region clipping-region) -(define-constructor make-styled-text-output-record - styled-text-output-record (string ink clipping-region) - :ink ink :string string :clipping-region clipping-region) +(define-constructor make-styled-text-output-record styled-text-output-record + (string ink clipping-region) + :ink ink :string string :clipping-region clipping-region) -(define-constructor make-styled-text-output-record-1 - styled-text-output-record +(define-constructor make-styled-text-output-record-1 styled-text-output-record (string ink clipping-region wrapped-p style baseline) :ink ink :string string :clipping-region clipping-region :wrapped-p wrapped-p :initial-style style :current-style style :baseline baseline) @@ -116,8 +115,12 @@ :align-y :top) (setf cursor-x new-cursor-x start next-char-index) (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? + (cond ((eql write-char #\Tab) (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) + ((diacritic-char-p write-char) + (draw-text* medium write-char + new-cursor-x (+ cursor-y (- baseline new-baseline)) + :align-y :top)) (t (multiple-value-bind (new-cursor-x new-cursor-y) (stream-draw-lozenged-character @@ -171,8 +174,12 @@ :text-style text-style) (setf cursor-x new-cursor-x start next-char-index) (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? + (cond ((eql write-char #\Tab) (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) + ((diacritic-char-p write-char) + (draw-text* medium write-char + new-cursor-x (+ cursor-y (- baseline new-baseline)) + :align-y :top)) (t (multiple-value-bind (new-cursor-x new-cursor-y) (stream-draw-lozenged-character @@ -396,7 +403,7 @@ (not (typep record 'styled-text-output-record))) (setq record (stylize-text-output-record record default-style stream))) (return-from get-text-output-record record))) - (let* ((string (make-array 16 :element-type 'character + (let* ((string (make-array 16 :element-type #+ANSI-90 'character #-ANSI-90 'string-char :fill-pointer 0 :adjustable t)) (record (if (not (eq style default-style)) (make-styled-text-output-record diff --git a/clim/translators.lisp b/clim/translators.lisp index 6b165e8dcfa3d269dae68a961f156a350e8765d6..77ebb31c7350966ada49de6e7e922eb91b20418c 100644 --- a/clim/translators.lisp +++ b/clim/translators.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: translators.lisp,v 1.8 92/08/18 17:25:45 cer Exp $ +;; $fiHeader: translators.lisp,v 1.9 92/09/24 09:39:31 cer Exp $ (in-package :clim-internals) @@ -51,6 +51,11 @@ (defun-inline presentation-translator-p (object) (typep object 'presentation-translator)) +(defclass presentation-action (presentation-translator) ()) + +(defun-inline presentation-action-p (object) + (typep object 'presentation-action)) + (defmethod presentation-translator-command-name ((translator presentation-translator)) nil) @@ -120,7 +125,8 @@ :pointer-documentation ,pointer-documentation :menu ,menu :priority ,priority - :tester-definitive t) + :tester-definitive t + :translator-class presentation-action) ,arglist ,@body)))) @@ -166,7 +172,7 @@ (check-type documentation (or string symbol list)) (check-type pointer-documentation (or string symbol list)) (check-type menu symbol) - (check-type priority (or null integer)) + (check-type priority (or null (integer 0))) (check-type translator-class (or null symbol)) (let ((defining-forms nil) (translator-functions nil)) @@ -567,14 +573,15 @@ (when (eq documentation-type :from-body) ;; In general, it is not safe to run the body of a translator to get ;; its documentation, but sometimes that's the only way. Command - ;; menus are one such example. (Beware of side-effects from actions.) - (catch 'no-translation ;catch simple action errors - (multiple-value-bind (translated-object translated-type) - (call-presentation-translator translator presentation context-type - frame event window x y) - (present translated-object (or translated-type context-type) - :stream stream :view +pointer-documentation-view+) - (return-from document-presentation-translator (values))))) + ;; menus are one such example. + (unless (presentation-action-p translator) + (catch 'no-translation ;just in case... + (multiple-value-bind (translated-object translated-type) + (call-presentation-translator translator presentation context-type + frame event window x y) + (present translated-object (or translated-type context-type) + :stream stream :view +pointer-documentation-view+) + (return-from document-presentation-translator (values)))))) ;; If we didn't get asked to run the body for the purpose of command ;; menus, then we might be able to take a different kind of short ;; cut for to-command translators.