From d4345d0d7c2d51dc413216dda84bba93fbc9e47a Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Wed, 15 Apr 1992 11:49:06 +0000 Subject: [PATCH] swmmerge --- Makefile | 7 +- clim/accept-values.lisp | 162 +- clim/accept.lisp | 13 +- clim/basic-translators.lisp | 41 +- clim/clim-defs.lisp | 112 +- clim/command-processor.lisp | 24 +- clim/command.lisp | 33 +- clim/completer.lisp | 63 +- clim/coordinate-sorted-set.lisp | 43 +- clim/cursor.lisp | 28 +- clim/db-stream.lisp | 49 +- clim/dragging-output.lisp | 14 +- clim/excl-presentations.lisp | 66 +- clim/frames.lisp | 145 +- clim/gadget-output.lisp | 83 +- clim/gestures.lisp | 92 +- clim/graph-formatting.lisp | 31 +- clim/graphics-recording.lisp | 90 +- clim/histories.lisp | 12 +- clim/incremental-redisplay.lisp | 128 +- clim/input-defs.lisp | 41 +- clim/input-editor-commands.lisp | 10 +- clim/input-protocol.lisp | 71 +- clim/interactive-protocol.lisp | 40 +- clim/menus.lisp | 15 +- clim/output-protocol.lisp | 204 ++- clim/output-recording-protocol.lisp | 1852 --------------------- clim/present.lisp | 6 +- clim/presentations.lisp | 16 +- clim/ptypes1.lisp | 8 +- clim/ptypes2.lisp | 26 +- clim/recording-defs.lisp | 4 +- clim/recording-protocol.lisp | 316 ++-- clim/standard-tree.lisp | 6 +- clim/standard-types.lisp | 42 +- clim/stream-class-defs.lisp | 6 +- clim/stream-defprotocols.lisp | 26 +- clim/surround-output.lisp | 4 +- clim/table-formatting.lisp | 115 +- clim/text-formatting.lisp | 10 +- clim/text-recording.lisp | 84 +- clim/tracking-pointer.lisp | 22 +- clim/window-stream.lisp | 11 +- clx/clx-frames.lisp | 9 +- clx/clx-gadgets.lisp | 10 +- clx/clx-medium.lisp | 19 +- clx/clx-mirror.lisp | 13 +- clx/clx-port.lisp | 7 +- demo/address-book.lisp | 72 +- demo/cad-demo.lisp | 110 +- demo/demo-driver.lisp | 6 +- demo/demo-prefill.lisp | 4 +- demo/graphics-demos.lisp | 4 +- demo/listener.lisp | 11 +- demo/navfun.lisp | 70 +- demo/puzzle.lisp | 69 +- demo/sysdcl.lisp | 15 +- demo/thinkadot.lisp | 37 +- genera/genera-activities.lisp | 5 +- genera/genera-frames.lisp | 8 +- genera/genera-gadgets.lisp | 10 +- genera/genera-medium.lisp | 15 +- genera/genera-mirror.lisp | 11 +- genera/genera-port.lisp | 33 +- misc/dev-load-1.lisp | 15 +- pre-silica/cloe-implementation.lisp | 14 +- pre-silica/clx-implementation.lisp | 106 +- pre-silica/default-application.lisp | 8 +- pre-silica/defs-graphics-generics.lisp | 58 +- pre-silica/genera-implementation.lisp | 25 +- pre-silica/graphics-internals.lisp | 10 +- pre-silica/postscript-implementation.lisp | 161 +- pre-silica/protocol-intermediaries.lisp | 22 +- pre-silica/window-protocol.lisp | 140 +- silica/db-border.lisp | 17 +- silica/db-box.lisp | 2 +- silica/db-button.lisp | 21 +- silica/db-layout.lisp | 28 +- silica/db-scroll.lisp | 275 ++- silica/db-slider.lisp | 6 +- silica/db-table.lisp | 6 +- silica/event.lisp | 16 +- silica/framem.lisp | 18 +- silica/gadgets.lisp | 148 +- silica/graphics.lisp | 246 ++- silica/layout.lisp | 85 +- silica/macros.lisp | 10 +- silica/mirror.lisp | 11 +- silica/pkg.lisp | 248 --- silica/port.lisp | 32 +- silica/sheet.lisp | 42 +- sys/defsystem.lisp | 7 +- sys/sysdcl.lisp | 23 +- test/test-suite.lisp | 34 +- test/test.lisp | 15 +- tk-silica/ol-gadgets.lisp | 30 +- tk-silica/xm-gadgets.lisp | 56 +- tk-silica/xm-silica.lisp | 2 +- tk-silica/xt-frames.lisp | 59 +- tk-silica/xt-gadgets.lisp | 9 +- tk-silica/xt-graphics.lisp | 43 +- tk-silica/xt-pixmaps.lisp | 5 +- tk-silica/xt-silica.lisp | 413 +++-- tk/event.lisp | 5 +- tk/font.lisp | 4 +- tk/foreign.lisp | 4 +- tk/gcontext.lisp | 4 +- tk/graphics.lisp | 6 +- tk/make-classes.lisp | 7 +- tk/ol-examples.lisp | 4 +- tk/resources.lisp | 16 +- tk/widget.lisp | 26 +- tk/xlib.lisp | 23 +- tk/xm-classes.lisp | 5 +- utils/clim-macros.lisp | 10 +- utils/clos.lisp | 8 +- utils/coral-char-bits.lisp | 15 +- utils/defun-utilities.lisp | 43 +- utils/extended-regions.lisp | 24 +- utils/lisp-utilities.lisp | 194 +-- utils/packages.lisp | 263 +-- utils/region-arithmetic.lisp | 4 +- utils/regions.lisp | 128 +- utils/transformations.lisp | 30 +- utils/utilities.lisp | 26 +- xlib/ffi.lisp | 36 +- xlib/xlib-defs.lisp | 4 +- xlib/xlib-funs.lisp | 4 +- 128 files changed, 3064 insertions(+), 5004 deletions(-) delete mode 100644 clim/output-recording-protocol.lisp delete mode 100644 silica/pkg.lisp diff --git a/Makefile b/Makefile index c8f947e1..5f0537b7 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,4 @@ -# $fiHeader: Makefile,v 1.20 92/04/03 12:04:47 cer Exp Locker: cer $ +# $fiHeader: Makefile,v 1.21 92/04/10 14:27:40 cer Exp Locker: cer $ # # Makefile for CLIM 2.0 # @@ -143,8 +143,8 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \ clim/incremental-redisplay.fasl \ clim/coordinate-sorted-set.fasl \ clim/window-stream.fasl \ - clim/completer.fasl \ clim/ptypes1.fasl \ + clim/completer.fasl \ clim/presentations.fasl \ clim/translators.fasl \ clim/histories.fasl \ @@ -330,7 +330,8 @@ clim-small: FORCE train : FORCE $(ECHO) "\ (load \"/net/vapor/usr/tech/cer/stuff/misc/test-clim.lisp\") \ - (clim-user::train-clim-2)" | $(CLIM) $(CLOPTS) -batch + (clim-user::train-clim-2) \ + (exit 0) " | $(CLIM) $(CLOPTS) -batch # Misc diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 1210644b..af35ea63 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.13 92/04/10 14:26:56 cer Exp Locker: cer $ +;; $fiHeader: accept-values.lisp,v 1.14 92/04/14 15:29:50 cer Exp Locker: cer $ (in-package :clim-internals) @@ -186,21 +186,21 @@ (:pane (with-slots (stream own-window exit-button-stream) *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 nil)))) - own-window))) - (outlining () - (setf exit-button-stream + (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 nil)))) + own-window))) + (outlining () + (setf exit-button-stream (make-pane 'clim-stream-pane - :initial-cursor-visibility nil)))))) - (:top-level (accept-values-top-level)) + :initial-cursor-visibility nil)))))) (:menu-bar nil) + (:top-level (accept-values-top-level)) (:command-table accept-values) (:command-definer nil)) @@ -278,8 +278,8 @@ (bottom-margin 10)) (if own-window (let ((frame (make-application-frame (or frame-class 'accept-values-own-window) - :parent *application-frame* :calling-frame *application-frame* + :parent *application-frame* :continuation continuation :exit-boxes exit-boxes :own-window the-own-window @@ -525,8 +525,8 @@ (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates stream (output-record-parent presentation)) - (multiple-value-bind (x y) (output-record-position* presentation) - (stream-set-cursor-position* stream (+ x xoff) (+ y yoff)))) + (multiple-value-bind (x y) (output-record-position presentation) + (stream-set-cursor-position stream (+ x xoff) (+ y yoff)))) (erase-output-record presentation stream) (catch-abort-gestures ("Abort editing the current field") (let ((new-value nil) @@ -806,7 +806,7 @@ ;; :X-SPACING makes it not spread the choices to fill the whole width. ;; :INITIAL-SPACING NIL makes it not add whitespace at the start of the field. (formatting-item-list (stream :max-width (- (stream-text-margin stream) - (stream-cursor-position* stream)) + (stream-cursor-position stream)) :x-spacing '(2 :character) :initial-spacing nil) (doseq (object sequence) @@ -1041,30 +1041,22 @@ (formatting-cell (stream) (with-output-as-gadget (stream) (make-pane 'push-button - :activate-callback - #'(lambda (gadget) - (declare (ignore gadget)) - (com-abort-avv)) - :client frame - :id :abort - :label abort))) + :label abort + :client frame :id :abort + :activate-callback + #'(lambda (gadget) + (declare (ignore gadget)) + (com-abort-avv))))) (formatting-cell (stream) (with-output-as-gadget (stream) (make-pane 'push-button - :activate-callback - #'(lambda (gadget) - (declare (ignore gadget)) - (com-exit-avv)) - :client frame - :id :exit - :label exit)))))))) - -;; Callback for exit boxes -#+ignore -(defmethod activate-callback ((button push-button) (client accept-values) id) - (ecase id - (:abort (com-abort-avv)) - (:exit (com-exit-avv)))) + :label exit + :client frame :id :exit + :activate-callback + #'(lambda (gadget) + (declare (ignore gadget)) + (com-exit-avv)))))))))) + ;; It's OK that this is only in the ACCEPT-VALUES command table because ;; we're going to execute it manually in the callbacks below @@ -1075,25 +1067,6 @@ (setf value new-value changed-p t))) -#+ignore -(defmethod value-changed-callback :around ((gadget value-gadget) - (client accept-values-stream) id new-value) - (declare (ignore new-value)) - (when (accept-values-query-valid-p (accept-values-query-presentation id)) - ;; Only call the callback if the query is still valid - (call-next-method))) - -#+ignore -(defmethod value-changed-callback ((gadget value-gadget) - (client accept-values-stream) id new-value) - (do-avv-command new-value client id)) - -#+ignore -(defmethod value-changed-callback ((gadget radio-box) - (client accept-values-stream) id new-value) - (do-avv-command (gadget-id new-value) client id)) - - (defun accept-values-value-changed-callback (gadget new-value stream query-id) (declare (ignore gadget)) (when (accept-values-query-valid-p (accept-values-query-presentation query-id)) @@ -1104,8 +1077,6 @@ ;; We attach a callback function directly now `(,#'accept-values-value-changed-callback ,stream ,query-id)) -;;;;;;;;;;;;;;; - (defun do-avv-command (new-value client id) (throw-highlighted-presentation (make-instance 'standard-presentation @@ -1122,58 +1093,39 @@ ;; This is how we associate an output-record with the button (defmethod invoke-accept-values-command-button - (stream continuation (view gadget-dialog-view) prompt - &key (documentation (if (stringp prompt) - prompt - (with-output-to-string (stream) - (funcall prompt stream)))) - (query-identifier (list ':button documentation)) - (cache-value t) (cache-test #'eql) - resynchronize) + (stream continuation (view gadget-dialog-view) prompt + &key (documentation (if (stringp prompt) + prompt + (with-output-to-string (stream) + (funcall prompt stream)))) + (query-identifier (list ':button documentation)) + (cache-value t) (cache-test #'eql) + resynchronize) (declare (dynamic-extent prompt)) (updating-output (stream :unique-id query-identifier :id-test #'equal :cache-value cache-value :cache-test cache-test) (with-output-as-gadget (stream) - (let ((id (stream-current-output-record (slot-value stream - 'stream))) + (let ((id (stream-current-output-record (slot-value stream 'stream))) (client (make-instance 'accept-values-command-button :continuation continuation :documentation documentation :resynchronize resynchronize))) (make-pane 'push-button - :activate-callback - #'(lambda (button) - (when (accept-values-query-valid-p id) - (throw-highlighted-presentation - (make-instance 'standard-presentation - :object `(com-avv-command-button ,client ,id) - :type 'command) - *input-context* - ;;--- It would be nice if we had the real event... - (make-instance 'pointer-button-press-event - :sheet (sheet-parent button) - :x 0 - :y 0 - :modifiers 0 - :button 256)))) - :label prompt - :id id - :client client))))) - -#+ignore -(defmethod activate-callback ((button push-button) - (client accept-values-command-button) id) - (when (accept-values-query-valid-p id) - (throw-highlighted-presentation - (make-instance 'standard-presentation - :object `(com-avv-command-button ,client ,id) - :type 'command) - *input-context* - ;;--- It would be nice if we had the real event... - (make-instance 'pointer-button-press-event - :sheet (sheet-parent button) - :x 0 - :y 0 - :modifiers 0 - :button 256)))) + :label prompt + :id id :client client + :activate-callback + #'(lambda (button) + (when (accept-values-query-valid-p id) + (throw-highlighted-presentation + (make-instance 'standard-presentation + :object `(com-avv-command-button ,client ,id) + :type 'command) + *input-context* + ;;--- It would be nice if we had the real event... + (make-instance 'pointer-button-press-event + :sheet (sheet-parent button) + :x 0 + :y 0 + :modifiers 0 + :button +pointer-left-button+))))))))) diff --git a/clim/accept.lisp b/clim/accept.lisp index 3045941a..53ce7885 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.4 92/03/04 16:21:07 cer Exp $ +;; $fiHeader: accept.lisp,v 1.5 92/03/10 10:12:15 cer Exp $ (in-package :clim-internals) @@ -222,13 +222,13 @@ (make-presentation-history-element :object default :type default-type))) (with-default-bound-in-history history default-element - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view :default default :default-type default-type))) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view :default default :default-type default-type)) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view))))))))) ;; A presentation translator was invoked @@ -351,10 +351,11 @@ (return-from accept-from-string (values default default-type index))))))) (if default-supplied-p - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view :default default :default-type default-type) - (call-presentation-generic-function accept type stream view)))) + (funcall-presentation-generic-function accept + type stream view)))) (values the-object (or the-type type) index)))) ;; Make ACCEPT work inside WITH-INPUT-FROM-STRING diff --git a/clim/basic-translators.lisp b/clim/basic-translators.lisp index ac08745e..15532910 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.3 92/02/24 13:06:55 cer Exp $ +;; $fiHeader: basic-translators.lisp,v 1.4 92/03/04 16:21:08 cer Exp $ (in-package :clim-internals) @@ -153,3 +153,42 @@ (with-presentation-type-parameters (input-editor context-type) (history-replace-input history stream element) (queue-rescan stream ':activation)))) + + +;; Display a menu of completions +(define-presentation-action menu-of-completions + (blank-area completer global-command-table + :gesture :menu + :documentation "Menu of completions") + (context-type window) + (with-presentation-type-parameters (completer context-type) + (multiple-value-bind (string success object nmatches possibilities) + (funcall function prefix :possibilities) + (declare (ignore string object success)) + (unless (or (= nmatches 0) (null possibilities)) + ;;--- Just using the first non-COMPLETER context type is far too simplistic + (let ((type (evacuate-list + (input-context-type (second *input-context*))))) + (labels ((print-possibility (possibility stream) + (cond (possibility-printer + (funcall possibility-printer possibility type stream)) + (type + (present (second possibility) type :stream stream)) + (t + (format stream "~A" (first possibility))))) + (menu-choose-body (stream presentation-type) + (declare (ignore presentation-type)) + (formatting-table (stream :multiple-columns t) + (dolist (possibility possibilities) + (formatting-row (stream) + (formatting-cell (stream) + (print-possibility possibility stream))))))) + (declare (dynamic-extent #'print-possibility #'menu-choose-body)) + (with-menu (menu window) + #-Silica (setf (window-label menu) "Menu of completions") + (with-end-of-line-action (menu :allow) + (let ((object + (menu-choose-from-drawer menu type #'menu-choose-body))) + (when object + (presentation-replace-input stream object type +textual-view+ + :buffer-start location :rescan t))))))))))) diff --git a/clim/clim-defs.lisp b/clim/clim-defs.lisp index ebd45ead..53a5cefe 100644 --- a/clim/clim-defs.lisp +++ b/clim/clim-defs.lisp @@ -1,69 +1,43 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-defs.lisp,v 1.5 92/01/31 14:57:36 cer Exp $ +;; $fiHeader: clim-defs.lisp,v 1.6 92/02/24 13:06:56 cer Exp $ (in-package :clim-internals) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. Portions copyright (c) 1988, 1989, 1990 International Lisp Associates." -(defun-inline position-translate (point dx dy) - (values (+ (point-x point) dx) - (+ (point-y point) dy))) - -(defun-inline position-translate* (x y dx dy) - (values (+ x dx) - (+ y dy))) - -(defmacro translate-positions (x-delta y-delta &body coordinate-pairs) +;; POSITIONS is a list of pairs of numbers. +;; No assumptions are made about the types of the numbers. +(defmacro translate-positions (x-delta y-delta &body positions) (once-only (x-delta y-delta) `(progn ,@(let ((forms nil)) - (dorest (pts coordinate-pairs cddr) + (dorest (pts positions cddr) (push `(incf ,(first pts) ,x-delta) forms) (push `(incf ,(second pts) ,y-delta) forms)) (nreverse forms))))) -#-Silica -;;--- Use COORDINATEs here... -(defmacro translate-fixnum-positions (x-delta y-delta &body coordinate-pairs) - (once-only (x-delta y-delta) - `(progn - ,@(let ((forms nil)) - (dorest (pts coordinate-pairs cddr) - (push `(setf ,(first pts) (the fixnum (+ ,(first pts) ,x-delta))) forms) - (push `(setf ,(second pts) (the fixnum (+ ,(second pts) ,y-delta))) forms)) - (nreverse forms))))) - -#+Silica -(defmacro translate-fixnum-positions (x-delta y-delta &body coordinate-pairs) - (once-only (x-delta y-delta) - `(progn - ,@(let ((forms nil)) - (dorest (pts coordinate-pairs cddr) - (push `(setf ,(first pts) (+ ,(first pts) ,x-delta)) forms) - (push `(setf ,(second pts) (+ ,(second pts) ,y-delta)) forms)) - (nreverse forms))))) - -(defun translate-point-sequence (x-delta y-delta points) - (let ((new-points (make-list (length points)))) - (do ((coords points (cddr coords)) - (new-coords new-points (cddr new-coords))) - ((null coords)) - (let ((x (first coords)) - (y (second coords))) +(defun translate-position-sequence (x-delta y-delta positions) + (let ((new-positions (make-list (length positions)))) + (do ((positions positions (cddr positions)) + (new-positions new-positions (cddr new-positions))) + ((null positions)) + (let ((x (first positions)) + (y (second positions))) (translate-positions x-delta y-delta x y) - (setf (first new-coords) x) - (setf (second new-coords) y))) - new-points)) + (setf (first new-positions) x) + (setf (second new-positions) y))) + new-positions)) ;; Destructive version of the above -(defun ntranslate-point-sequence (x-delta y-delta points) - (do ((coords points (cddr coords))) - ((null coords)) - (translate-positions x-delta y-delta (first coords) (second coords))) - points) +(defun ntranslate-position-sequence (x-delta y-delta positions) + (do ((positions positions (cddr positions))) + ((null positions)) + (translate-positions x-delta y-delta (first positions) (second positions))) + positions) + (defclass io-buffer () ((size :accessor io-buffer-size :initarg :size) @@ -102,10 +76,10 @@ (defmacro with-stream-cursor-position-saved ((stream) &body body) (let ((x '#:x) (y '#:y)) - `(multiple-value-bind (,x ,y) (stream-cursor-position* ,stream) + `(multiple-value-bind (,x ,y) (stream-cursor-position ,stream) (unwind-protect (progn ,@body) - (stream-set-cursor-position* ,stream ,x ,y))))) + (stream-set-cursor-position ,stream ,x ,y))))) (defmacro with-output-recording-options ((stream &key (draw nil draw-supplied) @@ -267,6 +241,46 @@ (when ,old-input-focus (stream-restore-input-focus ,stream ,old-input-focus)))))) + +(defmacro completing-from-suggestions ((stream &rest options) &body body) + (declare (arglist (stream &key partial-completers allow-any-input possibility-printer) + &body body)) + (declare (values object success string nmatches)) + #+Genera (declare (zwei:indentation 0 3 1 1)) + (let ((string '#:string) + (action '#:action)) + `(flet ((completing-from-suggestions-body (,string ,action) + (suggestion-completer (,string :action ,action + ,@(remove-keywords options '(:allow-any-input + :possibility-printer))) + ,@body))) + (declare (dynamic-extent #'completing-from-suggestions-body)) + (complete-input ,stream #'completing-from-suggestions-body ,@options)))) + +;; The second argument to the generator function is a function to be +;; called on a string (and object and presentation type) to suggest +;; that string. +(defmacro suggestion-completer ((string &key action partial-completers) &body body) + #+Genera (declare (zwei:indentation 0 3 1 1)) + (let ((function '#:function)) + `(flet ((suggestion-completer-body (,string ,function) + (declare (ignore ,string)) + (flet ((suggest (&rest args) + (declare (dynamic-extent args)) + (apply ,function args))) + nil ;workaround broken compilers + ,@body))) + (declare (dynamic-extent #'suggestion-completer-body)) + (complete-from-generator ,string #'suggestion-completer-body + ,partial-completers :action ,action)))) + +;; Very few lisp compilers seem to be able to handle the case where this top-level +;; macro is shadowed by the FLET in the continuation above. +#+Genera +(defmacro suggest (name &rest objects) + (declare (ignore name objects)) + (error "You cannot use ~S outside of ~S" 'suggest 'completing-from-suggestions)) + ;;; From MENUS.LISP ;;; For now, MENU-CHOOSE requires that you pass in a parent. diff --git a/clim/command-processor.lisp b/clim/command-processor.lisp index 38910527..b9fffe54 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.5 92/03/10 10:12:20 cer Exp Locker: cer $ +;; $fiHeader: command-processor.lisp,v 1.6 92/03/24 19:37:45 cer Exp $ (in-package :clim-internals) @@ -46,11 +46,10 @@ (with-accept-help ((:top-level-help #'command-help)) (multiple-value-bind (command final-delimiter) (invoke-command-name-parser-and-collect-1 - command-name arg-parser delimiter-parser stream) - ;;-- In the cad demo this ends up as NIL. Is that ok?? + command-name arg-parser delimiter-parser stream) (if (and final-delimiter (member final-delimiter *command-previewers* - :test #'keyboard-event-matches-gesture-name-p)) + :test #'keyboard-event-matches-gesture-name-p)) (with-input-editor-typeout (stream) (accept-values-command-parser command-name command-table @@ -126,8 +125,8 @@ (write-string (first possibility) stream) (let ((documentation (assoc (second possibility) keyword-documentation))) (when documentation - (multiple-value-bind (x y) (stream-cursor-position* stream) - (stream-set-cursor-position* stream (max 200 (+ x 20)) y) + (multiple-value-bind (x y) (stream-cursor-position stream) + (stream-set-cursor-position stream (max 200 (+ x 20)) y) (write-string (second documentation) stream))))))) (declare (dynamic-extent #'print-keyword)) (values (completing-from-suggestions (stream :possibility-printer #'print-keyword) @@ -396,7 +395,6 @@ (let ((command (lookup-keystroke-command-item keystroke command-table - :test #'keyboard-event-matches-gesture-name-p :numeric-argument numeric-arg))) (when (presentation-typep command command-type) (return-from menu-command-parser @@ -669,16 +667,14 @@ (command-parser *command-parser*) (command-unparser *command-unparser*) (partial-command-parser *partial-command-parser*) - (use-keystrokes nil) - (keystroke-test #'keyboard-event-matches-gesture-name-p)) + (use-keystrokes nil)) (if use-keystrokes (with-command-table-keystrokes (keystrokes command-table) (read-command-using-keystrokes command-table keystrokes :stream stream :command-parser command-parser :command-unparser command-unparser - :partial-command-parser partial-command-parser - :keystroke-test keystroke-test)) + :partial-command-parser partial-command-parser)) (let ((*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser)) @@ -691,8 +687,7 @@ &key (stream *query-io*) (command-parser *command-parser*) (command-unparser *command-unparser*) - (partial-command-parser *partial-command-parser*) - (keystroke-test #'keyboard-event-matches-gesture-name-p)) + (partial-command-parser *partial-command-parser*)) (let ((*command-parser* command-parser) (*command-unparser* command-unparser) (*partial-command-parser* partial-command-parser)) @@ -710,7 +705,6 @@ :stream stream :prompt nil)))) (if (keyboard-event-p command) (let ((command (lookup-keystroke-command-item command command-table - :test keystroke-test :numeric-argument numeric-arg))) (if (partial-command-p command) (funcall *partial-command-parser* @@ -802,7 +796,7 @@ (with-stack-list (type 'command-name ':command-table command-table) ;; Use a lower level function for speed (return-from document-presentation-to-command-translator - (call-presentation-generic-function present + (funcall-presentation-generic-function present command-name type stream +textual-view+)))))) (format stream "Command translator ~S" (presentation-translator-name translator)) (values)) diff --git a/clim/command.lisp b/clim/command.lisp index 2e41a621..de9983f1 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.5 92/03/06 09:08:41 cer Exp $ +;; $fiHeader: command.lisp,v 1.6 92/03/10 10:12:22 cer Exp $ (in-package :clim-internals) @@ -195,7 +195,7 @@ (nstring-capitalize (nsubstitute #\Space #\- name)))) (defun add-command-to-command-table (command-name command-table - &key name menu keystroke (test #'gesture-eql) (errorp t)) + &key name menu keystroke (errorp t)) (check-type command-name symbol) (setq command-table (find-command-table command-table)) (when (eq name t) @@ -230,7 +230,7 @@ menu-options)) (keystroke (add-keystroke-to-command-table command-table keystroke ':command command-name - :test test :errorp errorp))))) + :errorp errorp))))) command-name) (defun remove-command-from-command-table (command-name command-table &key (errorp t)) @@ -400,7 +400,10 @@ (check-type type (member :command :function :menu :divider)) (when keystroke (assert (keyboard-gesture-spec-p keystroke) (keystroke) - "~S is not a keyboard gesture spec" keystroke)) + "~S is not a keyboard gesture spec" keystroke) + (multiple-value-bind (keysym modifiers) + (decode-gesture-spec keystroke) + (setq keystroke (cons keysym modifiers)))) (check-type documentation (or string null)) (setq command-table (find-command-table command-table)) (let ((old-item (and string (find-menu-item string command-table :errorp nil)))) @@ -674,30 +677,29 @@ ;;; Keystroke accelerators (defun add-keystroke-to-command-table (command-table keystroke type value - &key documentation (test #'gesture-eql) (errorp t)) + &key documentation (errorp t)) (assert (keyboard-gesture-spec-p keystroke) (keystroke) "~S is not a keyboard gesture spec" keystroke) (check-type type (member :command :function :menu)) (check-type documentation (or string null)) (setq command-table (find-command-table command-table)) (let ((old-item (find-keystroke-item keystroke command-table - :test test :errorp nil))) + :test #'gesture-spec-eql :errorp nil))) (when old-item (when errorp (cerror "Remove the keystroke item and proceed" 'command-already-present :format-string "Keystroke item ~S already present in ~S" :format-args (list keystroke command-table))) - (remove-keystroke-from-command-table command-table keystroke :test test))) + (remove-keystroke-from-command-table command-table keystroke))) (add-menu-item-to-command-table command-table nil type value :documentation documentation :keystroke keystroke :errorp nil)) -(defun remove-keystroke-from-command-table (command-table keystroke - &key (test #'gesture-eql) (errorp t)) +(defun remove-keystroke-from-command-table (command-table keystroke &key (errorp t)) (setq command-table (find-command-table command-table)) (with-slots (menu keystrokes) command-table - (let ((index (position keystroke menu :key #'second :test test))) + (let ((index (position keystroke menu :key #'second :test #'gesture-spec-eql))) (cond (index (let ((element (aref menu index))) ;; Don't remove the whole item if there's a menu-name, @@ -722,11 +724,12 @@ (apply function entry))) (slot-value (find-command-table command-table) 'menu))) -(defun find-keystroke-item (keystroke command-table &key (test #'gesture-eql) (errorp t)) +(defun find-keystroke-item (keystroke command-table + &key (test #'keyboard-event-matches-gesture-name-p) (errorp t)) (declare (values menu-item command-table)) (let* ((command-table (find-command-table command-table)) (entry (block find-entry - ;; Do it the hard way so that GESTURE-EQL doesn't see NILs + ;; Do it the hard way so that GESTURE-SPEC-EQL doesn't see NILs (map nil #'(lambda (entry) (when (and (second entry) (funcall test keystroke (second entry))) @@ -740,7 +743,8 @@ :format-string "Keystroke ~S has no menu item present in ~S" :format-args (list keystroke command-table)))) -(defun lookup-keystroke-item (keystroke command-table &key (test #'gesture-eql)) +(defun lookup-keystroke-item (keystroke command-table + &key (test #'keyboard-event-matches-gesture-name-p)) (declare (values menu-item command-table)) (labels ((map-menu (command-table) (map nil #'(lambda (entry) @@ -764,7 +768,8 @@ ;; Return a command associated with a keystroke iff it is enabled. ;; Otherwise, return the keystroke keystroke. (defun lookup-keystroke-command-item (keystroke command-table - &key (test #'gesture-eql) (numeric-argument 1)) + &key (test #'keyboard-event-matches-gesture-name-p) + (numeric-argument 1)) (let ((item (lookup-keystroke-item keystroke command-table :test test))) (when item (let* ((type (command-menu-item-type item)) diff --git a/clim/completer.lisp b/clim/completer.lisp index b7adc522..b4307264 100644 --- a/clim/completer.lisp +++ b/clim/completer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: completer.lisp,v 1.4 92/03/04 16:21:17 cer Exp $ +;; $fiHeader: completer.lisp,v 1.5 92/03/10 10:12:24 cer Exp $ (in-package :clim-internals) @@ -23,6 +23,17 @@ (defvar *magic-completion-gestures* (append *completion-gestures* *help-gestures* *possibilities-gestures*)) +(define-presentation-type completer (&key stream function possibility-printer + prefix location)) + +(define-presentation-method presentation-typep (object (type completer)) + (declare (ignore object)) + nil) + +(define-presentation-method presentation-subtypep ((subtype completer) supertype) + (declare (ignore supertype)) + t) + (defun complete-input (stream function &key partial-completers allow-any-input possibility-printer (help-displays-possibilities t)) @@ -58,8 +69,15 @@ (loop ;; Maybe these, as well as TOKEN and CH should be LET inside the loop... (setq unread nil return nil extend nil) - (setq token (read-token stream)) - (setq ch (read-gesture :stream stream)) ;don't care about wait functions + (with-input-context (`(completer :stream ,stream + :function ,function + :possibility-printer ,possibility-printer + :prefix ,stuff-so-far + :location ,location)) () + (progn + (setq token (read-token stream)) + (setq ch (read-gesture :stream stream))) + (t (beep))) (extend-vector stuff-so-far token) (cond ((null ch) (error "Null ch?")) @@ -207,45 +225,6 @@ (formatting-cell (stream) (print-possibility possibility stream))))))))))))) -(defmacro completing-from-suggestions ((stream &rest options) &body body) - (declare (arglist (stream &key partial-completers allow-any-input possibility-printer) - &body body)) - (declare (values object success string nmatches)) - #+Genera (declare (zwei:indentation 0 3 1 1)) - (let ((string '#:string) - (action '#:action)) - `(flet ((completing-from-suggestions-body (,string ,action) - (suggestion-completer (,string :action ,action - ,@(remove-keywords options '(:allow-any-input - :possibility-printer))) - ,@body))) - (declare (dynamic-extent #'completing-from-suggestions-body)) - (complete-input ,stream #'completing-from-suggestions-body ,@options)))) - -;; The second argument to the generator function is a function to be -;; called on a string (and object and presentation type) to suggest -;; that string. -(defmacro suggestion-completer ((string &key action partial-completers) &body body) - #+Genera (declare (zwei:indentation 0 3 1 1)) - (let ((function '#:function)) - `(flet ((suggestion-completer-body (,string ,function) - (declare (ignore ,string)) - (flet ((suggest (&rest args) - (declare (dynamic-extent args)) - (apply ,function args))) - nil ;workaround broken compilers - ,@body))) - (declare (dynamic-extent #'suggestion-completer-body)) - (complete-from-generator ,string #'suggestion-completer-body - ,partial-completers :action ,action)))) - -;; Very few lisp compilers seem to be able to handle the case where this top-level -;; macro is shadowed by the FLET in the continuation above. -#+Genera -(defmacro suggest (name &rest objects) - (declare (ignore name objects)) - (error "You cannot use ~S outside of ~S" 'suggest 'completing-from-suggestions)) - (defvar *null-object* '#:null) ;; Complete STRING chunk-wise against the completion possibilities in the diff --git a/clim/coordinate-sorted-set.lisp b/clim/coordinate-sorted-set.lisp index 5bb414b2..4b35b237 100644 --- a/clim/coordinate-sorted-set.lisp +++ b/clim/coordinate-sorted-set.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: coordinate-sorted-set.lisp,v 1.2 92/02/24 13:07:10 cer Exp $ +;; $fiHeader: coordinate-sorted-set.lisp,v 1.3 92/03/04 16:21:18 cer Exp $ (in-package :clim-internals) @@ -19,7 +19,7 @@ ;;; map-over-output-records-overlapping-region: ;;; (function record region ;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) -;;; map-over-output-records-containing-point*: +;;; map-over-output-records-containing-position: ;;; (function record x y ;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) @@ -27,7 +27,7 @@ (output-record-mixin output-record-element-mixin output-record) ((coordinate-sorted-set) ;a simple vector, by gawd (fill-pointer :initform 0) - (tallest-box-height :initform 0))) + (tallest-box-height :initform (coordinate 0)))) (defmethod initialize-instance :after ((record standard-tree-output-record) &key (size 200)) @@ -57,7 +57,7 @@ (defmethod clear-output-record ((record standard-tree-output-record)) (with-slots (coordinate-sorted-set fill-pointer tallest-box-height) record - (setf tallest-box-height 0) + (setf tallest-box-height (coordinate 0)) ;; Release pointers to objects (fill coordinate-sorted-set nil :start 0 :end fill-pointer) (setf fill-pointer 0))) @@ -67,7 +67,7 @@ (let ((vector coordinate-sorted-set) (fp fill-pointer)) (declare (type simple-vector vector) #+Genera (sys:array-register vector)) - (declare (fixnum fp)) + (declare (type fixnum fp)) (maxf tallest-box-height (bounding-rectangle-height child)) (with-bounding-rectangle* (left top right bottom) child (declare (ignore left top)) @@ -86,7 +86,7 @@ (simple-vector-push-extend child vector fp 200)) (let ((index (coordinate-sorted-set-index-for-position vector right bottom 0 fp))) - (declare (fixnum index)) + (declare (type fixnum index)) ;; Make sure that the new child comes after any child it overlaps ;; so that replaying happens in the right order. (loop @@ -110,7 +110,8 @@ ;; Shift the whole vector downward (do ((i (the fixnum index) (1+ i))) ((= i new-fp)) - (declare (fixnum i) (optimize (speed 3) (safety 0))) + (declare (type fixnum i) + (optimize (speed 3) (safety 0))) (setf (svref vector i) (svref vector (1+ i))))) (setf fill-pointer new-fp) t)) @@ -131,17 +132,17 @@ (dovector ((child index) vector :start 0 :end length :simple-p t) (apply function child continuation-args)) (with-bounding-rectangle* (left1 top1 right1 bottom1) region - (translate-fixnum-positions x-offset y-offset left1 top1 right1 bottom1) + (translate-coordinates x-offset y-offset left1 top1 right1 bottom1) (let ((start (coordinate-sorted-set-index-for-position vector 0 top1 0 length)) (limit (+ bottom1 (slot-value record 'tallest-box-height)))) - (declare (fixnum start limit)) + (declare (type fixnum start limit)) ;; Subtract out the record offset from the region, to make comparison fair (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) left1 top1 right1 bottom1)) + (output-record-position record) + (translate-coordinates (- xoff) (- yoff) left1 top1 right1 bottom1)) (do ((index start (the fixnum (1+ (the fixnum index))))) ((= (the fixnum index) length)) - (declare (fixnum index)) + (declare (type fixnum index)) (let ((child (svref vector index))) (with-bounding-rectangle* (left2 top2 right2 bottom2) child (when (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 @@ -150,13 +151,13 @@ (when (> bottom2 limit) (return nil)))))))))) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (record standard-tree-output-record) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (dynamic-extent function continuation-args)) (declare (type coordinate x-offset y-offset)) (declare (optimize (safety 0))) - (translate-fixnum-positions x-offset y-offset x y) + (translate-coordinates x-offset y-offset x y) (let ((vector (slot-value record 'coordinate-sorted-set)) (length (slot-value record 'fill-pointer)) (bound (slot-value record 'tallest-box-height))) @@ -164,16 +165,16 @@ #+Genera (sys:array-register vector)) (let ((end (coordinate-sorted-set-index-for-position vector 0 (+ y bound 1) 0 length)) (limit (- y bound))) - (declare (fixnum end limit)) + (declare (type fixnum end limit)) (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) x y)) + (output-record-position record) + (translate-coordinates (- xoff) (- yoff) x y)) (do ((index (min (1- length) end) (the fixnum (1- (the fixnum index))))) ((< (the fixnum index) 0)) - (declare (fixnum index)) + (declare (type fixnum index)) (let ((child (svref vector index))) (with-bounding-rectangle* (left top right bottom) child - (when (ltrb-contains-point*-p left top right bottom x y) + (when (ltrb-contains-position-p left top right bottom x y) (apply function child continuation-args)) (when (< bottom limit) (return nil)))))))) @@ -187,7 +188,7 @@ ;; Binary search to find where this one goes. (let ((search-index (coordinate-sorted-set-index-for-position vector right bottom 0 fill-pointer))) - (declare (fixnum search-index)) + (declare (type fixnum search-index)) ;; Search back over things in the same place. (when (< search-index fill-pointer) (dovector ((record index) vector :start 0 :end (1+ search-index) @@ -215,7 +216,7 @@ (declare (optimize (speed 3) (safety 0))) (let ((below start) (above end)) - (declare (fixnum below above)) + (declare (type fixnum below above)) (assert (<= below above)) ;Binary search will loop otherwise. (let (#+(or Genera Minima) (vector vector)) #+Genera (declare (sys:array-register vector)) diff --git a/clim/cursor.lisp b/clim/cursor.lisp index 535e9ff6..7697518f 100644 --- a/clim/cursor.lisp +++ b/clim/cursor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cursor.lisp,v 1.7 92/03/04 16:21:20 cer Exp Locker: cer $ +;; $fiHeader: cursor.lisp,v 1.8 92/04/03 12:04:32 cer Exp Locker: cer $ (in-package :clim-internals) @@ -30,6 +30,7 @@ ;;; to go through to the port level, where an appropriate host-window-system thing ;;; may be manipulated. Should this be unified with the mouse cursor stuff? +;;--- The positions here should be a COORDINATE pair, no? (defclass text-cursor (cursor #+Silica region) ((x :initarg :x) @@ -60,12 +61,12 @@ (defmethod (setf cursor-stream) (new-value (cursor text-cursor)) (setf (slot-value cursor 'stream) new-value)) -(defmethod cursor-position* ((cursor text-cursor)) +(defmethod cursor-position ((cursor text-cursor)) (with-slots (x y) cursor (values x y))) #-Silica -(defmethod cursor-set-position* ((cursor text-cursor) nx ny) +(defmethod cursor-set-position ((cursor text-cursor) nx ny) (with-slots (x y visibility) cursor (unless (and (= x nx) (= y ny)) @@ -76,10 +77,20 @@ (draw-cursor cursor T))))) #+Silica -(defmethod cursor-set-position* ((cursor text-cursor) nx ny) +(defmethod cursor-set-position ((cursor text-cursor) nx ny) (with-slots (x y visibility) cursor (setf x nx y ny))) +#+CLIM-1-compatibility +(define-compatibility-function (cursor-position* cursor-position) + (cursor) + (cursor-position cursor)) + +#+CLIM-1-compatibility +(define-compatibility-function (cursor-set-position* cursor-set-position) + (cursor x y) + (cursor-set-position cursor x y)) + (defmethod (setf cursor-state) (new-state (cursor text-cursor)) (multiple-value-bind (active state focus) (decode-cursor-flags (slot-value cursor 'flags)) @@ -206,14 +217,13 @@ (with-output-recording-options (stream :record nil) (draw-line-internal stream 0 0 - ;;--- gack - (the fixnum x) (the fixnum (+ y height)) - (the fixnum (+ x 2)) (the fixnum (+ y height 2)) + (the coordinate x) (the coordinate (+ y height)) + (the coordinate (+ x 2)) (the coordinate (+ y height 2)) (if on-p +foreground-ink+ +background-ink+) +highlighting-line-style+) (draw-line-internal stream 0 0 - (the fixnum x) (the fixnum (+ y height)) - (the fixnum (- x 2)) (the fixnum (+ y height 2)) + (the coordinate x) (the coordinate (+ y height)) + (the coordinate (- x 2)) (the coordinate (+ y height 2)) (if on-p +foreground-ink+ +background-ink+) +highlighting-line-style+)) ;; --- do we really want to do this here?? (force-output stream))))) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index 282f9da2..64b8a432 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1990 by Xerox Corporations. All rights reserved. ;;; -;; $fiHeader: db-stream.lisp,v 1.10 92/03/24 19:37:47 cer Exp Locker: cer $ +;; $fiHeader: db-stream.lisp,v 1.11 92/04/10 14:26:58 cer Exp Locker: cer $ (in-package :clim-internals) @@ -32,6 +32,7 @@ ;;; CLIM stream sheets and panes ;;--- How to keep PANE-BACKGROUND/FOREGROUND in sync with the medium? +;;--- I'm not convinced that including WINDOW-STREAM here is right... (defclass clim-stream-sheet (window-stream ;includes output recording pane @@ -193,8 +194,8 @@ (defclass interactor-pane (clim-stream-pane) ()) (defclass application-pane (clim-stream-pane) ()) -(defclass pointer-documentation-pane (clim-stream-pane) ()) (defclass command-menu-pane (clim-stream-pane) ()) +(defclass pointer-documentation-pane (clim-stream-pane) ()) (defmethod compose-space :before ((pane command-menu-pane) &key width height) (declare (ignore width height)) @@ -227,8 +228,8 @@ (setq pane `(vertically () ,pane (make-pane 'label-pane - :text ,label - :max-width +fill+)))) + :text ,label + :max-width +fill+)))) `(outlining (:thickness 1) ,pane)))) @@ -247,7 +248,7 @@ (clear-output-history stream) (window-erase-viewport stream) (when (extended-output-stream-p stream) ;can we assume this? - (stream-set-cursor-position* stream 0 0) + (stream-set-cursor-position stream 0 0) (setf (stream-baseline stream) 0 (stream-current-line-height stream) 0)) ;; Flush the old mouse position relative to this window @@ -272,8 +273,7 @@ (with-sheet-medium (medium stream) (multiple-value-call #'draw-rectangle* medium - (bounding-rectangle* (or (pane-viewport stream) - stream)) + (bounding-rectangle* (or (pane-viewport stream) stream)) :ink +background-ink+))) (defmethod window-expose ((stream clim-stream-sheet)) @@ -294,10 +294,10 @@ (defmethod window-viewport ((stream clim-stream-sheet)) (pane-viewport-region stream)) -(defmethod window-viewport-position* ((stream clim-stream-sheet)) - (bounding-rectangle-position* (pane-viewport-region stream))) +(defmethod window-viewport-position ((stream clim-stream-sheet)) + (bounding-rectangle-position (pane-viewport-region stream))) -(defmethod window-set-viewport-position* ((stream clim-stream-sheet) x y) +(defmethod window-set-viewport-position ((stream clim-stream-sheet) x y) (scroll-extent stream :x x :y y)) (defmethod window-inside-size ((stream clim-stream-sheet)) @@ -326,20 +326,11 @@ (defun beep (&optional (stream *standard-output*)) (port-beep (port stream) stream)) -;; This is called by OUTPUT-RECORDING-MIXIN's whopper on set-viewport-position*. +;; This is called by OUTPUT-RECORDING-MIXIN's whopper on set-viewport-position. ;; It shifts a region of the "host screen" that's visible to some other visible ;; location. It does NOT do any cleaning up after itself. It does not side-effect ;; the output history of the window. It calls COPY-AREA whose contract is to ;; do the above, the whole above, and nothing but the above. - -;;;--- -(defmethod window-shift-visible-region ((window t) - old-left old-top old-right old-bottom - new-left new-top new-right - new-bottom) - (declare (ignore old-left old-top old-right old-bottom new-left new-top new-right new-bottom)) - nil) - (defmethod window-shift-visible-region ((window clim-stream-sheet) old-left old-top old-right old-bottom new-left new-top new-right new-bottom) @@ -372,15 +363,23 @@ (let ((width (- stream-width (abs delta-x))) (height (- stream-height (abs delta-y)))) (multiple-value-bind (ml mt) - (values 0 0) + (values (coordinate 0) (coordinate 0)) (declare (type coordinate ml mt)) - (translate-fixnum-positions ml mt from-x from-y) + (translate-coordinates ml mt from-x from-y) (let ((tf (sheet-transformation window))) (multiple-value-call #'copy-area window - (untransform-point* tf from-x from-y) - (untransform-point* tf (+ from-x width) (+ from-y height)) - (untransform-point* tf (+ from-x delta-x) (+ from-y delta-y)))))))))) + (untransform-position tf from-x from-y) + (untransform-position tf (+ from-x width) (+ from-y height)) + (untransform-position tf (+ from-x delta-x) (+ from-y delta-y)))))))))) + +;;;--- Why do we need this? +(defmethod window-shift-visible-region ((window t) + old-left old-top old-right old-bottom + new-left new-top new-right new-bottom) + (declare (ignore old-left old-top old-right old-bottom + new-left new-top new-right new-bottom)) + nil) #+Genera (defgeneric stream-compatible-inside-size (window) diff --git a/clim/dragging-output.lisp b/clim/dragging-output.lisp index 1b7cca16..6ccbe00f 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.5 92/03/04 16:21:30 cer Exp $ +;; $fiHeader: dragging-output.lisp,v 1.6 92/03/10 10:12:32 cer Exp $ (in-package :clim-internals) @@ -29,14 +29,14 @@ ;; Clipping region for repainting the damaged region (region (bounding-rectangle output-record))) (multiple-value-bind (initial-x initial-y) - (stream-pointer-position* stream) + (stream-pointer-position stream) (declare (type coordinate initial-x initial-y)) (multiple-value-bind (x-offset y-offset) (convert-from-relative-to-absolute-coordinates stream (output-record-parent output-record)) (declare (type coordinate x-offset y-offset)) (multiple-value-bind (record-x record-y) - (bounding-rectangle-position* output-record) + (bounding-rectangle-position output-record) ;; Deltas are the position of the mouse in the local coordinate ;; system of the record (setq delta-x (- initial-x record-x) @@ -52,7 +52,7 @@ ;; because the user can be moving the pointer really fast, ;; causing FINISH to be called on coordinates which are ;; "before" the values of LAST-X/Y. - (output-record-set-position* output-record (- x delta-x) (- y delta-y)) + (output-record-set-position output-record (- x delta-x) (- y delta-y)) (when parent (add-output-record output-record parent) (tree-recompute-extent output-record)) @@ -78,9 +78,11 @@ (funcall erase output-record stream))) (setq last-x x last-y y) ;; Remember the space the record used to occupy - (setq region (bounding-rectangle output-record region)) + (with-bounding-rectangle* (rl rt rr rb) output-record + (translate-coordinates x-offset y-offset rl rt rr rb) + (bounding-rectangle-set-edges region rl rt rr rb)) ;; Move the record - (output-record-set-position* output-record (- x delta-x) (- y delta-y)) + (output-record-set-position output-record (- x delta-x) (- y delta-y)) ;; Replay the region it used to live in, and then replay ;; the record in its new home. (when repaint diff --git a/clim/excl-presentations.lisp b/clim/excl-presentations.lisp index a4087cdb..faa9407b 100644 --- a/clim/excl-presentations.lisp +++ b/clim/excl-presentations.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: excl-presentations.lisp,v 1.7 92/03/06 14:17:45 cer Exp Locker: cer $ +;; $fiHeader: excl-presentations.lisp,v 1.8 92/03/09 17:41:46 cer Exp $ (in-package :clim-internals) @@ -33,7 +33,7 @@ nil) (defclass standard-excl-presentation (standard-presentation) - () + () (:default-initargs :single-box nil)) (defmethod initialize-instance :around ((rec standard-excl-presentation) @@ -41,14 +41,14 @@ &key (type nil type-p) object) (when (and - ;; (null type-p) - ;;--- If its a lisp kind of object then we want to generate expressions - ;;--- but in the lisp thats all we generate to there - ;;--- should be a problem - t) + ;; (null type-p) + ;;--- If its a lisp kind of object then we want to generate expressions + ;;--- but in the lisp thats all we generate to there + ;;--- should be a problem + t) (setf (getf args :type) - #-ignore 'expression - #+ignore (presentation-type-of object))) + #-ignore 'expression + #+ignore (presentation-type-of object))) (apply #'call-next-method rec args)) (defmethod excl::stream-presentation-record-type ((stream output-recording-mixin)) @@ -60,19 +60,18 @@ (defmethod excl::set-io-record-pos1 ((stream output-recording-mixin) record) (let ((current-output-position - (stream-output-history-position stream))) + (stream-output-history-position stream))) (multiple-value-bind (px py) - (point-position* current-output-position) + (point-position current-output-position) (declare (type coordinate px py)) (multiple-value-bind (cursor-x cursor-y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate cursor-x cursor-y)) (multiple-value-bind (x y) - (position-difference* cursor-x cursor-y px py) - (output-record-set-start-cursor-position* record x y) + (position-difference cursor-x cursor-y px py) + (output-record-set-start-cursor-position record x y) (stream-close-text-output-record stream) - (push (list (stream-current-output-record stream) - px py) + (push (list (stream-current-output-record stream) px py) *gross-output-history-stack*) (setf (point-x current-output-position) cursor-x (point-y current-output-position) cursor-y @@ -81,22 +80,19 @@ (defmethod excl::set-io-record-pos2 ((stream output-recording-mixin) record) (stream-close-text-output-record stream) (let ((current-output-position - (stream-output-history-position stream))) - (destructuring-bind - (parent abs-x abs-y) (pop *gross-output-history-stack*) - + (stream-output-history-position stream))) + (destructuring-bind (parent abs-x abs-y) + (pop *gross-output-history-stack*) (unless parent (setq parent (stream-output-history stream))) - (multiple-value-bind (end-x end-y) - (stream-cursor-position* stream) + (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))) + (output-record-set-end-cursor-position + record (- end-x abs-x) (- end-y abs-y))) (setf (point-x current-output-position) abs-x (point-y current-output-position) abs-y (stream-current-output-record stream) parent) - #+ignore(print (list parent abs-x abs-y) excl:*initial-terminal-io*) (when parent (add-output-record record parent))))) @@ -106,14 +102,14 @@ ;;; Somehow this does not integrate with the CLIM mechanism (defmethod excl::stream-set-font ((stm output-protocol) font-spec) (setf (medium-text-style stm) - (etypecase font-spec - ((nil) - (pop *font-stack-hack*))) - (character - (push (medium-text-style stm) *font-stack-hack*) - (ecase (char-downcase font-spec) - (#\r (window-stream-regular-font stm)) - (#\b (window-stream-bold-font stm)) - (#\i (window-stream-italic-font stm)) - (#\j (window-stream-bold-italic-font stm)))))) + (etypecase font-spec + ((nil) + (pop *font-stack-hack*)) + (character + (push (medium-text-style stm) *font-stack-hack*) + (ecase (char-downcase font-spec) + (#\r (window-stream-regular-font stm)) + (#\b (window-stream-bold-font stm)) + (#\i (window-stream-italic-font stm)) + (#\j (window-stream-bold-italic-font stm))))))) diff --git a/clim/frames.lisp b/clim/frames.lisp index 718117b7..c2643c77 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; ;; $fiHeader: frames.lisp,v 1.12 92/04/03 12:04:34 cer Exp Locker: cer $ +;; $fiHeader: frames.lisp,v 1.11 92/03/24 19:37:49 cer Exp $ + (in-package :clim-internals) @@ -13,7 +14,6 @@ ;;--- We should add an input event-queue to frames, so that other ;;--- processes can queue up requests. This queue should be managed ;;--- like other event queues. It can contains "command" events, too. - (defclass standard-application-frame (application-frame) ;;--- Is it right for these to be SHEET accessors?? ((name :initarg :name :accessor frame-name) @@ -41,15 +41,13 @@ :reader frame-current-layout) (default-size :initform nil :initarg :default-size) (shell :accessor frame-shell) - (pointer-documentationp - :initarg :pointer-documentation - :reader frame-pointer-documentationp) + (pointer-documentation-p :initarg :pointer-documentation + :reader frame-pointer-documentation-p) (pointer-documentation-pane :initform nil) (properties :initform nil :initarg :properties :accessor frame-properties)) - (:default-initargs - :pointer-documentation nil - :top-level 'default-frame-top-level)) + (:default-initargs :pointer-documentation nil + :top-level 'default-frame-top-level)) (defmethod port ((frame standard-application-frame)) (port (frame-manager frame))) @@ -57,29 +55,24 @@ (defmethod graft ((frame standard-application-frame)) (graft (frame-manager frame))) - -(defmethod frame-pointer-documentation-output ((frame standard-application-frame)) - (with-slots (pointer-documentation-pane) frame - pointer-documentation-pane)) - #+CLIM-1-compatibility (define-compatibility-function (frame-top-level-window frame-top-level-sheet) (frame) (frame-top-level-sheet frame)) (defmethod initialize-instance :after ((frame standard-application-frame) - &rest args &key - frame-manager - (parent frame-manager)) + &rest args + &key frame-manager + (parent frame-manager)) (declare (ignore args)) (let ((frame-manager - (etypecase parent - (null (find-frame-manager)) - (list (apply #'find-frame-manager parent)) - (frame-manager parent) - (application-frame (frame-manager parent)) - (port (find-frame-manager :port parent)) - (sheet (frame-manager (pane-frame parent)))))) + (etypecase parent + (null (find-frame-manager)) + (list (apply #'find-frame-manager parent)) + (frame-manager parent) + (application-frame (frame-manager parent)) + (port (find-frame-manager :port parent)) + (sheet (frame-manager (pane-frame parent)))))) (setf (slot-value frame 'frame-manager) frame-manager) (adopt-frame frame-manager frame))) @@ -103,8 +96,7 @@ (defmacro define-application-frame (name superclasses slots &rest options) #+Genera (declare (zwei:indentation 1 25 2 3 3 1)) (with-warnings-for-definition name define-application-frame - (let (pane panes layout top-level menu-bar - pointer-documentation + (let (pane panes layout top-level menu-bar pointer-documentation command-definer command-table disabled-commands) (macrolet ((extract (name keyword default &optional (pair t)) `(let ((entry (assoc ',keyword options))) @@ -119,14 +111,13 @@ `((assert (listp (rest entry)) (entry) "The remainder of ~S must be a list" entry) (setq ,name (rest entry) - options (delete entry - options))))))))) - (extract pointer-documentation :pointer-documentation nil) + options (delete entry options))))))))) (extract pane :pane nil) (extract panes :panes nil nil) (extract layout :layout nil nil) (extract top-level :top-level '(default-frame-top-level)) (extract menu-bar :menu-bar t) + (extract pointer-documentation :pointer-documentation nil) (extract command-definer :command-definer t) (extract command-table :command-table t) (extract disabled-commands :disabled-commands nil)) @@ -175,8 +166,8 @@ (defclass ,name ,superclasses ,slots ,@options (:default-initargs - :pointer-documentation ',pointer-documentation - :menu-bar ',menu-bar + :menu-bar ',menu-bar + :pointer-documentation ',pointer-documentation ,@(and command-table `(:command-table ',(car command-table))) ,@(and top-level `(:top-level ',top-level)) ,@(and panes `(:pane-constructors ,pane-constructors)) @@ -378,16 +369,13 @@ (setq width (space-requirement-width sr) height (space-requirement-height sr)))) ;;--- Don't bother with this if the size didn't change? - ;;-- This is wrong We want to resize the top level sheet - ;;; (allocate-space panes width height) (resize-sheet* - (or (frame-top-level-sheet frame) - panes) - width height - ;;-- we need to do this because if the wm has changed the sheet - ;; then this will not change its size but we need it to start - ;; the layout stuff - :force t)))) + (or (frame-top-level-sheet frame) panes) + width height + ;; We need to do this because if the WM has changed the sheet + ;; then this will not change its size but we need it to start + ;; the layout stuff + :force t)))) (defmethod (setf frame-current-layout) (nv (frame standard-application-frame)) (unless (eq (frame-current-layout frame) nv) @@ -549,34 +537,33 @@ (loop (catch 'layout-changed (let* ((*standard-output* - (or (frame-standard-output frame) *standard-output*)) + (or (frame-standard-output frame) *standard-output*)) (*standard-input* - (or (frame-standard-input frame) *standard-output*)) + (or (frame-standard-input frame) *standard-output*)) (*query-io* - (or (frame-query-io frame) *standard-input*)) + (or (frame-query-io frame) *standard-input*)) (*error-output* - (or (frame-error-output frame) *standard-output*)) + (or (frame-error-output frame) *standard-output*)) (interactor - (not (null (find-frame-pane-of-type frame 'interactor-pane)))) + (not (null (find-frame-pane-of-type frame 'interactor-pane)))) (*command-parser* - (or command-parser - (if interactor - #'command-line-command-parser - #'menu-command-parser))) + (or command-parser + (if interactor + #'command-line-command-parser + #'menu-command-parser))) (*command-unparser* - (or command-unparser - #'command-line-command-unparser)) + (or command-unparser + #'command-line-command-unparser)) (*partial-command-parser* - (or partial-command-parser - (if interactor - #'command-line-read-remaining-arguments-for-partial-command - #'menu-read-remaining-arguments-for-partial-command))) + (or partial-command-parser + (if interactor + #'command-line-read-remaining-arguments-for-partial-command + #'menu-read-remaining-arguments-for-partial-command))) (command-stream - (typecase *standard-input* - (output-protocol-mixin - *standard-input*) - (t - (frame-top-level-sheet frame))))) + ;;--- I'm not really convinced that this is right + (typecase *standard-input* + (output-protocol-mixin *standard-input*) + (t (frame-top-level-sheet frame))))) #+Allegro (unless (typep *standard-input* 'excl::bidirectional-terminal-stream) (assert (port *standard-input*))) @@ -663,23 +650,23 @@ (cond ((pane-display-function pane) (let* ((ir (slot-value pane 'incremental-redisplay-p)) (redisplay-p (if (listp ir) (first ir) ir)) - (check-overlapping (or (atom ir) ;default is T + (check-overlapping (or (atom ir) ;default is T (getf (rest ir) :check-overlapping t)))) (with-simple-restart (nil "Skip redisplaying pane ~S" pane) (loop (with-simple-restart (nil "Retry displaying pane ~S" pane) (return (let ((redisplay-record - (and redisplay-p - (let ((history (stream-output-history pane))) - (when history - #+compulsive-redisplay - (when (> (output-record-count history) 1) - (cerror "Clear the output history and proceed" - "There is more than one element in this redisplay pane") - (window-clear pane)) - (unless (zerop (output-record-count history)) - (output-record-element history 0))))))) + (and redisplay-p + (let ((history (stream-output-history pane))) + (when history + #+compulsive-redisplay + (when (> (output-record-count history) 1) + (cerror "Clear the output history and proceed" + "There is more than one element in this redisplay pane") + (window-clear pane)) + (unless (zerop (output-record-count history)) + (output-record-element history 0))))))) (cond ((and redisplay-p (or force-p (null redisplay-record))) (when force-p @@ -689,8 +676,7 @@ (redisplay redisplay-record pane :check-overlapping check-overlapping)) (t - (invoke-pane-display-function frame - pane)))))))))) + (invoke-pane-display-function frame pane)))))))))) (force-p ;;-- Is there anything else we need to do? (stream-replay pane)))) @@ -791,7 +777,7 @@ #+Allegro (when (and *click-outside-menu-handler* (output-recording-stream-p window) - (not (region-contains-point*-p (stream-output-history window) x y))) + (not (region-contains-position-p (stream-output-history window) x y))) (funcall *click-outside-menu-handler*)) (when highlighted-presentation ;; Unhighlight on the way out. @@ -827,14 +813,17 @@ (defmethod frame-error-output ((frame standard-application-frame)) (frame-standard-output frame)) +(defmethod frame-pointer-documentation-output ((frame standard-application-frame)) + (with-slots (pointer-documentation-pane) frame + pointer-documentation-pane)) + ;;--- This causes direct-manipulation and menu-driven applications not to ;;--- maintain histories. Is there a better heuristic? (defmethod frame-maintain-presentation-histories ((frame standard-application-frame)) (not (null (find-frame-pane-of-type frame 'interactor-pane)))) -;;--- What should this really do? - (defmethod notify-user (frame format-string &rest format-arguments) + (declare (dynamic-extent format-arguments)) (apply #'port-notify-user (port frame) frame format-string format-arguments)) @@ -891,7 +880,7 @@ (defun frame-document-highlighted-presentation-1 (frame presentation input-context window x y stream) (let ((modifier-state (window-modifier-state window))) - (declare (fixnum modifier-state)) + (declare (type fixnum modifier-state)) (multiple-value-bind (left left-presentation left-context middle middle-presentation middle-context right right-presentation right-context) @@ -908,7 +897,7 @@ ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS* (let ((bit #o20) (shift-name '("h-" "s-" "m-" "c-" "sh-"))) - (declare (fixnum bit)) + (declare (type fixnum bit)) (dotimes (i 5) #-(or Allegro Minima) (declare (ignore i)) (unless (zerop (logand bit modifier-state)) @@ -922,6 +911,8 @@ :documentation-type :pointer) (write-string separator stream))) (declare (dynamic-extent #'document-translator)) + ;;--- The button names should be hard-wired in. Consider 1-button + ;;--- Macs and 2-button PCs... (when left (let ((button-name (cond ((and (eq left middle) (eq left right)) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index 9534dce5..f8818839 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gadget-output.lisp,v 1.8 92/03/24 19:37:52 cer Exp Locker: cer $ +;; $fiHeader: gadget-output.lisp,v 1.9 92/04/10 14:27:02 cer Exp Locker: cer $ (in-package :clim-internals) @@ -41,7 +41,7 @@ (setf (output-record-gadget rec) gadget) (let ((sr (compose-space gadget))) (multiple-value-bind (abs-x abs-y) - (point-position* + (point-position (stream-output-history-position stream)) (decf x abs-x) (decf y abs-y) @@ -62,7 +62,7 @@ (declare (ignore a b c d)) (update-gadget-position rec)) -(defmethod bounding-rectangle-set-position* :after ((rec gadget-output-record) a b) +(defmethod bounding-rectangle-set-position :after ((rec gadget-output-record) a b) (declare (ignore a b)) (update-gadget-position rec)) @@ -75,7 +75,7 @@ (do ((parent record (output-record-parent parent))) ((null parent)) (multiple-value-bind (x y) - (output-record-position* parent) + (output-record-position parent) (incf xoff x) (incf yoff y))) (move-and-resize-sheet* gadget @@ -126,13 +126,13 @@ (assert frame) (assert framem) (multiple-value-bind (x y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (let* (gadget (record (with-new-output-record (stream 'gadget-output-record record) - ;;--- Do we really need to do this. under what - ;;--- situations does this happen and why cant we loose - ;;--- the gadget + ;;--- Do we really need to do this? Under what + ;;--- situations does this happen and why can't we + ;;--- release the gadget? (unless (setq gadget (output-record-gadget record)) (associate-record-and-gadget record @@ -148,7 +148,7 @@ (assert frame) (assert framem) (multiple-value-bind (x y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (let* (gadget (record (with-new-output-record (stream 'gadget-output-record record) @@ -227,22 +227,21 @@ ;; value-key, test, sequence (with-output-as-gadget (stream) (let* ((gadget - (make-pane 'radio-box - :label (and (stringp prompt) prompt) - :value-changed-callback + (make-pane 'radio-box + :label (and (stringp prompt) prompt) + :client stream :id query-identifier + :value-changed-callback (make-accept-values-value-changed-callback - stream query-identifier) - :client stream - :id query-identifier))) + stream query-identifier)))) (dolist (element sequence) (make-pane 'toggle-button - :value (and default-supplied-p - (funcall test - (funcall value-key element) - (funcall value-key default))) - :label (princ-to-string element) - :id element - :parent gadget)) + :label (princ-to-string element) + :value (and default-supplied-p + (funcall test + (funcall value-key element) + (funcall value-key default))) + :id element + :parent gadget)) gadget))) @@ -258,20 +257,19 @@ present-p query-identifier &key (prompt t)) (declare (ignore default-supplied-p present-p)) - (let ((x (with-output-as-gadget (stream) - (make-pane 'toggle-button - :client stream - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :id query-identifier - :value default - :label (and (stringp prompt) prompt))))) - ;;--- WE end up not making a new gadget sometimes, I think because + (let ((gadget + (with-output-as-gadget (stream) + (make-pane 'toggle-button + :label (and (stringp prompt) prompt) + :value default + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier))))) + ;;--- We end up not making a new gadget sometimes, I think because ;;--- we find a gadget already in the record so we need to modify - ;;-- the value! - (setf (gadget-value x) default))) - + ;;--- the value! + (setf (gadget-value gadget) default))) ;;; Integer gadget @@ -287,14 +285,13 @@ (declare (ignore present-p)) (with-output-as-gadget (stream) (make-pane 'slider - :value-changed-callback - (make-accept-values-value-changed-callback - stream query-identifier) - :client stream - :width 100 - :value (if default-supplied-p default 0) - :id query-identifier - :label (and (stringp prompt) prompt)))) + :label (and (stringp prompt) prompt) + :value (if default-supplied-p default 0) + :client stream :id query-identifier + :value-changed-callback + (make-accept-values-value-changed-callback + stream query-identifier)))) + ;;--- These should be defined in the standard DEFOPERATION way... diff --git a/clim/gestures.lisp b/clim/gestures.lisp index 055672b7..e3f4bd0d 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.4 92/03/04 16:21:43 cer Exp $ +;; $fiHeader: gestures.lisp,v 1.5 92/03/10 10:12:36 cer Exp $ (in-package :clim-internals) @@ -69,7 +69,7 @@ ;; BUTTON is a button number (0, 1, or 2), and MODIFIER-STATE is a mask (defun-inline button-and-modifier-state-gesture-names (button modifier-state) - (declare (fixnum button modifier-state)) + (declare (type fixnum button modifier-state)) (aref *button-and-modifier-key->gesture* button modifier-state)) ;; BUTTON is a button number (0, 1, or 2), and MODIFIER-STATE is a mask @@ -138,7 +138,7 @@ ;; We typically have our hands on a button index and a modifier key state, ;; and we need to know if it matches a named gesture -;; BUTTON is a button number (0, 1, or 2), and STATE is a mask. + (defun-inline button-and-modifier-state-matches-gesture-name-p (button state gesture-name) (or (eq gesture-name 't) (member gesture-name (button-and-modifier-state-gesture-names button state)))) @@ -159,12 +159,12 @@ (defun button-press-event-matches-gesture-name-p (event gesture-name) (let ((button (pointer-event-button event)) (modifier-state (event-modifier-state event))) - (declare (fixnum button modifier-state)) + (declare (type fixnum button modifier-state)) (button-and-modifier-state-matches-gesture-name-p (- (integer-length button) #.(integer-length +pointer-left-button+)) modifier-state gesture-name))) -;;--- Shouldn't #\A match (:A :SHIFT), and so forth? +;; GESTURE-NAME either names a gesture, or is a canonicalized gesture spec (defun keyboard-event-matches-gesture-name-p (event gesture-name) (when (and (characterp event) (characterp gesture-name) @@ -173,40 +173,66 @@ (multiple-value-bind (keysym modifier-state character) (etypecase event (character + ;;--- This should canonicalize #\a into :A, and #\A into :A (:SHIFT), + ;;--- and so forth (values nil 0 event)) (key-press-event (values (keyboard-event-key-name event) (event-modifier-state event) (keyboard-event-character event)))) - (declare (fixnum modifier-state)) - (let ((bucket (aref *keysym-and-modifier-key->gesture* modifier-state))) - ;;--- Presently allows both keysyms and characters. Is that right? - (or (member gesture-name (cdr (assoc keysym bucket))) - (member gesture-name (cdr (assoc character bucket))))))) + (declare (type fixnum modifier-state)) + (cond ((consp gesture-name) + (and (eql keysym (first gesture-name)) + (eq modifier-state (apply #'make-modifier-state (rest gesture-name))))) + (t + (let ((bucket (aref *keysym-and-modifier-key->gesture* modifier-state))) + (or (member gesture-name (cdr (assoc keysym bucket))) + (member gesture-name (cdr (assoc character bucket))))))))) (defun-inline keyboard-event-p (x) (or (characterp x) (typep x 'key-press-event))) +;;--- This accepts way too much... (defun keyboard-gesture-spec-p (x) - (let ((keysym (if (consp x) (first x) x)) - (modifiers (and (consp x) (rest x)))) - (and (or (characterp keysym) - (symbolp keysym)) - (every #'(lambda (x) (find x *modifier-keys*)) modifiers)))) - -;;--- Shouldn't #\A match (:A :SHIFT), and so forth? -(defun gesture-eql (gesture1 gesture2) - (let ((g1-keysym (if (consp gesture1) (first gesture1) gesture1)) - (g1-modifiers (and (consp gesture1) (rest gesture1))) - (g2-keysym (if (consp gesture2) (first gesture2) gesture2)) - (g2-modifiers (and (consp gesture2) (rest gesture2)))) - (and (or (eql g1-keysym g2-keysym) - (and (characterp g1-keysym) - (characterp g2-keysym) - (char-equal g1-keysym g2-keysym))) - (every #'(lambda (x) (member x g2-modifiers)) g1-modifiers) - (every #'(lambda (x) (member x g1-modifiers)) g2-modifiers)))) + (multiple-value-bind (keysym modifiers) (decode-gesture-spec x) + (declare (ignore modifiers)) + keysym)) + +(defun gesture-spec-eql (gesture1 gesture2) + (multiple-value-bind (k1 m1) (decode-gesture-spec gesture1) + (multiple-value-bind (k2 m2) (decode-gesture-spec gesture2) + (and (or (eql k1 k2) + (and (characterp k1) + (characterp k2) + (char-equal k1 k2))) + (equal m1 m2))))) + +(defun decode-gesture-spec (gesture-spec &key (errorp t)) + (declare (values button modifiers)) + (when (atom gesture-spec) + (return-from decode-gesture-spec + (values gesture-spec nil))) + (let ((modifiers nil) + (button nil)) + (dolist (x gesture-spec) + (cond ((find x *modifier-keys*) + (if (member x modifiers) + (if errorp + (cerror "Ignore the extra modifier" + "The modifier ~S appears more than once in the gesture spec ~S" + x gesture-spec) + (return-from decode-gesture-spec nil)) + (push x modifiers))) + (button + (if errorp + (error "The gesture spec ~S is invalid" gesture-spec) + (return-from decode-gesture-spec nil))) + (t + (setq button x)))) + ;;--- This should canonicalize #\a into :A, and #\A into :A (:SHIFT), + ;;--- and so forth. + (values button (nreverse modifiers)))) (defun add-gesture-name (name type gesture-spec &key (unique t)) @@ -215,10 +241,9 @@ (delete-gesture-name name)) (ecase type (:keyboard - (destructuring-bind (key-name &rest modifiers) gesture-spec + (multiple-value-bind (key-name modifiers) + (decode-gesture-spec gesture-spec) (check-type key-name (or symbol character)) - (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) - "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) (let* ((index (apply #'make-modifier-state modifiers)) (bucket (aref *keysym-and-modifier-key->gesture* index)) (entry (assoc key-name bucket))) @@ -230,10 +255,9 @@ (push entry (aref *keysym-and-modifier-key->gesture* index)))) bucket))) (:pointer-button - (destructuring-bind (button &rest modifiers) gesture-spec + (multiple-value-bind (button modifiers) + (decode-gesture-spec gesture-spec) (check-type button (member :left :middle :right)) - (assert (every #'(lambda (x) (find x *modifier-keys*)) modifiers) (modifiers) - "~S is not a subset of ~S" modifiers '(:shift :control :meta :super :hyper)) (pushnew name (button-and-modifier-state-gesture-names (button-index button) (apply #'make-modifier-state modifiers))))))) diff --git a/clim/graph-formatting.lisp b/clim/graph-formatting.lisp index f6faae54..e90297a0 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.6 92/02/24 13:07:40 cer Exp $ +;; $fiHeader: graph-formatting.lisp,v 1.7 92/03/04 16:21:44 cer Exp $ (in-package :clim-internals) @@ -75,13 +75,13 @@ (bounding-rectangle-left node)) (defmethod (setf graph-node-x) (new-value (node standard-graph-node-output-record)) - (output-record-set-position* node new-value (bounding-rectangle-top node))) + (output-record-set-position node new-value (bounding-rectangle-top node))) (defmethod graph-node-y ((node standard-graph-node-output-record)) (bounding-rectangle-top node)) (defmethod (setf graph-node-y) (new-value (node standard-graph-node-output-record)) - (output-record-set-position* node (bounding-rectangle-left node) new-value)) + (output-record-set-position node (bounding-rectangle-left node) new-value)) ;; For compatibility... @@ -216,7 +216,7 @@ (node-breadth (node-breadth ,node-var)) (breadth-margin ,within-generation-separation-var) (depth-margin ,generation-separation-var) - (tallest-child 0)) + (tallest-child (coordinate 0))) (declare (type coordinate start-breadth node-breadth depth-margin breadth-margin tallest-child)) (dolist (child children) @@ -298,7 +298,7 @@ (parent-attachment-position parent) (multiple-value-bind (child-x child-y) (child-attachment-position child) - (translate-fixnum-positions xoff yoff + (translate-coordinates xoff yoff parent-x parent-y child-x child-y) ;;--- This really needs to pass the objects, too (apply arc-drawer stream @@ -386,21 +386,21 @@ (with-slots (orientation center-nodes generation-separation within-generation-separation n-generations root-nodes hash-table) graph - (let ((start-x 0) - (start-y 0)) + (let ((start-x (coordinate 0)) + (start-y (coordinate 0))) (flet ((inferior-mapper (function node) (map nil function (graph-node-children node))) - (yx-output-record-set-position* (record y x) - (output-record-set-position* record x y))) - (declare (dynamic-extent #'inferior-mapper #'yx-output-record-set-position*)) + (yx-output-record-set-position (record y x) + (output-record-set-position record x y))) + (declare (dynamic-extent #'inferior-mapper #'yx-output-record-set-position)) (multiple-value-bind (breadthfun depthfun set-positionfun start-breadth start-depth) (ecase orientation ((:vertical :down :up) (values #'bounding-rectangle-width #'bounding-rectangle-height - #'output-record-set-position* start-x start-y)) + #'output-record-set-position start-x start-y)) ((:horizontal :right :left) (values #'bounding-rectangle-height #'bounding-rectangle-width - #'yx-output-record-set-position* start-y start-x))) + #'yx-output-record-set-position start-y start-x))) (macrolet ((traverse (new-node-function &optional (old-node-function '#'false)) `(traverse-graph root-nodes #'inferior-mapper hash-table #'identity @@ -414,7 +414,7 @@ collect (make-generation-descriptor :generation generation :breadth-so-far start-breadth))) - (max-gen-breadth 0) + (max-gen-breadth (coordinate 0)) broadest-gen-descr) (when (member orientation '(:up :left)) (setq generation-descriptors (nreverse generation-descriptors))) @@ -460,7 +460,8 @@ (generation-breadth-so-far descr) (if center-nodes (+ (generation-start-depth descr) - (floor (- (generation-depth descr) (depth child-node)) 2)) + (floor (- (generation-depth descr) + (depth child-node)) 2)) (generation-start-depth descr))) (incf (generation-breadth-so-far descr) (breadth child-node))))) (declare (dynamic-extent #'place-node)) @@ -508,7 +509,7 @@ (funcall parent-attach parent) (multiple-value-bind (child-x child-y) (funcall child-attach child) - (translate-fixnum-positions xoff yoff + (translate-coordinates xoff yoff parent-x parent-y child-x child-y) ;;--- This really needs to pass the objects, too (apply arc-drawer stream diff --git a/clim/graphics-recording.lisp b/clim/graphics-recording.lisp index 28498006..bf7cb812 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.2 92/03/30 17:52:26 cer Exp Locker: cer $ +;; $fiHeader: graphics-recording.lisp,v 1.3 92/04/14 15:29:53 cer Exp Locker: cer $ (in-package :clim-internals) @@ -58,12 +58,12 @@ (member 'line-style medium-components)) `((when filled (setq line-style nil)))) (multiple-value-bind (abs-x abs-y) - (point-position* (stream-output-history-position medium)) + (point-position (stream-output-history-position medium)) (declare (type coordinate abs-x abs-y)) ,@(mapcar #'(lambda (p) - `(transform-point-sequence (transformation) ,p)) + `(transform-position-sequence (transformation) ,p)) point-sequences-to-transform) - (transform-points (transformation) ,@points-to-transform) + (transform-positions (transformation) ,@points-to-transform) (transform-distances (transformation) ,@distances-to-transform) (let ((record (make-instance ',class @@ -76,10 +76,10 @@ (bounding-rectangle-set-edges record (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y)) - (multiple-value-bind (cx cy) (stream-cursor-position* medium) + (multiple-value-bind (cx cy) (stream-cursor-position medium) (declare (type coordinate cx cy)) ;; Doing this directly beats calling - ;; OUTPUT-RECORD-SET-START-CURSOR-POSITION* + ;; OUTPUT-RECORD-SET-START-CURSOR-POSITION (with-slots (start-x start-y) record (setq start-x (- cx abs-x) start-y (- cy abs-y)))) @@ -107,30 +107,30 @@ (with-slots (,@slots) record (with-sheet-medium (medium stream) (letf-globally (((medium-transformation medium) +identity-transformation+)) - (with-drawing-options - (medium ,@(mapcan #'(lambda (medium-component) - (list (intern (symbol-name medium-component) - *keyword-package*) - medium-component)) - medium-components)) - (let (,@(when (and (member 'filled function-args) - (member 'line-style medium-components)) - `((filled (not line-style)))) - ,@(mapcar #'(lambda (p) (list p p)) - points-to-transform) - ,@(mapcar #'(lambda (p) (list p p)) - point-sequences-to-transform)) - ,@(mapcar #'(lambda (p) - `(setq ,p (adjust-point-sequence - ,p (- x-offset) (- y-offset)))) - point-sequences-to-transform) - (setf ,@(do ((p points-to-transform (cddr p)) - r) - ((null p) (nreverse r)) - (push (first p) r) - (push `(+ ,(first p) x-offset) r) - (push (second p) r) - (push `(+ ,(second p) y-offset) r))) + (with-drawing-options + (medium ,@(mapcan #'(lambda (medium-component) + (list (intern (symbol-name medium-component) + *keyword-package*) + medium-component)) + medium-components)) + (let (,@(when (and (member 'filled function-args) + (member 'line-style medium-components)) + `((filled (not line-style)))) + ,@(mapcar #'(lambda (p) (list p p)) + points-to-transform) + ,@(mapcar #'(lambda (p) (list p p)) + point-sequences-to-transform)) + ,@(mapcar #'(lambda (p) + `(setq ,p (adjust-point-sequence + ,p (- x-offset) (- y-offset)))) + point-sequences-to-transform) + (setf ,@(do ((p points-to-transform (cddr p)) + r) + ((null p) (nreverse r)) + (push (first p) r) + (push `(+ ,(first p) x-offset) r) + (push (second p) r) + (push `(+ ,(second p) y-offset) r))) (,medium-graphics-function* medium ,@function-args))))))) ,@(when highlighting-test @@ -165,7 +165,7 @@ ((record output-record-mixin) x-offset y-offset) (let ((designs nil)) (flet ((make-design (record) - (multiple-value-bind (xoff yoff) (output-record-position* record) + (multiple-value-bind (xoff yoff) (output-record-position record) (declare (type coordinate xoff yoff)) (let ((design (make-design-from-output-record-1 @@ -241,7 +241,7 @@ (defmethod draw-design ((point standard-point) stream &rest args &key ink line-style) (declare (dynamic-extent args) (ignore ink line-style)) - (multiple-value-bind (x y) (point-position* point) + (multiple-value-bind (x y) (point-position point) (apply #'draw-point* stream x y args))) @@ -328,8 +328,6 @@ (with-slots (x1 y1 x2 y2 line-style) record (or (null line-style) (with-half-thickness (lthickness rthickness) line-style - ;; Don't use LTRB-CONTAINS-POINT*-P, since that expects fixnums - ;;---- Not any more! (not (and (<= (+ x1 rthickness) x) (<= (+ y1 rthickness) y) (>= (- x2 lthickness) x) @@ -380,7 +378,7 @@ ((polygon polygon-output-record) x-offset y-offset) (with-slots (list-of-xs-and-ys closed line-style ink) polygon (let ((coords (copy-list list-of-xs-and-ys))) - (translate-point-sequence x-offset y-offset coords) + (translate-position-sequence x-offset y-offset coords) (compose-in ink (if (null line-style) @@ -421,6 +419,15 @@ ((null p)) (funcall fn (car p) (cadr p)))) +(defun adjust-point-sequence (list-of-x-and-ys dx dy) + (let (r) + (map-point-sequence + #'(lambda (x y) + (push (- x dx) r) + (push (- y dy) r)) + list-of-x-and-ys) + (nreverse r))) + (define-output-recorder ellipse-output-record draw-ellipse (ink line-style) :bounding-rectangle @@ -553,16 +560,3 @@ vb (+ y (round height 2))))) (values vx vt vr vb))) - -;;--- Does anyone use this? -(defun adjust-point-sequence (list-of-x-and-ys dx dy) - (let (r) - (map-point-sequence - #'(lambda (x y) - (push (- x dx) r) - (push (- y dy) r)) - list-of-x-and-ys) - (nreverse r))) - - - diff --git a/clim/histories.lisp b/clim/histories.lisp index f376ed9e..cd8a3843 100644 --- a/clim/histories.lisp +++ b/clim/histories.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: histories.lisp,v 1.3 92/02/24 13:07:47 cer Exp $ +;; $fiHeader: histories.lisp,v 1.4 92/03/04 16:21:47 cer Exp $ (in-package :clim-internals) @@ -446,6 +446,16 @@ (defmethod canonicalize-default ((history presentation-history) element) (unparse-presentation-history-element history element)) +#+compulsive-type-checking +(defmethod push-history-element :around ((history presentation-history) element) + (when (and (presentation-typep + (presentation-history-element-object element) + (presentation-history-element-type element)) + (presentation-subtypep + (presentation-history-element-type element) + (presentation-history-type history))) + (call-next-method))) + (defmethod history-replace-input ((history presentation-history) (istream input-editing-stream-mixin) element &key replace-previous) diff --git a/clim/incremental-redisplay.lisp b/clim/incremental-redisplay.lisp index 6a2beb08..352e050e 100644 --- a/clim/incremental-redisplay.lisp +++ b/clim/incremental-redisplay.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: incremental-redisplay.lisp,v 1.3 92/02/24 13:07:49 cer Exp $ +;; $fiHeader: incremental-redisplay.lisp,v 1.4 92/03/04 16:21:50 cer Exp $ (in-package :clim-internals) @@ -43,7 +43,8 @@ ;; UPDATING-OUTPUT-RECORD's can be easily moved through the ;; hierarchy, in which case it would be slightly expensive to ;; convert from relative to absolute coordinates. - (old-position :initform (make-point 0 0) :initarg :old-position + (old-position :initform (make-point (coordinate 0) (coordinate 0)) + :initarg :old-position :accessor output-record-old-cursor-position) (old-parent :initform nil :initarg :old-parent :accessor output-record-old-parent))) @@ -51,7 +52,9 @@ (define-output-record-constructor standard-updating-output-record (&key x-position y-position (size 25) unique-id cache-value fixed-position - displayer all-new (old-position (make-point 0 0)) + displayer all-new + (old-position + (make-point (coordinate 0) (coordinate 0))) old-parent) :x-position x-position :y-position y-position :size size :unique-id unique-id :cache-value cache-value :fixed-position fixed-position @@ -72,7 +75,7 @@ (if (null old-bounding-rectangle) (setf old-bounding-rectangle (bounding-rectangle record)) ;cons a new rectangle (bounding-rectangle record old-bounding-rectangle)) - (output-record-set-old-start-cursor-position* record start-x start-y) + (output-record-set-old-start-cursor-position record start-x start-y) (setf contents-ok (not (null old-is-ok))) (unless old-is-ok (setf parent nil)))) @@ -129,6 +132,7 @@ ;; some of the arguments, and then passes it on to the real (and generic) ;; FIND-INFERIOR-OUTPUT-RECORD. FIND-INFERIOR-OUTPUT-RECORD is the exported ;; interface, and is defined in the protocol. +;;--- Rename to FIND-CHILD-OUTPUT-RECORD-1 (defun find-inferior-output-record-1 (record record-type &rest init-args) (declare (dynamic-extent init-args)) (apply #'find-inferior-output-record @@ -138,6 +142,7 @@ record-type init-args)) +;;--- Rename to DECACHE-CHILD-OUTPUT-RECORD-1 (defun decache-inferior-output-record-1 (record child) (decache-inferior-output-record record child @@ -172,6 +177,7 @@ (find item sequence :key key :test #'robust-test) (find item sequence :key key)))) +;;--- Rename to FIND-CHILD-OUTPUT-RECORD (defmethod find-inferior-output-record ((record output-record-mixin) use-old-children record-type &rest init-args &key unique-id id-test &allow-other-keys) @@ -223,6 +229,7 @@ #'no-unique-id) record))))))) +;;--- Rename to DECACHE-CHILD-OUTPUT-RECORD-1 (defmethod decache-inferior-output-record ((record output-record-mixin) child use-old-children) (when use-old-children @@ -269,12 +276,12 @@ (and (zerop width) (zerop height))) (multiple-value-bind (our-delta-x our-delta-y) (multiple-value-bind (sx sy) - (output-record-start-cursor-position* child) + (output-record-start-cursor-position child) (declare (type coordinate sx sy)) (multiple-value-bind (osx osy) - (output-record-old-start-cursor-position* child) + (output-record-old-start-cursor-position child) (declare (type coordinate osx osy)) - (position-difference* sx sy osx osy))) + (position-difference sx sy osx osy))) (declare (type coordinate our-delta-x our-delta-y)) (if (null delta-x) (setf delta-x our-delta-x delta-y our-delta-y) @@ -294,7 +301,7 @@ (if old-bounding-rectangle (bounding-rectangle-position-difference record old-bounding-rectangle) - (values 0 0)) + (values (coordinate 0) (coordinate 0))) (and (= delta-x e-delta-x) (= delta-y e-delta-y)))) (setf (output-record-contents-ok record) t) ;; If delta-x wasn't set, then we didn't see any relevant @@ -306,9 +313,9 @@ ;; COMPUTE-DIFFERENCES will never walk down past this record, ;; since contents-ok is T. (multiple-value-bind (new-x new-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (declare (type coordinate new-x new-y)) - (output-record-set-old-start-cursor-position* + (output-record-set-old-start-cursor-position record (- new-x delta-x) (- new-y delta-y))))))))) @@ -336,11 +343,11 @@ (multiple-value-bind (x y) (if y (values (+ x (- parent-x sup-x)) (+ y (- parent-y sup-y))) - (output-record-position* record)) + (output-record-position record)) (declare (type coordinate x y)) (with-end-of-page-action (stream :allow) (with-stream-cursor-position-saved (stream) - (stream-set-cursor-position* + (stream-set-cursor-position stream (+ sup-x x) (+ sup-y y)) (with-stream-redisplaying (stream) (let ((parent (output-record-parent record))) @@ -366,7 +373,9 @@ (output-record-parent record) record :change ;; You can use the state saved by COPY-DISPLAY-STATE here, since ;; the contract of NEW-OUTPUT-RECORDS is to maintain the old state. - (output-record-old-start-cursor-position record) + (multiple-value-bind (x y) + (output-record-old-start-cursor-position record) + (make-point x y)) (output-record-old-bounding-rectangle record) stream erases moves draws erase-overlapping move-overlapping)))) @@ -388,6 +397,7 @@ ;; Mode is one of :DELETE, :ADD, :CHANGE, :MOVE, or :NONE ;; If you don't recursively call your parent, then it is >your< ;; responsibility to call INCREMENTAL-REDISPLAY. +;;--- Rename to NOTE-OUTPUT-RECORD-CHILD-CHANGED (defmethod inferior-output-record-changed ((parent output-record-mixin) child mode old-child-position old-child-extent ;of child stream @@ -402,7 +412,10 @@ old-child-position old-child-extent) (with-slots (old-bounding-rectangle start-x start-y old-start-x old-start-y) parent (let ((old-parent-extent old-bounding-rectangle) - (old-parent-position (output-record-old-start-cursor-position parent))) + (old-parent-position + (multiple-value-bind (x y) + (output-record-old-start-cursor-position record) + (make-point x y)))) (setf old-start-x start-x old-start-y start-y) (if (null old-bounding-rectangle) (setf old-bounding-rectangle (bounding-rectangle parent)) @@ -420,7 +433,10 @@ new-erases new-moves new-draws new-erase-overlapping new-move-overlapping)))))) (t - (incremental-redisplay stream (output-record-start-cursor-position parent) + (incremental-redisplay stream + (multiple-value-bind (x y) + (output-record-start-cursor-position parent) + (make-point x y)) erases moves draws erase-overlapping move-overlapping)))) ;; for efficiency we might want to pass in the five elements as an @@ -432,6 +448,7 @@ ;; from that origin to the parent of RECORD. ;; ;; Need to clip this to the visible viewport, but we'll do that later, too. +;;--- Rename to COMPUTE-DIFFERENCE-SET (defmethod compute-differences ((record output-record-element-mixin) &optional (check-overlapping nil) (x-offset 0) (y-offset 0) @@ -455,10 +472,10 @@ ;;--- but do we want to penalize the user? (when old-bounding-rectangle (multiple-value-bind (e-x e-y) - (bounding-rectangle-position* record) + (bounding-rectangle-position record) (declare (type coordinate e-x e-y)) (multiple-value-bind (old-e-x old-e-y) - (bounding-rectangle-position* old-bounding-rectangle) + (bounding-rectangle-position old-bounding-rectangle) (declare (type coordinate old-e-x old-e-y)) (unless (and (= (+ x-offset e-x) (+ old-x-offset old-e-x)) (= (+ y-offset e-y) (+ old-y-offset old-e-y))) @@ -486,10 +503,10 @@ (when (output-record-p record) ;; We have to look at the children. (multiple-value-bind (start-x start-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (declare (type coordinate start-x start-y)) (multiple-value-bind (o-start-x o-start-y) - (output-record-old-start-cursor-position* record) + (output-record-old-start-cursor-position record) (declare (type coordinate o-start-x o-start-y)) (dolist (child (output-record-old-children record)) (erase child (bounding-rectangle-shift-position @@ -539,10 +556,10 @@ draws)) (when (output-record-p record) (multiple-value-bind (start-x start-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (declare (type coordinate start-x start-y)) (multiple-value-bind (o-start-x o-start-y) - (output-record-old-start-cursor-position* record) + (output-record-old-start-cursor-position record) (declare (type coordinate o-start-x o-start-y)) (let ((x-offset (+ x-offset start-x)) (y-offset (+ y-offset start-y)) @@ -562,7 +579,7 @@ erase-overlapping move-overlapping) (with-output-recording-options (stream :draw t :record nil) (multiple-value-bind (xoff yoff) - (bounding-rectangle-position* position) + (bounding-rectangle-position position) (declare (type coordinate xoff yoff)) ;; Do the erases first, then the moves, then the draws. ;; Do the draws in the "right" order. @@ -580,12 +597,13 @@ ;; All of this must be done relative to position... (flet ((erase-rectangle (stream rectangle) (with-bounding-rectangle* (left top right bottom) rectangle - (translate-fixnum-positions xoff yoff left top right bottom) - (draw-rectangle* stream left top right bottom :ink +background-ink+ :filled t))) + (translate-coordinates xoff yoff left top right bottom) + (draw-rectangle* stream left top right bottom + :ink +background-ink+ :filled t))) (replay-record (record stream region) ;; REGION is the bounding rectangle - (multiple-value-bind (x y) (bounding-rectangle-position* record) - (multiple-value-bind (eleft etop) (bounding-rectangle-position* region) + (multiple-value-bind (x y) (bounding-rectangle-position record) + (multiple-value-bind (eleft etop) (bounding-rectangle-position region) (replay-output-record record stream nil (+ xoff (- eleft x)) (+ yoff (- etop y))))))) (dolist (erase erases) @@ -616,22 +634,22 @@ (defmethod new-output-records ((record output-record-element-mixin) stream) ;; Position and bounding rectangle are identical on these guys. (multiple-value-bind (cursor-x cursor-y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate cursor-x cursor-y)) (multiple-value-bind (new-x new-y) (multiple-value-bind (px py) - (point-position* + (point-position (stream-output-history-position stream)) (declare (type coordinate px py)) - (position-difference* cursor-x cursor-y px py)) + (position-difference cursor-x cursor-y px py)) (declare (type coordinate new-x new-y)) ;; because we don't know what to do, just do the same thing as before... (copy-display-state record t) - (output-record-set-start-cursor-position* record new-x new-y)) + (output-record-set-start-cursor-position record new-x new-y)) (multiple-value-bind (delta-x delta-y) - (output-record-end-cursor-position* record) + (output-record-end-cursor-position record) (declare (type coordinate delta-x delta-y)) - (stream-set-cursor-position* + (stream-set-cursor-position stream (+ cursor-x delta-x) (+ cursor-y delta-y))))) ;; If you do REDISPLAY on a random output-record, do you want it to walk @@ -658,10 +676,13 @@ ;; old-inferior-extent and inferior-extent, are all relative to the ;; parents start-position. Nothing is relative to the parent's ;; old-start-position. +;;--- Rename to PROPAGATE-OUTPUT-RECORD-CHANGES-P (defmethod propagate-inferior-output-record-changes-p ((record output-record-mixin) child mode &optional (old-child-position - (output-record-old-start-cursor-position child)) + (multiple-value-bind (x y) + (output-record-old-start-cursor-position child) + (make-point x y))) (old-child-extent (output-record-old-bounding-rectangle child))) #---ignore @@ -670,14 +691,16 @@ (and (if (or (eq mode :change) (eq mode :move) (eq mode :none)) (or (not (bounding-rectangle-position-equal old-child-position - (output-record-start-cursor-position child))) + (multiple-value-bind (x y) + (output-record-start-cursor-position child) + (make-point x y)))) (not (bounding-rectangle-edges-equal old-child-extent (bounding-rectangle child)))) ;; mode is :add or :delete. (multiple-value-bind (width height) (bounding-rectangle-size child) (declare (type coordinate width height)) (not (and (zerop width) (zerop height))))) - (multiple-value-bind (x-offset y-offset) (output-record-position* record) + (multiple-value-bind (x-offset y-offset) (output-record-position record) (declare (type coordinate x-offset y-offset)) (with-bounding-rectangle* (left top right bottom) record (block anything-needs-moving @@ -713,8 +736,12 @@ ;; --- still needs to be implemented... (defmethod propagate-output-record-changes ((record output-record-mixin) child mode - &optional (old-child-position (output-record-old-start-cursor-position child)) - (old-child-extent (output-record-old-bounding-rectangle child)) + &optional (old-child-position + (multiple-value-bind (x y) + (output-record-old-start-cursor-position child) + (make-point x y))) + (old-child-extent + (output-record-old-bounding-rectangle child)) erases moves draws erase-overlapping move-overlapping) (declare (values new-mode new-erases new-moves new-draws new-erase-overlapping new-move-overlapping)) @@ -737,6 +764,7 @@ ;; just use default, for now. #+ignore +;;--- Rename to FIND-CHILD-OUTPUT-RECORD (defmethod find-inferior-output-record ((record standard-updating-output-record) use-old-children record-type &rest init-args &key unique-id id-test @@ -755,7 +783,7 @@ (defmethod reposition-output-record ((output-record standard-updating-output-record) stream x y abs-x abs-y) (multiple-value-bind (delta-x delta-y) - (output-record-end-cursor-position* output-record) + (output-record-end-cursor-position output-record) (declare (type coordinate delta-x delta-y)) (copy-display-state output-record t) (cond ((output-record-fixed-position output-record) @@ -767,16 +795,16 @@ ;; well-thought-out design. It just seemed like the right ;; thing after three minutes of thought. (multiple-value-bind (abs-x abs-y) - (point-position* + (point-position (stream-output-history-position stream)) (declare (type coordinate abs-x abs-y)) - (multiple-value-bind (x y) (output-record-position* output-record) + (multiple-value-bind (x y) (output-record-position output-record) (declare (type coordinate x y)) - (stream-set-cursor-position* + (stream-set-cursor-position stream (+ abs-x x delta-x) (+ abs-y y delta-y))))) (t - (output-record-set-start-cursor-position* output-record x y) - (stream-set-cursor-position* + (output-record-set-start-cursor-position output-record x y) + (stream-set-cursor-position stream (+ abs-x delta-x) (+ abs-y delta-y)))))) ;; The contents of the output-record are not yet known to be ok, so we're going to have to run @@ -789,7 +817,7 @@ (letf-globally (((stream-current-redisplay-record stream) output-record)) ;; OK, now copy and reinitialize (copy-display-state output-record nil) - (output-record-set-start-cursor-position* output-record x y) + (output-record-set-start-cursor-position output-record x y) (with-output-record-1 continuation stream output-record abs-x abs-y))) @@ -903,13 +931,13 @@ (if output-record ;; we've already been through this path once, just update if necessary. (multiple-value-bind (cursor-x cursor-y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate cursor-x cursor-y)) (multiple-value-bind (x y) (multiple-value-bind (px py) - (point-position* current-output-record-position) + (point-position current-output-record-position) (declare (type coordinate px py)) - (position-difference* cursor-x cursor-y px py)) + (position-difference cursor-x cursor-y px py)) (declare (type coordinate x y)) ;; Update displayer, in case something changed. (flet ((updating-output-displayer (stream) @@ -932,10 +960,10 @@ ;; old extent is bogus, since it is relative to ;; old-parent. Convert it to be relative to current-output-record. (multiple-value-call - #'output-record-set-start-cursor-position* + #'output-record-set-start-cursor-position output-record ;; could be wildly out of bounding box, but that's OK. - (bounding-rectangle-position-difference ;this works on points, too + (bounding-rectangle-position-difference ;; old-position is cached absolute coordinates (output-record-old-cursor-position output-record) current-output-record-position))) @@ -982,7 +1010,7 @@ (when redisplay-piece (cache-output-record redisplay-piece record unique-id id-test)) (multiple-value-bind (x y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (letf-globally (((stream-current-redisplay-record stream) record)) (funcall continuation stream)) (let ((position (output-record-old-cursor-position record))) diff --git a/clim/input-defs.lisp b/clim/input-defs.lisp index a05a1c9e..984d5e63 100644 --- a/clim/input-defs.lisp +++ b/clim/input-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: input-defs.lisp,v 1.5 92/02/24 13:07:51 cer Exp $ +;; $fiHeader: input-defs.lisp,v 1.6 92/03/04 16:21:52 cer Exp $ (in-package :clim-internals) @@ -16,8 +16,11 @@ ((root :accessor pointer-root :initform nil :initarg :root) (window :accessor pointer-window :initform nil) ;; Position in root coordinates + ;;--- Are these of type COORDINATE or FIXNUM? (x-position :accessor pointer-x-position :initform 0) (y-position :accessor pointer-y-position :initform 0) + ;;--- Are these of type COORDINATE or FIXNUM? + ;;--- It's clear that they need to be FIXed before passing them to the host (native-x-position :accessor pointer-native-x-position :initform 0) (native-y-position :accessor pointer-native-y-position :initform 0) (button-state :accessor pointer-button-state :initform 0) @@ -35,31 +38,35 @@ (progn (declaim (notinline pointer-window (setf pointer-window)))) -(defmethod pointer-position* ((pointer standard-pointer)) +(defmethod pointer-position ((pointer standard-pointer)) (with-slots (x-position y-position) pointer (values x-position y-position))) -;; NEW-X and NEW-Y had better be fixnums -;;--- Coerce X and Y to COORDINATE -(defmethod pointer-set-position* ((pointer standard-pointer) new-x new-y) - (declare (type coordinate new-x new-y)) +(defmethod pointer-set-position ((pointer standard-pointer) new-x new-y) (with-slots (x-position y-position position-changed) pointer - (setf x-position new-x - y-position new-y + (setf x-position (coordinate new-x) + y-position (coordinate new-y) position-changed t)) (values new-x new-y)) -(defmethod pointer-native-position* ((pointer standard-pointer)) +#+CLIM-1-compatibility +(define-compatibility-function (pointer-position* pointer-position) + (pointer) + (pointer-position pointer)) + +#+CLIM-1-compatibility +(define-compatibility-function (pointer-set-position* pointer-set-position) + (pointer x y) + (pointer-set-position pointer x y)) + +(defmethod pointer-native-position ((pointer standard-pointer)) (with-slots (native-x-position native-y-position) pointer (values native-x-position native-y-position))) -;; NEW-X and NEW-Y had better be fixnums -;;--- Coerce X and Y to COORDINATE -(defmethod pointer-set-native-position* ((pointer standard-pointer) new-x new-y) - (declare (type coordinate new-x new-y)) +(defmethod pointer-set-native-position ((pointer standard-pointer) new-x new-y) (with-slots (native-x-position native-y-position position-changed) pointer - (setf native-x-position new-x - native-y-position new-y + (setf native-x-position (coordinate new-x) + native-y-position (coordinate new-y) position-changed t)) (values new-x new-y)) @@ -80,8 +87,8 @@ (let ((native-x-position (pointer-native-x-position pointer)) (native-y-position (pointer-native-y-position pointer))) (multiple-value-setq (native-x-position native-y-position) - (untransform-point* (sheet-native-transformation window) - native-x-position native-y-position)) + (untransform-position (sheet-native-transformation window) + native-x-position native-y-position)) (setf (pointer-x-position pointer) native-x-position (pointer-y-position pointer) native-y-position))))) diff --git a/clim/input-editor-commands.lisp b/clim/input-editor-commands.lisp index 1c867970..4144ff2b 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.5 92/03/10 10:12:37 cer Exp Locker: cer $ +;; $fiHeader: input-editor-commands.lisp,v 1.6 92/03/10 15:40:10 cer Exp $ (in-package :clim-internals) @@ -250,7 +250,7 @@ (stream-output-history window)))) (when (and window (pane-viewport window)) - (multiple-value-bind (x y) (window-viewport-position* window) + (multiple-value-bind (x y) (window-viewport-position window) (incf y (* (if (= distance 1) (bounding-rectangle-height (window-viewport window)) (* distance (stream-line-height window))) @@ -258,7 +258,7 @@ (with-bounding-rectangle* (hleft htop hright hbottom) history (declare (ignore hleft hright)) (setq y (min (max htop y) hbottom))) - (window-set-viewport-position* window x y))))) + (window-set-viewport-position window x y))))) ;;; Some macrology for talking about the input-buffer @@ -670,8 +670,8 @@ (:ie-forward-word :\F :meta) (:ie-backward-character :\B :control) (:ie-backward-word :\B :meta) - (:ie-beginning-of-buffer :\< :meta) - (:ie-end-of-buffer :\> :meta) + (:ie-beginning-of-buffer :\< :meta) + (:ie-end-of-buffer :\> :meta) (:ie-beginning-of-line :\A :control) (:ie-end-of-line :\E :control) (:ie-next-line :\N :control) diff --git a/clim/input-protocol.lisp b/clim/input-protocol.lisp index 7f213482..094fd504 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.9 92/03/10 10:12:39 cer Exp Locker: cer $ +;; $fiHeader: input-protocol.lisp,v 1.10 92/03/30 17:52:30 cer Exp $ (in-package :clim-internals) @@ -89,20 +89,20 @@ (setf (cursor-stream text-cursor) stream) (setf (cursor-visibility text-cursor) initial-cursor-visibility)))) -;;; --- Cross-protocol violation here because the cursor-position* is a method on -;;; --- extended-OUTPUT-protocol right now. Secondly, this should probably be a method -;;; --- on the abstract class, anyway. +;;; --- Cross-protocol violation here because CURSOR-POSITION is a method on +;;; --- extended-OUTPUT-protocol right now. Secondly, this should probably be a +;;; --- method on the abstract class, anyway. #+Silica -(defmethod stream-set-cursor-position* :after ((stream input-protocol-mixin) x y) +(defmethod stream-set-cursor-position :after ((stream input-protocol-mixin) x y) (let ((cursor (stream-text-cursor stream))) (when cursor - (cursor-set-position* cursor x y)))) + (cursor-set-position cursor x y)))) #+Silica -(defmethod stream-set-cursor-position*-internal :after ((stream input-protocol-mixin) x y) +(defmethod stream-set-cursor-position-internal :after ((stream input-protocol-mixin) x y) (let ((cursor (stream-text-cursor stream))) (when cursor - (cursor-set-position* cursor x y)))) + (cursor-set-position cursor x y)))) (defmethod initialize-menu :before (port (menu input-protocol-mixin) associated-window) @@ -127,7 +127,7 @@ (when (and (cursor-active cursor) (cursor-state cursor) (cursor-focus cursor)) - (multiple-value-bind (x y) (cursor-position* cursor) + (multiple-value-bind (x y) (cursor-position cursor) (multiple-value-bind (width height) (cursor-width-and-height-pending-protocol cursor) (let ((cursor-rect (make-bounding-rectangle x y (+ x width) (+ y height)))) @@ -200,8 +200,8 @@ (defmethod queue-event ((stream input-protocol-mixin) (event pointer-motion-event)) (let ((pointer (stream-primary-pointer stream))) - (pointer-set-position* pointer (pointer-event-x event) (pointer-event-y event)) - (pointer-set-native-position* + (pointer-set-position pointer (pointer-event-x event) (pointer-event-y event)) + (pointer-set-native-position pointer (pointer-event-native-x event) (pointer-event-native-y event)) (setf (pointer-button-state pointer) @@ -243,15 +243,15 @@ (set-pointer-window-and-location window pointer))) #-Silica -(defmethod window-set-viewport-position* :around ((stream input-protocol-mixin) new-x new-y) +(defmethod window-set-viewport-position :around ((stream input-protocol-mixin) new-x new-y) (declare (ignore new-x new-y)) (let ((cursor (stream-text-cursor stream))) (if cursor ;; Shifting the viewport may need to redraw the cursor (multiple-value-bind (x y) - (cursor-position* cursor) + (cursor-position cursor) (call-next-method) - (cursor-set-position* cursor x y)) + (cursor-set-position cursor x y)) (call-next-method)))) @@ -461,11 +461,11 @@ ;;; stream-read-gesture directly. (defun read-gesture (&rest args &key (stream *standard-input*) &allow-other-keys) (declare (arglist &key (stream *standard-input*) - timeout peek-p input-wait-test input-wait-handler - pointer-button-press-handler)) + timeout peek-p input-wait-test input-wait-handler + pointer-button-press-handler)) (declare (dynamic-extent args)) (with-keywords-removed (keywords args '(:stream)) - (apply #'stream-read-gesture stream keywords))) + (apply #'stream-read-gesture stream keywords))) (defmethod stream-unread-gesture ((stream input-protocol-mixin) gesture) (queue-unget (stream-input-buffer stream) gesture)) @@ -687,20 +687,32 @@ nil) -;;; STREAM-POINTER-POSITION* method returns x,y in history coordinates. +;;; STREAM-POINTER-POSITION method returns X,Y in history coordinates. ;;; Around methods take care of this (see protocol-intermediaries.lisp) -(defmethod stream-pointer-position* ((stream input-protocol-mixin) &key (timeout 0) pointer) +(defmethod stream-pointer-position ((stream input-protocol-mixin) &key (timeout 0) pointer) (stream-pointer-position-in-window-coordinates stream :timeout timeout :pointer pointer)) -(defmethod stream-set-pointer-position* ((stream input-protocol-mixin) x y &key pointer) +(defmethod stream-set-pointer-position ((stream input-protocol-mixin) x y &key pointer) (set-stream-pointer-position-in-window-coordinates stream x y :pointer pointer)) +#+CLIM-1-compatibility +(define-compatibility-function (stream-pointer-position* + stream-pointer-position) + (stream) + (stream-pointer-position stream)) + +#+CLIM-1-compatibility +(define-compatibility-function (stream-set-pointer-position* + stream-set-pointer-position) + (stream x y) + (stream-set-pointer-position stream x y)) + ;;; The primitive we are interested in. The pointer is in inside-host-window coords. #+Silica (defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer) (declare (ignore timeout)) (let ((pointer (or pointer (stream-primary-pointer stream)))) - (pointer-position* pointer))) + (pointer-position pointer))) #-Silica (defun stream-pointer-position-in-window-coordinates (stream &key (timeout 0) pointer) @@ -710,17 +722,17 @@ (multiple-value-bind (left top) (window-offset stream) (declare (type coordinate left top)) (if pointer - (multiple-value-bind (x y) (pointer-position* pointer) + (multiple-value-bind (x y) (pointer-position pointer) (declare (type coordinate x y)) (values (- x left) (- y top))) - (values 0 0))))) + (values (coordinate 0) (coordinate 0)))))) (defun set-stream-pointer-position-in-window-coordinates (stream x y &key pointer) (declare (type coordinate x y)) (unless pointer (setf pointer (stream-primary-pointer stream))) (setf (pointer-position-changed pointer) t) #+Silica - (pointer-set-position* pointer x y) + (pointer-set-position pointer x y) #-Silica (multiple-value-bind (left top) (window-offset stream) (declare (type coordinate left top)) @@ -734,8 +746,9 @@ (with-slots (input-buffer) stream (queue-put input-buffer ;; X and Y had better be fixnums - ;;--- Coerce to COORDINATE - (make-button-press-event stream x y button modifier-state)))) + (make-button-press-event stream + (coordinate x) (coordinate y) + button modifier-state)))) #-Silica (defmethod stream-note-pointer-button-release ((stream input-protocol-mixin) @@ -743,9 +756,9 @@ (declare (ignore pointer)) (with-slots (input-buffer) stream (queue-put input-buffer - ;; X and Y had better be fixnums - ;;--- Coerce to COORDINATE - (make-button-release-event stream x y button modifier-state)))) + (make-button-release-event stream + (coordinate x) (coordinate y) + button modifier-state)))) #+Silica (defmethod stream-set-input-focus ((stream input-protocol-mixin)) diff --git a/clim/interactive-protocol.lisp b/clim/interactive-protocol.lisp index ba8c58ca..3c1a788c 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.5 92/03/04 16:21:59 cer Exp $ +;; $fiHeader: interactive-protocol.lisp,v 1.6 92/03/10 10:12:42 cer Exp $ (in-package :clim-internals) @@ -151,11 +151,11 @@ (unless end-position (setf end-position (fill-pointer input-buffer))) ;; cursor-X, cursor-Y are right if the start position is the insertion position. (cond ((= start-position 0) - (multiple-value-setq (cursor-x cursor-y) (start-cursor-position* istream))) + (multiple-value-setq (cursor-x cursor-y) (start-cursor-position istream))) ((= start-position insertion-pointer)) (t (multiple-value-setq (cursor-x cursor-y) - (input-buffer-input-position->cursor-position* istream start-position)))) + (input-buffer-input-position->cursor-position istream start-position)))) ;; OK, now we know our cursor-(X,Y) and the line height. Now scan things from here. (do-input-buffer-pieces (input-buffer :start start-position :end end-position) (from to noise-string) @@ -229,8 +229,8 @@ (accept-result-presentation-type next-char))) (t (apply #'accept-1 (or *original-stream* istream) type args)))))) -(defmethod input-buffer-input-position->cursor-position* ((istream input-editing-stream-mixin) - &optional position) +(defmethod input-buffer-input-position->cursor-position ((istream input-editing-stream-mixin) + &optional position) (multiple-value-bind (cursor-x cursor-y) (flet ((ignore (&rest args) (declare (ignore args)))) @@ -243,8 +243,8 @@ &optional (start-position 0)) (with-slots (input-buffer stream insertion-pointer) istream (multiple-value-bind (x-pos y-pos) - (input-buffer-input-position->cursor-position* istream start-position) - (stream-set-cursor-position* stream x-pos y-pos)) + (input-buffer-input-position->cursor-position istream start-position) + (stream-set-cursor-position stream x-pos y-pos)) (macrolet ((do-part (from &optional to) `(do-input-buffer-pieces (input-buffer :start ,from :end ,to) (start-index end-index noise-string) @@ -264,10 +264,10 @@ (let ((ip (min insertion-pointer (fill-pointer input-buffer)))) (do-part start-position ip) ;; Remember where the cursor goes (at the insertion pointer!) - (multiple-value-bind (x-pos y-pos) (stream-cursor-position* istream) + (multiple-value-bind (x-pos y-pos) (stream-cursor-position istream) (do-part ip) ;; And put it there. - (stream-set-cursor-position* stream x-pos y-pos)))) + (stream-set-cursor-position stream x-pos y-pos)))) (force-output stream))) ;;--- Too bad this never gets called... @@ -340,10 +340,10 @@ (throw 'rescan (values))))) (defun shift-buffer-portion (buffer from-index to-index) - (declare (fixnum from-index to-index)) + (declare (type fixnum from-index to-index)) (let (#+(or Genera Minima) (buffer buffer) (length (fill-pointer buffer))) - (declare (fixnum length)) + (declare (type fixnum length)) #+Genera (declare (sys:array-register buffer)) #+Minima (declare (type vector buffer)) (cond ((< from-index to-index) @@ -411,7 +411,7 @@ (with-slots (stream input-buffer scan-pointer insertion-pointer activation-gesture rescanning-p numeric-argument previous-history) istream - (declare (fixnum scan-pointer insertion-pointer)) + (declare (type fixnum scan-pointer insertion-pointer)) (loop ;until a real gesture is read or we throw out ;; First look in the input-buffer of the input-editor and see ;; if there's something there. @@ -441,16 +441,16 @@ ;;--- This is presumably much slower than necessary. ;;--- Perhaps there is a better way to keep track of where the cursor should be. (multiple-value-bind (x-pos y-pos) - (input-buffer-input-position->cursor-position* istream insertion-pointer) + (input-buffer-input-position->cursor-position istream insertion-pointer) (declare (type coordinate x-pos y-pos)) (multiple-value-bind (cx cy) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate cx cy)) ;; Don't set the cursor position if it's already right. ;; This prevents the input editor from scrolling the window after ;; the user has scrolled it back until the cursor position actually changes. (unless (and (= cx x-pos) (= cy y-pos)) - (stream-set-cursor-position* stream x-pos y-pos)))) + (stream-set-cursor-position stream x-pos y-pos)))) (setf rescanning-p nil) (multiple-value-bind (thing type) @@ -628,10 +628,10 @@ (defmethod replace-input ((istream input-editing-stream-mixin) new-input &key (start 0) end rescan (buffer-start (input-position istream))) - (declare (fixnum start buffer-start)) + (declare (type fixnum start buffer-start)) (let ((rescan-p nil)) (with-slots (input-buffer scan-pointer insertion-pointer) istream - (declare (fixnum scan-pointer insertion-pointer)) + (declare (type fixnum scan-pointer insertion-pointer)) (let* ((the-end (the fixnum (or end (length new-input)))) (nchars (the fixnum (- the-end start))) (buffer-total-length (the fixnum (array-dimension input-buffer 0))) @@ -737,7 +737,7 @@ (original-stream-recording-p :accessor original-stream-recording-p))) ;;; Required methods: -(defmethod start-cursor-position* ((istream standard-input-editing-stream)) +(defmethod start-cursor-position ((istream standard-input-editing-stream)) (with-slots (start-x-position start-y-position) istream (values start-x-position start-y-position))) @@ -747,13 +747,13 @@ ;; in this specific implementation it's ok for ;; us to know that our encapsulated stream will ;; support the extended output protocol. - (stream-cursor-position* stream) + (stream-cursor-position stream) (setf start-x-position x start-y-position y)))) (defmethod reset-cursor-position ((istream standard-input-editing-stream)) (with-slots (stream start-x-position start-y-position) istream - (stream-set-cursor-position* stream start-x-position start-y-position))) + (stream-set-cursor-position stream start-x-position start-y-position))) (defmethod erase-input-buffer ((istream standard-input-editing-stream) &optional (start-position 0)) diff --git a/clim/menus.lisp b/clim/menus.lisp index fa93046b..b294d6b3 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.17 92/04/03 12:04:36 cer Exp Locker: cer $ +;; $fiHeader: menus.lisp,v 1.18 92/04/10 14:27:04 cer Exp Locker: cer $ (in-package :clim-internals) @@ -17,7 +17,8 @@ (outlining () (scrolling () (setq menu (make-pane 'clim-stream-pane - :initial-cursor-visibility nil)))))) + :initial-cursor-visibility nil)))))) + (:menu-bar nil)) (defmethod frame-calling-frame ((frame menu-frame)) @@ -107,7 +108,7 @@ parent-width) (min (+ (max label-height height) bottom-margin wtm wbm tm bm) parent-height))))))) - (window-set-viewport-position* menu left top) + (window-set-viewport-position menu left top) ;; blech (clear-input menu)))) @@ -121,7 +122,7 @@ (width (min gw (+ (- maxx minx) right-margin))) (height (min gh (+ (- maxy miny) bottom-margin)))) (window-set-inside-size menu width height) - (window-set-viewport-position* menu minx miny))))) + (window-set-viewport-position menu minx miny))))) #-Silica (defun position-window-near-carefully (window x y) @@ -137,8 +138,8 @@ (setq left (- parent-width width))) (when (> bottom parent-height) (setq top (- parent-height height))) - (bounding-rectangle-set-position* window - (max 0 left) (max 0 top)))))) + (bounding-rectangle-set-position window + (max 0 left) (max 0 top)))))) #-Silica (defun position-window-near-pointer (window &optional x y) @@ -482,7 +483,7 @@ #+Cloe-Runtime (stream-set-input-focus menu) (when default-presentation (with-bounding-rectangle* (left top right bottom) default-presentation - (stream-set-pointer-position* + (stream-set-pointer-position menu (floor (+ left right) 2) (floor (+ top bottom) 2)))) ;; Pointer documentation usually adds no information, and slows things ;; down in a big way, which is why we defaultly disable it. diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index 61fb0737..95fa1d40 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.8 92/03/04 16:22:03 cer Exp Locker: cer $ +;; $fiHeader: output-protocol.lisp,v 1.9 92/03/09 17:41:47 cer Exp $ (in-package :clim-internals) @@ -23,17 +23,18 @@ (defclass output-protocol-mixin (basic-extended-output-protocol) - ((cursor-x :initform 0) - (cursor-y :initform 0) - (baseline :initform 0 :accessor stream-baseline) + ((cursor-x :initform (coordinate 0)) + (cursor-y :initform (coordinate 0)) + (baseline :initform (coordinate 0) :accessor stream-baseline) (foreground :initform +black+ :accessor medium-foreground :initarg :stream-foreground) (background :initform +white+ :accessor medium-background :initarg :stream-background) - (current-line-height :initform 0 :accessor stream-current-line-height) - (vertical-space :initform 2 :initarg :vertical-spacing + (current-line-height :initform (coordinate 0) + :accessor stream-current-line-height) + (vertical-space :initform (coordinate 2) :initarg :vertical-spacing :accessor stream-vertical-spacing) (end-of-line-action :initarg :end-of-line-action :accessor stream-end-of-line-action) @@ -135,7 +136,8 @@ ;;--- I sure don't like having to do this to make string streams work (defmethod stream-default-view ((stream t)) +textual-view+) -(defmethod stream-vertical-spacing ((stream t)) 0) +(defmethod stream-vertical-spacing ((stream t)) + (coordinate 0)) ;;; The default text margin, by the way, isn't in user-visible coordinates. (defmethod stream-text-margin ((stream output-protocol-mixin)) @@ -214,42 +216,52 @@ default-text-style)) (setf merged-text-style-valid t))))) -(defmethod stream-cursor-position* ((stream output-protocol-mixin)) +(defmethod stream-cursor-position ((stream output-protocol-mixin)) (with-slots (cursor-x cursor-y) stream (values cursor-x cursor-y))) -;; X and Y had better be fixnums -;;--- Coerce to COORDINATE -(defmethod stream-set-cursor-position* ((stream output-protocol-mixin) x y) +(defmethod stream-set-cursor-position ((stream output-protocol-mixin) x y) (declare (type coordinate x y)) (with-slots (cursor-x cursor-y current-line-height baseline) stream - (when x (setf cursor-x x)) + (when x + (setf cursor-x (coordinate x))) (when y (unless (eq y cursor-y) - (setf current-line-height 0 baseline 0)) ;going to a new line - (setf cursor-y y))) + (setf current-line-height (coordinate 0) ;going to a new line + baseline (coordinate 0))) + (setf cursor-y (coordinate y)))) #+Silica - ;; --- Call explicitly in Silica version, rather than around methods on - ;; --- intermediary class. + ;;--- In the non-Silica case, this happens via an intermediary class (stream-ensure-cursor-visible stream x y)) -;; X and Y had better be fixnums -;;--- Coerce to COORDINATE -(defmethod stream-set-cursor-position*-internal ((stream output-protocol-mixin) x y) +#+CLIM-1-compatibility +(define-compatibility-function (stream-cursor-position* + stream-cursor-position) + (stream) + (stream-cursor-position stream)) + +#+CLIM-1-compatibility +(define-compatibility-function (stream-set-cursor-position* + stream-set-cursor-position) + (stream x y) + (stream-set-cursor-position stream x y)) + +(defmethod stream-set-cursor-position-internal ((stream output-protocol-mixin) x y) (declare (type coordinate x y)) (with-slots (cursor-x cursor-y current-line-height baseline) stream - (when x (setf cursor-x x)) + (when x + (setf cursor-x (coordinate x))) (when y (unless (eq y cursor-y) - (setf current-line-height 0 baseline 0)) ;going to a new line - (setf cursor-y y))) + (setf current-line-height (coordinate 0) ;going to a new line + baseline (coordinate 0))) + (setf cursor-y (coordinate y)))) #+Silica - ;; --- Call explicitly in Silica version, rather than around methods on - ;; --- intermediary class. + ;;--- In the non-Silica case, this happens via an intermediary class (stream-ensure-cursor-visible stream x y)) #+Genera -(defmethod stream-compatible-cursor-position* ((stream output-protocol-mixin) &optional unit) +(defmethod stream-compatible-cursor-position ((stream output-protocol-mixin) &optional unit) (with-slots (cursor-x cursor-y) stream (if (eq unit :character) (values (floor cursor-x (stream-character-width stream #\m)) @@ -257,22 +269,22 @@ (values cursor-x cursor-y)))) #+Genera -(defmethod stream-compatible-set-cursor-position* ((stream output-protocol-mixin) x y - &optional unit) +(defmethod stream-compatible-set-cursor-position ((stream output-protocol-mixin) x y + &optional unit) (when (eq unit :character) (setq x (* x (stream-character-width stream #\m)) y (* y (stream-line-height stream)))) - (stream-set-cursor-position* stream x y)) + (stream-set-cursor-position stream x y)) #+Genera -(defmethod stream-compatible-increment-cursor-position* ((stream output-protocol-mixin) x y - &optional unit) +(defmethod stream-compatible-increment-cursor-position ((stream output-protocol-mixin) x y + &optional unit) (when (eq unit :character) (when x (setq x (* x (stream-character-width stream #\m)))) (when y (setq y (* y (stream-line-height stream))))) - (stream-increment-cursor-position* stream x y)) + (stream-increment-cursor-position stream x y)) ;;; Make normal output streams obey some parts of other protocols for efficiency. @@ -349,46 +361,52 @@ (declare (ignore origin-x origin-y)) (let ((new-x (floor (* column space-width)))) (when (< (slot-value output-stream 'cursor-x) new-x) - (stream-set-cursor-position* output-stream new-x nil) + (stream-set-cursor-position output-stream new-x nil) t)))) -(defmethod stream-increment-cursor-position* ((stream output-protocol-mixin) dx dy) +(defmethod stream-increment-cursor-position ((stream output-protocol-mixin) dx dy) (declare (type coordinate dx dy)) (with-slots (cursor-x cursor-y) stream (declare (type coordinate cursor-x cursor-y)) (let ((cx (if dx (+ cursor-x dx) cursor-x)) (cy (if dy (+ cursor-y dy) cursor-y))) - (stream-set-cursor-position* stream cx cy)))) + (stream-set-cursor-position stream cx cy)))) + +#+CLIM-1-compatibility +(define-compatibility-function (stream-increment-cursor-position* + stream-increment-cursor-position) + (stream dx dy) + (stream-increment-cursor-position stream dx dy)) (defmethod stream-advance-cursor-x ((stream output-protocol-mixin) amount) (declare (type coordinate amount)) (with-slots (cursor-x cursor-y) stream (declare (type coordinate cursor-x cursor-y)) - (stream-set-cursor-position* + (stream-set-cursor-position stream (+ cursor-x amount) cursor-y))) (defmethod stream-advance-cursor-line ((stream output-protocol-mixin)) (with-slots (cursor-x cursor-y vertical-space current-line-height baseline) stream (declare (type coordinate cursor-x cursor-y vertical-space current-line-height baseline)) - (stream-set-cursor-position* + (stream-set-cursor-position stream 0 (+ cursor-y (stream-line-height stream) vertical-space)))) (defmethod window-clear :before ((stream output-protocol-mixin)) (with-slots (baseline current-line-height) stream - (setf baseline 0 - current-line-height 0))) + (setf baseline (coordinate 0) + current-line-height (coordinate 0)))) ;;; --- Should probably be on some intermediary class, since it can only ;;; be run when the stream is part of a WINDSHIELD hierarchy. #+Silica -;; --- See comment on stream-set-cursor-position* +;; --- See comment on stream-set-cursor-position (defmethod stream-ensure-cursor-visible ((stream output-protocol-mixin) &optional cx cy) (when (and (or (not (output-recording-stream-p stream)) (stream-drawing-p stream)) (pane-scroller stream)) - (unless cy (multiple-value-setq (cx cy) (stream-cursor-position* stream))) + (unless cy (multiple-value-setq (cx cy) (stream-cursor-position stream))) (let ((viewport (pane-viewport-region stream)) (new-x nil) (new-y nil) @@ -416,11 +434,11 @@ ;; If the cursor moves outside the current region, expand ;; it to include the new cursor position. (when (> cy (bounding-rectangle-height stream)) - (update-region stream - (bounding-rectangle-min-x stream) - (bounding-rectangle-min-y stream) - cx - cy :no-repaint t)) + (update-region stream + (bounding-rectangle-min-x stream) + (bounding-rectangle-min-y stream) + cx cy + :no-repaint t)) (when (or new-x new-y) (scroll-extent stream :x (or new-x vleft) :y (or new-y vtop))))))) @@ -673,11 +691,11 @@ (declare (values last-x largest-x last-y total-height baseline)) (unless end (setf end (length string))) (let ((style (or text-style (medium-merged-text-style stream))) - (cursor-x 0) - (cursor-y 0) - (height 0) - (baseline 0) - (largest-x 0)) + (cursor-x (coordinate 0)) + (cursor-y (coordinate 0)) + (height (coordinate 0)) + (baseline (coordinate 0)) + (largest-x (coordinate 0))) (declare (type coordinate cursor-x cursor-y height baseline largest-x)) (let (#+Silica (medium (sheet-medium stream))) (loop @@ -685,9 +703,7 @@ (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height) (stream-scan-string-for-writing stream #+Silica medium string start end style - ;;--- MOST-POSITIVE-FIXNUM will - ;;--- lose, use a big single-float - cursor-x most-positive-fixnum) + cursor-x +largest-coordinate+) (declare (type coordinate new-cursor-x new-baseline new-height)) (maxf largest-x new-cursor-x) (maxf baseline new-baseline) @@ -699,9 +715,7 @@ ((or (graphic-char-p write-char) (diacritic-char-p write-char)) (multiple-value-bind (no-wrap new-cursor-x new-baseline new-height) (stream-scan-character-for-writing stream character style - ;;--- MOST-POSITIVE-FIXNUM will - ;;--- lose, use a big single-float - cursor-x most-positive-fixnum) + cursor-x +largest-coordinate+) (declare (ignore no-wrap)) (maxf largest-x new-cursor-x) (maxf baseline new-baseline) @@ -709,9 +723,9 @@ (setf cursor-x new-cursor-x))) ((or (eql write-char #\Newline) (eql write-char #\Return)) - (setf cursor-x 0) + (setf cursor-x (coordinate 0)) (incf cursor-y height) - (setf baseline 0 + (setf baseline (coordinate 0) height (stream-line-height stream style))) ((eql write-char #\Tab) (setf cursor-x (stream-next-tab-column stream cursor-x style)) @@ -720,9 +734,7 @@ (multiple-value-bind (new-cursor-x new-cursor-y new-baseline new-height) (stream-draw-lozenged-character stream write-char cursor-x cursor-y baseline height text-style - ;;--- MOST-POSITIVE-FIXNUM will - ;;--- lose, use a big single-float - most-positive-fixnum nil nil) + +largest-coordinate+ nil nil) (setf cursor-x new-cursor-x cursor-y new-cursor-y baseline new-baseline height new-height)))) (incf start))))) @@ -746,10 +758,10 @@ (values bb-x bb-y))) ((or (eql character #\Newline) (eql character #\Return)) - (values (- (stream-cursor-position* stream)) + (values (- (stream-cursor-position stream)) (stream-line-height stream style))) ((eql character #\Tab) - (let ((here (stream-cursor-position* stream))) + (let ((here (stream-cursor-position stream))) (- (stream-next-tab-column stream here style) here))) (t (cerror "Continue without drawing the character" "Can't yet draw lozenged characters: ~@C" character))))) @@ -821,7 +833,7 @@ (defmethod decode-stream-for-writing ((stream output-protocol-mixin) &optional brief-p) (declare (values cursor-x cursor-y baseline line-height style max-x record-p draw-p glyph-buffer)) - (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position* stream) + (multiple-value-bind (cursor-x cursor-y) (stream-cursor-position stream) (let ((baseline (stream-baseline stream)) (line-height (stream-current-line-height stream)) (wrap-p (unless brief-p (eq (stream-end-of-line-action stream) ':wrap)))) @@ -831,16 +843,14 @@ (medium-merged-text-style stream) (cond ((and wrap-p (stream-text-margin stream))) - ;;--- MOST-POSITIVE-FIXNUM will - ;;--- lose, use a big single-float - (t most-positive-fixnum)) + (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) - (stream-set-cursor-position*-internal stream cursor-x cursor-y) + (stream-set-cursor-position-internal stream cursor-x cursor-y) (setf (stream-baseline stream) baseline (stream-current-line-height stream) line-height)) @@ -872,8 +882,8 @@ ;;; translation is done, and STREAM-WRITE-STRING-1 will be called with the ;;; original string, not the glyph buffer. (defmacro stream-scan-string-for-writing-body () - '(let ((baseline 0) - (height 0) + '(let ((baseline (coordinate 0)) + (height (coordinate 0)) (our-font nil) (next-glyph (if (and glyph-buffer (array-has-fill-pointer-p glyph-buffer)) (fill-pointer glyph-buffer) @@ -904,15 +914,13 @@ #-Silica stream #+Silica medium character style our-font) (declare (ignore escapement-y origin-x bb-x)) - (declare (fixnum index)) - (declare (type coordinate origin-y bb-y)) + (declare (type fixnum index) + (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)) (chars-left (- end start)) (glyphs-left - ;;--- MOST-POSITIVE-FIXNUM will - ;;--- lose, use a big single-float (if max-glyph (- max-glyph next-glyph) most-positive-fixnum)) (chars-to-do (min spaces-left chars-left glyphs-left)) (chars-done 0) @@ -962,7 +970,7 @@ cursor-x max-x &optional glyph-buffer) (declare (values write-char next-char-index new-cursor-x new-baseline new-height font)) (declare (type coordinate cursor-x max-x)) - (declare (fixnum start end)) + (declare (type fixnum start end)) (stream-scan-string-for-writing-body)) ;;; This function returns NIL as its first value if the character won't @@ -1009,6 +1017,9 @@ (let ((tab-size (stream-tab-size stream style))) (* tab-size (ceiling (1+ cursor-x) tab-size)))) + +;;; Genera hooks + #+Genera (defmethod stream-compatible-output-as-presentation-1 ((stream output-protocol-mixin) @@ -1057,6 +1068,38 @@ (with-text-style (stream new-style) (declare (ignore stream)) (funcall continuation xstream)))) + +#+Genera +;; Allows outputting a fat string to a CLIM stream +(defmethod stream-write-string :around ((stream output-protocol-mixin) string + &optional (outer-start 0) outer-end) + (unless outer-end + (setq outer-end (length string))) + (unless (and (> outer-end outer-start) (scl:string-fat-p string)) + (return-from stream-write-string (call-next-method))) + (let ((string string)) + (declare (sys:array-register string)) + (loop for start = outer-start then end + while start + as char = (char string start) + as style = (si:char-style char) + as end = (position style string + :test-not #'eql :key #'si:char-style + :start start :end outer-end) + do + (scl:with-character-style (style stream) + (call-next-method + stream + (scl:string-thin string :start start :end (or end outer-end))))))) + +#+Genera +;; Allows outputting a fat character to a CLIM stream +(defmethod stream-write-char :around ((stream output-protocol-mixin) character) + (unless (scl:char-fat-p character) + (return-from stream-write-char (call-next-method))) + (scl:with-character-style ((si:char-style character) stream) + (call-next-method stream (si:strip-style character)))) + ;;; Input Editor support. This does STREAM-SCAN-STRING-FOR-WRITING and ;;; other stuff, and calls the continuation so the Input Editor can know @@ -1072,7 +1115,8 @@ (let ((vsp (stream-vertical-spacing stream)) #+Silica (medium (sheet-medium stream))) (loop - (when (>= start end) (return (values cursor-x cursor-y height baseline))) + (when (>= start end) + (return (values cursor-x cursor-y height baseline))) (multiple-value-bind (write-char next-char-index new-cursor-x new-baseline new-height) (stream-scan-string-for-writing stream #+Silica medium string start end style @@ -1089,7 +1133,9 @@ (eql write-char #\Newline) (eql write-char #\Return)) (incf cursor-y (+ height vsp)) - (setf height 0 cursor-x 0 baseline 0) + (setf height (coordinate 0) + cursor-x (coordinate 0) + baseline (coordinate 0)) ;; If we wrapped, rescan the character normally, but if this is a newline ;; we're done with it. (when (or (eql write-char #\Newline) @@ -1103,7 +1149,9 @@ (let ((new-cursor-x (stream-next-tab-column stream cursor-x style))) (when (> (+ new-cursor-x *character-wrap-indicator-width*) max-x) (incf cursor-y (+ height vsp)) - (setf height 0 cursor-x 0 baseline 0) + (setf height (coordinate 0) + cursor-x (coordinate 0) + baseline (coordinate 0)) (setf new-cursor-x (stream-next-tab-column stream cursor-x style))) (funcall continuation cursor-x cursor-y new-cursor-x (+ cursor-y height vsp) baseline) diff --git a/clim/output-recording-protocol.lisp b/clim/output-recording-protocol.lisp deleted file mode 100644 index c272a05f..00000000 --- a/clim/output-recording-protocol.lisp +++ /dev/null @@ -1,1852 +0,0 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- - -;; $fiHeader: output-recording-protocol.lisp,v 1.5 92/01/31 14:58:28 cer Exp Locker: cer $ - -(in-package :clim-internals) - -"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved. - Portions copyright (c) 1989, 1990 International Lisp Associates." - -;; The protocol class for an object that obeys the output record protocol, -;; that is, can hold output record elements -(define-protocol-class output-record (bounding-rectangle)) - -;; The protocol class for output records that are leaves. -(define-protocol-class displayed-output-record (bounding-rectangle)) - -;; The protocol class for textual displayed output records. -(define-protocol-class text-displayed-output-record (displayed-output-record)) - -;; The protocol class for graphical displayed output records. -(define-protocol-class graphics-displayed-output-record (displayed-output-record)) - - -;;; A mix-in for classes that can be stored by other output records -;;; OUTPUT-RECORD-ELEMENT-MIXIN has slots for -;;; (bounding rectangle, parent, start-position, end-position, contents-ok) -;;; plus space to store old bounding rectangle and position for incremental redisplay -;;; graphics output records -;;; text output records -;;; OUTPUT-RECORD-MIXIN has slots for (generation-tick, old-children) -;;; both used for incremental redisplay. -;;; STANDARD-SEQUENCE-OUTPUT-RECORD -;;; table, row, column, cell, presentation -;;; STANDARD-TREE-OUTPUT-RECORD -;;; KD-TREE-OUTPUT-RECORD (someday) - -;;; The output-record-element "protocol" -;;; :x-position, :y-position, :parent init args. -;;; bounding rectangle protocol - -;;; The output record protocol: -;;; output-record-children: (record) -;;; add-output-record: (child record) -;;; delete-output-record: (child record) -;;; clear-output-record: (record) -;;; replay-output-record: (record stream &optional region (x-offset 0) (y-offset 0) -;;; recompute-extent: (record) -;;; recompute-extent-for-new-child (there's a default): (record child) -;;; recompute-extent-for-changed-child: (record child) -;;; map-over-output-records-overlapping-region: -;;; (function record region -;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) -;;; map-over-output-records-containing-point*: -;;; (function record x y -;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) - -;;; The incremental redisplay protocol: -;;; see file incremental-redisplay-protocol.text, and incremental-redisplay.lisp. -;;; - -;; Bounding rectangle position and set-position are in relative coordinates, -;; relative to (OUTPUT-RECORD-POSITION* (OUTPUT-RECORD-PARENT RECORD)). -;; The bounding rectangle measures just the ink. -;; (OUTPUT-RECORD-START-CURSOR-POSITION* RECORD) refers to the position of the -;; cursor at the start of RECORD. It is also the origin of the -;; coordinate system for all children of RECORD. -(defclass output-record-element-mixin (standard-bounding-rectangle) - ;; start position is relative to the parent's start-position - ;; start position is where the cursor was when the new - ;; output-record was started. - ((start-x :initform 0 :initarg :start-x) - (start-y :initform 0 :initarg :start-y) - ;; end position is relative to start position. - ;; end position is where the cursor was when we finished the - ;; output-record. - (end-x :initform 0 :initarg :end-x) - (end-y :initform 0 :initarg :end-y) - ;; old-start-position is relative to old-start-position of parent - (old-start-x :initform 0) - (old-start-y :initform 0) - ;; old bounding rectangle is relative to parents' old-start-position. - (old-bounding-rectangle :initform nil - :accessor output-record-old-bounding-rectangle) - (contents-ok :initform nil :accessor output-record-contents-ok) - (parent :accessor output-record-parent :initarg :parent) - (stream :initform nil :accessor output-record-stream)) - (:default-initargs :parent nil :left 0 :top 0 :right 0 :bottom 0)) - -;;; Give initial rectangle of 0 size, it will get expanded as children are added. -(defmethod initialize-instance :after ((record output-record-element-mixin) - &key (x-position 0) (y-position 0)) - (with-slots (left top right bottom) record - (setf left x-position - top y-position - right x-position - bottom y-position))) - -;;; Shadow the method on RECTANGLE with this one that keeps the start-position and -;;; bounding rectangle in synch. -(defmethod bounding-rectangle-set-position* ((record output-record-element-mixin) nx ny) - (declare (type coordinate nx ny)) - (with-slots (left top right bottom start-x start-y parent) record - (declare (type coordinate left top right bottom start-x start-y)) - ;; Move the start position by as much as we do the record. - (setq start-x (+ start-x (- nx left))) - (setq start-y (+ start-y (- ny top))) - (let ((width (- right left)) - (height (- bottom top))) - (setf left nx top ny) - (setf right (+ nx width) - bottom (+ ny height))))) - - -#+ignore -(defmethod bounding-rectangle-set-position* :around ((record output-record-element-mixin) nx ny) - (with-bounding-rectangle* (x1 y1 x2 y2) record - (call-next-method) - (note-output-record-moved record (- nx x1) (- ny y1) (- nx x2) (- ny y2)))) - - -#+ignore -(defmethod bounding-rectangle-set-edges :around ((record output-record-element-mixin) - left top right bottom) - (with-bounding-rectangle* (x1 y1 x2 y2) record - (call-next-method) - (note-output-record-moved record (- left x1) (- top y1) (- right x2) (- bottom y2)))) - - -#+Silica -(defmethod note-output-record-moved ((record output-record-element-mixin) dx1 dy1 dx2 dy2) - (declare (ignore dx1 dy1 dx2 dy2)) - nil) - -(defun-inline output-record-position* (record) - (output-record-start-cursor-position* record)) - -;; X and Y had better be fixnums -;;--- Coerce to COORDINATE -(defmethod output-record-set-position* ((record output-record-element-mixin) x y) - (declare (type coordinate x y)) - (bounding-rectangle-set-position* record x y)) - -(defmethod output-record-start-cursor-position ((record output-record-element-mixin)) - (with-slots (start-x start-y) record - (make-point start-x start-y))) - -(defmethod output-record-start-cursor-position* ((record output-record-element-mixin)) - (with-slots (start-x start-y) record - (values start-x start-y))) - -;;; Keep the start-position and bounding rectangle in synch -(defmethod output-record-set-start-cursor-position* - ((record output-record-element-mixin) nx ny) - (declare (type coordinate nx ny)) - (with-slots (start-x start-y) record - (declare (type coordinate start-x start-y)) - (with-bounding-rectangle* (left top right bottom) record - (let ((dx (- nx start-x)) - (dy (- ny start-y))) - (bounding-rectangle-set-edges - record - (+ left dx) (+ top dy) (+ right dx) (+ bottom dy)) - (setf start-x nx start-y ny))))) - -(defmethod output-record-end-cursor-position* ((record output-record-element-mixin)) - (with-slots (end-x end-y) record - (values end-x end-y))) - -(defmethod output-record-set-end-cursor-position* ((record output-record-element-mixin) nx ny) - (declare (type coordinate nx ny)) - (with-slots (end-x end-y) record - (setf end-x nx) - (setf end-y ny))) - -(defmethod output-record-old-start-cursor-position ((record output-record-element-mixin)) - (with-slots (old-start-x old-start-y) record - (make-point old-start-x old-start-y))) - -(defmethod output-record-old-start-cursor-position* ((record output-record-element-mixin)) - (with-slots (old-start-x old-start-y) record - (values old-start-x old-start-y))) - -(defmethod output-record-set-old-start-cursor-position* - ((record output-record-element-mixin) nx ny) - (declare (type coordinate nx ny)) - (with-slots (old-start-x old-start-y) record - (setf old-start-x nx) - (setf old-start-y ny))) - -#+CLIM-1-compatibility -(progn -(define-compatibility-function (output-record-start-position - output-record-start-cursor-position) - (record) - (output-record-start-cursor-position record)) - -(define-compatibility-function (output-record-start-position* - output-record-start-cursor-position*) - (record) - (output-record-start-cursor-position* record)) - -(define-compatibility-function (output-record-set-start-position* - output-record-set-start-cursor-position*) - (record nx ny) - (output-record-set-start-cursor-position* record nx ny)) - -(define-compatibility-function (output-record-end-position* - output-record-end-cursor-position*) - (record) - (output-record-end-cursor-position* record)) - -(define-compatibility-function (output-record-set-end-position* - output-record-set-end-cursor-position*) - (record nx ny) - (output-record-set-end-cursor-position* record nx ny)) -) ;#+CLIM-1-compatibility - - -(defmethod output-record-children ((record output-record-element-mixin)) - nil) - -;;; For specialization by PRESENTATIONs, for example -(defmethod output-record-refined-sensitivity-test ((record output-record-element-mixin) x y) - (declare (ignore x y)) - T) - -(defun compute-output-record-offsets (record) - (let ((parent (output-record-parent record))) - (if (null parent) - (values 0 0) - (multiple-value-bind (x y) - (compute-output-record-offsets parent) - (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* record) - (declare (type coordinate our-x our-y)) - (values (+ our-x x) (+ our-y y))))))) - -(defmethod region-equal - ((record1 output-record-element-mixin) (record2 output-record-element-mixin)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) record1 - (with-bounding-rectangle* (left2 top2 right2 bottom2) record2 - (if (eq (output-record-parent record1) (output-record-parent record2)) - (ltrb-equals-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2) - (multiple-value-bind (xoff1 yoff1) (compute-output-record-offsets record1) - (declare (type coordinate xoff1 yoff1)) - (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) - (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) - (ltrb-equals-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2))))))) - -(defmethod region-contains-point*-p - ((record output-record-element-mixin) x y) - (with-bounding-rectangle* (left top right bottom) record - (multiple-value-bind (xoff yoff) (compute-output-record-offsets record) - (declare (type coordinate xoff yoff)) - (ltrb-contains-point*-p left top right bottom - (+ x xoff) (+ y yoff))))) - -(defmethod region-contains-region-p - ((record1 output-record-element-mixin) (record2 output-record-element-mixin)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) record1 - (with-bounding-rectangle* (left2 top2 right2 bottom2) record2 - (if (eq (output-record-parent record1) (output-record-parent record2)) - (ltrb-contains-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2) - (multiple-value-bind (xoff1 yoff1) (compute-output-record-offsets record1) - (declare (type coordinate xoff1 yoff1)) - (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) - (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) - (ltrb-contains-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2))))))) - -(defmethod region-intersects-region-p - ((record1 output-record-element-mixin) (record2 output-record-element-mixin)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) record1 - (with-bounding-rectangle* (left2 top2 right2 bottom2) record2 - (if (eq (output-record-parent record1) (output-record-parent record2)) - (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2) - (multiple-value-bind (xoff1 yoff1) (compute-output-record-offsets record1) - (declare (type coordinate xoff1 yoff1)) - (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) - (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) - (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2))))))) - -(defun region-contains-offset-region-p (region1 region2 xoff yoff) - (declare (type coordinate xoff yoff)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) region1 - (with-bounding-rectangle* (left2 top2 right2 bottom2) region2 - (ltrb-contains-ltrb-p left1 top1 right1 bottom1 - (+ left2 xoff) (+ top2 yoff) (+ right2 xoff) (+ bottom2 yoff))))) - -(defun region-intersects-offset-region-p (region1 region2 xoff yoff) - (declare (type coordinate xoff yoff)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) region1 - (with-bounding-rectangle* (left2 top2 right2 bottom2) region2 - (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 - (+ left2 xoff) (+ top2 yoff) (+ right2 xoff) (+ bottom2 yoff))))) - -(defun offset-region-contains-point*-p (region xoff yoff x y) - (declare (type coordinate xoff yoff x y)) - (with-bounding-rectangle* (left top right bottom) region - (ltrb-contains-point*-p (+ left xoff) (+ top yoff) (+ right xoff) (+ bottom yoff) - x y))) - -;;; This maps over all of the children of the record -#+Genera (zwei:defindentation (map-over-output-records 1 1)) -(defun map-over-output-records (function record - &optional (x-offset 0) (y-offset 0) - &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records-overlapping-region - function record nil x-offset y-offset continuation-args)) - -#+CLIM-1-compatibility -(define-compatibility-function (map-over-output-record-elements - map-over-output-records) - (record function - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records - function record x-offset y-offset continuation-args)) - -;;; This must map over the children in such a way that, when it maps over -;;; overlapping children, the topmost (most recently inserted) child is -;;; hit last. This is because this function is used for things such as -;;; replaying, where the most recently drawn thing must come out on top -;;; (i.e., must be drawn last). If the region is NIL, then this maps over -;;; all of the children in the output record. -#+Genera (zwei:defindentation (map-over-output-records-overlapping-region 2 1)) -(defgeneric map-over-output-records-overlapping-region - (function record region - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args))) - -#+CLIM-1-compatibility -(define-compatibility-function (map-over-output-record-elements-overlapping-region - map-over-output-records-overlapping-region) - (record region function - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records-overlapping-region - function record region x-offset y-offset continuation-args)) - -;;; This must map over the children in such a way that, when it maps over -;;; overlapping children, the topmost (most recently inserted) child is -;;; hit first, that is, the opposite order of MAP-...-OVERLAPPING-REGION. -;;; This is because this function is used for things like locating the -;;; presentation under the pointer, where the topmost thing wants to be -;;; located first. -#+Genera (zwei:defindentation (map-over-output-records-containing-point* 3 1)) -(defgeneric map-over-output-records-containing-point* - (function record x y - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args))) - -#+CLIM-1-compatibility -(define-compatibility-function (map-over-output-record-elements-containing-point* - map-over-output-records-containing-point*) - (record x y function - &optional x-offset y-offset &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records-containing-point* - function record x y x-offset y-offset continuation-args)) - -;;; X-offset and Y-offset represent the accumulated offset between the -;;; regions's native coordinates and "our" coordinates and must be added -;;; to our local coordinates (or subtracted from the region, if -;;; possible) in order to validly compare them. -;;; -;;; In the absence of x- and y- offsets, region should be in the -;;; coordinate system of the record - i.e. relative to -;;; (OUTPUT-RECORD-POSITION* RECORD). -;;; This is the same coordinate system as the output record children -;;; we are mapping over. -(defmethod map-over-output-records-overlapping-region - (function (record output-record-element-mixin) region - &optional (x-offset 0) (y-offset 0) &rest continuation-args) - (declare (ignore region function x-offset y-offset continuation-args) - (dynamic-extent function continuation-args)) - nil) - -(defmethod map-over-output-records-containing-point* - (function (record output-record-element-mixin) x y - &optional (x-offset 0) (y-offset 0) &rest continuation-args) - (declare (ignore x y function x-offset y-offset continuation-args) - (dynamic-extent function continuation-args)) - nil) - -(defmethod map-over-output-records-containing-point* - (function (record t) x y - &optional (x-offset 0) (y-offset 0) &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records-overlapping-region - function record (make-point x y) - x-offset y-offset continuation-args)) - -;; If some coordinate is relative to a given output-record, then -;; CONVERT-FROM-RELATIVE-TO-ABSOLUTE-COORDINATES returns an x,y offset -;; to be ADDED to any coordinates relative to OUTPUT-RECORD to give you -;; absolute coordinates. -(defun convert-from-relative-to-absolute-coordinates (stream output-record) - (declare (values x-offset y-offset)) - (cond ((null output-record) - (values 0 0)) ;;---------------------------- Why? - ((and stream - (eql output-record (stream-current-output-record stream))) - (let ((position (stream-output-history-position stream))) - (values (point-x position) (point-y position)))) - ((null (output-record-parent output-record)) - (values 0 0)) - (t - (multiple-value-bind (x y) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent output-record)) - (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* output-record) - (declare (type coordinate our-x our-y)) - (values (+ our-x x) (+ our-y y))))))) - -;; If some coordinate is in absolute coordinates, then -;; CONVERT-FROM-ABSOLUTE-TO-RELATIVE-COORDINATES returns an x,y offset -;; to be ADDED to any absolute coordinates to give you coordinates -;; relative to OUTPUT-RECORD. -(defun convert-from-absolute-to-relative-coordinates (stream output-record) - (declare (values x-offset y-offset)) - (cond ((eql output-record (stream-current-output-record stream)) - (let ((position (stream-output-history-position stream))) - (values (- (point-x position)) (- (point-y position))))) - ((null (output-record-parent output-record)) - (values 0 0)) - (t - (multiple-value-bind (x y) - (convert-from-absolute-to-relative-coordinates - stream (output-record-parent output-record)) - (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* output-record) - (declare (type coordinate our-x our-y)) - (values (- x our-x) (- y our-y))))))) - -;; if ANCESTOR is an output-record with DESCENDANT as a descendant -;; output-record (member of the transitive closure of all children of -;; ancestor) then: CONVERT-FROM-ANCESTOR-TO-DESCENDANT-COORDINATES -;; returns an x,y offset pair that can be ADDED to any coordinates -;; relative to ANCESTOR in order to get coordinates relative to -;; DESCENDANT. -(defun convert-from-ancestor-to-descendant-coordinates (ancestor descendant) - (declare (values x-offset y-offset)) - (cond ((eql descendant ancestor) - (values 0 0)) - ((null descendant) - (error "~S was not an ancestor of ~S" ancestor descendant)) - (t - (multiple-value-bind (x y) - (convert-from-ancestor-to-descendant-coordinates - ancestor (output-record-parent descendant)) - (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* descendant) - (declare (type coordinate our-x our-y)) - (values (- x our-x) (- y our-y))))))) - -;; if ANCESTOR is an output-record with DESCENDANT as a descendant -;; output-record (member of the transitive closure of all children of -;; ancestor) then: CONVERT-FROM-DESCENDANT-TO-ANCESTOR-COORDINATES -;; returns an x,y offset pair that can be ADDED to any coordinates -;; relative to DESCENDANT in order to get coordinates relative to -;; ANCESTOR. -(defun convert-from-descendant-to-ancestor-coordinates (descendant ancestor) - (declare (values x-offset y-offset)) - (cond ((eql descendant ancestor) - (values 0 0)) - ((null descendant) - (error "~s was not an ancestor of ~s" ancestor descendant)) - (t - (multiple-value-bind (x y) - (convert-from-descendant-to-ancestor-coordinates - (output-record-parent descendant) ancestor) - (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* descendant) - (declare (type coordinate our-x our-y)) - (values (+ our-x x) (+ our-y y))))))) - -;; A mix-in for classes that can store other output records -(defclass output-record-mixin () - ;; OLD-CHILDREN is the list of >unmatched< output records from last - ;; redisplay pass. if you implement your own FIND-INFERIOR-OUTPUT-RECORD, - ;; and iff you match from OLD-CHILDREN, you are required to remove the - ;; match from OLD-CHILDREN, probably by using DECACHE-INFERIOR-OUTPUT-RECORD. - ((old-children :initform nil :accessor output-record-old-children) - (generation-tick :initform 0 :initarg :generation-tick - :accessor output-record-generation-tick))) - -(defmethod inferiors-never-overlap-p ((record output-record-mixin)) nil) - -#+Silica -(defmethod note-output-record-moved :after ((record output-record-mixin) dx1 dy1 dx2 dy2) - (unless (= 0 dx1 dy1 dx2 dy2) - (map-over-output-records - #'(lambda (child) - (note-output-record-moved child dx1 dy1 dx2 dy2)) - record))) - -#+Silica -(defmethod bounding-rectangle-set-position* :around ((record output-record-mixin) nx ny) - (multiple-value-bind (ox oy) - (output-record-position* record) - (call-next-method) - (when (or (/= ox nx) (/= oy ny)) - (note-output-record-moved record 1 1 1 1)))) - -#+Silica -(defmethod bounding-rectangle-set-edges :around ((record output-record-mixin) - left top right bottom) - (declare (ignore left top right bottom)) - (multiple-value-bind (ox oy) - (output-record-position* record) - (call-next-method) - (multiple-value-bind (nx ny) - (output-record-position* record) - (when (or (/= ox nx) (/= oy ny)) - (note-output-record-moved record 1 1 1 1))))) - -(defun with-output-record-1 (continuation stream record &optional abs-x abs-y) - ;; Close the text record before and after, - (stream-close-text-output-record stream) - (let ((current-output-position - (stream-output-history-position stream))) - (unless abs-y - (multiple-value-setq (abs-x abs-y) - (stream-cursor-position* stream))) - (letf-globally (((point-x current-output-position) abs-x) - ((point-y current-output-position) abs-y) - ((stream-current-output-record stream) record)) - (funcall continuation record) - (multiple-value-bind (end-x end-y) - (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 stream)))) - -;;; Rest of stuff started in clim-defs... -(defun construct-output-record-1 (type &rest init-args) - (declare (dynamic-extent init-args)) - (let ((constructor (gethash type *output-record-constructor-cache*))) - (if constructor - (apply constructor init-args) - (apply #'make-instance type init-args)))) - -#|| -;;; A hash table associating vectors holding free output records. -;;; The idea is to not cons on allocate/free, but be fast. -(defvar *record-resource-table* (make-hash-table)) -(defvar *use-record-resources* nil) - -(defun allocate-record (type) - (when *use-record-resources* - (multiple-value-bind (record-vector found-p) - (gethash type *record-resource-table*) - (unless found-p - (setq record-vector - (setf (gethash type *record-resource-table*) - (make-array 20 :fill-pointer 0)))) - (vector-pop record-vector)))) - -(defun free-record (record) - (when *use-record-resources* - (let ((type (class-name (class-of record)))) - (multiple-value-bind (record-vector found-p) - (gethash type *record-resource-table*) - (unless found-p - (setq record-vector - (setf (gethash type *record-resource-table*) - (make-array 20 :fill-pointer 0)))) - (setf (output-record-parent record) nil) - (vector-push-extend record record-vector))))) -||# - -(defun invoke-with-new-output-record (stream continuation record-type constructor - &rest init-args &key parent &allow-other-keys) - (declare (dynamic-extent init-args)) - (with-keywords-removed (init-args init-args '(:parent)) - (let* ((current-output-record (stream-current-output-record stream)) - (new-output-record (and (stream-redisplaying-p stream) - current-output-record - (apply #'find-inferior-output-record-1 - current-output-record record-type init-args)))) - (multiple-value-bind (cursor-x cursor-y) - (stream-cursor-position* stream) - (declare (type coordinate cursor-x cursor-y)) - (multiple-value-bind (x y) - (multiple-value-bind (px py) - (point-position* - (stream-output-history-position stream)) - (declare (type coordinate px py)) - (position-difference* cursor-x cursor-y px py)) - (declare (type coordinate x y)) - (if new-output-record - (copy-display-state new-output-record nil) - (setq new-output-record - ;;--- Used to call ALLOCATE-RECORD, then initialize by - ;;--- setting the edges (or INITIALIZE-INSTANCE) - (if constructor - (apply constructor - :x-position x :y-position y init-args) - (apply #'construct-output-record-1 record-type - :x-position x :y-position y init-args)))) - (output-record-set-start-cursor-position* new-output-record x y) - (with-output-record-1 continuation - 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 - ;; to RECOMPUTE-CONTENTS-OK inside the dynamic extent of the - ;; continuation won't take forever. - (let ((parent (or parent - current-output-record - (stream-output-history stream)))) - (when parent - (add-output-record new-output-record parent))) - new-output-record))))) - -(defun invoke-with-room-for-graphics (stream continuation record-type move-cursor &key height) - (let ((record - (with-output-recording-options (stream :draw nil :record t) - (with-first-quadrant-coordinates (stream) - (with-new-output-record (stream record-type) - (funcall continuation stream)))))) - (multiple-value-bind (x y) (output-record-position* record) - (declare (type coordinate x y)) - ;;--- Hey, there is something wierd going on here. The problem is that - ;;--- OUTPUT-RECORD-POSITION* and OUTPUT-RECORD-SET-POSITION* seem to obey - ;;--- different coordinate system conventions. Geez. - (when height - (incf y (- height (bounding-rectangle-height record)))) - (output-record-set-position* record x y)) - (tree-recompute-extent record) - (replay record stream) - (when move-cursor - (move-cursor-beyond-output-record stream record)) - record)) - -(defun replay (record stream &optional region) - (when (stream-drawing-p stream) - (multiple-value-bind (x-offset y-offset) - (convert-from-relative-to-absolute-coordinates stream (output-record-parent record)) - ;; Output recording should be off, but let's be forgiving... - (letf-globally (((stream-recording-p stream) nil)) - (replay-output-record record stream region x-offset y-offset))))) - -;; Replay all the the inferiors of RECORD that overlap REGION. -(defmethod replay-output-record ((record output-record-mixin) stream - &optional region (x-offset 0) (y-offset 0)) - (declare (type coordinate x-offset y-offset)) - ;;--- Doing things this way bypasses any REPLAY-OUTPUT-RECORD methods supplied on - ;;--- non-standard classes that satisfy the output record protocol. - ;;--- Too bad, this relative coordinates stuff is a disaster anyway. - (labels ((replay-internal (record x-offset y-offset) - (declare (type coordinate x-offset y-offset)) - (if (output-record-p record) - (multiple-value-bind (xoff yoff) (output-record-position* record) - (map-over-output-records-overlapping-region - #'replay-internal record region - (- x-offset) (- y-offset) - (+ x-offset xoff) (+ y-offset yoff))) - (replay-output-record record stream region x-offset y-offset)))) - (declare (dynamic-extent #'replay-internal)) - (replay-internal record x-offset y-offset))) - -(defun move-cursor-beyond-output-record (stream record) - (multiple-value-bind (x-offset y-offset) - (convert-from-relative-to-absolute-coordinates - stream (output-record-parent record)) - (declare (type coordinate x-offset y-offset)) - (with-bounding-rectangle* (left top right bottom) record - (declare (ignore left top)) - (with-end-of-page-action (stream :allow) - (stream-set-cursor-position* - stream - (+ right x-offset) (- (+ bottom y-offset) (stream-line-height stream))))))) - -(defmethod recompute-extent-for-changed-child ((record output-record-mixin) child - old-left old-top old-right old-bottom) - (declare (type coordinate old-top old-right old-bottom)) - ;; old edges are passed in parent's coordinate system because - ;; their reference point may have changed. - ;; (assert (child-completely-contained-within-extent-of record child)) - (with-slots (parent) record - (with-bounding-rectangle* (left top right bottom) record - ;; We must recompute the extent if the child is not completely contained - ;; or if it used to "define" one of the old edges. - ;; A picture would help, but we're not going to draw it here. (:-) - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates record parent) - (when (or (not (region-contains-offset-region-p record child xoff yoff)) - (= old-left left) - (= old-top top) - (= old-right right) - (= old-bottom bottom)) - (recompute-extent record)))))) - -(defmethod recompute-extent ((record output-record-mixin)) - (with-slots (parent) record - (with-bounding-rectangle* (old-left old-top old-right old-bottom) record - (let ((once nil) - (min-x 0) (min-y 0) (max-x 0) (max-y 0)) - (declare (type coordinate min-x min-y max-x max-y)) - (flet ((recompute-extent-of-child (child) - (with-bounding-rectangle* (left top right bottom) child - (cond (once - (minf min-x left) - (minf min-y top) - (maxf max-x right) - (maxf max-y bottom)) - (t - (setq min-x left - min-y top - max-x right - max-y bottom - once t)))))) - (declare (dynamic-extent #'recompute-extent-of-child)) - (map-over-output-records #'recompute-extent-of-child record)) - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates record parent) - (declare (type coordinate xoff yoff)) - (if once - (progn (assert (ltrb-well-formed-p min-x min-y max-x max-y)) - (bounding-rectangle-set-edges - record - (+ min-x xoff) (+ min-y yoff) - (+ max-x xoff) (+ max-y yoff))) - ;; No children - (bounding-rectangle-set-edges record 0 0 0 0)) - ;; Pass these coordinates in parent's coordinate system (I think) - (translate-fixnum-positions xoff yoff - old-left old-top old-right old-bottom)) - (when parent - (recompute-extent-for-changed-child - parent record old-left old-top old-right old-bottom)))))) - -(defmethod recompute-extent-for-new-child ((record output-record-mixin) child) - (with-slots (parent) record - (with-bounding-rectangle* (left top right bottom) record - (let ((old-left left) - (old-top top) - (old-right right) - (old-bottom bottom)) - (with-bounding-rectangle* (eleft etop eright ebottom) child - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates record parent) - (translate-fixnum-positions xoff yoff - eleft etop eright ebottom - ;; pass these coordinates in parent's coordinate system. - old-left old-top old-right old-bottom)) - (cond ((= (output-record-count record) 1) - (bounding-rectangle-set-edges record eleft etop eright ebottom)) - (t (bounding-rectangle-set-edges record - (min left eleft) (min top etop) - (max right eright) (max bottom ebottom))))) - (when parent - (recompute-extent-for-changed-child - parent record old-left old-top old-right old-bottom)))))) - -;;; This is for adjusting extents after a bunch of leaves have been moved. -(defmethod tree-recompute-extent ((record output-record-element-mixin)) - (with-bounding-rectangle* (old-left old-top old-right old-bottom) record - (let ((parent (output-record-parent record))) - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates record parent) - (declare (type coordinate xoff yoff)) - ;; we must pass the old coordinates in the parent's coordinate system - ;; because tree-recompute-extent-1 may adjust the reference point. - (translate-fixnum-positions xoff yoff old-left old-top old-right old-bottom)) - (tree-recompute-extent-1 record) - (when parent - (recompute-extent-for-changed-child - parent record old-left old-top old-right old-bottom))))) - -#+CLIM-1-compatibility -(progn -(define-compatibility-function (add-output-record-element add-output-record) - (record child) - (add-output-record child record)) - -(define-compatibility-function (delete-output-record-element delete-output-record) - (record child &optional (errorp t)) - (delete-output-record child record errorp)) - -(define-compatibility-function (output-record-elements output-record-children) - (record) - (output-record-children record)) - -(define-compatibility-function (output-record-element-count output-record-count)n - (record) - (output-record-count record)) -) ;#+CLIM-1-compatibility - - -;;; Common to all implementations. -;;; ADD-OUTPUT-RECORD assumes that CHILD's start-position and bounding -;;; rectangle have already been normalized to RECORD's coordinate system. -(defmethod add-output-record :after (child (record output-record-mixin)) ;was :around - (setf (output-record-parent child) record) - (recompute-extent-for-new-child record child) - (when (output-record-stream record) - (note-output-record-attached child (output-record-stream record)))) - -(defmethod note-output-record-attached ((record output-record-element-mixin) stream) - (setf (output-record-stream record) stream)) - -(defmethod note-output-record-attached :after ((record output-record-mixin) stream) - (map-over-output-records - #'(lambda (rec) - (note-output-record-attached rec stream)) - record)) - -;;; Ditto. -(defmethod delete-output-record :after - (child (record output-record-mixin) &optional (errorp t)) - (declare (ignore errorp)) - (with-bounding-rectangle* (left top right bottom) child - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates child record) - (declare (type coordinate xoff yoff)) - (translate-fixnum-positions xoff yoff left top right bottom) - (recompute-extent-for-changed-child record child left top right bottom))) - (setf (output-record-parent child) nil)) ;in case other things are still pointing to it. - -(defmethod delete-output-record :around (child (record output-record-mixin) &optional errorp) - (declare (ignore errorp)) - (let ((stream (output-record-stream child))) - (multiple-value-prog1 - (call-next-method) - (when stream - (note-output-record-detached child))))) - - -(defmethod note-output-record-detached ((record output-record-element-mixin)) - (setf (output-record-stream record) nil)) - -(defmethod note-output-record-detached :after ((record output-record-mixin)) - (map-over-output-records - #'note-output-record-detached - record)) - -;;; Recurse down all inferiors returning them to the "resource" table. -#+++Ignore -(defmethod clear-output-record :before ((record output-record-mixin)) - (free-output-record record)) - -;;; Invoked by CLEAR-OUTPUT-RECORD. -#+++Ignore -(defmethod free-output-record ((record output-record-element-mixin)) - (free-record record) - (map-over-output-records #'free-output-record record)) - -(defmethod clear-output-record :after ((record output-record-mixin)) - (bounding-rectangle-set-edges record 0 0 0 0)) - -(defmethod clear-output-record :around ((record output-record-mixin)) - (when (output-record-stream record) - (map-over-output-records - #'note-output-record-detached - record)) - (call-next-method)) - - -;;; Sequence output records store their children in a vector -(defclass standard-sequence-output-record - (output-record-mixin output-record-element-mixin output-record) - ((elements :initform nil) - (fill-pointer :initform 0 :type fixnum))) - -(define-output-record-constructor standard-sequence-output-record - (&key x-position y-position (size 5)) - :x-position x-position :y-position y-position :size size) - -(defmethod initialize-instance :after ((record standard-sequence-output-record) - &key (size 5)) - ;; probably want to save size away somewhere so that the - ;; guy who actually makes the array can reference it... - (declare (ignore size)) - ;; size defaults to very small to save space - ;; most dependent classes will have supplied default-initargs with better - ;; chosen default. - (with-slots (elements fill-pointer) record - ;; We run initialize-instance to re-initialize the record, so don't re-alloc the array - (etypecase elements - ((or null output-record displayed-output-record) (setf elements nil)) - (array (setf fill-pointer 0))))) - -;;; For debugging. -(defmethod output-record-children ((record standard-sequence-output-record)) - (with-slots (elements fill-pointer) record - (typecase elements - (null nil) - (array - (let ((result (make-list fill-pointer))) - (replace result elements :end1 fill-pointer :end2 fill-pointer) - result)) - ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD - (otherwise (list elements))))) - -(defmethod output-record-element ((record standard-sequence-output-record) index) - (with-slots (elements) record - (svref elements index))) - -(defmethod output-record-count ((record standard-sequence-output-record)) - (with-slots (elements fill-pointer) record - (typecase elements - (null 0) - (array fill-pointer) - ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD - (otherwise 1)))) - -(defmethod clear-output-record ((record standard-sequence-output-record)) - (with-slots (elements fill-pointer) record - (typecase elements - (null nil) - (array (setf fill-pointer 0)) - ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD - (otherwise (setf elements nil))))) - -(defmethod add-output-record (child (record standard-sequence-output-record)) - (with-slots (elements fill-pointer) record - (typecase elements - (null - (setf elements child)) - (array - (multiple-value-setq (elements fill-pointer) - (simple-vector-push-extend child elements fill-pointer))) - ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD - (otherwise - (let ((first elements)) - (setf elements (make-array 5)) - (setf fill-pointer 2) - (setf (svref elements 0) first) - (setf (svref elements 1) child)))))) - -(defmethod delete-output-record - (child (record standard-sequence-output-record) &optional (errorp t)) - (with-slots (elements fill-pointer) record - (typecase elements - (null (error "The output record ~S was not found in ~S" child record)) - (array - (let ((index (position child elements :end fill-pointer))) - (cond (index - (let ((new-fp (the fixnum (1- fill-pointer))) - (vector elements)) - (declare (type simple-vector vector) (fixnum new-fp) - #+Genera (sys:array-register vector)) - (unless (= (the fixnum index) new-fp) - ;; Shift the whole vector downward - (do ((i (the fixnum index) (1+ i))) - ((= i new-fp)) - (declare (fixnum i) (optimize (speed 3) (safety 0))) - (setf (svref vector i) (svref vector (1+ i))))) - (setf fill-pointer new-fp))) - (errorp - (error "The output record ~S was not found in ~S" child record))))) - ;; It must be an OUTPUT-RECORD or a DISPLAYED-OUTPUT-RECORD - (otherwise - (unless (eql elements child) - (error "The output record ~S was not found in ~S" child record)) - (setf elements nil)))) - t) - -(defmethod map-over-output-records-overlapping-region - (function (record standard-sequence-output-record) region - &optional (x-offset 0) (y-offset 0) &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (declare (type coordinate x-offset y-offset)) - (declare (optimize (safety 0))) - (with-slots (elements fill-pointer) record - (typecase elements - (null nil) - (array - (if (or (null region) (eql region +everywhere+)) - (dovector (child elements :start 0 :end fill-pointer :simple-p t) - (apply function child continuation-args)) - (with-bounding-rectangle* (left1 top1 right1 bottom1) region - (translate-fixnum-positions x-offset y-offset left1 top1 right1 bottom1) - ;; Subtract out the record offset from the region, to make comparison fair - (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) left1 top1 right1 bottom1)) - (dovector (child elements :start 0 :end fill-pointer :simple-p t) - (with-bounding-rectangle* (left2 top2 right2 bottom2) child - (when (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 - left2 top2 right2 bottom2) - (apply function child continuation-args))))))) - (otherwise - (if (or (null region) (eql region +everywhere+)) - (apply function elements continuation-args) - (multiple-value-bind (xoff yoff) - (output-record-position* record) - (declare (type coordinate xoff yoff)) - (when (region-intersects-offset-region-p - elements region (- x-offset xoff) (- y-offset yoff)) - (apply function elements continuation-args))))))) - nil) - -(defmethod map-over-output-records-containing-point* - (function (record standard-sequence-output-record) x y - &optional (x-offset 0) (y-offset 0) &rest continuation-args) - (declare (dynamic-extent function continuation-args)) - (declare (type coordinate x y x-offset y-offset)) - (declare (optimize (safety 0))) - (translate-fixnum-positions x-offset y-offset x y) - (with-slots (elements fill-pointer) record - (typecase elements - (null nil) - (array - (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) x y)) - (dovector (child elements :start 0 :end fill-pointer :from-end t :simple-p t) - (with-bounding-rectangle* (left top right bottom) child - (when (ltrb-contains-point*-p left top right bottom x y) - (apply function child continuation-args))))) - (otherwise - (multiple-value-bind (xoff yoff) (output-record-position* record) - (when (offset-region-contains-point*-p elements xoff yoff x y) - (apply function elements continuation-args)))))) - nil) - - -;;; Text line output recording. A stream which does text output creates one of -;;; these per line of text. Lines are delimited by either #\RETURNs or by -;;; wrapping. Line boundaries are not recalculated when window size is changed; a -;;; higher-level kind of output record is required for that (protocol not yet -;;; defined, but should be obvious). - -;;; The string is a vector of those characters which were output on the current -;;; line. The initial-text-style is the very first style which -;;; appeared on the line. The current-text-style is the style of -;;; the last character which appeared on the line. The baseline is used to -;;; determine where to draw the glyphs. - -;;; The text-style-changes is an NCONCed list of conses of the form -;;; (style . position). The characters between the beginning of the record -;;; and the first change are in the initial-text-style. Unfortunately, -;;; you can't just use STREAM-WRITE-STRING-1 on the substring involved -;;; because that function returns in the middle when it encounters a character it -;;; can't deal with, such as tabs and non-graphic characters. There should never -;;; be a #\Return character in a STANDARD-TEXT-OUTPUT-RECORD. - -(defclass standard-text-output-record - (output-record-element-mixin text-displayed-output-record) - ((string :initarg :string) - (wrapped-p :initform nil :initarg :wrapped-p) - (ink :initarg :ink))) - -(defclass styled-text-output-record - (standard-text-output-record text-displayed-output-record) - ((initial-text-style :initform nil :initarg :initial-style) - (text-style-changes :initform nil) - (current-text-style :initform nil :initarg :current-style) - (baseline :initform 0 :initarg :baseline))) - -(define-constructor make-standard-text-output-record - standard-text-output-record (ink string) - :ink ink :string string) - -(define-constructor make-styled-text-output-record - styled-text-output-record (ink string) - :ink ink :string string) - -(define-constructor make-styled-text-output-record-1 - styled-text-output-record (ink string wrapped-p style baseline) - :ink ink :string string :wrapped-p wrapped-p - :initial-style style :current-style style :baseline baseline) - -(defmethod print-object ((object standard-text-output-record) stream) - (print-unreadable-object (object stream :type t :identity t) - (format stream "~S /x ~A:~A y ~A:~A/" - (safe-slot-value object 'string) - (safe-slot-value object 'left) - (safe-slot-value object 'right) - (safe-slot-value object 'top) - (safe-slot-value object 'bottom)))) - -(defmethod output-record-unique-id ((text standard-text-output-record)) - (slot-value text 'string)) - -(defmethod replay-output-record ((record standard-text-output-record) stream - &optional region (x-offset 0) (y-offset 0)) - (declare (type coordinate x-offset y-offset)) - (declare (ignore region)) - (let* ((string (slot-value record 'string)) - (start 0) - (end (length string)) - (text-style (medium-default-text-style stream)) - (baseline (- (text-style-height text-style stream) - (text-style-descent text-style stream))) - (glyph-buffer (stream-output-glyph-buffer stream)) - (color (slot-value record 'ink))) - (declare (fixnum start end)) - (#-Silica progn - #+Silica with-sheet-medium #+Silica (medium stream) - (macrolet - ((do-it (end-position) - `(loop - (when (>= start ,end-position) (return)) - (multiple-value-bind (write-char next-char-index - new-cursor-x new-baseline new-height font) - (stream-scan-string-for-writing stream - #+Silica medium - string start ,end-position - text-style cursor-x - ;;--- MOST-POSITIVE-FIXNUM loses - most-positive-fixnum - glyph-buffer) - ;; GLYPH-BUFFER NIL => pass the string to the port-specific code. - #-Silica - (if glyph-buffer - (stream-write-string-1 - stream glyph-buffer 0 (the fixnum (- next-char-index start)) - font color - cursor-x (+ cursor-y (- baseline new-baseline))) - (stream-write-string-1 - stream string start next-char-index - font color - cursor-x (+ cursor-y (- baseline new-baseline)))) - #+Silica - (with-identity-transformation (medium) - (draw-text* medium string - cursor-x (+ cursor-y (- baseline new-baseline)) - :start start :end next-char-index - :align-y :top - :text-style text-style :ink color)) - (setf cursor-x new-cursor-x start next-char-index) - (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? - (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) - (t - (multiple-value-bind (new-cursor-x new-cursor-y) - (stream-draw-lozenged-character - stream write-char cursor-x cursor-y new-baseline new-height - ;;--- MOST-POSITIVE-FIXNUM loses - text-style most-positive-fixnum nil t) - (setf cursor-x new-cursor-x - cursor-y new-cursor-y)))) - (incf start)))))) - (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position* record) - (declare (type coordinate cursor-x cursor-y)) - (translate-fixnum-positions x-offset y-offset cursor-x cursor-y) - (do-it end) - #-Silica - (when (slot-value record 'wrapped-p) - (draw-character-wrap-indicator - stream cursor-y (bounding-rectangle-height record) (stream-text-margin stream) nil))))))) - -(defmethod replay-output-record ((record styled-text-output-record) stream - &optional region (x-offset 0) (y-offset 0)) - (declare (type coordinate x-offset y-offset)) - (declare (ignore region)) - (let* ((string (slot-value record 'string)) - (start 0) - (end (length string)) - (text-style (slot-value record 'initial-text-style)) - (baseline (slot-value record 'baseline)) - (glyph-buffer (stream-output-glyph-buffer stream)) - (color (slot-value record 'ink))) - (declare (fixnum start end)) - (#-Silica progn - #+Silica with-sheet-medium #+Silica (medium stream) - (macrolet - ((do-it (end-position) - `(loop - (when (>= start ,end-position) (return)) - (multiple-value-bind (write-char next-char-index - new-cursor-x new-baseline new-height font) - (stream-scan-string-for-writing stream - #+Silica medium - string start ,end-position - text-style cursor-x - ;;--- LOSES - most-positive-fixnum - glyph-buffer) - #-Silica - (if glyph-buffer - (stream-write-string-1 - stream glyph-buffer 0 (the fixnum (- next-char-index start)) - font color - cursor-x (+ cursor-y (- baseline new-baseline))) - (stream-write-string-1 - stream string start next-char-index - font color - cursor-x (+ cursor-y (- baseline new-baseline)))) - #+Silica - (with-identity-transformation (medium) - (draw-text* medium string - cursor-x (+ cursor-y (- baseline new-baseline)) - :start start :end next-char-index - :align-y :top - :text-style text-style :ink color)) - (setf cursor-x new-cursor-x start next-char-index) - (when write-char - (cond ((eql write-char #\Tab) ;Only non-lozenged exception char? - (setf cursor-x (stream-next-tab-column stream cursor-x text-style))) - (t - (multiple-value-bind (new-cursor-x new-cursor-y) - (stream-draw-lozenged-character - stream write-char cursor-x cursor-y new-baseline new-height - ;;--- LOSES - text-style most-positive-fixnum nil t) - (setf cursor-x new-cursor-x - cursor-y new-cursor-y)))) - (incf start)))))) - (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position* record) - (declare (type coordinate cursor-x cursor-y)) - (translate-fixnum-positions x-offset y-offset cursor-x cursor-y) - (dolist (text-style-change (slot-value record 'text-style-changes)) - (let ((new-text-style (car text-style-change)) - (change-position (cdr text-style-change))) - (do-it change-position) - (setf text-style new-text-style - start change-position))) - (do-it end) - #-Silica - (when (slot-value record 'wrapped-p) - (draw-character-wrap-indicator - stream cursor-y (bounding-rectangle-height record) - (stream-text-margin stream) nil))))))) - -(defmethod bounding-rectangle-set-edges :around - ((record standard-text-output-record) new-left new-top new-right new-bottom) - (declare (ignore new-left new-top new-right new-bottom)) - (let ((parent (output-record-parent record))) - (if (not (null parent)) - (with-bounding-rectangle* (old-left old-top old-right old-bottom) record - (multiple-value-bind (xoff yoff) - (convert-from-descendant-to-ancestor-coordinates record parent) - (declare (type coordinate xoff yoff)) - (translate-fixnum-positions xoff yoff old-left old-top old-right old-bottom) - (call-next-method) - (recompute-extent-for-changed-child parent record - old-left old-top old-right old-bottom))) - (call-next-method)))) - -(defmethod add-string-output-to-text-record ((record standard-text-output-record) - text-string start end text-style - new-width new-height new-baseline) - (declare (ignore text-style new-baseline)) - (declare (fixnum start end)) - (when (>= start end) - (return-from add-string-output-to-text-record)) - (let* ((count (the fixnum (- end start))) - (string (prepare-text-record-for-appending record count nil)) - (fill-pointer (fill-pointer string))) - (multiple-value-bind (width height) (bounding-rectangle-size record) - (declare (type coordinate width height)) - (setf (fill-pointer string) (the fixnum (+ fill-pointer count))) - (replace string text-string :start1 fill-pointer :start2 start :end2 end) - (incf width new-width) - (maxf height new-height) - (bounding-rectangle-set-size record width height)))) - -(defmethod add-string-output-to-text-record ((record styled-text-output-record) - text-string start end text-style - new-width new-height new-baseline) - (declare (fixnum start end)) - (when (>= start end) - (return-from add-string-output-to-text-record)) - (let* ((count (the fixnum (- end start))) - (string (prepare-text-record-for-appending record count text-style)) - (fill-pointer (fill-pointer string))) - (multiple-value-bind (width height) (bounding-rectangle-size record) - (declare (type coordinate width height)) - (setf (fill-pointer string) (the fixnum (+ fill-pointer count))) - (replace string text-string :start1 fill-pointer :start2 start :end2 end) - (incf width new-width) - (maxf height new-height) - (maxf (slot-value record 'baseline) new-baseline) - (bounding-rectangle-set-size record width height)))) - -(defmethod add-character-output-to-text-record ((record standard-text-output-record) - character text-style - new-width new-height new-baseline) - (declare (ignore text-style new-baseline)) - (let* ((string (prepare-text-record-for-appending record 1 nil)) - (fill-pointer (fill-pointer string))) - (multiple-value-bind (width height) (bounding-rectangle-size record) - (declare (type coordinate width height)) - (setf (fill-pointer string) (1+ fill-pointer) - (aref string fill-pointer) character) - (incf width new-width) - (maxf height new-height) - (bounding-rectangle-set-size record width height)))) - -(defmethod add-character-output-to-text-record ((record styled-text-output-record) - character text-style - new-width new-height new-baseline) - (let* ((string (prepare-text-record-for-appending record 1 text-style)) - (fill-pointer (fill-pointer string))) - (multiple-value-bind (width height) (bounding-rectangle-size record) - (declare (type coordinate width height)) - (setf (fill-pointer string) (1+ fill-pointer) - (aref string fill-pointer) character) - (incf width new-width) - (maxf height new-height) - (maxf (slot-value record 'baseline) new-baseline) - (bounding-rectangle-set-size record width height)))) - -(defmethod prepare-text-record-for-appending - ((record standard-text-output-record) space-needed style) - (declare (fixnum space-needed)) - (declare (ignore style)) - (let* ((string (slot-value record 'string)) - (fill-pointer (fill-pointer string))) - (declare (fixnum fill-pointer)) - (when (> (the fixnum (+ fill-pointer space-needed)) (array-dimension string 0)) - (setf string (adjust-array string (the fixnum (+ fill-pointer space-needed 16)))) - (setf (slot-value record 'string) string)) - string)) - -(defmethod prepare-text-record-for-appending - ((record styled-text-output-record) space-needed style) - (declare (fixnum space-needed)) - (with-slots (initial-text-style current-text-style - text-style-changes baseline) record - (let* ((string (slot-value record 'string)) - (fill-pointer (fill-pointer string))) - (unless (eql style current-text-style) - (if (null initial-text-style) - (setf initial-text-style style) - (let ((change-record (cons style fill-pointer))) - (setf text-style-changes - (nconc text-style-changes (list change-record))))) - (setf current-text-style style)) - (when (> (the fixnum (+ fill-pointer space-needed)) (array-dimension string 0)) - (setf string (adjust-array string (the fixnum (+ fill-pointer space-needed 16)))) - (setf (slot-value record 'string) string)) - string))) - -(defun text-recompute-contents-id-test (id1 id2) - (or (eql id1 id2) - (and (stringp id2) - (string= id1 id2)))) - -;; We don't do a INVOKE-WITH-NEW-OUTPUT-RECORD for STANDARD-TEXT-OUTPUT-RECORDs. -;; However, STREAM-CLOSE-TEXT-OUTPUT-RECORD does a RECOMPUTE-CONTENTS-OK, too. -(defmethod recompute-contents-ok ((text standard-text-output-record)) - (with-slots (string wrapped-p) text - (let* ((output-record (output-record-parent text)) - (match (and output-record - (find-inferior-output-record - output-record t 'standard-text-output-record - :unique-id string :id-test #'text-recompute-contents-id-test)))) - (when match - ;; The old extent is a copy of MATCH's bounding rectangle - (setf (output-record-old-bounding-rectangle text) (bounding-rectangle match)) - (when (and (bounding-rectangle-size-equal match text) - (eql wrapped-p (slot-value match 'wrapped-p)) - (eql (class-of text) (class-of match))) - (setf (output-record-contents-ok text) t) - ;; make sure that old bounding-rect is the same relative position from - ;; old-start-position as the bounding-rect is from start-position - (multiple-value-bind (delta-x delta-y) - (multiple-value-bind (ex ey) (bounding-rectangle-position* text) - (declare (type coordinate ex ey)) - (multiple-value-bind (sx sy) - (output-record-start-cursor-position* text) - (declare (type coordinate sx sy)) - (position-difference* ex ey sx sy))) - (declare (type coordinate delta-x delta-y)) - (multiple-value-bind (old-start-x old-start-y) - (multiple-value-bind (px py) (bounding-rectangle-position* match) - (declare (type coordinate px py)) - (position-difference* px py delta-x delta-y)) - (output-record-set-old-start-cursor-position* - text old-start-x old-start-y)))))))) - -(defmethod recompute-contents-ok ((text styled-text-output-record)) - (with-slots (string wrapped-p initial-text-style current-text-style text-style-changes) - text - (let* ((output-record (output-record-parent text)) - (match (and output-record - (find-inferior-output-record - output-record t 'styled-text-output-record - :unique-id string :id-test #'text-recompute-contents-id-test)))) - (when match - ;; The old extent is a copy of MATCH's bounding rectangle - (setf (output-record-old-bounding-rectangle text) (bounding-rectangle match)) - ;; --- maybe make a method out of this to get efficient slot access? - (when (and (bounding-rectangle-size-equal match text) - (eql wrapped-p (slot-value match 'wrapped-p)) - (eql (class-of text) (class-of match)) - (eql initial-text-style - (slot-value match 'initial-text-style)) - (eql current-text-style - (slot-value match 'current-text-style)) - (equal text-style-changes - (slot-value match 'text-style-changes))) - (setf (output-record-contents-ok text) t) - ;; make sure that old bounding-rect is the same relative position from - ;; old-start-position as the bounding-rect is from start-position - (multiple-value-bind (delta-x delta-y) - (multiple-value-bind (ex ey) (bounding-rectangle-position* text) - (declare (type coordinate ex ey)) - (multiple-value-bind (sx sy) - (output-record-start-cursor-position* text) - (declare (type coordinate sx sy)) - (position-difference* ex ey sx sy))) - (declare (type coordinate delta-x delta-y)) - (multiple-value-bind (old-start-x old-start-y) - (multiple-value-bind (px py) (bounding-rectangle-position* match) - (declare (type coordinate px py)) - (position-difference* px py delta-x delta-y)) - (output-record-set-old-start-cursor-position* - text old-start-x old-start-y)))))))) - -(defun find-text-baseline (record stream) - ;; This finds the lowest baseline of the text in RECORD, which will be slower than, say, - ;; the first baseline but more likely to look good with misaligned things. - (let ((baseline 0) - (style (medium-default-text-style stream))) - (declare (type coordinate baseline)) - (labels ((find-or-recurse (record y-offset) - (declare (type coordinate y-offset)) - (typecase record - (styled-text-output-record - (maxf baseline (+ y-offset (slot-value record 'baseline)))) - (standard-text-output-record - (maxf baseline - (+ y-offset (- (text-style-height style stream) - (text-style-descent style stream))))) - (t - (multiple-value-bind (xoff yoff) (output-record-position* record) - (declare (type coordinate yoff)) - (declare (ignore xoff)) - (map-over-output-records #'find-or-recurse record - 0 0 (+ yoff y-offset))))))) - (declare (dynamic-extent #'find-or-recurse)) - (find-or-recurse record 0)) - baseline)) - - -;;; Mix this in for top-level output histories -(defclass stream-output-history-mixin () ((stream))) - -(defmethod bounding-rectangle-set-edges ((record stream-output-history-mixin) - left top right bottom) - (declare (type coordinate left top right bottom)) - #+ignore (assert (<= left right)) - #+ignore (assert (<= top bottom)) - (with-slots ((bl left) (bt top) (br right) (bb bottom) parent stream) record - ;; Top-level output records must not have their upper left corner any - ;; "later" than (0,0), or else scroll bars and scrolling will not do - ;; the right thing. - (let ((old-left bl) - (old-top bt) - (old-right br) - (old-bottom bb)) - (declare (type coordinate old-left old-top old-right old-bottom)) - (setq bl (min left 0) - bt (min top 0) - br right - bb bottom))) - record) - -#+Silica -(defmethod bounding-rectangle-set-edges :around ((r stream-output-history-mixin) - nminx nminy nmaxx nmaxy) - (multiple-value-bind - (minx miny maxx maxy) - (bounding-rectangle* r) - (call-next-method) - (unless (and (= minx nminx) - (= miny nminy) - (= maxx nmaxx) - (= maxy nmaxy)) - ;; This should update the scrollbars etc - (let* ((stream (output-record-stream r)) - (vp (pane-viewport-sheet stream))) - (when vp - (update-scrollbars vp)) - (update-region stream (- nmaxx nminx) (- nmaxy nminy)))))) - -;;; Defclass of OUTPUT-RECORDING-MIXIN, etc. is in STREAM-CLASS-DEFS -(defmethod initialize-instance :after ((stream output-recording-mixin) &rest args) - (declare (ignore args)) - (with-slots (output-record) stream - ;;--- Our OUTPUT-RECORDING-MIXIN expects extended output... - (multiple-value-bind (x y) (stream-cursor-position* stream) - ;; I don't understand why the output record's initial position was set to - ;; some untransformed "viewport" coordinate. The cursor position is the - ;; right place, no? - (output-record-set-position* output-record x y)) - (setf (slot-value output-record 'stream) stream))) - -(defmethod clear-output-history ((stream output-recording-mixin)) - (when (stream-output-history stream) - (clear-output-record (stream-output-history stream))) - (setf (stream-text-output-record stream) nil) - (setf (stream-highlighted-presentation stream) nil)) - -(defmethod stream-add-output-record ((stream output-recording-mixin) record) - (with-slots (output-record current-output-record-stack) stream - (let ((the-output-record (or current-output-record-stack output-record))) - (add-output-record record the-output-record) - #+Silica - (let ((width (bounding-rectangle-width stream)) - (height (bounding-rectangle-height stream))) - (declare (type coordinate width height)) - (with-bounding-rectangle* (rl rt rr rb) the-output-record - (when (or (< rl 0) (< width rr) - (< rt 0) (< height rb)) - (update-region stream (- rr rl) (- rb rt)))))))) - -(defmethod stream-replay ((stream output-recording-mixin) &optional region) - (when (stream-drawing-p stream) - (with-slots (output-record text-output-record record-p) stream - (when (or output-record text-output-record) - (letf-globally ((record-p nil)) - (when output-record - (replay-output-record output-record stream region 0 0)) - (when text-output-record - (replay-output-record text-output-record stream region 0 0))))))) - -(defun erase-output-record (output-record stream) ;--- specialize on stream? - (multiple-value-bind (xoff yoff) - (convert-from-relative-to-absolute-coordinates - ;; --- I'm certainly going to forget to use the PARENT at some point! - stream (output-record-parent output-record)) - (with-bounding-rectangle* (left top right bottom) output-record - (with-output-recording-options (stream :record nil) - (if (or (= left right) (= top bottom)) - ;; Handle specially, for a line is wider than a rectangle of zero width or height - (draw-line-internal stream xoff yoff - left top right bottom - +background-ink+ nil) - (draw-rectangle-internal stream xoff yoff - left top right bottom - +background-ink+ nil))))) - (when (output-record-parent output-record) - (delete-output-record output-record (output-record-parent output-record))) - ;; Use the output record itself as the replay region, and replay - ;; the stuff that might have been obscured by the erased output - (frame-replay *application-frame* stream output-record)) - -(defmethod invoke-with-output-recording-options ((stream output-recording-mixin) - continuation record draw) - (letf-globally (((stream-recording-p stream) record) - ((stream-drawing-p stream) draw)) - (funcall continuation))) - -(defmethod get-text-output-record ((stream output-recording-mixin) style) - (let ((default-style (medium-default-text-style stream))) - (let ((record (stream-text-output-record stream))) - (when record - ;; If we're changing styles mid-stream, need to convert this - ;; text record to the more expensive form - (when (and (not (eq style default-style)) - (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 'extended-char ;--- 16? - :fill-pointer 0 :adjustable t)) - (record (if (not (eq style default-style)) - (make-styled-text-output-record (medium-ink stream) string) - (make-standard-text-output-record (medium-ink stream) string)))) - (setf (stream-text-output-record stream) record) - (multiple-value-bind (abs-x abs-y) - (point-position* - (stream-output-history-position stream)) - (declare (type coordinate abs-x abs-y)) - (multiple-value-bind (cx cy) (stream-cursor-position* stream) - (declare (type coordinate cx cy)) - (output-record-set-start-cursor-position* - record (- cx abs-x) (- cy abs-y)))) - ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing - ;; in the history until then. This should save an extra recompute-extent call - ;; (one in here, one when the string is added). - ;; (stream-add-output-record stream record) - record))) - -;; The cost of stylizing an existing record is actually fairly low, and we -;; don't do it very often, because of the optimization in GET-TEXT-OUTPUT-RECORD -;; that creates a stylized record as early as possible. -(defmethod stylize-text-output-record ((record standard-text-output-record) style stream) - (with-slots (ink string wrapped-p left top right bottom - start-x start-y end-x end-y) record - (let ((new-record (make-styled-text-output-record-1 - ink string wrapped-p - style (- (text-style-height style stream) - (text-style-descent style stream))))) - (with-slots ((new-left left) (new-top top) (new-right right) (new-bottom bottom) - (new-sx start-x) (new-sy start-y) (new-ex end-x) (new-ey end-y) - (new-wrapped-p wrapped-p)) new-record - (setq new-left left - new-top top - new-right right - new-bottom bottom - new-sx start-x - new-sy start-y - new-ex end-x - new-ey end-y)) - (setf (stream-text-output-record stream) new-record) - new-record))) - -;;; The following two are only called when STREAM-RECORDING-P is true and the -;;; characters are printable (see CHARACTER-DRAWING.LISP). -(defmethod stream-add-string-output ((stream output-recording-mixin) string - start end text-style width height baseline) - (declare (fixnum start end)) - (when (< start end) - (let ((record (get-text-output-record stream text-style))) - (add-string-output-to-text-record record string start end text-style - width height baseline)))) - -(defmethod stream-add-character-output ((stream output-recording-mixin) character - text-style width height baseline) - (let ((record (get-text-output-record stream text-style))) - (add-character-output-to-text-record record character text-style - width height baseline))) - -(defmethod stream-close-text-output-record ((stream output-recording-mixin) - &optional wrapped) - ;; It's faster to access the slot directly instead of going through - ;; STREAM-TEXT-OUTPUT-RECORD - (let ((text-record (slot-value stream 'text-output-record))) - (when text-record - (when wrapped - (setf (slot-value text-record 'wrapped-p) t)) - (stream-add-output-record stream text-record) - (when (stream-redisplaying-p stream) - (recompute-contents-ok text-record)) - (setf (slot-value stream 'text-output-record) nil)))) - -(defmethod stream-force-output :after ((stream output-recording-mixin)) - (stream-close-text-output-record stream)) - -(defmethod stream-finish-output :after ((stream output-recording-mixin)) - (stream-close-text-output-record stream)) - -;; When setting cursor position, have to dump old text record. -;; This is necessary in order to capture the correct cursor position in -;; text output records. If we did not close the current text record, -;; a sequence such as WRITE-STRING/SET-CURSORPOS/WRITE-STRING would -;; create only a single output record, and intervening whitespace would -;; be lost if the two WRITE-STRINGs took place on the same line. -(defmethod stream-set-cursor-position* :before ((stream output-recording-mixin) x y) - (declare (ignore x y)) - (stream-close-text-output-record stream)) - -;; This gets used to reposition the cursor when drawing text. We need to -;; close the text output record when there was a line wrap, but not when -;; we are simply incrementing the cursor beyond the just-written glyph. -(defmethod stream-set-cursor-position*-internal :before ((stream output-recording-mixin) x y) - (declare (ignore x)) - (multiple-value-bind (old-x old-y) (stream-cursor-position* stream) - (declare (ignore old-x)) - (unless (eql y old-y) - (stream-close-text-output-record stream)))) - -;; Copy just the text from the window to the stream. If REGION is supplied, -;; only the text overlapping that region is copied. -;; This loses information about text styles, presentations, and graphics, and -;; doesn't deal perfectly with tab characters and changing baselines. -(defun copy-textual-output-history (window stream &optional region) - (let* ((char-width (stream-character-width window #\space)) - (line-height (stream-line-height window)) - (history (stream-output-history window)) - (array (make-array (ceiling (bounding-rectangle-height history) line-height) - :fill-pointer 0 :adjustable t :initial-element nil))) - (labels ((collect (record x-offset y-offset) - (multiple-value-bind (start-x start-y) - (output-record-start-cursor-position* record) - (translate-positions x-offset y-offset start-x start-y) - (when (typep record 'standard-text-output-record) - (vector-push-extend (list* start-y start-x (slot-value record 'string)) - array)) - (map-over-output-records-overlapping-region - #'collect record region - (- x-offset) (- y-offset) start-x start-y)))) - (declare (dynamic-extent #'collect)) - (collect history 0 0)) - (sort array #'(lambda (r1 r2) - (or (< (first r1) (first r2)) - (and (= (first r1) (first r2)) - (< (second r1) (second r2)))))) - (let ((current-x 0) - (current-y (first (aref array 0)))) - (dotimes (i (fill-pointer array)) - (let* ((item (aref array i)) - (y (pop item)) - (x (pop item))) - (unless (= y current-y) - (dotimes (j (round (- y current-y) line-height)) - #-(or Allegro Minima) (declare (ignore j)) - (terpri stream) - (setq current-x 0)) - (setq current-y y)) - (unless (= x current-x) - (dotimes (j (round (- x current-x) char-width)) - #-(or Allegro Minima) (declare (ignore j)) - (write-char #\space stream)) - (setq current-x x)) - (write-string item stream) - (incf current-x (stream-string-width window item))))))) - -;;; This method should cover a multitude of sins. -#+Silica -(defmethod repaint-sheet :after ((stream output-recording-mixin) region) - ;;--- Who should establish the clipping region? - ;; Who should clear the region? - (with-sheet-medium (medium stream) - (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* (region-intersection - region - (or (pane-viewport-region stream) - (bounding-rectangle stream)))) - :ink +background-ink+)) - (stream-replay stream region)) - - - -;;; For Silica -;;;--- Consider these old methods on a case-by-case basis to see if the -;;; general handle-repaint method subsumes them. - -;;; --- should merge our process-update-region with handle-repaint -;;; Do we use it anywhere where Silica isn't generating handle-repaint? - -;;; Mix in window-output-recording when you have mixed together -;;; something supporting the window protocol and something supporting -;;; the output recording protocol. -#-Silica -(progn - -(defmethod window-process-update-region :around ((stream window-output-recording)) - (let ((update-region (slot-value stream 'update-region))) - (when update-region - (with-output-recording-options (stream :draw t :record nil) - (let ((highlighted-presentation (slot-value stream 'highlighted-presentation))) - (when highlighted-presentation - (highlight-output-record stream highlighted-presentation :unhighlight)) - (call-next-method) - (dolist (region update-region) - (with-clipping-region (stream region) - (frame-replay *application-frame* stream region))) - (when highlighted-presentation - (highlight-output-record stream highlighted-presentation :highlight)))) - (window-flush-update-region stream)))) - -;;;--- We need some version of this code to do the area copying. -(defmethod window-set-viewport-position* :around ((stream window-output-recording) - new-x new-y) - (declare (ignore new-x new-y)) - (with-bounding-rectangle* (left top right bottom) (window-viewport stream) - (call-next-method) - ;; now replay - (with-bounding-rectangle* (nl nt nr nb) (window-viewport stream) - (cond - ;; if some of the stuff that was previously on display is still on display - ;; bitblt it into the proper place and redraw the rest. - ((ltrb-overlaps-ltrb-p left top right bottom - nl nt nr nb) - ;; move the old stuff to the new position - (window-shift-visible-region stream left top right bottom - nl nt nr nb) - (window-process-update-region stream)) - ;; otherwise, just redraw the whole visible viewport - ;; Adjust for the left and top margins by hand so clear-area doesn't erase - ;; the margin components. - (t (multiple-value-bind (ml mt) (window-margins stream) - ;;--- Will these be coords or fixnums? - (declare (type coordinate ml mt)) - (multiple-value-bind (vw vh) (window-inside-size stream) - (declare (type coordinate vw vh)) - (window-clear-area stream - ml mt (+ ml vw) (+ mt vh)))) - (frame-replay *application-frame* stream (window-viewport stream))))))) - -(defmethod window-refresh :after ((stream window-output-recording)) - ;; don't bother me, it takes too long and is useless since - ;; we'll refresh this again when it eventually becomes visible - (when (window-drawing-possible stream) - (frame-replay *application-frame* stream (window-viewport stream)) - (let ((text-record (stream-text-output-record stream))) - (when text-record (replay text-record stream))) - (redisplay-decorations stream))) - -;;; I don't think that this is needed. -(defmethod window-note-size-or-position-change :after ((stream window-output-recording) - left top right bottom) - (declare (ignore left top right bottom)) - #+Ignore - (when (window-visibility stream) - (window-refresh stream))) - -;;; --- Define Silica version of this. -(defmethod window-clear :before ((stream window-output-recording)) - (clear-output-history stream)) - -) ; end of #-Silica PROGN - - -;;; Genera compatibility - -#+Genera -(defmethod stream-compatible-output-as-presentation - ((stream output-recording-mixin) - continuation xstream - &key (object nil) (type t) single-box &allow-other-keys) - (dw:with-type-decoded (type-name nil pr-args) type - (if (or (null type) - (and (eq type-name 'sys:expression) - (not (getf pr-args :escape *print-escape*)) - (stringp object))) - (funcall continuation xstream) - (multiple-value-bind (object clim-type changed-p) - (dw-type-to-clim-type object type) - (if changed-p - (with-output-as-presentation (xstream object clim-type - :single-box single-box) - (funcall continuation xstream)) - (funcall continuation xstream)))))) - -#+Genera -(defmethod stream-compatible-output-as-presentation-1 - ((stream output-recording-mixin) - continuation continuation-args - &key (object nil) (type t) single-box &allow-other-keys) - (dw:with-type-decoded (type-name nil pr-args) type - (if (or (null type) - (and (eq type-name 'sys:expression) - (not (getf pr-args :escape *print-escape*)) - (stringp object))) - (apply continuation continuation-args) - (multiple-value-bind (object clim-type changed-p) - (dw-type-to-clim-type object type) - (if changed-p - (with-output-as-presentation (stream object clim-type - :single-box single-box) - (apply continuation continuation-args)) - (apply continuation continuation-args)))))) - - diff --git a/clim/present.lisp b/clim/present.lisp index 200f6fae..d88a163d 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.2 92/01/31 14:58:31 cer Exp $ +;; $fiHeader: present.lisp,v 1.3 92/02/24 13:08:16 cer Exp $ (in-package :clim-internals) @@ -43,10 +43,10 @@ :single-box single-box :allow-sensitive-inferiors allow-sensitive-inferiors :record-type record-type) - (call-presentation-generic-function present + (funcall-presentation-generic-function present object presentation-type stream view :acceptably acceptably :for-context-type for-context-type)) - (call-presentation-generic-function present + (funcall-presentation-generic-function present object presentation-type stream view :acceptably acceptably :for-context-type for-context-type))) diff --git a/clim/presentations.lisp b/clim/presentations.lisp index 6581a137..180956c7 100644 --- a/clim/presentations.lisp +++ b/clim/presentations.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: presentations.lisp,v 1.6 92/03/04 16:22:07 cer Exp $ +;; $fiHeader: presentations.lisp,v 1.7 92/03/10 10:12:45 cer Exp $ (in-package :clim-internals) @@ -92,7 +92,7 @@ (if (eq record child) (call-next-method) ;avoid infinite recursion (highlight-output-record-1 child stream state))) - (multiple-value-bind (xoff yoff) (output-record-position* child) + (multiple-value-bind (xoff yoff) (output-record-position child) (declare (type coordinate xoff yoff)) (map-over-output-records #'highlight child 0 0 @@ -187,14 +187,14 @@ (when parent ;we're done if it's null (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates stream parent) - (translate-fixnum-positions xoff yoff left top right bottom))) + (translate-coordinates xoff yoff left top right bottom))) (loop (cond ((or (null parent) (with-bounding-rectangle* (pleft ptop pright pbottom) parent (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates stream (output-record-parent parent)) - (translate-fixnum-positions xoff yoff pleft ptop pright pbottom)) + (translate-coordinates xoff yoff pleft ptop pright pbottom)) (not (ltrb-equals-ltrb-p left top right bottom pleft ptop pright pbottom)))) (return nil)) @@ -268,7 +268,7 @@ (declare (type coordinate x y)) ;; Depth first search for a presentation that is both under the pointer and ;; matches the input context. - ;; This relies on MAP-OVER-OUTPUT-RECORDS-CONTAINING-POINT* traversing + ;; This relies on MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION traversing ;; the most recently drawn of overlapping output records first. (labels ((mapper (record presentations x-offset y-offset) (declare (type coordinate x-offset y-offset)) @@ -316,8 +316,8 @@ (setq presentations more-presentations)) ;; Depth-first recursion - (multiple-value-bind (dx dy) (output-record-position* record) - (map-over-output-records-containing-point* + (multiple-value-bind (dx dy) (output-record-position record) + (map-over-output-records-containing-position #'mapper record x y (- x-offset) (- y-offset) presentations (+ x-offset dx) (+ y-offset dy))) @@ -363,7 +363,7 @@ (when history-window (with-slots (highlighted-presentation) history-window (multiple-value-bind (px py) - (stream-pointer-position* history-window) + (stream-pointer-position history-window) (let ((presentation (frame-find-innermost-applicable-presentation frame input-context history-window px py))) (when (and (null presentation) diff --git a/clim/ptypes1.lisp b/clim/ptypes1.lisp index 41d5fde8..8b9b5ad8 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.8 92/03/10 10:12:47 cer Exp Locker: cer $ +;; $fiHeader: ptypes1.lisp,v 1.9 92/04/10 14:27:06 cer Exp Locker: cer $ (in-package :clim-internals) @@ -1416,6 +1416,12 @@ ,@(when options-var `(,options-var)) ,@arguments)))) +(defmacro funcall-presentation-generic-function (presentation-function-name &body arguments) + `(call-presentation-generic-function ,presentation-function-name ,@arguments)) + +(defmacro apply-presentation-generic-function (presentation-function-name &body arguments) + `(call-presentation-generic-function apply ,presentation-function-name ,@arguments)) + ;;; Presentation generic functions have their own class just so we can define ;;; one method that aids in implementing presentation-method-combination #-CCL-2 diff --git a/clim/ptypes2.lisp b/clim/ptypes2.lisp index 8b49e554..6bd21330 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.4 92/02/24 13:08:24 cer Exp $ +;; $fiHeader: ptypes2.lisp,v 1.5 92/03/04 16:22:11 cer Exp $ (in-package :clim-internals) @@ -68,8 +68,8 @@ (handler-case (with-stack-list* (class-and-parameters class parameters-given) (with-stack-list* (type-specifier class-and-parameters options-given) - (call-presentation-generic-function presentation-type-specifier-p - type-specifier))) + (funcall-presentation-generic-function + presentation-type-specifier-p type-specifier))) (error () nil)) ;; If no parameters nor options, no need for user-defined validation t))))))) @@ -99,7 +99,7 @@ (let ((description (getf options :description))) (if description (default-describe-presentation-type description stream plural-count) - (call-presentation-generic-function describe-presentation-type + (funcall-presentation-generic-function describe-presentation-type type stream plural-count))))))) ;;; The default method that works for describing most presentation types @@ -143,7 +143,8 @@ (defun presentation-type-history (presentation-type) (let ((type (expand-presentation-type-abbreviation presentation-type))) (loop - (let ((history (call-presentation-generic-function presentation-type-history type))) + (let ((history + (funcall-presentation-generic-function presentation-type-history type))) (cond ((null history) (return-from presentation-type-history nil)) ((typep history 'basic-history) @@ -169,7 +170,7 @@ (defun presentation-default-preprocessor (default presentation-type &key default-type) (let ((type (expand-presentation-type-abbreviation presentation-type))) - (call-presentation-generic-function presentation-default-preprocessor + (funcall-presentation-generic-function presentation-default-preprocessor default type :default-type default-type))) (define-default-presentation-method presentation-default-preprocessor @@ -186,7 +187,7 @@ #+Genera (zwei:defindentation (map-over-presentation-type-supertypes 1 2)) (defun map-over-presentation-type-supertypes (presentation-type function) (declare (dynamic-extent function)) - (call-presentation-generic-function map-over-presentation-type-supertypes + (funcall-presentation-generic-function map-over-presentation-type-supertypes presentation-type function)) ;;; Map over unparameterized presentation types, including some mappings @@ -235,7 +236,7 @@ ;; that object is a member of the correct class, or to do it all. ;; No default method should be defined, since what the default method ;; could do (call typep) has already been done above. - (call-presentation-generic-function presentation-typep object type))))) + (funcall-presentation-generic-function presentation-typep object type))))) ;;; SUBTYPEP @@ -280,7 +281,7 @@ (values t t)) ;Everything is its own subtype (t (multiple-value-bind (subtype-p known-p) - (call-presentation-generic-function presentation-subtypep + (funcall-presentation-generic-function presentation-subtypep type putative-supertype) ;; Catch a common mistake in PRESENTATION-SUBTYPEP methods (when (and subtype-p (not known-p)) @@ -330,7 +331,8 @@ (values t t)) ;Everything is its own subtype (t ;Call method to figure out the parameters (multiple-value-bind (subtype-p known-p) - (call-presentation-generic-function presentation-subtypep + (funcall-presentation-generic-function + presentation-subtypep ntype putative-supertype) (when (and subtype-p (not known-p)) (cerror "Return the two values T and T" @@ -362,7 +364,7 @@ ;;; Called when ACCEPT turns into PRESENT (defun accept-present-default (presentation-type stream view default default-supplied-p present-p query-identifier &key (prompt t)) - (call-presentation-generic-function accept-present-default + (funcall-presentation-generic-function accept-present-default presentation-type stream view default default-supplied-p present-p query-identifier :prompt prompt)) @@ -383,7 +385,7 @@ (defun highlight-presentation (record presentation-type stream state) (unless (eq record *null-presentation*) (with-output-recording-options (stream :record nil) - (call-presentation-generic-function highlight-presentation + (funcall-presentation-generic-function highlight-presentation presentation-type record stream state) (force-output stream)))) diff --git a/clim/recording-defs.lisp b/clim/recording-defs.lisp index e71e42cf..67bd1150 100644 --- a/clim/recording-defs.lisp +++ b/clim/recording-defs.lisp @@ -1,8 +1,8 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -(in-package :clim-internals) +;; $fiHeader: recording-defs.lisp,v 1.2 92/03/10 15:46:27 cer Exp $ -;; $fiHeader$ +(in-package :clim-internals) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." diff --git a/clim/recording-protocol.lisp b/clim/recording-protocol.lisp index b5741186..6adb3eff 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.6 92/03/24 19:37:56 cer Exp Locker: cer $ +;; $fiHeader: recording-protocol.lisp,v 1.7 92/04/14 15:29:55 cer Exp Locker: cer $ (in-package :clim-internals) @@ -38,7 +38,7 @@ ;;; map-over-output-records-overlapping-region: ;;; (function record region ;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) -;;; map-over-output-records-containing-point*: +;;; map-over-output-records-containing-position: ;;; (function record x y ;;; &optional (x-offset 0) (y-offset 0) &rest continuation-args) @@ -47,9 +47,9 @@ ;;; ;; Bounding rectangle position and set-position are in relative coordinates, -;; relative to (OUTPUT-RECORD-POSITION* (OUTPUT-RECORD-PARENT RECORD)). +;; relative to (OUTPUT-RECORD-POSITION (OUTPUT-RECORD-PARENT RECORD)). ;; The bounding rectangle measures just the ink. -;; (OUTPUT-RECORD-START-CURSOR-POSITION* RECORD) refers to the position of the +;; (OUTPUT-RECORD-START-CURSOR-POSITION RECORD) refers to the position of the ;; cursor at the start of RECORD. It is also the origin of the ;; coordinate system for all children of RECORD. (defclass output-record-element-mixin (standard-bounding-rectangle) @@ -85,7 +85,7 @@ ;;; Shadow the method on RECTANGLE with this one that keeps the start-position and ;;; bounding rectangle in synch. -(defmethod bounding-rectangle-set-position* ((record output-record-element-mixin) nx ny) +(defmethod bounding-rectangle-set-position ((record output-record-element-mixin) nx ny) (declare (type coordinate nx ny)) (with-slots (left top right bottom start-x start-y parent) record (declare (type coordinate left top right bottom start-x start-y)) @@ -99,7 +99,7 @@ bottom (+ ny height))))) #+ignore -(defmethod bounding-rectangle-set-position* :around ((record output-record-element-mixin) nx ny) +(defmethod bounding-rectangle-set-position :around ((record output-record-element-mixin) nx ny) (with-bounding-rectangle* (x1 y1 x2 y2) record (call-next-method) (note-output-record-moved record (- nx x1) (- ny y1) (- nx x2) (- ny y2)))) @@ -116,25 +116,29 @@ (declare (ignore dx1 dy1 dx2 dy2)) nil) -(defun-inline output-record-position* (record) - (output-record-start-cursor-position* record)) +(defun-inline output-record-position (record) + (output-record-start-cursor-position record)) -;; X and Y had better be fixnums -;;--- Coerce to COORDINATE -(defmethod output-record-set-position* ((record output-record-element-mixin) x y) +(defmethod output-record-set-position ((record output-record-element-mixin) x y) (declare (type coordinate x y)) - (bounding-rectangle-set-position* record x y)) + (bounding-rectangle-set-position record (coordinate x) (coordinate y))) -(defmethod output-record-start-cursor-position ((record output-record-element-mixin)) - (with-slots (start-x start-y) record - (make-point start-x start-y))) +#+CLIM-1-compatibility +(define-compatibility-function (output-record-position* output-record-position) + (record) + (output-record-position record)) + +#+CLIM-1-compatibility +(define-compatibility-function (output-record-set-position* output-record-set-position) + (record x y) + (output-record-set-position record x y)) -(defmethod output-record-start-cursor-position* ((record output-record-element-mixin)) +(defmethod output-record-start-cursor-position ((record output-record-element-mixin)) (with-slots (start-x start-y) record (values start-x start-y))) ;;; Keep the start-position and bounding rectangle in synch -(defmethod output-record-set-start-cursor-position* +(defmethod output-record-set-start-cursor-position ((record output-record-element-mixin) nx ny) (declare (type coordinate nx ny)) (with-slots (start-x start-y) record @@ -147,25 +151,21 @@ (+ left dx) (+ top dy) (+ right dx) (+ bottom dy)) (setf start-x nx start-y ny))))) -(defmethod output-record-end-cursor-position* ((record output-record-element-mixin)) +(defmethod output-record-end-cursor-position ((record output-record-element-mixin)) (with-slots (end-x end-y) record (values end-x end-y))) -(defmethod output-record-set-end-cursor-position* ((record output-record-element-mixin) nx ny) +(defmethod output-record-set-end-cursor-position ((record output-record-element-mixin) nx ny) (declare (type coordinate nx ny)) (with-slots (end-x end-y) record (setf end-x nx) (setf end-y ny))) (defmethod output-record-old-start-cursor-position ((record output-record-element-mixin)) - (with-slots (old-start-x old-start-y) record - (make-point old-start-x old-start-y))) - -(defmethod output-record-old-start-cursor-position* ((record output-record-element-mixin)) (with-slots (old-start-x old-start-y) record (values old-start-x old-start-y))) -(defmethod output-record-set-old-start-cursor-position* +(defmethod output-record-set-old-start-cursor-position ((record output-record-element-mixin) nx ny) (declare (type coordinate nx ny)) (with-slots (old-start-x old-start-y) record @@ -177,27 +177,29 @@ (define-compatibility-function (output-record-start-position output-record-start-cursor-position) (record) - (output-record-start-cursor-position record)) + (multiple-value-bind (x y) + (output-record-start-cursor-position record) + (make-point x y))) (define-compatibility-function (output-record-start-position* - output-record-start-cursor-position*) + output-record-start-cursor-position) (record) - (output-record-start-cursor-position* record)) + (output-record-start-cursor-position record)) (define-compatibility-function (output-record-set-start-position* - output-record-set-start-cursor-position*) + output-record-set-start-cursor-position) (record nx ny) - (output-record-set-start-cursor-position* record nx ny)) + (output-record-set-start-cursor-position record nx ny)) (define-compatibility-function (output-record-end-position* - output-record-end-cursor-position*) + output-record-end-cursor-position) (record) - (output-record-end-cursor-position* record)) + (output-record-end-cursor-position record)) (define-compatibility-function (output-record-set-end-position* - output-record-set-end-cursor-position*) + output-record-set-end-cursor-position) (record nx ny) - (output-record-set-end-cursor-position* record nx ny)) + (output-record-set-end-cursor-position record nx ny)) ) ;#+CLIM-1-compatibility @@ -212,11 +214,11 @@ (defun compute-output-record-offsets (record) (let ((parent (output-record-parent record))) (if (null parent) - (values 0 0) + (values (coordinate 0) (coordinate 0)) (multiple-value-bind (x y) (compute-output-record-offsets parent) (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* record) + (multiple-value-bind (our-x our-y) (output-record-position record) (declare (type coordinate our-x our-y)) (values (+ our-x x) (+ our-y y))))))) @@ -231,18 +233,18 @@ (declare (type coordinate xoff1 yoff1)) (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) + (translate-coordinates xoff1 yoff1 left1 top1 right1 bottom1) + (translate-coordinates xoff2 yoff2 left2 top2 right2 bottom2) (ltrb-equals-ltrb-p left1 top1 right1 bottom1 left2 top2 right2 bottom2))))))) -(defmethod region-contains-point*-p +(defmethod region-contains-position-p ((record output-record-element-mixin) x y) (with-bounding-rectangle* (left top right bottom) record (multiple-value-bind (xoff yoff) (compute-output-record-offsets record) (declare (type coordinate xoff yoff)) - (ltrb-contains-point*-p left top right bottom - (+ x xoff) (+ y yoff))))) + (ltrb-contains-position-p left top right bottom + (+ x xoff) (+ y yoff))))) (defmethod region-contains-region-p ((record1 output-record-element-mixin) (record2 output-record-element-mixin)) @@ -255,8 +257,8 @@ (declare (type coordinate xoff1 yoff1)) (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) + (translate-coordinates xoff1 yoff1 left1 top1 right1 bottom1) + (translate-coordinates xoff2 yoff2 left2 top2 right2 bottom2) (ltrb-contains-ltrb-p left1 top1 right1 bottom1 left2 top2 right2 bottom2))))))) @@ -271,8 +273,8 @@ (declare (type coordinate xoff1 yoff1)) (multiple-value-bind (xoff2 yoff2) (compute-output-record-offsets record2) (declare (type coordinate xoff2 yoff2)) - (translate-fixnum-positions xoff1 yoff1 left1 top1 right1 bottom1) - (translate-fixnum-positions xoff2 yoff2 left2 top2 right2 bottom2) + (translate-coordinates xoff1 yoff1 left1 top1 right1 bottom1) + (translate-coordinates xoff2 yoff2 left2 top2 right2 bottom2) (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 left2 top2 right2 bottom2))))))) @@ -290,11 +292,11 @@ (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 (+ left2 xoff) (+ top2 yoff) (+ right2 xoff) (+ bottom2 yoff))))) -(defun offset-region-contains-point*-p (region xoff yoff x y) +(defun offset-region-contains-position-p (region xoff yoff x y) (declare (type coordinate xoff yoff x y)) (with-bounding-rectangle* (left top right bottom) region - (ltrb-contains-point*-p (+ left xoff) (+ top yoff) (+ right xoff) (+ bottom yoff) - x y))) + (ltrb-contains-position-p (+ left xoff) (+ top yoff) (+ right xoff) (+ bottom yoff) + x y))) ;;; This maps over all of the children of the record #+Genera (zwei:defindentation (map-over-output-records 1 1)) @@ -341,19 +343,19 @@ ;;; This is because this function is used for things like locating the ;;; presentation under the pointer, where the topmost thing wants to be ;;; located first. -#+Genera (zwei:defindentation (map-over-output-records-containing-point* 3 1)) -(defgeneric map-over-output-records-containing-point* +#+Genera (zwei:defindentation (map-over-output-records-containing-position 3 1)) +(defgeneric map-over-output-records-containing-position (function record x y &optional x-offset y-offset &rest continuation-args) (declare (dynamic-extent function continuation-args))) #+CLIM-1-compatibility (define-compatibility-function (map-over-output-record-elements-containing-point* - map-over-output-records-containing-point*) + map-over-output-records-containing-position) (record x y function &optional x-offset y-offset &rest continuation-args) (declare (dynamic-extent function continuation-args)) - (apply #'map-over-output-records-containing-point* + (apply #'map-over-output-records-containing-position function record x y x-offset y-offset continuation-args)) ;;; X-offset and Y-offset represent the accumulated offset between the @@ -363,7 +365,7 @@ ;;; ;;; In the absence of x- and y- offsets, region should be in the ;;; coordinate system of the record - i.e. relative to -;;; (OUTPUT-RECORD-POSITION* RECORD). +;;; (OUTPUT-RECORD-POSITION RECORD). ;;; This is the same coordinate system as the output record children ;;; we are mapping over. (defmethod map-over-output-records-overlapping-region @@ -373,14 +375,14 @@ (dynamic-extent function continuation-args)) nil) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (record output-record-element-mixin) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (ignore x y function x-offset y-offset continuation-args) (dynamic-extent function continuation-args)) nil) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (record t) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (dynamic-extent function continuation-args)) @@ -410,24 +412,28 @@ record))) #+Silica -(defmethod bounding-rectangle-set-position* :around ((record output-record-mixin) nx ny) +(defmethod bounding-rectangle-set-position :around ((record output-record-mixin) nx ny) (multiple-value-bind (ox oy) - (output-record-position* record) + (output-record-position record) (call-next-method) (when (or (/= ox nx) (/= oy ny)) - (note-output-record-moved record 1 1 1 1)))) + (note-output-record-moved record + (coordinate 1) (coordinate 1) + (coordinate 1) (coordinate 1))))) #+Silica (defmethod bounding-rectangle-set-edges :around ((record output-record-mixin) left top right bottom) (declare (ignore left top right bottom)) (multiple-value-bind (ox oy) - (output-record-position* record) + (output-record-position record) (call-next-method) (multiple-value-bind (nx ny) - (output-record-position* record) + (output-record-position record) (when (or (/= ox nx) (/= oy ny)) - (note-output-record-moved record 1 1 1 1))))) + (note-output-record-moved record + (coordinate 1) (coordinate 1) + (coordinate 1) (coordinate 1)))))) ;; If some coordinate is relative to a given output-record, then @@ -437,19 +443,20 @@ (defun convert-from-relative-to-absolute-coordinates (stream output-record) (declare (values x-offset y-offset)) (cond ((null output-record) - (values 0 0)) ;;---------------------------- Why? + ;;--- Why on earth do we need this now? + (values (coordinate 0) (coordinate 0))) ((and stream (eq output-record (stream-current-output-record stream))) (let ((position (stream-output-history-position stream))) (values (point-x position) (point-y position)))) ((null (output-record-parent output-record)) - (values 0 0)) + (values (coordinate 0) (coordinate 0))) (t (multiple-value-bind (x y) (convert-from-relative-to-absolute-coordinates stream (output-record-parent output-record)) (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* output-record) + (multiple-value-bind (our-x our-y) (output-record-position output-record) (declare (type coordinate our-x our-y)) (values (+ our-x x) (+ our-y y))))))) @@ -463,13 +470,13 @@ (let ((position (stream-output-history-position stream))) (values (- (point-x position)) (- (point-y position))))) ((null (output-record-parent output-record)) - (values 0 0)) + (values (coordinate 0) (coordinate 0))) (t (multiple-value-bind (x y) (convert-from-absolute-to-relative-coordinates stream (output-record-parent output-record)) (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* output-record) + (multiple-value-bind (our-x our-y) (output-record-position output-record) (declare (type coordinate our-x our-y)) (values (- x our-x) (- y our-y))))))) @@ -482,7 +489,7 @@ (defun convert-from-ancestor-to-descendant-coordinates (ancestor descendant) (declare (values x-offset y-offset)) (cond ((eq descendant ancestor) - (values 0 0)) + (values (coordinate 0) (coordinate 0))) ((null descendant) (error "~S was not an ancestor of ~S" ancestor descendant)) (t @@ -490,7 +497,7 @@ (convert-from-ancestor-to-descendant-coordinates ancestor (output-record-parent descendant)) (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* descendant) + (multiple-value-bind (our-x our-y) (output-record-position descendant) (declare (type coordinate our-x our-y)) (values (- x our-x) (- y our-y))))))) @@ -503,15 +510,15 @@ (defun convert-from-descendant-to-ancestor-coordinates (descendant ancestor) (declare (values x-offset y-offset)) (cond ((eq descendant ancestor) - (values 0 0)) + (values (coordinate 0) (coordinate 0))) ((null descendant) - (error "~s was not an ancestor of ~s" ancestor descendant)) + (error "~S was not an ancestor of ~S" ancestor descendant)) (t (multiple-value-bind (x y) (convert-from-descendant-to-ancestor-coordinates (output-record-parent descendant) ancestor) (declare (type coordinate x y)) - (multiple-value-bind (our-x our-y) (output-record-position* descendant) + (multiple-value-bind (our-x our-y) (output-record-position descendant) (declare (type coordinate our-x our-y)) (values (+ our-x x) (+ our-y y))))))) @@ -523,15 +530,15 @@ (stream-output-history-position stream))) (unless abs-y (multiple-value-setq (abs-x abs-y) - (stream-cursor-position* stream))) + (stream-cursor-position stream))) (letf-globally (((point-x current-output-position) abs-x) ((point-y current-output-position) abs-y) ((stream-current-output-record stream) record)) (funcall continuation record) (multiple-value-bind (end-x end-y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate end-x end-y)) - (output-record-set-end-cursor-position* + (output-record-set-end-cursor-position record (- end-x abs-x) (- end-y abs-y))) (stream-close-text-output-record stream)))) @@ -582,14 +589,14 @@ (apply #'find-inferior-output-record-1 current-output-record record-type init-args)))) (multiple-value-bind (cursor-x cursor-y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (type coordinate cursor-x cursor-y)) (multiple-value-bind (x y) (multiple-value-bind (px py) - (point-position* + (point-position (stream-output-history-position stream)) (declare (type coordinate px py)) - (position-difference* cursor-x cursor-y px py)) + (position-difference cursor-x cursor-y px py)) (declare (type coordinate x y)) (if new-output-record (copy-display-state new-output-record nil) @@ -601,7 +608,7 @@ :x-position x :y-position y init-args) (apply #'construct-output-record-1 record-type :x-position x :y-position y init-args)))) - (output-record-set-start-cursor-position* new-output-record x y) + (output-record-set-start-cursor-position new-output-record x y) (with-output-record-1 continuation stream new-output-record cursor-x cursor-y) (when (stream-redisplaying-p stream) @@ -622,14 +629,14 @@ (with-first-quadrant-coordinates (stream) (with-new-output-record (stream record-type) (funcall continuation stream)))))) - (multiple-value-bind (x y) (output-record-position* record) + (multiple-value-bind (x y) (output-record-position record) (declare (type coordinate x y)) ;;--- Hey, there is something wierd going on here. The problem is that - ;;--- OUTPUT-RECORD-POSITION* and OUTPUT-RECORD-SET-POSITION* seem to obey + ;;--- OUTPUT-RECORD-POSITION and OUTPUT-RECORD-SET-POSITION seem to obey ;;--- different coordinate system conventions. Geez. (when height (incf y (- height (bounding-rectangle-height record)))) - (output-record-set-position* record x y)) + (output-record-set-position record x y)) (tree-recompute-extent record) (replay record stream) (when move-cursor @@ -654,7 +661,7 @@ (labels ((replay-1 (record x-offset y-offset) (declare (type coordinate x-offset y-offset)) (if (output-record-p record) - (multiple-value-bind (xoff yoff) (output-record-position* record) + (multiple-value-bind (xoff yoff) (output-record-position record) (map-over-output-records-overlapping-region #'replay-1 record region (- x-offset) (- y-offset) @@ -671,7 +678,7 @@ (with-bounding-rectangle* (left top right bottom) record (declare (ignore left top)) (with-end-of-page-action (stream :allow) - (stream-set-cursor-position* + (stream-set-cursor-position stream (+ right x-offset) (- (+ bottom y-offset) (stream-line-height stream))))))) @@ -700,7 +707,10 @@ (with-slots (parent) record (with-bounding-rectangle* (old-left old-top old-right old-bottom) record (let ((once nil) - (min-x 0) (min-y 0) (max-x 0) (max-y 0)) + (min-x (coordinate 0)) + (min-y (coordinate 0)) + (max-x (coordinate 0)) + (max-y (coordinate 0))) (declare (type coordinate min-x min-y max-x max-y)) (flet ((recompute-extent-of-child (child) (with-bounding-rectangle* (left top right bottom) child @@ -727,9 +737,11 @@ (+ min-x xoff) (+ min-y yoff) (+ max-x xoff) (+ max-y yoff))) ;; No children - (bounding-rectangle-set-edges record 0 0 0 0)) + (bounding-rectangle-set-edges record + (coordinate 0) (coordinate 0) + (coordinate 0) (coordinate 0))) ;; Pass these coordinates in parent's coordinate system (I think) - (translate-fixnum-positions xoff yoff + (translate-coordinates xoff yoff old-left old-top old-right old-bottom)) (when parent (recompute-extent-for-changed-child @@ -745,7 +757,7 @@ (with-bounding-rectangle* (eleft etop eright ebottom) child (multiple-value-bind (xoff yoff) (convert-from-descendant-to-ancestor-coordinates record parent) - (translate-fixnum-positions xoff yoff + (translate-coordinates xoff yoff eleft etop eright ebottom ;; pass these coordinates in parent's coordinate system. old-left old-top old-right old-bottom)) @@ -767,7 +779,7 @@ (declare (type coordinate xoff yoff)) ;; we must pass the old coordinates in the parent's coordinate system ;; because tree-recompute-extent-1 may adjust the reference point. - (translate-fixnum-positions xoff yoff old-left old-top old-right old-bottom)) + (translate-coordinates xoff yoff old-left old-top old-right old-bottom)) (tree-recompute-extent-1 record) (when parent (recompute-extent-for-changed-child @@ -819,7 +831,7 @@ (multiple-value-bind (xoff yoff) (convert-from-descendant-to-ancestor-coordinates child record) (declare (type coordinate xoff yoff)) - (translate-fixnum-positions xoff yoff left top right bottom) + (translate-coordinates xoff yoff left top right bottom) (recompute-extent-for-changed-child record child left top right bottom))) (setf (output-record-parent child) nil)) ;in case other things are still pointing to it. @@ -852,7 +864,9 @@ (map-over-output-records #'free-output-record record)) (defmethod clear-output-record :after ((record output-record-mixin)) - (bounding-rectangle-set-edges record 0 0 0 0)) + (bounding-rectangle-set-edges record + (coordinate 0) (coordinate 0) + (coordinate 0) (coordinate 0))) (defmethod clear-output-record :around ((record output-record-mixin)) (when (output-record-stream record) @@ -950,7 +964,8 @@ ;; Shift the whole vector downward (do ((i (the fixnum index) (1+ i))) ((= i new-fp)) - (declare (fixnum i) (optimize (speed 3) (safety 0))) + (declare (type fixnum i) + (optimize (speed 3) (safety 0))) (setf (svref vector i) (svref vector (1+ i))))) (setf fill-pointer new-fp))) (errorp @@ -976,11 +991,11 @@ (dovector (child elements :start 0 :end fill-pointer :simple-p t) (apply function child continuation-args)) (with-bounding-rectangle* (left1 top1 right1 bottom1) region - (translate-fixnum-positions x-offset y-offset left1 top1 right1 bottom1) + (translate-coordinates x-offset y-offset left1 top1 right1 bottom1) ;; Subtract out the record offset from the region, to make comparison fair (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) left1 top1 right1 bottom1)) + (output-record-position record) + (translate-coordinates (- xoff) (- yoff) left1 top1 right1 bottom1)) (dovector (child elements :start 0 :end fill-pointer :simple-p t) (with-bounding-rectangle* (left2 top2 right2 bottom2) child (when (ltrb-overlaps-ltrb-p left1 top1 right1 bottom1 @@ -990,34 +1005,34 @@ (if (or (null region) (eq region +everywhere+)) (apply function elements continuation-args) (multiple-value-bind (xoff yoff) - (output-record-position* record) + (output-record-position record) (declare (type coordinate xoff yoff)) (when (region-intersects-offset-region-p elements region (- x-offset xoff) (- y-offset yoff)) (apply function elements continuation-args))))))) nil) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (record standard-sequence-output-record) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (dynamic-extent function continuation-args)) (declare (type coordinate x y x-offset y-offset)) (declare (optimize (safety 0))) - (translate-fixnum-positions x-offset y-offset x y) + (translate-coordinates x-offset y-offset x y) (with-slots (elements fill-pointer) record (typecase elements (null nil) (array (multiple-value-bind (xoff yoff) - (output-record-position* record) - (translate-fixnum-positions (- xoff) (- yoff) x y)) + (output-record-position record) + (translate-coordinates (- xoff) (- yoff) x y)) (dovector (child elements :start 0 :end fill-pointer :from-end t :simple-p t) (with-bounding-rectangle* (left top right bottom) child - (when (ltrb-contains-point*-p left top right bottom x y) + (when (ltrb-contains-position-p left top right bottom x y) (apply function child continuation-args))))) (otherwise - (multiple-value-bind (xoff yoff) (output-record-position* record) - (when (offset-region-contains-point*-p elements xoff yoff x y) + (multiple-value-bind (xoff yoff) (output-record-position record) + (when (offset-region-contains-position-p elements xoff yoff x y) (apply function elements continuation-args)))))) nil) @@ -1026,61 +1041,53 @@ (defclass stream-output-history-mixin () ((stream))) (defmethod bounding-rectangle-set-edges ((record stream-output-history-mixin) - left top right bottom) - (declare (type coordinate left top right bottom)) - #+ignore (assert (<= left right)) - #+ignore (assert (<= top bottom)) - (with-slots ((bl left) (bt top) (br right) (bb bottom) parent stream) record + nleft ntop nright nbottom) + (declare (type coordinate nleft ntop nright nbottom)) + #+ignore (assert (<= nleft nright)) + #+ignore (assert (<= ntop nbottom)) + (with-slots (left top right bottom parent stream) record ;; Top-level output records must not have their upper left corner any ;; "later" than (0,0), or else scroll bars and scrolling will not do ;; the right thing. - (let ((old-left bl) - (old-top bt) - (old-right br) - (old-bottom bb)) + (let ((old-left left) + (old-top top) + (old-right right) + (old-bottom bottom)) (declare (type coordinate old-left old-top old-right old-bottom)) - (setq bl (min left 0) - bt (min top 0) - br right - bb bottom))) + (setq left (min nleft (coordinate 0)) + top (min ntop (coordinate 0)) + right nright + bottom nbottom))) record) #+Silica -(defmethod bounding-rectangle-set-edges :around ((r stream-output-history-mixin) - nminx nminy nmaxx nmaxy) - (multiple-value-bind - (minx miny maxx maxy) - (bounding-rectangle* r) +(defmethod bounding-rectangle-set-edges :around ((record stream-output-history-mixin) + nleft ntop nright nbottom) + (with-bounding-rectangle* (left top right bottom) record (call-next-method) - (unless (and (= minx nminx) - (= miny nminy) - (= maxx nmaxx) - (= maxy nmaxy)) - ;; This should update the scrollbars etc - (let* ((stream (output-record-stream r)) - (vp (pane-viewport stream))) - (when vp - (update-scrollbars vp)) - #-ignore - (update-region stream - nminx - nminy - nmaxy - nmaxx) - #+ignore - (update-region stream (- nmaxx nminx) (- nmaxy nminy)))))) + (unless (and (= left nleft) + (= top ntop) + (= right nright) + (= bottom nbottom)) + ;; This should update the scroll-bars etc + (let* ((stream (output-record-stream record)) + (viewport (pane-viewport stream))) + (when viewport + (update-scroll-bars viewport)) + (update-region stream nleft ntop nright nbottom))))) ;;; Defclass of OUTPUT-RECORDING-MIXIN, etc. is in STREAM-CLASS-DEFS (defmethod initialize-instance :after ((stream output-recording-mixin) &rest args) (declare (ignore args)) (with-slots (output-record) stream ;;--- Our OUTPUT-RECORDING-MIXIN expects extended output... - (multiple-value-bind (x y) (stream-cursor-position* stream) + (multiple-value-bind (x y) (stream-cursor-position stream) ;; I don't understand why the output record's initial position was set to ;; some untransformed "viewport" coordinate. The cursor position is the ;; right place, no? - (output-record-set-position* output-record x y)) - (setf (slot-value output-record 'stream) stream))) + (output-record-set-position output-record x y)) + (when (typep output-record 'stream-output-history-mixin) + (setf (slot-value output-record 'stream) stream)))) (defmethod clear-output-history ((stream output-recording-mixin)) (when (stream-output-history stream) @@ -1091,16 +1098,15 @@ (defmethod stream-add-output-record ((stream output-recording-mixin) record) (with-slots (output-record current-output-record-stack) stream (let ((the-output-record (or current-output-record-stack output-record))) - (add-output-record record the-output-record) - ;;--- I think we let the history worry about this - #+ignore-Silica - (let ((width (bounding-rectangle-width stream)) - (height (bounding-rectangle-height stream))) - (declare (type coordinate width height)) - (with-bounding-rectangle* (rl rt rr rb) the-output-record - (when (or (< rl 0) (< width rr) - (< rt 0) (< height rb)) - (update-region stream (- rr rl) (- rb rt)))))))) + (add-output-record record the-output-record) + #+++ignore ;--- the output history already does this, we think + (let ((width (bounding-rectangle-width stream)) + (height (bounding-rectangle-height stream))) + (declare (type coordinate width height)) + (with-bounding-rectangle* (rl rt rr rb) the-output-record + (when (or (< rl 0) (< width rr) + (< rt 0) (< height rb)) + (update-region stream rl rt rr rb))))))) (defmethod stream-replay ((stream output-recording-mixin) &optional region) (when (stream-drawing-p stream) @@ -1139,12 +1145,11 @@ ((stream-drawing-p stream) draw)) (funcall continuation))) - ;;; The following two are only called when STREAM-RECORDING-P is true and the ;;; characters are printable (see CHARACTER-DRAWING.LISP). (defmethod stream-add-string-output ((stream output-recording-mixin) string start end text-style width height baseline) - (declare (fixnum start end)) + (declare (type fixnum start end)) (when (< start end) (let ((record (get-text-output-record stream text-style))) (add-string-output-to-text-record record string start end text-style @@ -1181,16 +1186,16 @@ ;; a sequence such as WRITE-STRING/SET-CURSORPOS/WRITE-STRING would ;; create only a single output record, and intervening whitespace would ;; be lost if the two WRITE-STRINGs took place on the same line. -(defmethod stream-set-cursor-position* :before ((stream output-recording-mixin) x y) +(defmethod stream-set-cursor-position :before ((stream output-recording-mixin) x y) (declare (ignore x y)) (stream-close-text-output-record stream)) ;; This gets used to reposition the cursor when drawing text. We need to ;; close the text output record when there was a line wrap, but not when ;; we are simply incrementing the cursor beyond the just-written glyph. -(defmethod stream-set-cursor-position*-internal :before ((stream output-recording-mixin) x y) +(defmethod stream-set-cursor-position-internal :before ((stream output-recording-mixin) x y) (declare (ignore x)) - (multiple-value-bind (old-x old-y) (stream-cursor-position* stream) + (multiple-value-bind (old-x old-y) (stream-cursor-position stream) (declare (ignore old-x)) (unless (eq y old-y) (stream-close-text-output-record stream)))) @@ -1243,7 +1248,7 @@ (window-flush-update-region stream)))) ;;;--- We need some version of this code to do the area copying. -(defmethod window-set-viewport-position* :around ((stream window-output-recording) +(defmethod window-set-viewport-position :around ((stream window-output-recording) new-x new-y) (declare (ignore new-x new-y)) (with-bounding-rectangle* (left top right bottom) (window-viewport stream) @@ -1263,7 +1268,6 @@ ;; Adjust for the left and top margins by hand so clear-area doesn't erase ;; the margin components. (t (multiple-value-bind (ml mt) (window-margins stream) - ;;--- Will these be coords or fixnums? (declare (type coordinate ml mt)) (multiple-value-bind (vw vh) (window-inside-size stream) (declare (type coordinate vw vh)) diff --git a/clim/standard-tree.lisp b/clim/standard-tree.lisp index be52bdc0..cf6b84e7 100644 --- a/clim/standard-tree.lisp +++ b/clim/standard-tree.lisp @@ -19,7 +19,7 @@ ;; applicable. ;; -;; $fiHeader: standard-tree.lisp,v 1.1 91/11/25 10:00:54 cer Exp Locker: cer $ +;; $fiHeader: standard-tree.lisp,v 1.2 92/03/09 17:41:53 cer Exp Locker: cer $ (in-package :clim-internals) @@ -235,11 +235,11 @@ Copyright (c) 1991, Franz Inc. All rights reserved ; (= miny nminy) ; (= maxx nmaxx) ; (= maxy nmaxy)) -; ;; This should update the scrollbars etc +; ;; This should update the scroll-bars etc ; (let* ((stream (stream-output-history-mixin-stream r)) ; (vp (pane-viewport-sheet stream))) ; (when vp -; (update-scrollbars vp)) +; (update-scroll-bars vp)) ; (update-region stream ; nminx ; nminy diff --git a/clim/standard-types.lisp b/clim/standard-types.lisp index 034cb738..65a42ce7 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.4 92/03/04 16:22:15 cer Exp $ +;; $fiHeader: standard-types.lisp,v 1.5 92/03/10 10:12:52 cer Exp $ (in-package :clim-internals) @@ -407,10 +407,13 @@ (pathname-complete string action default)) :allow-any-input t :help-displays-possibilities nil) (declare (ignore success)) - (unless pathname - (setq pathname (parse-namestring string nil default))) - (when merge-default - (setq pathname (merge-pathnames pathname default default-version))) + (handler-bind ((error + #'(lambda (error) + (simple-parse-error "Error parsing pathname string ~A" string)))) + (unless pathname + (setq pathname (parse-namestring string nil default))) + (when merge-default + (setq pathname (merge-pathnames pathname default default-version)))) (unless (rescanning-p stream) (presentation-replace-input stream pathname type view :buffer-start buffer-start)) @@ -497,7 +500,8 @@ ;;;; "One-of" Presentation Types -(define-presentation-type completion (sequence &key (test 'eql) (value-key 'identity)) +(define-presentation-type completion (&optional (sequence nil) + &key (test 'eql) (value-key 'identity)) :options ((name-key 'completion-default-name-key) (documentation-key 'completion-default-doc-key) (partial-completers '(#\Space)))) @@ -655,8 +659,8 @@ ;;;; "Some-of" Presentation Types -(define-presentation-type subset-completion - (sequence &key (test 'eql) (value-key 'identity)) +(define-presentation-type subset-completion (&optional (sequence nil) + &key (test 'eql) (value-key 'identity)) :options ((name-key 'completion-default-name-key) (documentation-key 'completion-default-doc-key) (partial-completers '(#\Space)) @@ -980,13 +984,13 @@ (if default-supplied-p (if history (with-default-bound-in-history history default-element - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept element-type stream view :default element-default :default-type element-default-type)) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept element-type stream view :default element-default :default-type element-default-type)) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept element-type stream view)))) ;; The user clicked on an object having the element type (t @@ -1151,7 +1155,7 @@ (when (presentation-typep object type) (return-from present ;; This must call the real present function, rather than using - ;; call-presentation-generic-function, so that a nested presentation + ;; CALL-PRESENTATION-GENERIC-FUNCTION, so that a nested presentation ;; of the correct type will be created ;;--- Maybe. See RWK comment in the DW version. (apply #'present object type :stream stream :view view options)))) @@ -1192,13 +1196,13 @@ (presentation-typep default type)) (if history (with-default-bound-in-history history default-element - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view :default default :default-type default-type)) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view :default default :default-type default-type)) - (call-presentation-generic-function accept + (funcall-presentation-generic-function accept type stream view)) (return-from accept (values object (or object-type type))))))) @@ -1281,14 +1285,14 @@ (define-presentation-method present (object (type and) stream view &rest options) (declare (dynamic-extent options)) - (call-presentation-generic-function apply present + (apply-presentation-generic-function present object (first types) stream view options)) (define-presentation-method accept ((type and) stream view &rest options) (declare (dynamic-extent options)) (loop (multiple-value-bind (object input-type) - (call-presentation-generic-function apply accept + (apply-presentation-generic-function accept (first types) stream view options) (when (every #'(lambda (type) (and-presentation-typep object type)) (rest types)) (return-from accept (values object input-type))) @@ -1313,12 +1317,12 @@ (define-presentation-method accept ((type boolean) stream view &rest options) (declare (dynamic-extent options)) (values - (call-presentation-generic-function apply accept + (apply-presentation-generic-function accept *boolean-member-type* stream view options))) (define-presentation-method present (object (type boolean) stream view &rest options) (declare (dynamic-extent options)) - (call-presentation-generic-function apply present + (apply-presentation-generic-function present object *boolean-member-type* stream view options)) ;; Supplying this gives us a nice "pushbutton" effect for booleans, too diff --git a/clim/stream-class-defs.lisp b/clim/stream-class-defs.lisp index 65d0924c..b56c8918 100644 --- a/clim/stream-class-defs.lisp +++ b/clim/stream-class-defs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: stream-class-defs.lisp,v 1.3 92/01/31 14:58:45 cer Exp $ +;; $fiHeader: stream-class-defs.lisp,v 1.4 92/02/24 13:08:30 cer Exp $ (in-package :clim-internals) @@ -17,8 +17,8 @@ left top right bottom) (bounding-rectangle-set-edges (slot-value stream 'stream) left top right bottom)) -(defmethod bounding-rectangle-set-position* ((stream standard-encapsulating-stream) x y) - (bounding-rectangle-set-position* (slot-value stream 'stream) x y)) +(defmethod bounding-rectangle-set-position ((stream standard-encapsulating-stream) x y) + (bounding-rectangle-set-position (slot-value stream 'stream) x y)) (defmethod bounding-rectangle-set-size ((stream standard-encapsulating-stream) width height) (bounding-rectangle-set-size (slot-value stream 'stream) width height)) diff --git a/clim/stream-defprotocols.lisp b/clim/stream-defprotocols.lisp index e9ab0f8c..dc8d48b7 100644 --- a/clim/stream-defprotocols.lisp +++ b/clim/stream-defprotocols.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: stream-defprotocols.lisp,v 1.4 92/02/24 13:08:31 cer Exp $ +;; $fiHeader: stream-defprotocols.lisp,v 1.5 92/03/04 16:22:17 cer Exp $ (in-package :clim-internals) @@ -107,11 +107,11 @@ (defoperation stream-input-wait basic-extended-input-protocol ((stream basic-extended-input-protocol) &key timeout input-wait-test)) -(defoperation stream-pointer-position* basic-extended-input-protocol +(defoperation stream-pointer-position basic-extended-input-protocol ((stream basic-extended-input-protocol) &key (timeout 0) pointer) (declare (values x y))) -(defoperation stream-set-pointer-position* basic-extended-input-protocol +(defoperation stream-set-pointer-position basic-extended-input-protocol ((stream basic-extended-input-protocol) x y &key pointer)) (defoperation stream-note-pointer-button-press basic-extended-input-protocol @@ -232,19 +232,19 @@ (stream) (stream-vertical-spacing stream)) -(defoperation stream-cursor-position* basic-extended-output-protocol +(defoperation stream-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol)) (declare (values x y))) -(defoperation stream-set-cursor-position* basic-extended-output-protocol +(defoperation stream-set-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) x y)) -;; Like STREAM-SET-CURSOR-POSITION*, but is more conservative about closing +;; Like STREAM-SET-CURSOR-POSITION, but is more conservative about closing ;; the current text output record. -(defoperation stream-set-cursor-position*-internal basic-extended-output-protocol +(defoperation stream-set-cursor-position-internal basic-extended-output-protocol ((stream basic-extended-output-protocol) x y)) -(defoperation stream-increment-cursor-position* basic-extended-output-protocol +(defoperation stream-increment-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) dx dy)) (defoperation stream-ensure-cursor-visible basic-extended-output-protocol @@ -279,17 +279,17 @@ ((stream basic-extended-output-protocol) &optional brief-p)) #+Genera -(defoperation stream-compatible-cursor-position* basic-extended-output-protocol +(defoperation stream-compatible-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) &optional unit) (:selector :read-cursorpos)) #+Genera -(defoperation stream-compatible-set-cursor-position* basic-extended-output-protocol +(defoperation stream-compatible-set-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) x y &optional unit) (:selector :set-cursorpos)) #+Genera -(defoperation stream-compatible-increment-cursor-position* basic-extended-output-protocol +(defoperation stream-compatible-increment-cursor-position basic-extended-output-protocol ((stream basic-extended-output-protocol) x y &optional unit) (:selector :increment-cursorpos)) @@ -364,10 +364,10 @@ (defoperation window-drawing-possible window-mixin ((window window-mixin))) -(defoperation window-viewport-position* window-mixin +(defoperation window-viewport-position window-mixin ((window window-mixin))) -(defoperation window-set-viewport-position* window-mixin +(defoperation window-set-viewport-position window-mixin ((window window-mixin) x y)) (defoperation redisplay-decorations window-mixin diff --git a/clim/surround-output.lisp b/clim/surround-output.lisp index 867a506f..f53abd93 100644 --- a/clim/surround-output.lisp +++ b/clim/surround-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: surround-output.lisp,v 1.3 92/01/31 14:58:50 cer Exp $ +;; $fiHeader: surround-output.lisp,v 1.4 92/02/24 13:08:34 cer Exp $ (in-package :clim-internals) @@ -89,7 +89,7 @@ (multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates stream (output-record-parent (output-record-parent body))) - (translate-fixnum-positions xoff yoff left top right bottom)) + (translate-coordinates xoff yoff left top right bottom)) (with-output-recording-options (stream :draw nil :record t) (with-new-output-record (stream 'standard-sequence-output-record nil :parent border-record) diff --git a/clim/table-formatting.lisp b/clim/table-formatting.lisp index abf2625d..24ce2616 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.4 92/02/24 13:08:36 cer Exp $ +;; $fiHeader: table-formatting.lisp,v 1.5 92/03/04 16:22:19 cer Exp $ (in-package :clim-internals) @@ -170,7 +170,10 @@ (defmethod tree-recompute-extent-1 ((record output-record-mixin)) (let ((once nil) - (min-x 0) (min-y 0) (max-x 0) (max-y 0)) + (min-x (coordinate 0)) + (min-y (coordinate 0)) + (max-x (coordinate 0)) + (max-y (coordinate 0))) (declare (type coordinate min-x min-y max-x max-y)) (multiple-value-bind (x-offset y-offset) (convert-from-descendant-to-ancestor-coordinates @@ -194,9 +197,12 @@ (declare (dynamic-extent #'recompute-extent-of-child)) (map-over-output-records #'recompute-extent-of-child record)) (when (null min-x) - (setq min-x 0 min-y 0 max-x 0 max-y 0)) + (setq min-x (coordinate 0) + min-y (coordinate 0) + max-x (coordinate 0) + max-y (coordinate 0))) #+ignore (assert (ltrb-well-formed-p min-x min-y max-x max-y)) - (translate-fixnum-positions x-offset y-offset min-x min-y max-x max-y) + (translate-coordinates x-offset y-offset min-x min-y max-x max-y) (bounding-rectangle-set-edges record min-x min-y max-x max-y) (values min-x min-y max-x max-y)))) @@ -242,7 +248,7 @@ (x-spacing (slot-value table 'x-spacing)) (y-spacing (slot-value table 'y-spacing)) (equalize-column-widths (slot-value table 'equalize-column-widths))) - (declare (fixnum nrows cells)) + (declare (type fixnum nrows cells)) (declare (type coordinate x-spacing y-spacing)) (labels ((count-rows (row) (incf nrows) @@ -265,12 +271,14 @@ (with-stack-array (column-array ncells :initial-element nil) (let ((x-pos nil) (y-pos nil) - (row-count 0) (column-count 0) - (total-width 0) (total-height 0)) - (declare (fixnum row-count column-count)) + (row-count 0) + (column-count 0) + (total-width (coordinate 0)) + (total-height (coordinate 0))) + (declare (type fixnum row-count column-count)) (declare (type coordinate total-width total-height)) ;; We always want the table to start at its START-X and START-Y positions. - (multiple-value-setq (x-pos y-pos) (output-record-position* table)) + (multiple-value-setq (x-pos y-pos) (output-record-position table)) (macrolet (#-CCL-2 (row-max-height (row-number) `(svref row-array ,row-number)) #-CCL-2 (column-max-width (column-number) @@ -305,9 +313,9 @@ (declare (dynamic-extent #'row-mapper)) (funcall table-mapper #'row-mapper table)) (when equalize-column-widths - (let ((column-width 0) + (let ((column-width (coordinate 0)) (n-columns (1+ column-count))) - (declare (fixnum n-columns)) + (declare (type fixnum n-columns)) (declare (type coordinate column-width)) (dotimes (i n-columns) (maxf column-width (column-max-width i))) @@ -338,9 +346,11 @@ (ecase (slot-value cell 'x-alignment) (:left ) (:right - (setq x-alignment-adjust (- column-width cell-width))) + (setq x-alignment-adjust + (- column-width cell-width))) (:center - (setq x-alignment-adjust (floor (- column-width cell-width) 2)))) + (setq x-alignment-adjust + (floor (- column-width cell-width) 2)))) (ecase (slot-value cell 'y-alignment) (:top ) (:bottom @@ -353,7 +363,7 @@ (convert-from-ancestor-to-descendant-coordinates (output-record-parent table) (output-record-parent cell)) (declare (type coordinate x-offset y-offset)) - (output-record-set-position* + (output-record-set-position cell (+ x-offset total-width x-alignment-adjust) (+ y-offset total-height y-alignment-adjust))) @@ -373,7 +383,7 @@ (defmethod adjust-multiple-columns ((table standard-table-output-record) stream &optional n-columns x-spacing) (let ((row-count 0)) - (declare (fixnum row-count)) + (declare (type fixnum row-count)) (when (slot-value table 'row-table-p) (flet ((row-counter (row) (declare (ignore row)) @@ -395,31 +405,32 @@ ':multiple-columns-x-spacing) (stream-string-width stream " "))) (column-width (+ table-width between-column-margin)) - (possible-columns (or n-columns (floor stream-width column-width))) + (possible-columns (or n-columns + (max (floor stream-width column-width) 1))) (y-spacing (slot-value table 'y-spacing)) (rows-per-column (max 3 (ceiling row-count possible-columns))) (row-number 0) - (row-x 0) - (row-y 0)) + (row-x (coordinate 0)) + (row-y (coordinate 0))) (declare (type coordinate table-width between-column-margin column-width row-x row-y)) (declare (type fixnum possible-columns rows-per-column row-number)) (flet ((layout-multiple-columns (row) - (multiple-value-bind (rl rt) (bounding-rectangle-position* row) + (multiple-value-bind (rl rt) (bounding-rectangle-position row) (multiple-value-bind (xoff yoff) (convert-from-descendant-to-ancestor-coordinates row (output-record-parent table)) (declare (type coordinate xoff yoff)) - (translate-fixnum-positions xoff yoff rl rt)) + (translate-coordinates xoff yoff rl rt)) ;; Position the row so that the X position relative to the ;; original table is preserved, so that :ALIGN-X :RIGHT works ;;--- ROW-Y needs the same treatment for :ALIGN-Y - (output-record-set-position* row (+ row-x (- rl tleft)) row-y) + (output-record-set-position row (+ row-x (- rl tleft)) row-y) (incf row-number) (incf row-y (+ (bounding-rectangle-height row) y-spacing)) (when (zerop (mod row-number rows-per-column)) (setq row-x (+ row-x column-width) - row-y 0))))) + row-y (coordinate 0)))))) (declare (dynamic-extent #'layout-multiple-columns)) (map-over-table-rows #'layout-multiple-columns table))))) (tree-recompute-extent table))))) @@ -433,7 +444,7 @@ #'(lambda (cell) (with-bounding-rectangle* (left top right bottom) cell (declare (ignore bottom)) - (output-record-set-position* cell x-position top) + (output-record-set-position cell x-position top) (incf x-position (+ (- right left) x-spacing)))) row))) @@ -441,15 +452,16 @@ (declare (ignore stream)) #+ignore (let ((x-spacing (slot-value (output-record-parent column) 'x-spacing)) - (x-position 0)) + (x-position (coordinate 0))) (map-over-row-cells #'(lambda (cell) (with-bounding-rectangle* (left top right bottom) cell (declare (ignore bottom)) - (output-record-set-position* cell x-position top) + (output-record-set-position cell x-position top) (incf x-position (+ (- right left) x-spacing)))) column))) +;;--- Should this return a COORDINATE? (defun process-spacing-arg (stream spacing form &optional clause) (cond ((null spacing) nil) ((integerp spacing) spacing) @@ -520,17 +532,18 @@ ;;--- inline in FORMATTING-CELL it would just work. We could skip the IF and ;;--- just call INVOKE-WITH-NEW-OUTPUT-RECORD... (let ((stream (or *original-stream* stream))) - (multiple-value-bind (x y) (stream-cursor-position* stream) - (if (eq record-type 'standard-cell-output-record) - (with-new-output-record (stream 'standard-cell-output-record nil - :align-x align-x :align-y align-y - :min-width min-width :min-height min-height) - (funcall continuation stream)) - (with-new-output-record (stream record-type nil - :align-x align-x :align-y align-y - :min-width min-width :min-height min-height) - (funcall continuation stream))) - (stream-set-cursor-position* stream x y)))) + (multiple-value-bind (x y) (stream-cursor-position stream) + (prog1 + (if (eq record-type 'standard-cell-output-record) + (with-new-output-record (stream 'standard-cell-output-record nil + :align-x align-x :align-y align-y + :min-width min-width :min-height min-height) + (funcall continuation stream)) + (with-new-output-record (stream record-type nil + :align-x align-x :align-y align-y + :min-width min-width :min-height min-height) + (funcall continuation stream))) + (stream-set-cursor-position stream x y))))) (defmethod invoke-formatting-cell :around ((stream output-recording-mixin) continuation &rest options) @@ -586,8 +599,8 @@ (let ((ncolumns (slot-value menu 'n-columns)) (nrows (slot-value menu 'n-rows)) (ncells 0) - (max-cell-width 0) - (max-cell-height 0) + (max-cell-width (coordinate 0)) + (max-cell-height (coordinate 0)) (x-spacing (slot-value menu 'x-spacing)) (y-spacing (slot-value menu 'y-spacing)) (initial-spacing (slot-value menu 'initial-spacing)) @@ -629,7 +642,7 @@ ;; could compute this better (setq nrows (max 1 - (let ((acc-height 0) + (let ((acc-height (coordinate 0)) (count 0)) (loop (incf acc-height max-cell-height) @@ -674,7 +687,7 @@ (with-stack-array (column-array ncolumns :initial-element nil) (let ((row-count 0) (column-count 0)) - (declare (fixnum row-count column-count)) + (declare (type fixnum row-count column-count)) (macrolet (#-CCL-2 (row-height (row-number) `(svref row-array ,row-number)) #-CCL-2 (column-width (column-number) @@ -708,12 +721,12 @@ *default-minimum-menu-x-spacing*))) (setq row-count 0 column-count 0) - (multiple-value-bind (left-margin top-margin) (bounding-rectangle-position* menu) + (multiple-value-bind (left-margin top-margin) (bounding-rectangle-position menu) (declare (type coordinate left-margin top-margin)) - (let ((accumulated-height 0) + (let ((accumulated-height (coordinate 0)) (accumulated-width (if (or (stream-redisplaying-p stream) initial-spacing) - 0 + (coordinate 0) x-spacing))) (declare (type coordinate accumulated-height accumulated-width)) (flet ((adjust-cells (cell) @@ -729,20 +742,24 @@ (ecase (slot-value cell 'x-alignment) (:left ) (:right - (setq x-alignment-adjust (- column-width cell-width))) + (setq x-alignment-adjust + (- column-width cell-width))) (:center - (setq x-alignment-adjust (floor (- column-width cell-width) 2)))) + (setq x-alignment-adjust + (floor (- column-width cell-width) 2)))) (ecase (slot-value cell 'y-alignment) (:top ) (:bottom - (setq y-alignment-adjust (- row-height cell-height))) + (setq y-alignment-adjust + (- row-height cell-height))) (:center - (setq y-alignment-adjust (floor (- row-height cell-height) 2)))) + (setq y-alignment-adjust + (floor (- row-height cell-height) 2)))) (multiple-value-bind (x-offset y-offset) (convert-from-ancestor-to-descendant-coordinates (output-record-parent menu) (output-record-parent cell)) (declare (type coordinate x-offset y-offset)) - (output-record-set-position* + (output-record-set-position cell (+ x-offset left-margin accumulated-width x-alignment-adjust) (+ y-offset top-margin accumulated-height y-alignment-adjust)))) @@ -752,7 +769,7 @@ (when (= column-count ncolumns) (setf accumulated-width (if (or (stream-redisplaying-p stream) initial-spacing) - 0 + (coordinate 0) x-spacing)) (incf accumulated-height (row-height row-count)) (incf accumulated-height y-spacing) diff --git a/clim/text-formatting.lisp b/clim/text-formatting.lisp index e61e6144..bd45b929 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.5 92/03/04 16:22:21 cer Exp $ +;; $fiHeader: text-formatting.lisp,v 1.6 92/03/10 10:12:55 cer Exp $ (in-package :clim-internals) @@ -102,8 +102,8 @@ (stream-write-string stream buffer) (setf (fill-pointer buffer) 0) ;; Move to the next line if necessary, writing the prefix string - ;;--- STREAM-CURSOR-POSITION* is the wrong thing to look at - (when (> (stream-cursor-position* stream) fill-width) + ;;--- STREAM-CURSOR-POSITION is the wrong thing to look at + (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))) @@ -187,8 +187,8 @@ :indentation indentation) (with-new-output-record (stream) (funcall continuation stream)))))) - (multiple-value-bind (x y) (output-record-position* indenting-record) - (output-record-set-position* indenting-record (+ x indentation) y)) + (multiple-value-bind (x y) (output-record-position indenting-record) + (output-record-set-position indenting-record (+ x indentation) y)) (tree-recompute-extent indenting-record) (replay indenting-record stream) (when move-cursor diff --git a/clim/text-recording.lisp b/clim/text-recording.lisp index 67b12a0d..42a634c4 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.2 92/03/04 16:22:22 cer Exp $ +;; $fiHeader: text-recording.lisp,v 1.3 92/03/10 10:12:56 cer Exp $ (in-package :clim-internals) @@ -78,7 +78,7 @@ (text-style-descent text-style #-Silica stream #+Silica port))) (glyph-buffer (stream-output-glyph-buffer stream)) (color (slot-value record 'ink))) - (declare (fixnum start end)) + (declare (type fixnum start end)) (#-Silica progn #+Silica with-sheet-medium #+Silica (medium stream) (macrolet @@ -89,9 +89,7 @@ new-cursor-x new-baseline new-height font) (stream-scan-string-for-writing stream #+Silica medium string start ,end-position text-style - cursor-x - ;;--- MOST-POSITIVE-FIXNUM loses - most-positive-fixnum + cursor-x +largest-coordinate+ glyph-buffer) ;; GLYPH-BUFFER NIL => pass the string to the port-specific code. #-Silica @@ -119,15 +117,14 @@ (multiple-value-bind (new-cursor-x new-cursor-y) (stream-draw-lozenged-character stream write-char cursor-x cursor-y new-baseline new-height - ;;--- MOST-POSITIVE-FIXNUM loses - text-style most-positive-fixnum nil t) + text-style +largest-coordinate+ nil t) (setf cursor-x new-cursor-x cursor-y new-cursor-y)))) (incf start)))))) (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (declare (type coordinate cursor-x cursor-y)) - (translate-fixnum-positions x-offset y-offset cursor-x cursor-y) + (translate-coordinates x-offset y-offset cursor-x cursor-y) (do-it end) #-Silica (when (slot-value record 'wrapped-p) @@ -145,7 +142,7 @@ (baseline (slot-value record 'baseline)) (glyph-buffer (stream-output-glyph-buffer stream)) (color (slot-value record 'ink))) - (declare (fixnum start end)) + (declare (type fixnum start end)) (#-Silica progn #+Silica with-sheet-medium #+Silica (medium stream) (macrolet @@ -156,9 +153,7 @@ new-cursor-x new-baseline new-height font) (stream-scan-string-for-writing stream #+Silica medium string start ,end-position text-style - cursor-x - ;;--- LOSES - most-positive-fixnum + cursor-x +largest-coordinate+ glyph-buffer) #-Silica (if glyph-buffer @@ -185,15 +180,14 @@ (multiple-value-bind (new-cursor-x new-cursor-y) (stream-draw-lozenged-character stream write-char cursor-x cursor-y new-baseline new-height - ;;--- LOSES - text-style most-positive-fixnum nil t) + text-style +largest-coordinate+ nil t) (setf cursor-x new-cursor-x cursor-y new-cursor-y)))) (incf start)))))) (multiple-value-bind (cursor-x cursor-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (declare (type coordinate cursor-x cursor-y)) - (translate-fixnum-positions x-offset y-offset cursor-x cursor-y) + (translate-coordinates x-offset y-offset cursor-x cursor-y) (dolist (text-style-change (slot-value record 'text-style-changes)) (let ((new-text-style (car text-style-change)) (change-position (cdr text-style-change))) @@ -216,7 +210,7 @@ (multiple-value-bind (xoff yoff) (convert-from-descendant-to-ancestor-coordinates record parent) (declare (type coordinate xoff yoff)) - (translate-fixnum-positions xoff yoff old-left old-top old-right old-bottom) + (translate-coordinates xoff yoff old-left old-top old-right old-bottom) (call-next-method) (recompute-extent-for-changed-child parent record old-left old-top old-right old-bottom))) @@ -226,7 +220,7 @@ text-string start end text-style new-width new-height new-baseline) (declare (ignore text-style new-baseline)) - (declare (fixnum start end)) + (declare (type fixnum start end)) (when (>= start end) (return-from add-string-output-to-text-record)) (let* ((count (the fixnum (- end start))) @@ -243,7 +237,7 @@ (defmethod add-string-output-to-text-record ((record styled-text-output-record) text-string start end text-style new-width new-height new-baseline) - (declare (fixnum start end)) + (declare (type fixnum start end)) (when (>= start end) (return-from add-string-output-to-text-record)) (let* ((count (the fixnum (- end start))) @@ -288,11 +282,11 @@ (defmethod prepare-text-record-for-appending ((record standard-text-output-record) space-needed style) - (declare (fixnum space-needed)) + (declare (type fixnum space-needed)) (declare (ignore style)) (let* ((string (slot-value record 'string)) (fill-pointer (fill-pointer string))) - (declare (fixnum fill-pointer)) + (declare (type fixnum fill-pointer)) (when (> (the fixnum (+ fill-pointer space-needed)) (array-dimension string 0)) (setf string (adjust-array string (the fixnum (+ fill-pointer space-needed 16)))) (setf (slot-value record 'string) string)) @@ -300,7 +294,7 @@ (defmethod prepare-text-record-for-appending ((record styled-text-output-record) space-needed style) - (declare (fixnum space-needed)) + (declare (type fixnum space-needed)) (with-slots (initial-text-style current-text-style text-style-changes baseline) record (let* ((string (slot-value record 'string)) @@ -341,18 +335,18 @@ ;; make sure that old bounding-rect is the same relative position from ;; old-start-position as the bounding-rect is from start-position (multiple-value-bind (delta-x delta-y) - (multiple-value-bind (ex ey) (bounding-rectangle-position* text) + (multiple-value-bind (ex ey) (bounding-rectangle-position text) (declare (type coordinate ex ey)) (multiple-value-bind (sx sy) - (output-record-start-cursor-position* text) + (output-record-start-cursor-position text) (declare (type coordinate sx sy)) - (position-difference* ex ey sx sy))) + (position-difference ex ey sx sy))) (declare (type coordinate delta-x delta-y)) (multiple-value-bind (old-start-x old-start-y) - (multiple-value-bind (px py) (bounding-rectangle-position* match) + (multiple-value-bind (px py) (bounding-rectangle-position match) (declare (type coordinate px py)) - (position-difference* px py delta-x delta-y)) - (output-record-set-old-start-cursor-position* + (position-difference px py delta-x delta-y)) + (output-record-set-old-start-cursor-position text old-start-x old-start-y)))))))) (defmethod recompute-contents-ok ((text styled-text-output-record)) @@ -380,18 +374,18 @@ ;; make sure that old bounding-rect is the same relative position from ;; old-start-position as the bounding-rect is from start-position (multiple-value-bind (delta-x delta-y) - (multiple-value-bind (ex ey) (bounding-rectangle-position* text) + (multiple-value-bind (ex ey) (bounding-rectangle-position text) (declare (type coordinate ex ey)) (multiple-value-bind (sx sy) - (output-record-start-cursor-position* text) + (output-record-start-cursor-position text) (declare (type coordinate sx sy)) - (position-difference* ex ey sx sy))) + (position-difference ex ey sx sy))) (declare (type coordinate delta-x delta-y)) (multiple-value-bind (old-start-x old-start-y) - (multiple-value-bind (px py) (bounding-rectangle-position* match) + (multiple-value-bind (px py) (bounding-rectangle-position match) (declare (type coordinate px py)) - (position-difference* px py delta-x delta-y)) - (output-record-set-old-start-cursor-position* + (position-difference px py delta-x delta-y)) + (output-record-set-old-start-cursor-position text old-start-x old-start-y)))))))) (defmethod get-text-output-record ((stream output-recording-mixin) style) @@ -411,12 +405,12 @@ (make-standard-text-output-record (medium-ink stream) string)))) (setf (stream-text-output-record stream) record) (multiple-value-bind (abs-x abs-y) - (point-position* + (point-position (stream-output-history-position stream)) (declare (type coordinate abs-x abs-y)) - (multiple-value-bind (cx cy) (stream-cursor-position* stream) + (multiple-value-bind (cx cy) (stream-cursor-position stream) (declare (type coordinate cx cy)) - (output-record-set-start-cursor-position* + (output-record-set-start-cursor-position record (- cx abs-x) (- cy abs-y)))) ;; Moved to STREAM-CLOSE-TEXT-OUTPUT-RECORD, since we don't need this thing ;; in the history until then. This should save an extra recompute-extent call @@ -453,7 +447,7 @@ (defun find-text-baseline (record stream) ;; This finds the lowest baseline of the text in RECORD, which will be slower than, say, ;; the first baseline but more likely to look good with misaligned things. - (let ((baseline 0) + (let ((baseline (coordinate 0)) (style (medium-default-text-style stream)) #+Silica (port (port stream))) (declare (type coordinate baseline)) @@ -468,13 +462,13 @@ (- (text-style-height style #-Silica stream #+Silica port) (text-style-descent style #-Silica stream #+Silica port))))) (t - (multiple-value-bind (xoff yoff) (output-record-position* record) + (multiple-value-bind (xoff yoff) (output-record-position record) (declare (type coordinate yoff)) (declare (ignore xoff)) (map-over-output-records #'find-or-recurse record 0 0 (+ yoff y-offset))))))) (declare (dynamic-extent #'find-or-recurse)) - (find-or-recurse record 0)) + (find-or-recurse record (coordinate 0))) baseline)) ;; Copy just the text from the window to the stream. If REGION is supplied, @@ -489,7 +483,7 @@ :fill-pointer 0 :adjustable t :initial-element nil))) (labels ((collect (record x-offset y-offset) (multiple-value-bind (start-x start-y) - (output-record-start-cursor-position* record) + (output-record-start-cursor-position record) (translate-positions x-offset y-offset start-x start-y) (when (typep record 'standard-text-output-record) (vector-push-extend (list* start-y start-x (slot-value record 'string)) @@ -498,12 +492,12 @@ #'collect record region (- x-offset) (- y-offset) start-x start-y)))) (declare (dynamic-extent #'collect)) - (collect history 0 0)) + (collect history (coordinate 0) (coordinate 0))) (sort array #'(lambda (r1 r2) (or (< (first r1) (first r2)) (and (= (first r1) (first r2)) (< (second r1) (second r2)))))) - (let ((current-x 0) + (let ((current-x (coordinate 0)) (current-y (first (aref array 0)))) (dotimes (i (fill-pointer array)) (let* ((item (aref array i)) @@ -513,7 +507,7 @@ (dotimes (j (round (- y current-y) line-height)) #-(or Allegro Minima) (declare (ignore j)) (terpri stream) - (setq current-x 0)) + (setq current-x (coordinate 0))) (setq current-y y)) (unless (= x current-x) (dotimes (j (round (- x current-x) char-width)) diff --git a/clim/tracking-pointer.lisp b/clim/tracking-pointer.lisp index dbe30546..cfa86f13 100644 --- a/clim/tracking-pointer.lisp +++ b/clim/tracking-pointer.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: tracking-pointer.lisp,v 1.5 92/03/04 16:22:24 cer Exp $ +;; $fiHeader: tracking-pointer.lisp,v 1.6 92/03/10 10:12:59 cer Exp $ (in-package :clim-internals) @@ -148,9 +148,9 @@ ;; Genera's ancient window system cannot be easily cajoled into ;; doing this, so we'll do it by hand right here. (make-release-event (window pointer buttons) - (multiple-value-bind (px py) (pointer-position* pointer) + (multiple-value-bind (px py) (pointer-position pointer) (multiple-value-bind (ox oy) - #+Silica (values 0 0) + #+Silica (values (coordinate 0) (coordinate 0)) #-Silica (window-offset window) (let ((wx (- px ox)) (wy (- py oy)) @@ -165,8 +165,8 @@ :x wx :y wy))) (when transformp (multiple-value-bind (tx ty) - (transform-point* (medium-transformation window) - wx wy) + (transform-position (medium-transformation window) + wx wy) (setq wx (floor tx) wy (floor ty)))) (values event wx wy))))))) @@ -185,7 +185,7 @@ (when (or motion-function presentation-motion-function highlight) (when multiple-window (setq current-window (or (pointer-window pointer) (pointer-root pointer)))) - (multiple-value-bind (x y) (pointer-position* pointer) + (multiple-value-bind (x y) (pointer-position pointer) (when moved-p (setq moved-p nil) (setq last-x x last-y y @@ -193,7 +193,7 @@ ;; Pointer position is in root coordinates ;;--- What to do about window offset and drawing-to-surface-coordinates? (multiple-value-bind (ox oy) - #+Silica (values 0 0) + #+Silica (values (coordinate 0) (coordinate 0)) #-Silica (window-offset current-window) (declare (type coordinate ox oy)) (let ((wx (- x ox)) @@ -220,8 +220,8 @@ (when motion-function (when transformp (multiple-value-bind (tx ty) - (transform-point* (medium-transformation current-window) - wx wy) + (transform-position (medium-transformation current-window) + wx wy) (setq wx (floor tx) wy (floor ty)))) (funcall motion-function @@ -278,8 +278,8 @@ (wy py)) (when transformp (multiple-value-bind (tx ty) - (transform-point* (medium-transformation current-window) - px py) + (transform-position (medium-transformation current-window) + px py) (setq wx (floor tx) wy (floor ty)))) (typecase gesture diff --git a/clim/window-stream.lisp b/clim/window-stream.lisp index 80d8e687..301390f2 100644 --- a/clim/window-stream.lisp +++ b/clim/window-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: window-stream.lisp,v 1.4 92/02/24 13:08:55 cer Exp $ +;; $fiHeader: window-stream.lisp,v 1.5 92/03/10 10:13:02 cer Exp $ (in-package :clim-internals) @@ -157,13 +157,16 @@ (when bottom (error "Can't supply both :BOTTOM and :HEIGHT.")) (setq bottom (+ top height))) - (make-instance 'window-stream :parent parent :min-x left :min-y top :max-x right :max-y bottom)) + (make-instance 'window-stream + :parent parent + :left left :top top + :right right :bottom bottom)) #-Silica (progn ;;; For hooking up with host window decorations. -(defmethod window-set-viewport-position* :after ((window window-stream) new-x new-y) +(defmethod window-set-viewport-position :after ((window window-stream) new-x new-y) (declare (ignore new-x new-y)) (redisplay-decorations window)) @@ -171,7 +174,7 @@ (declare (ignore left top right bottom)) (redisplay-decorations window)) -(defmethod bounding-rectangle-set-position* :after ((window window-stream) left top) +(defmethod bounding-rectangle-set-position :after ((window window-stream) left top) (declare (ignore left top)) (redisplay-decorations window)) diff --git a/clx/clx-frames.lisp b/clx/clx-frames.lisp index c3e7c851..be4fc79d 100644 --- a/clx/clx-frames.lisp +++ b/clx/clx-frames.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: clx-frames.lisp,v 1.3 92/03/04 16:20:49 cer Exp $ + (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: clx-frames.lisp,v 1.3 92/03/04 16:20:49 cer Exp Locker: cer $ (defclass clx-frame-manager (standard-frame-manager) @@ -20,9 +21,9 @@ (vertically () (outlining () (make-pane 'command-menu-pane - :display-function - `(display-command-menu :command-table ,menu-bar) - :width :compute :height :compute)) + :display-function + `(display-command-menu :command-table ,menu-bar) + :width :compute :height :compute)) pane)) pane))) diff --git a/clx/clx-gadgets.lisp b/clx/clx-gadgets.lisp index 3cbc9567..a8f23e36 100644 --- a/clx/clx-gadgets.lisp +++ b/clx/clx-gadgets.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: clx-gadgets.lisp,v 1.3 92/03/04 16:20:50 cer Exp $ + (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: clx-gadgets.lisp,v 1.3 92/03/04 16:20:50 cer Exp Locker: cer $ (defmethod make-pane-class ((framem clx-frame-manager) class &rest options) (declare (ignore options)) @@ -31,17 +32,18 @@ )))) (defmethod make-pane-1 ((framem clx-frame-manager) - frame abstract-type &rest options) + frame abstract-type &rest options) (let ((type (apply #'make-pane-class framem abstract-type options))) (if type (apply #'make-instance type :frame frame :frame-manager framem - (apply #'make-pane-arglist - framem abstract-type options)) + (apply #'make-pane-arglist framem abstract-type options)) (call-next-method)))) (defmethod make-pane-arglist (realizer type &rest options) (declare (ignore realizer type)) options) +;;--- This isn't really right. +(defmethod sheet-shell (sheet) sheet) diff --git a/clx/clx-medium.lisp b/clx/clx-medium.lisp index be9743a1..613288dc 100644 --- a/clx/clx-medium.lisp +++ b/clx/clx-medium.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: clx-medium.lisp,v 1.4 92/03/10 10:12:06 cer Exp $ + (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: clx-medium.lisp,v 1.3 92/03/04 16:20:52 cer Exp $ (defclass clx-medium (medium) @@ -467,7 +468,8 @@ (let ((minx most-positive-fixnum) (miny most-positive-fixnum) (points (copy-list points))) - (declare (fixnum minx miny)) + ;; These really are fixnums, since we're fixing coordinates below + (declare (type fixnum minx miny)) (do* ((points points (cddr points))) ((null points)) (let ((x (first points)) @@ -682,8 +684,9 @@ (xlib:copy-area (realize-pixmap port source) gcontext left (- (pixmap-height source) (+ bottom height)) - width height - drawable (integerize-coordinate x) (integerize-coordinate y))))) + (fix-coordinate width) (fix-coordinate height) + drawable + (fix-coordinate x) (fix-coordinate y))))) (defmethod copy-area ((medium clg-display-medium) x y @@ -702,10 +705,10 @@ (+ left width) (+ bottom height)))) (xlib:with-gcontext (gcontext :function boole) (xlib:copy-area (slot-value source 'drawable) gcontext - (integerize-coordinate left) - (integerize-coordinate bottom) + (fix-coordinate left) (fix-coordinate bottom) (round width) (round height) ;--- round??? - drawable (integerize-coordinate x) (integerize-coordinate y))))) + drawable + (fix-coordinate x) (fix-coordinate y))))) (defmethod copy-area ((pixmap pixmap) dst-x dst-y (medium clg-display-medium) src-x src-y src-w src-h @@ -719,7 +722,7 @@ (let ((xbm (realize-pixmap port pixmap))) (xlib:with-gcontext (gcontext :function boole) (xlib:copy-area drawable gcontext - (integerize-coordinate src-x) (integerize-coordinate src-y) + (fix-coordinate src-x) (fix-coordinate src-y) src-w src-h xbm dst-x (- (pixmap-height pixmap) dst-y src-h)))))) ||# diff --git a/clx/clx-mirror.lisp b/clx/clx-mirror.lisp index adec7771..59f6be17 100644 --- a/clx/clx-mirror.lisp +++ b/clx/clx-mirror.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: clx-mirror.lisp,v 1.3 92/03/04 16:20:54 cer Exp $ + (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: clx-mirror.lisp,v 1.2 92/02/24 13:23:50 cer Exp $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -11,7 +12,7 @@ (with-slots (display screen) port (multiple-value-bind (left top right bottom) (sheet-native-region* sheet) - (integerize-coordinates left top right bottom) + (fix-coordinates left top right bottom) (let* ((clx-parent (sheet-mirror sheet)) (mirror (xlib:create-window @@ -140,10 +141,10 @@ left top right bottom) (let* ((mirror (sheet-mirror sheet)) (display (port-display port)) - (w (integerize-coordinate (- right left))) - (h (integerize-coordinate (- bottom top))) - (x (integerize-coordinate left)) - (y (integerize-coordinate top))) + (w (fix-coordinate (- right left))) + (h (fix-coordinate (- bottom top))) + (x (fix-coordinate left)) + (y (fix-coordinate top))) (xlib:with-display (display) (setf (xlib:drawable-x mirror) x (xlib:drawable-y mirror) y diff --git a/clx/clx-port.lisp b/clx/clx-port.lisp index c87861d7..aac6b495 100644 --- a/clx/clx-port.lisp +++ b/clx/clx-port.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: clx-port.lisp,v 1.4 92/03/10 10:12:08 cer Exp $ + (in-package :clx-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: clx-port.lisp,v 1.4 92/03/10 10:12:08 cer Exp Locker: cer $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -564,8 +565,8 @@ (defmethod set-cursor-location ((port clx-port) sheet x y) (xlib:warp-pointer (sheet-mirror sheet) - (integerize-coordinate x) - (integerize-coordinate y))) + (fix-coordinate x) (fix-coordinate y))) + ;;--- Doesn't this need a sheet/stream argument? diff --git a/demo/address-book.lisp b/demo/address-book.lisp index 0b8c804f..d260cdfb 100644 --- a/demo/address-book.lisp +++ b/demo/address-book.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: address-book.lisp,v 1.3 92/03/24 19:38:14 cer Exp Locker: cer $ +;; $fiHeader: address-book.lisp,v 1.4 92/04/10 14:27:28 cer Exp Locker: cer $ (in-package :clim-demo) @@ -38,18 +38,16 @@ (setq *addresses* (sort *addresses* #'string-lessp :key #'address-last-name))) (progn - (add-address (make-address :name "Bill York" - :address "ILA, Mountain View" - :number "415-968-3656")) - (add-address (make-address :name "Dennis Doughty" - :address "ILA, Cambridge" - :number "617-576-1151")) - (add-address (make-address :name "Mark Son-Bell" - :address "ILA, Cambridge" - :number "617-576-1151")) - (add-address (make-address :name "Richard Lamson" - :address "ILA, San Francisco" - :number "415-661-5477"))) + (add-address (make-address :name "Chris Richardson" + :address "Franz Inc" + :number "510-548-3600")) + (add-address (make-address :name "John Irwin" + :address "Franz Inc" + :number "510-548-3600")) + (add-address (make-address :name "Scott Mckay" + :address "Symbolics Inc" + :number "617-221-xxxx")) +) ;;; -------------------------------- ;;; Define the user interface here. @@ -94,34 +92,32 @@ (write-string number stream)))) ;;; Define the application-frame for our application - (define-application-frame address-book - () - ;; This application has two state variables, the currently displayed - ;; address and the window from which user queries should be read. - ((current-address :initform nil) - (interaction-pane ) - (name-pane)) - + () + ;; This application has two state variables, the currently displayed + ;; address and the window from which user queries should be read. + ((current-address :initform nil) + (interaction-pane ) + (name-pane)) (:panes - (interactor - (scrolling () - (make-pane 'interactor-pane))) - (address - (scrolling () - (make-pane 'application-pane - :incremental-redisplay t - :display-function - 'display-current-address))) - (names - (scrolling () - (make-pane 'application-pane - :incremental-redisplay t - :display-function 'display-names)))) + (interactor + (scrolling () + (make-pane 'interactor-pane))) + (address + (scrolling () + (make-pane 'application-pane + :incremental-redisplay t + :display-function 'display-current-address))) + (names + (scrolling () + (make-pane 'application-pane + :incremental-redisplay t + :display-function 'display-names)))) (:layout - (default - (vertically () - (horizontally () address names) + (default + (vertically () + (horizontally () + address names) interactor)))) ;;; This is the display-function for the upper-left pane, which specified diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index 23757179..c82e9929 100644 --- a/demo/cad-demo.lisp +++ b/demo/cad-demo.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cad-demo.lisp,v 1.4 92/03/24 19:38:15 cer Exp Locker: cer $ +;; $fiHeader: cad-demo.lisp,v 1.5 92/04/10 14:27:29 cer Exp Locker: cer $ (in-package :clim-demo) @@ -21,23 +21,23 @@ (defmethod bounding-rectangle* ((thing basic-thing)) (with-slots (x y size) thing - #-Silica (declare (fixnum x y size)) + (declare (type coordinate x y size)) (values x y (+ x size) (+ y size)))) -(defmethod region-contains-point*-p ((thing basic-thing) x y) +(defmethod region-contains-position-p ((thing basic-thing) x y) (with-bounding-rectangle* (left top right bottom) thing (and (<= left x) (<= top y) (>= right x) (>= bottom y)))) -(defmethod output-record-start-cursor-position* ((thing basic-thing)) +(defmethod output-record-start-cursor-position ((thing basic-thing)) (values 0 0)) -;; NEW-X and NEW-Y had better be fixnums -(defmethod output-record-set-position* ((thing basic-thing) new-x new-y) +(defmethod output-record-set-position ((thing basic-thing) new-x new-y) (with-slots (x y) thing - (setf x new-x y new-y))) + (setf x (coordinate new-x) + y (coordinate new-y)))) (defmethod map-over-output-records-overlapping-region (function (thing basic-thing) region @@ -46,7 +46,7 @@ (declare (dynamic-extent continuation-args)) nil) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (thing basic-thing) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (ignore x y function x-offset y-offset continuation-args)) @@ -80,10 +80,10 @@ (with-slots (x y) thing (values x y))) -;; NEW-X and NEW-Y had better be fixnums (defmethod move ((thing basic-thing) new-x new-y) (with-slots (x y) thing - (setf x new-x y new-y))) + (setf x (coordinate new-x) + y (coordinate new-y)))) ;;;**************************************************************** @@ -133,7 +133,7 @@ (defmethod bounding-rectangle* ((conn connection)) (let ((fudge 2)) (with-slots (x y size) conn - #-Silica (declare (fixnum x y size)) + (declare (type coordinate x y size)) ;; size is a radius, but make the box larger so that connections ;; are easier to point to (values (- x size fudge) (- y size fudge) @@ -297,10 +297,10 @@ ;; Not (- X SIZE) because the component is a half-circle (values x (- y size) (+ x size) (+ y size)))) -;; NEW-X and NEW-Y had better be fixnums -(defmethod output-record-set-position* ((thing basic-thing) new-x new-y) +(defmethod output-record-set-position ((thing basic-thing) new-x new-y) (with-slots (x y size) thing - (setf x new-x y (+ new-y size)))) + (setf x (coordinate new-x) + y (coordinate (+ new-y size))))) (defmethod presentation-type ((comp component)) @@ -499,13 +499,11 @@ (cond ((eq ink +background-ink+) ;;--- gee, am I getting carried away? (multiple-value-bind (nx ny) - #+ignore drawing-surface-to-viewport-coordinates - (values x y) - (decf ny *component-size*) - (with-sheet-medium (medium stream) - (draw-rectangle* medium - (- nx 10) (- ny 10) nx (+ ny 20) - :ink +background-ink+)))) + (values x (- y *component-size*)) + (with-sheet-medium (medium stream) + (draw-rectangle* medium + (- nx 10) (- ny 10) nx (+ ny 20) + :ink +background-ink+)))) (t (draw-text* stream name (- x 10) (- y 10))))))) @@ -531,33 +529,27 @@ ;;; First define a "application" that manages the application's state variables ;;; and defines a high-level division of screen real estate. - - - (define-application-frame cad-demo (standard-application-frame output-record) - ((object-list :initform nil)) + ((object-list :initform nil)) (:panes - (design-area - (make-pane 'application-pane))) + (design-area + (make-pane 'application-pane))) (:pointer-documentation t) (:layout - (:default - (scrolling () - design-area))) + (default + (scrolling () + design-area))) (:top-level (default-frame-top-level :partial-command-parser cad-demo-partial-command-parser))) -;;--- I am amazed every day by something -;; and this was it today !!!! - (defmethod initialize-instance :around ((cd cad-demo) &key) (call-next-method) (let ((dp (get-frame-pane cd 'design-area))) ;;--- kludge this one pane (setf (stream-output-history dp) cd) (setf (stream-recording-p dp) nil))) - + (defun cad-demo-partial-command-parser (partial-command command-table stream start-location) (let ((name (command-name partial-command))) (if (eq name 'com-create-component) @@ -596,16 +588,16 @@ object region x-offset y-offset)) (apply function object continuation-args)))) -(defmethod map-over-output-records-containing-point* +(defmethod map-over-output-records-containing-position (function (cd cad-demo) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args) (declare (dynamic-extent continuation-args)) (translate-positions x-offset y-offset x y) (dolist (object (slot-value cd 'object-list)) - (when (region-contains-point*-p object x y) + (when (region-contains-position-p object x y) (apply function object continuation-args)))) -(defmethod output-record-start-cursor-position* ((record cad-demo)) +(defmethod output-record-start-cursor-position ((record cad-demo)) (values 0 0)) (defmethod add-output-record (element (record cad-demo)) @@ -623,7 +615,7 @@ (setq region nil)) (multiple-value-bind (rl rt rr rb) (and region (bounding-rectangle* region)) - (multiple-value-bind (xoff yoff) (output-record-position* record) + (multiple-value-bind (xoff yoff) (output-record-position record) (map-over-output-records-overlapping-region #'(lambda (element) (with-bounding-rectangle* (left top right bottom) element @@ -680,7 +672,6 @@ ;(make-component-prototypes) ;;; Return the class name of the selected component - (defun select-component (parent) (labels ((draw-icon-menu (menu presentation-type) (formatting-table (menu :x-spacing 5) @@ -691,8 +682,8 @@ (progn ;; (with-user-coordinates (menu) (draw-self icon menu) (multiple-value-bind (x y) - (stream-cursor-position* menu) - (stream-set-cursor-position* + (stream-cursor-position menu) + (stream-set-cursor-position menu ;; fudge for the fact that the presentation encloses the ;; half of the circle that's invisible @@ -722,8 +713,8 @@ (with-user-coordinates (menu) (draw-self icon menu) (multiple-value-bind (x y) - (stream-cursor-position* menu) - (stream-set-cursor-position* + (stream-cursor-position menu) + (stream-set-cursor-position menu ;; fudge for the fact that the presentation encloses the ;; half of the circle that's invisible @@ -877,7 +868,7 @@ ((output 'output :gesture :describe)) (let ((comp (connection-component output)) (win (get-frame-pane *application-frame* 'design-area))) - (stream-set-cursor-position* win 0 0) + (stream-set-cursor-position win 0 0) (draw-rectangle* win 0 0 800 20 :ink +background-ink+) (with-text-style (win '(:sans-serif :bold :very-large)) (format win "~A" (equation-part comp))))) @@ -889,18 +880,16 @@ (define-cad-demo-command (com-exit-CAD-demo :menu "Exit" :keystroke #\X) () - ;; assume called via run-cad-demo (frame-exit *application-frame*)) -;;;------------ -;;; Right now there is only one -;(define-cad-demo-command (com-swap-layouts :menu "Swap Layouts") -; () -; (let ((current-layout (frame-current-layout *application-frame*))) -; (setf (frame-current-layout *application-frame*) -; (case current-layout -; (main 'other) -; (other 'main))))) +#+++ignore ;--- right now there is only one layout +(define-cad-demo-command (com-swap-layouts :menu "Swap Layouts") + () + (let ((current-layout (frame-current-layout *application-frame*))) + (setf (frame-current-layout *application-frame*) + (case current-layout + (main 'other) + (other 'main))))) #|| @@ -919,14 +908,9 @@ but first get better menu formatting! (let ((cd (cdr (assoc root *cad-demos*))) (*highlight-ink* (if (color-stream-p root) +red+ +flipping-ink+))) (when (or (null cd) reinit) - (setq cd (make-application-frame 'cad-demo :parent root)) - (push (cons root cd) *cad-demos*) - ;; The application implements its own output history - (let ((dp (get-frame-pane cd 'design-area))) - ;;--- kludge this one pane - (setf (stream-output-history dp) cd) - (setf (stream-recording-p dp) nil))) - (catch 'exit-cad-demo - (run-frame-top-level cd)))) + (setq cd (make-application-frame 'cad-demo + :width 700 :height 600)) + (push (cons root cd) *cad-demos*)) + (run-frame-top-level cd))) (define-demo "Mini-CAD" (run-cad-demo :root *demo-root*)) diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp index bcac7ac2..6eee8ab8 100644 --- a/demo/demo-driver.lisp +++ b/demo/demo-driver.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: aaai-demo-driver.lisp,v 1.3 92/02/26 10:23:54 cer Exp $ +;; $fiHeader: aaai-demo-driver.lisp,v 1.4 92/03/04 16:22:56 cer Exp $ (in-package :clim-demo) @@ -47,6 +47,8 @@ (lisp:format t "~&No current value for *DEMO-ROOT*. Use what value? ") (setq root (eval (lisp:read))) (setq *demo-root* root)) + #+Silica + (unless root (setq root (find-graft))) (labels ((demo-menu-drawer (stream type &rest args) (declare (dynamic-extent args)) (with-text-style (stream '(:serif :roman :very-large)) @@ -72,6 +74,6 @@ (defparameter *color-stream-p* t) (defun color-stream-p (stream) #-Genera *color-stream-p* ;--- kludge - #+Genera (if (eql (port-type (port stream)) ':genera) + #+Genera (if (eql (silica:port-type (port stream)) ':genera) (slot-value stream 'clim-internals::color-p) *color-stream-p*)) diff --git a/demo/demo-prefill.lisp b/demo/demo-prefill.lisp index 9fa286ef..f9d2ac99 100644 --- a/demo/demo-prefill.lisp +++ b/demo/demo-prefill.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: demo-prefill.lisp,v 1.1 92/01/31 14:32:00 cer Exp $ +;; $fiHeader: demo-prefill.lisp,v 1.2 92/02/24 13:09:22 cer Exp $ (in-package :clim-internals) @@ -132,7 +132,7 @@ (CLIM-DEMO::LISP-LISTENER T)) (MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION (T CLIM-DEMO::CAD-DEMO T)) - (MAP-OVER-OUTPUT-RECORDS-CONTAINING-POINT* + (MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION (T CLIM-DEMO::CAD-DEMO T T)) (READ-FRAME-COMMAND (CLIM-DEMO::GRAPHICS-DEMO) (CLIM-DEMO::FLIGHT-PLANNER) diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp index 58050a22..51adc4a2 100644 --- a/demo/graphics-demos.lisp +++ b/demo/graphics-demos.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-demos.lisp,v 1.2 92/02/24 13:09:23 cer Exp Locker: cer $ +;; $fiHeader: graphics-demos.lisp,v 1.3 92/04/10 14:27:31 cer Exp Locker: cer $ (in-package :clim-demo) @@ -29,7 +29,7 @@ (make-pane 'application-pane))) (explanation (scrolling () (make-pane 'application-pane - :height 100)))) + :height 100)))) (:layout (:default (vertically () demo explanation)))) diff --git a/demo/listener.lisp b/demo/listener.lisp index 2bc27dd7..94b52a02 100644 --- a/demo/listener.lisp +++ b/demo/listener.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: listener.lisp,v 1.7 92/03/10 10:13:08 cer Exp Locker: cer $ +;; $fiHeader: listener.lisp,v 1.8 92/04/10 14:27:32 cer Exp Locker: cer $ (in-package :clim-demo) @@ -119,7 +119,7 @@ (when (eq type :keystroke) (let ((command (lookup-keystroke-command-item command-or-form command-table :numeric-argument numeric-arg))) - (unless (clim-internals::keyboard-gesture-p command) + (unless (clim-internals::keyboard-event-p command) (when (partial-command-p command) (setq command (funcall *partial-command-parser* command command-table *standard-input* nil @@ -333,15 +333,16 @@ (formatting-table (stream :x-spacing " ") (dolist (pathname pathnames) (let (size creation-date author) - #-genera + #-Genera (with-open-file (file-stream pathname :direction :input) (setf size (file-length file-stream) creation-date (file-write-date file-stream) author (file-author file-stream))) - #+genera + #+Genera (setf size (getf (rest pathname) :length-in-bytes) creation-date (getf (rest pathname) :modification-date) - author (getf (rest pathname) :author)) + author (getf (rest pathname) :author) + pathname (first pathname)) (with-output-as-presentation (stream pathname 'pathname :single-box t) (formatting-row (stream) diff --git a/demo/navfun.lisp b/demo/navfun.lisp index afad4f82..e65578ae 100644 --- a/demo/navfun.lisp +++ b/demo/navfun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: navfun.lisp,v 1.4 92/04/10 14:27:34 cer Exp Locker: cer $ +;; $fiHeader: navfun.lisp,v 1.5 92/04/14 15:30:01 cer Exp Locker: cer $ (in-package :clim-demo) @@ -43,6 +43,9 @@ (defvar *label-text-style* #+Genera '(:fix :roman :small) #-Genera '(:fix :roman :normal)) +(defclass iconic-view (gadget-view) ()) +(defvar +iconic-view+ (make-instance 'iconic-view)) + ;;; Basic data structures - points and positions @@ -220,11 +223,11 @@ (draw-coastline *coastline*) (flet ((present-position (object) (present object (class-name (class-of object)) - :view +gadget-view+ :single-box t))) + :view +iconic-view+ :single-box t))) (mapc #'present-position *position-list*)) (flet ((present-route (object) (present object (class-name (class-of object)) - :view +gadget-view+ :single-box nil))) + :view +iconic-view+ :single-box nil))) (mapc #'present-route *route-list*) (mapc #'present-route *victor-airway-list*))) @@ -313,8 +316,8 @@ (eval-when (compile load eval) (defclass named-intersection (named-position) ())) -(defmethod draw-position ((named-intersection named-intersection) stream &optional label) - (with-slots (longitude latitude) named-intersection +(defmethod draw-position ((intersection named-intersection) stream &optional label) + (with-slots (longitude latitude) intersection (multiple-value-bind (x y) (scale-coordinates longitude latitude) (rounding-coordinates (x y) (let ((color-args (and (color-stream-p stream) @@ -343,7 +346,7 @@ (define-presentation-type ground-position ()) -(define-presentation-method present (object (type ground-position) stream (view gadget-view) &key) +(define-presentation-method present (object (type ground-position) stream (view iconic-view) &key) (draw-position object stream)) @@ -354,7 +357,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (position-name object)))) -(define-presentation-method present (object (type named-position) stream (view gadget-view) +(define-presentation-method present (object (type named-position) stream (view iconic-view) &key) (draw-position object stream (and (typep object 'named-position) @@ -494,7 +497,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (route-name object)))) -(define-presentation-method present (object (type route) stream (view gadget-view) &key) +(define-presentation-method present (object (type route) stream (view iconic-view) &key) (let ((drawing-args (if (color-stream-p stream) (list :ink +red+) '(:line-dashes t)))) @@ -522,7 +525,7 @@ (let ((*print-object-readably* acceptably)) (format stream "~A" (route-name object)))) -(define-presentation-method present (object (type victor-airway) stream (view gadget-view) +(define-presentation-method present (object (type victor-airway) stream (view iconic-view) &key) (let ((drawing-args (if (color-stream-p stream) (list :ink +blue+) @@ -1010,25 +1013,24 @@ (multiple-value-bind (x y) (scale-coordinates longitude latitude) (with-bounding-rectangle* (left top right bottom) (window-viewport window) - (window-set-viewport-position* window - (max 0 (- (floor x) (floor (- right left) 2))) - (max 0 (- (floor y) (floor (- bottom top) 2)))))))) + (window-set-viewport-position window + (max 0 (- (floor x) (floor (- right left) 2))) + (max 0 (- (floor y) (floor (- bottom top) 2)))))))) ;;; Flight-Planner user interface (define-application-frame Flight-Planner - () - ((fp-window)) + () + ((fp-window)) (:panes - (display (make-pane 'application-pane)) - (interactor (make-pane 'interactor-pane))) + (display (make-pane 'application-pane)) + (interactor (make-pane 'interactor-pane))) (:layout - (default - (vertically - () - (scrolling () display) - (scrolling () interactor))))) + (default + (vertically () + (scrolling () display) + (scrolling () interactor))))) (define-Flight-Planner-command (com-Zoom-In :name t :menu t) () (multiple-value-bind (longitude latitude) @@ -1119,17 +1121,17 @@ (ground-position (let ((new-position (query-new-position))) (when new-position - (present new-position 'ground-position :view +gadget-view+) + (present new-position 'ground-position :view +iconic-view+) (push new-position *position-list*)))) (route (let* ((new-route (query-new-route :route-start route-start))) (when new-route - (present new-route 'route :view +gadget-view+) + (present new-route 'route :view +iconic-view+) (push new-route *route-list*)))) (victor-airway (let ((new-victor-airway (query-new-victor-airway))) (when new-victor-airway - (present new-victor-airway 'victor-airway :view +gadget-view+) + (present new-victor-airway 'victor-airway :view +iconic-view+) (push new-victor-airway *victor-airway-list*)))) (aircraft (let ((new-aircraft (query-new-aircraft))) @@ -1601,13 +1603,18 @@ (defun customize-database () ;; Airports - (add-position "HFD" 'airport (degminsec 41 44) (degminsec 72 39) 19 15 "Hartford-Brainard") + (add-position "HFD" 'airport + (degminsec 41 44) (degminsec 72 39) 19 15 "Hartford-Brainard") - ;; Named-Intersections - (add-position "DREEM" 'named-intersection (degminsec 42 21.6) (degminsec 71 44.3) 0 15 "DREEM") - (add-position "GRAYM" 'named-intersection (degminsec 42 06.1) (degminsec 72 01.9) 0 15 "GRAYM") - (add-position "WITNY" 'named-intersection (degminsec 42 03) (degminsec 72 14.2) 0 15 "WITNY") - (add-position "EAGRE" 'named-intersection (degminsec 41 45) (degminsec 72 20.6) 0 15 "EAGRE") + ;; Intersections + (add-position "DREEM" 'named-intersection + (degminsec 42 21.6) (degminsec 71 44.3) 0 15 "DREEM") + (add-position "GRAYM" 'named-intersection + (degminsec 42 06.1) (degminsec 72 01.9) 0 15 "GRAYM") + (add-position "WITNY" 'named-intersection + (degminsec 42 03) (degminsec 72 14.2) 0 15 "WITNY") + (add-position "EAGRE" 'named-intersection + (degminsec 41 45) (degminsec 72 20.6) 0 15 "EAGRE") ;; VOR's @@ -1649,7 +1656,8 @@ (defun run-flight-planner (&key reinit root) (let ((fp (cdr (assoc root *flight-planners*)))) (when (or (null fp) reinit) - (setq fp (make-application-frame 'flight-planner :parent root)) + (setq fp (make-application-frame 'flight-planner + :width 1000 :height 800)) (push (cons root fp) *flight-planners*)) (run-frame-top-level fp))) diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp index 48963154..955706b6 100644 --- a/demo/puzzle.lisp +++ b/demo/puzzle.lisp @@ -1,28 +1,28 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: puzzle.lisp,v 1.3 92/03/24 19:38:21 cer Exp Locker: cer $ +;; $fiHeader: puzzle.lisp,v 1.4 92/04/10 14:27:36 cer Exp Locker: cer $ (in-package :clim-demo) "Copyright (c) 1989, 1990, 1991 Symbolics, Inc. All rights reserved." (define-application-frame puzzle - () - ((puzzle :initform (make-array '(4 4)) - :accessor puzzle-puzzle)) + () + ((puzzle :initform (make-array '(4 4)) + :accessor puzzle-puzzle)) (:panes - (display - (outlining () - (make-pane 'application-pane - :text-cursor nil - :width :compute - :max-width +fill+ - :height :compute - :max-height +fill+ - :incremental-redisplay T - :display-function 'draw-puzzle)))) + (display + (outlining () + (make-pane 'application-pane + :text-cursor nil + :width :compute + :max-width +fill+ + :height :compute + :max-height +fill+ + :incremental-redisplay T + :display-function 'draw-puzzle)))) (:layout - (:default display))) + (:default display))) (defmethod frame-query-io ((puzzle puzzle)) (get-frame-pane puzzle 'display)) @@ -71,26 +71,27 @@ (defmethod draw-puzzle ((puzzle puzzle) stream &key max-width max-height) (declare (ignore max-width max-height)) - (with-text-style (stream '(:fix :bold :very-large)) - (with-end-of-page-action (stream :allow) + (with-text-style (stream '(:fix :bold :very-large)) + (with-end-of-page-action (stream :allow) (with-end-of-line-action (stream :allow) - (let ((puzzle-array (puzzle-puzzle puzzle))) - ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this - (stream-set-cursor-position* stream 0 0) - (updating-output (stream) - (formatting-table (stream) - (dotimes (row 4) - (formatting-row (stream) - (dotimes (column 4) - (let ((value (aref puzzle-array row column))) - (updating-output (stream - :unique-id (encode-puzzle-cell row column) - :cache-value value) - (formatting-cell (stream :align-x :right) - (unless (zerop value) - (with-output-as-presentation - (stream (encode-puzzle-cell row column) 'puzzle-cell) - (format stream "~2D" value)))))))))))))))) + (let ((puzzle-array (puzzle-puzzle puzzle))) + ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this + (stream-set-cursor-position stream 0 0) + (updating-output (stream) + (formatting-table (stream) + (dotimes (row 4) + (formatting-row (stream) + (dotimes (column 4) + (let ((value (aref puzzle-array row column))) + (updating-output (stream + :unique-id (encode-puzzle-cell row column) + :cache-value value) + (formatting-cell (stream :align-x :right) + (unless (zerop value) + (with-output-as-presentation + (stream (encode-puzzle-cell row column) 'puzzle-cell) + (format stream "~D" value)))))))))))))))) + (defun find-open-cell (puzzle) (dotimes (row 4) diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp index 86e622da..6aca3296 100644 --- a/demo/sysdcl.lisp +++ b/demo/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.6 92/03/24 19:38:22 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.7 92/04/10 14:27:37 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -22,26 +22,23 @@ #+Allegro (frob-pathname "demo") #+CMU "/home/hornig/clim/rel-2/cmu/" #+CCL-2 "ccl;clim-2.0:fasls:" -;;;; :needed-systems (clim-standalone) - ) + ;;--- :needed-systems (clim-standalone) + ) ("packages") ("aaai-demo-driver" :load-before-compile ("packages")) ("listener" :load-before-compile ("aaai-demo-driver" "packages")) ("graphics-demos" :load-before-compile ("aaai-demo-driver" "packages") :features (not Minima)) - ("puzzle" :load-before-compile ("aaai-demo-driver" "packages")) ("cad-demo" :load-before-compile ("aaai-demo-driver" "packages") :features (not Minima)) ("navdata" :load-before-compile ("packages") :features (not Minima)) ("navfun" :load-before-compile ("aaai-demo-driver" "navdata" "packages") :features (not Minima)) - ("address-book" :load-before-compile ("aaai-demo-driver" - "packages")) - ("thinkadot" :load-before-compile ("aaai-demo-driver" - "packages")) - + ("puzzle" :load-before-compile ("aaai-demo-driver" "packages")) + ("address-book" :load-before-compile ("aaai-demo-driver" "packages")) + ("thinkadot" :load-before-compile ("aaai-demo-driver" "packages")) ("demo-prefill" :features (and (not Silica) (or Genera Cloe-Runtime)))) #+Genera diff --git a/demo/thinkadot.lisp b/demo/thinkadot.lisp index b8eb5e92..2d5e1b43 100644 --- a/demo/thinkadot.lisp +++ b/demo/thinkadot.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: thinkadot.lisp,v 1.4 92/03/24 19:38:23 cer Exp Locker: cer $ +;; $fiHeader: thinkadot.lisp,v 1.5 92/04/10 14:27:38 cer Exp Locker: cer $ (in-package :clim-demo) @@ -39,24 +39,24 @@ (define-application-frame thinkadot () - ((node1) - (node2) - (node3) - (node4) - (node5) - (node6) - (node7) - (node8) - (all-nodes) - (lexit) - (rexit)) + ((node1) + (node2) + (node3) + (node4) + (node5) + (node6) + (node7) + (node8) + (all-nodes) + (lexit) + (rexit)) (:panes - (display - (make-pane 'application-pane - :display-function 'draw-the-display - :incremental-redisplay t))) + (display + (make-pane 'application-pane + :display-function 'draw-the-display + :incremental-redisplay t))) (:layout - (:default (scrolling () display)))) + (:default (scrolling () display)))) (defmethod initialize-instance :after ((frame thinkadot) &key) (multiple-value-bind (w h) @@ -90,7 +90,6 @@ (defvar *light-color* (make-gray-color 0.667)) (defvar *dark-color* +black+) - (defmethod draw-the-display ((frame thinkadot) stream &key max-width max-height) (declare (ignore max-width max-height)) (with-slots (all-nodes lexit rexit) frame @@ -143,7 +142,7 @@ (define-presentation-to-command-translator drop-a-marble (entry-node com-drop-marble thinkadot - :documentation "Drop Marble") + :documentation "Drop a Marble") (object) `(,object)) diff --git a/genera/genera-activities.lisp b/genera/genera-activities.lisp index 0afa976e..6f6fb5a6 100644 --- a/genera/genera-activities.lisp +++ b/genera/genera-activities.lisp @@ -1,12 +1,11 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-activities.lisp,v 1.1 92/02/24 13:28:00 cer Exp $ +;; $fiHeader: genera-activities.lisp,v 1.3 92/03/10 10:13:06 cer Exp $ (in-package :genera-clim) - "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: genera-activities.lisp,v 1.1 92/02/24 13:28:00 cer Exp $ + (defvar *sheet-roots* nil) (defvar *deactivated-clim-activities* nil) diff --git a/genera/genera-frames.lisp b/genera/genera-frames.lisp index f9036dbb..75e16d37 100644 --- a/genera/genera-frames.lisp +++ b/genera/genera-frames.lisp @@ -1,9 +1,9 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: genera-frames.lisp,v 1.2 92/03/04 16:22:45 cer Exp $ (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: genera-frames.lisp,v 1.2 92/03/04 16:22:45 cer Exp Locker: cer $ (defclass genera-frame-manager (standard-frame-manager) ()) @@ -19,9 +19,9 @@ (vertically () (outlining () (make-pane 'command-menu-pane - :display-function - `(display-command-menu :command-table ,menu-bar) - :width :compute :height :compute)) + :display-function + `(display-command-menu :command-table ,menu-bar) + :width :compute :height :compute)) pane)) pane))) diff --git a/genera/genera-gadgets.lisp b/genera/genera-gadgets.lisp index adefbd06..8584bad1 100644 --- a/genera/genera-gadgets.lisp +++ b/genera/genera-gadgets.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: genera-gadgets.lisp,v 1.2 92/03/04 16:22:47 cer Exp $ + (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: genera-gadgets.lisp,v 1.2 92/03/04 16:22:47 cer Exp Locker: cer $ (defmethod make-pane-class ((framem genera-frame-manager) class &rest options) (declare (ignore options)) @@ -31,17 +32,18 @@ )))) (defmethod make-pane-1 ((framem genera-frame-manager) - frame abstract-type &rest options) + frame abstract-type &rest options) (let ((type (apply #'make-pane-class framem abstract-type options))) (if type (apply #'make-instance type :frame frame :frame-manager framem - (apply #'make-pane-arglist - framem abstract-type options)) + (apply #'make-pane-arglist framem abstract-type options)) (call-next-method)))) (defmethod make-pane-arglist (realizer type &rest options) (declare (ignore realizer type)) options) +;;--- This isn't really right. +(defmethod sheet-shell (sheet) sheet) diff --git a/genera/genera-medium.lisp b/genera/genera-medium.lisp index 245808ba..3b344e83 100644 --- a/genera/genera-medium.lisp +++ b/genera/genera-medium.lisp @@ -1,9 +1,11 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: genera-medium.lisp,v 1.2 92/03/04 16:22:49 cer Exp $ + (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved." -;;; $fiHeader: genera-medium.lisp,v 1.1 92/02/24 13:28:05 cer Exp $ + (defclass genera-medium (medium) ((window :initform nil) @@ -403,7 +405,7 @@ (eq region +nowhere+)) ;---yow! howcum? (kernel window) (with-bounding-rectangle* (left top right bottom) region - (integerize-coordinates left top right bottom) + (fix-coordinates left top right bottom) (with-stack-list (cr (+ (tv:sheet-left-margin-size window) left) (+ (tv:sheet-top-margin-size window) top) (+ (tv:sheet-right-margin-size window) right) @@ -821,8 +823,8 @@ (height (if (<= target-y source-y) (+ height) (- height)))) (tv:bitblt-from-sheet-to-sheet boole (round width) (round height) ;--- round??? - source-drawable (integerize-coordinate source-x) (integerize-coordinate source-y) - target-drawable (integerize-coordinate target-x) (integerize-coordinate target-y))))) + source-drawable (fix-coordinate source-x) (fix-coordinate source-y) + target-drawable (fix-coordinate target-x) (fix-coordinate target-y))))) ;;; X also has a way to copy from a medium into a pixmap. Should this be allowed here? (defmethod copy-area ((pixmap pixmap) dst-x dst-y @@ -839,6 +841,7 @@ (raster (realize-pixmap port pixmap))) (scl:send drawable :bitblt-from-sheet boole (round device-width) (round device-height) ;--- round??? - (integerize-coordinate device-min-x) (integerize-coordinate device-min-y) - raster (integerize-coordinate dst-x) (integerize-coordinate dst-y)))))) + (fix-coordinate device-min-x) (fix-coordinate device-min-y) + raster + (fix-coordinate dst-x) (fix-coordinate dst-y)))))) ||# diff --git a/genera/genera-mirror.lisp b/genera/genera-mirror.lisp index 1ffd81de..42141a2d 100644 --- a/genera/genera-mirror.lisp +++ b/genera/genera-mirror.lisp @@ -1,10 +1,11 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: genera-mirror.lisp,v 1.2 92/03/04 16:22:50 cer Exp $ + (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. Portions copyright (c) 1991, 1992 International Lisp Associates." -;;; $fiHeader: genera-mirror.lisp,v 1.1 92/02/24 13:28:07 cer Exp $ (defvar *clim-window-count* 0) @@ -14,7 +15,7 @@ (with-slots (screen height-pixels) port (multiple-value-bind (left top right bottom) (sheet-native-region* sheet) - (integerize-coordinates left top right bottom) + (fix-coordinates left top right bottom) (let* ((genera-parent (sheet-mirror sheet)) (name (format nil "CLIM window ~D" (incf *clim-window-count*))) (mirror @@ -157,10 +158,8 @@ (multiple-value-bind (left top right bottom) (fit-region*-in-region* left top right bottom clip-left clip-top clip-right clip-bottom) - (scl:send mirror :set-edges (integerize-coordinate left) - (integerize-coordinate top) - (integerize-coordinate right) - (integerize-coordinate bottom)))))) + (scl:send mirror :set-edges (fix-coordinate left) (fix-coordinate top) + (fix-coordinate right) (fix-coordinate bottom)))))) ;; Port trigger not nil means that the port is triggering the diff --git a/genera/genera-port.lisp b/genera/genera-port.lisp index 5de613ba..c51a4b31 100644 --- a/genera/genera-port.lisp +++ b/genera/genera-port.lisp @@ -1,9 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- +;; $fiHeader: genera-port.lisp,v 1.2 92/03/04 16:22:52 cer Exp $ + (in-package :genera-clim) "Copyright (c) 1992 Symbolics, Inc. All rights reserved. -;;; $fiHeader: genera-port.lisp,v 1.2 92/03/04 16:22:52 cer Exp Locker: cer $ Portions copyright (c) 1991, 1992 International Lisp Associates." @@ -384,7 +385,7 @@ (cons real-genera-keysym shifts)))) ;; The standard characters -(define-genera-keysym #\Space :Space) +(define-genera-keysym #\Space :space) (define-genera-keysym #\! :\!) (define-genera-keysym #\" :\") (define-genera-keysym #\# :\#) @@ -418,31 +419,57 @@ (define-genera-keysym #\? :\?) (define-genera-keysym #\@ :\@) (define-genera-keysym #\A :\A) +(define-genera-keysym #\a :\A) (define-genera-keysym #\B :\B) +(define-genera-keysym #\b :\B) (define-genera-keysym #\C :\C) +(define-genera-keysym #\c :\C) (define-genera-keysym #\D :\D) +(define-genera-keysym #\d :\D) (define-genera-keysym #\E :\E) +(define-genera-keysym #\e :\E) (define-genera-keysym #\F :\F) +(define-genera-keysym #\f :\F) (define-genera-keysym #\G :\G) +(define-genera-keysym #\g :\G) (define-genera-keysym #\H :\H) +(define-genera-keysym #\h :\H) (define-genera-keysym #\I :\I) +(define-genera-keysym #\i :\I) (define-genera-keysym #\J :\J) +(define-genera-keysym #\j :\J) (define-genera-keysym #\K :\K) +(define-genera-keysym #\k :\K) (define-genera-keysym #\L :\L) +(define-genera-keysym #\l :\L) (define-genera-keysym #\M :\M) +(define-genera-keysym #\m :\M) (define-genera-keysym #\N :\N) +(define-genera-keysym #\n :\N) (define-genera-keysym #\O :\O) +(define-genera-keysym #\o :\O) (define-genera-keysym #\P :\P) +(define-genera-keysym #\p :\P) (define-genera-keysym #\Q :\Q) +(define-genera-keysym #\q :\Q) (define-genera-keysym #\R :\R) +(define-genera-keysym #\r :\R) (define-genera-keysym #\S :\S) +(define-genera-keysym #\s :\S) (define-genera-keysym #\T :\T) +(define-genera-keysym #\t :\T) (define-genera-keysym #\U :\U) +(define-genera-keysym #\u :\U) (define-genera-keysym #\V :\V) +(define-genera-keysym #\v :\V) (define-genera-keysym #\W :\W) +(define-genera-keysym #\w :\W) (define-genera-keysym #\X :\X) +(define-genera-keysym #\x :\X) (define-genera-keysym #\Y :\Y) +(define-genera-keysym #\y :\Y) (define-genera-keysym #\Z :\Z) +(define-genera-keysym #\z :\Z) (define-genera-keysym #\[ :\[) (define-genera-keysym #\\ :\\) (define-genera-keysym #\] :\]) @@ -516,7 +543,7 @@ (let ((transformation (sheet-native-transformation stream))) (multiple-value-bind (x y) (bounding-rectangle* cursor) (multiple-value-setq (x y) - (transform-point* transformation x y)) + (transform-position transformation x y)) (cond ((and active state focus) (scl:send mirror :set-cursorpos x y) (scl:send blinker :set-visibility :blink)) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index a4075e1d..c0a77598 100644 --- a/misc/dev-load-1.lisp +++ b/misc/dev-load-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: dev-load-1.lisp,v 1.1 92/03/24 19:45:42 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.2 92/04/10 14:27:45 cer Exp Locker: cer $ (excl::free (excl::malloc 131072)) @@ -55,12 +55,15 @@ (compile-file-if-needed "test/test-suite") - (tenuring - (load "test/test-suite") ) + (let ((*load-source-file-info* t) + (*load-xref-info* nil)) - (load "demo/sysdcl") - (tenuring - (clim-defsys::load-system 'clim-demo)) + (tenuring + (load "test/test-suite") ) + + (load "demo/sysdcl") + (tenuring + (clim-defsys::load-system 'clim-demo))) (when (probe-file "/scm/4.1/sparc/src/code/") (let ((sys::*require-search-list* diff --git a/pre-silica/cloe-implementation.lisp b/pre-silica/cloe-implementation.lisp index e6967b46..f29b0848 100644 --- a/pre-silica/cloe-implementation.lisp +++ b/pre-silica/cloe-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-implementation.lisp,v 1.2 92/02/24 13:07:01 cer Exp $ +;; $fiHeader: cloe-implementation.lisp,v 1.3 92/03/10 10:12:16 cer Exp $ (in-package :clim-internals) @@ -588,16 +588,14 @@ (round (+ (* (cos end-angle) x-radius) center-x)) (round (+ (* (sin end-angle) y-radius) center-y)) (round (+ (* (cos start-angle) x-radius) center-x)) - (round (+ (* (sin start-angle) y-radius) center-y)) - - )) + (round (+ (* (sin start-angle) y-radius) center-y)))) (t ;; drawing an arc (win::arc window left top right bottom - (+ (* (cos start-angle) x-radius) center-x) - (+ (* (sin start-angle) y-radius) center-y) - (+ (* (cos end-angle) x-radius) center-x) - (+ (* (sin end-angle) y-radius) center-y)))))))) + (round (+ (* (cos end-angle) x-radius) center-x)) + (round (+ (* (sin end-angle) y-radius) center-y)) + (round (+ (* (cos start-angle) x-radius) center-x)) + (round (+ (* (sin start-angle) y-radius) center-y))))))))) diff --git a/pre-silica/clx-implementation.lisp b/pre-silica/clx-implementation.lisp index 658bbb75..cc00fc1b 100644 --- a/pre-silica/clx-implementation.lisp +++ b/pre-silica/clx-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clx-implementation.lisp,v 1.3 92/03/04 16:21:10 cer Exp $ +;; $fiHeader: clx-implementation.lisp,v 1.4 92/03/10 10:12:18 cer Exp $ (in-package :clim-internals) @@ -439,7 +439,7 @@ (multiple-value-bind (x y same-screen-p child mask root-x root-y root) (xlib:query-pointer root-window) (declare (ignore x y same-screen-p child mask root)) - (pointer-set-position* pointer root-x root-y) + (pointer-set-position pointer root-x root-y) (setf (pointer-window pointer) ws) (setf (pointer-motion-pending ws pointer) t)) (return-from event-loop :mouse-motion)) @@ -456,7 +456,6 @@ (setf (pointer-window pointer) ws) ;; Resolve the selected-window issue. We currently just put the ;; button-press "blip" in the clicked-on window's input buffer. - ;; X and Y are presumed to be fixnums here (case event-key (:button-press (stream-note-pointer-button-press @@ -645,21 +644,21 @@ (and *clx-use-color* (> (xlib:screen-root-depth (clx-stream-screen stream)) 2))) -(defparameter *clx-scrollbar-border-width* 0) -(defparameter *clx-scrollbar-width* 14) +(defparameter *clx-scroll-bar-border-width* 0) +(defparameter *clx-scroll-bar-width* 14) -;;--- Scrollbars have an inner margin +;;--- Scroll-Bars have an inner margin ;;--- Perhaps we should use window-margin! -(defvar *clx-scrollbar-inner-margin* 2) +(defvar *clx-scroll-bar-inner-margin* 2) -(defclass clx-scrollbar (clx-window) +(defclass clx-scroll-bar (clx-window) ((scroll-bar-values-1 :initform nil :accessor scroll-bar-values-1) (scroll-bar-values-2 :initform nil :accessor scroll-bar-values-2))) -(defclass clx-h-scrollbar (clx-scrollbar) ()) -(defclass clx-v-scrollbar (clx-scrollbar) ()) +(defclass clx-h-scroll-bar (clx-scroll-bar) ()) +(defclass clx-v-scroll-bar (clx-scroll-bar) ()) (defmethod initialize-instance :before ((stream clx-window) &key parent) (setf (slot-value stream 'display-device-type) @@ -763,7 +762,7 @@ (when scroll-bars ;; Adjust right and bottom for the border of the window (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum rom bom) (ignore lom tom)) + (declare (type coordinate rom bom) (ignore lom tom)) (decf right rom) (decf bottom bom)) (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream @@ -772,11 +771,11 @@ (when hp (setf horizontal-scroll-bar (open-window-stream :parent stream - :window-class 'clx-h-scrollbar + :window-class 'clx-h-scroll-bar :borders nil - :left (if vp *clx-scrollbar-width* 0) + :left (if vp *clx-scroll-bar-width* 0) :right right - :top (- bottom top *clx-scrollbar-width*) + :top (- bottom top *clx-scroll-bar-width*) :bottom (- bottom top) :scroll-bars nil)) (setf (stream-recording-p horizontal-scroll-bar) nil) @@ -785,11 +784,11 @@ (setf vertical-scroll-bar (open-window-stream :parent stream :borders nil - :window-class 'clx-v-scrollbar + :window-class 'clx-v-scroll-bar :left 0 - :right *clx-scrollbar-width* + :right *clx-scroll-bar-width* :top 0 - :bottom (- bottom top (if hp *clx-scrollbar-width* 0)) + :bottom (- bottom top (if hp *clx-scroll-bar-width* 0)) :scroll-bars nil)) (setf (stream-recording-p vertical-scroll-bar) nil) (window-expose vertical-scroll-bar)))))) @@ -797,11 +796,11 @@ ;;; Scroll bars -(defmethod stream-replay ((stream clx-scrollbar) &optional region) +(defmethod stream-replay ((stream clx-scroll-bar) &optional region) (declare (ignore region)) - (draw-scrollbar stream t)) + (draw-scroll-bar stream t)) -(defmethod stream-note-pointer-button-press ((bar clx-v-scrollbar) +(defmethod stream-note-pointer-button-press ((bar clx-v-scroll-bar) pointer button modifier-state x y) (declare (ignore pointer modifier-state x)) (let* ((stream (window-parent bar)) @@ -811,14 +810,14 @@ (declare (ignore hleft hright)) (with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream) (declare (ignore v-right)) - (window-set-viewport-position* stream + (window-set-viewport-position stream v-left (compute-scroll-to-value y (bounding-rectangle-width bar) (bounding-rectangle-height bar) htop hbottom v-top v-bottom button)) - (draw-scrollbar bar)))))) + (draw-scroll-bar bar)))))) -(defmethod stream-note-pointer-button-press ((bar clx-h-scrollbar) +(defmethod stream-note-pointer-button-press ((bar clx-h-scroll-bar) pointer button modifier-state x y) (declare (ignore pointer modifier-state y)) (let* ((stream (window-parent bar)) @@ -828,12 +827,12 @@ (declare (ignore htop hbottom)) (with-bounding-rectangle* (v-left v-top v-right v-bottom) (window-viewport stream) (declare (ignore v-bottom)) - (window-set-viewport-position* stream + (window-set-viewport-position stream (compute-scroll-to-value x (bounding-rectangle-height bar) (bounding-rectangle-width bar) hleft hright v-left v-right button) v-top) - (draw-scrollbar bar)))))) + (draw-scroll-bar bar)))))) (defun compute-scroll-to-value (y bar-width bar-height history-top history-bottom viewport-top viewport-bottom @@ -863,7 +862,7 @@ (scroll-bar-values-2 stream) slug-length) ,@body))) -(defmethod draw-scrollbar ((stream clx-v-scrollbar) &optional force-p) +(defmethod draw-scroll-bar ((stream clx-v-scroll-bar) &optional force-p) (with-bounding-rectangle* (left top right bottom) stream (let ((width (- right left)) (height (- bottom top)) @@ -875,8 +874,8 @@ (window-viewport win) (declare (ignore viewport-left viewport-right)) (multiple-value-bind (y1 y2 y3 y4 x1 x2 slug-start slug-length) - (compute-scrollbar-values - height width *clx-scrollbar-inner-margin* + (compute-scroll-bar-values + height width *clx-scroll-bar-inner-margin* extent-top extent-bottom viewport-top viewport-bottom) (with-scroll-bar-update (if (or force-p (null old-slug-start)) @@ -899,7 +898,7 @@ (1+ x1) slug-start (1- x2) (+ slug-start slug-length) :ink +light-gray+)))))))) -(defmethod draw-scrollbar ((stream clx-h-scrollbar) &optional force-p) +(defmethod draw-scroll-bar ((stream clx-h-scroll-bar) &optional force-p) (with-bounding-rectangle* (left top right bottom) stream ;; The -1 adjusts for X unfilled rectangles being one pixel too big. jdi (let ((width (- right left 1)) @@ -912,8 +911,8 @@ (window-viewport win) (declare (ignore viewport-top viewport-bottom)) (multiple-value-bind (x1 x2 x3 x4 y1 y2 slug-start slug-length) - (compute-scrollbar-values - width height *clx-scrollbar-inner-margin* + (compute-scroll-bar-values + width height *clx-scroll-bar-inner-margin* extent-left extent-right viewport-left viewport-right) (with-scroll-bar-update (if (or force-p (null old-slug-start)) @@ -936,7 +935,7 @@ slug-start (1+ y1) (+ slug-start slug-length) (1- y2) :ink +light-gray+)))))))) -(defun compute-scrollbar-values (long short margin +(defun compute-scroll-bar-values (long short margin extent-min extent-max viewport-min viewport-max) (let* ((square (- short (* 2 margin))) (x1 margin) @@ -956,30 +955,30 @@ (values x1 x2 x3 x4 y1 y2 (floor slug-start) (floor slug-length)))) ;; Update the scroll-bars when their parent window changes -(defun update-scrollbars (stream width height) +(defun update-scroll-bars (stream width height) ;; Adjust width and height for the border of the window (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum lom tom rom bom)) + (declare (type coordinate lom tom rom bom)) (decf width (+ lom rom)) (decf height (+ tom bom))) (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream (when vertical-scroll-bar (let ((new-height - (if horizontal-scroll-bar (- height *clx-scrollbar-width*) height))) + (if horizontal-scroll-bar (- height *clx-scroll-bar-width*) height))) (when (/= new-height (bounding-rectangle-height vertical-scroll-bar)) (bounding-rectangle-set-size vertical-scroll-bar (bounding-rectangle-width vertical-scroll-bar) new-height) - (draw-scrollbar vertical-scroll-bar t)))) + (draw-scroll-bar vertical-scroll-bar t)))) (when horizontal-scroll-bar (bounding-rectangle-set-edges horizontal-scroll-bar - (if vertical-scroll-bar *clx-scrollbar-width* 0) - (- height *clx-scrollbar-width*) + (if vertical-scroll-bar *clx-scroll-bar-width* 0) + (- height *clx-scroll-bar-width*) width height) - (draw-scrollbar horizontal-scroll-bar)))) + (draw-scroll-bar horizontal-scroll-bar)))) (defmethod host-window-margins ((stream clx-window)) (let* ((parent (window-parent stream))) @@ -1002,17 +1001,17 @@ (let ((h (window-horizontal-scroll-bar stream)) (v (window-vertical-scroll-bar stream))) (values (if v - (+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-width v)) + (+ (* 2 *clx-scroll-bar-border-width*) (bounding-rectangle-width v)) 0) 0 0 (if h - (+ (* 2 *clx-scrollbar-border-width*) (bounding-rectangle-height h)) + (+ (* 2 *clx-scroll-bar-border-width*) (bounding-rectangle-height h)) 0)))) (defmethod window-note-size-or-position-change :after ((stream clx-window) new-left new-top new-right new-bottom) - (update-scrollbars stream (- new-right new-left) (- new-bottom new-top))) + (update-scroll-bars stream (- new-right new-left) (- new-bottom new-top))) (defmethod (setf medium-foreground) :after (ink (stream clx-window)) @@ -1142,12 +1141,12 @@ (defmethod invoke-with-clipping-region ((stream clx-window) continuation (region standard-bounding-rectangle)) (with-slots (window clip-mask) stream - (multiple-value-bind (x y) (window-viewport-position* stream) + (multiple-value-bind (x y) (window-viewport-position stream) (declare (type coordinate x y)) (multiple-value-bind (ml mt) (window-margins stream) (declare (type coordinate ml mt)) (with-bounding-rectangle* (left top right bottom) region - (translate-fixnum-positions (- ml x) (- mt y) + (translate-coordinates (- ml x) (- mt y) left top right bottom) (fix-points left top right bottom) ;;--- How not to cons? (this list and the rectangles) @@ -1246,7 +1245,7 @@ (let ((width (- right left)) (height (- bottom top))) (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum lom tom rom bom)) + (declare (type coordinate lom tom rom bom)) (let ((x-width (- width lom rom)) (x-height (- height tom bom))) (assert (plusp x-width) (x-width) @@ -1259,12 +1258,12 @@ (xlib:drawable-y window) top (xlib:drawable-width window) x-width (xlib:drawable-height window) x-height))))) - (update-scrollbars stream width height)) + (update-scroll-bars stream width height)) (clx-force-output-if-necessary stream t)) (defmethod bounding-rectangle-set-size :after ((stream clx-window) width height) (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum lom tom rom bom)) + (declare (type coordinate lom tom rom bom)) (with-slots (window) stream (let ((x-width (- width lom rom)) (x-height (- height tom bom))) @@ -1275,10 +1274,10 @@ (xlib:with-state (window) (setf (xlib:drawable-width window) x-width (xlib:drawable-height window) x-height))))) - (update-scrollbars stream width height) + (update-scroll-bars stream width height) (clx-force-output-if-necessary stream t)) -(defmethod bounding-rectangle-set-position* :after ((stream clx-window) new-left new-top) +(defmethod bounding-rectangle-set-position :after ((stream clx-window) new-left new-top) (with-slots (window) stream (xlib:with-state (window) (setf (xlib:drawable-x window) new-left) @@ -1288,9 +1287,9 @@ (defmethod redisplay-decorations ((stream clx-window)) (with-slots (horizontal-scroll-bar vertical-scroll-bar) stream (when vertical-scroll-bar - (draw-scrollbar vertical-scroll-bar)) + (draw-scroll-bar vertical-scroll-bar)) (when horizontal-scroll-bar - (draw-scrollbar horizontal-scroll-bar)))) + (draw-scroll-bar horizontal-scroll-bar)))) @@ -1708,11 +1707,12 @@ (defmethod draw-polygon-internal ((stream clx-window) x-offset y-offset list-of-x-and-ys closed ink line-style) (setq list-of-x-and-ys - (mapcar #'round (translate-point-sequence x-offset y-offset list-of-x-and-ys))) + (mapcar #'round + (translate-position-sequence x-offset y-offset list-of-x-and-ys))) (let ((minx most-positive-fixnum) (miny most-positive-fixnum) (points list-of-x-and-ys)) - (declare (fixnum minx miny)) + (declare (type fixnum minx miny)) (do* ((points list-of-x-and-ys (cddr points)) (x (car points) (car points)) (y (cadr points) (cadr points))) diff --git a/pre-silica/default-application.lisp b/pre-silica/default-application.lisp index 1d230f34..a5116d2c 100644 --- a/pre-silica/default-application.lisp +++ b/pre-silica/default-application.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: default-application.lisp,v 1.3 92/03/04 16:21:23 cer Exp $ +;; $fiHeader: default-application.lisp,v 1.4 92/03/10 10:12:25 cer Exp $ (in-package :clim-internals) @@ -27,7 +27,7 @@ #+Allegro (when (and *click-outside-menu-handler* (output-recording-stream-p window) - (not (region-contains-point*-p (stream-output-history window) x y))) + (not (region-contains-position-p (stream-output-history window) x y))) (funcall *click-outside-menu-handler*)) (when highlighted-presentation ;; Unhighlight on the way out. @@ -109,7 +109,7 @@ (defun frame-document-highlighted-presentation-1 (frame presentation input-context window x y stream) (let ((modifier-state (window-modifier-state window))) - (declare (fixnum modifier-state)) + (declare (type fixnum modifier-state)) (multiple-value-bind (left left-presentation left-context middle middle-presentation middle-context right right-presentation right-context) @@ -126,7 +126,7 @@ ;; Assumes 5 modifier keys and the reverse ordering of *MODIFIER-KEYS* (let ((bit #o20) (shift-name '("h-" "s-" "m-" "c-" "sh-"))) - (declare (fixnum bit)) + (declare (type fixnum bit)) (dotimes (i 5) #-(or Allegro Minima) (declare (ignore i)) (unless (zerop (logand bit modifier-state)) diff --git a/pre-silica/defs-graphics-generics.lisp b/pre-silica/defs-graphics-generics.lisp index e2155300..975cf8e1 100644 --- a/pre-silica/defs-graphics-generics.lisp +++ b/pre-silica/defs-graphics-generics.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: defs-graphics-generics.lisp,v 1.2 92/02/24 13:07:23 cer Exp $ +;; $fiHeader: defs-graphics-generics.lisp,v 1.3 92/03/04 16:21:28 cer Exp $ (in-package :clim-internals) @@ -93,43 +93,43 @@ forms)) (values))) -(defmacro transform-points ((transform) &rest points) - (when points - (assert (evenp (length points)) () - "Points must be x/y pairs. There are an odd number of elements in ~S" - points) +(defmacro transform-positions ((transform) &rest positions) + (when positions + (assert (evenp (length positions)) () + "Positions must be x/y pairs. There are an odd number of elements in ~S" + positions) (let ((xform '#:transform)) `(let ((,xform ,transform)) - ,@(do* ((points points (cddr points)) - (x (first points) (first points)) - (y (second points) (second points)) + ,@(do* ((positions positions (cddr positions)) + (x (first positions) (first positions)) + (y (second positions) (second positions)) (forms nil)) - ((null points) (nreverse forms)) + ((null positions) (nreverse forms)) (push `(multiple-value-setq (,x ,y) - (transform-point* ,xform ,x ,y)) + (transform-position ,xform ,x ,y)) forms)) (values))))) -;;; Update the points list in the reference. -(defmacro transform-point-sequence ((transform) points-reference) - (let ((pts-sequence '#:points-sequence) - (pts-temp '#:points) - (original-pts-temp '#:original-points) +;;; Update the positions list in the reference. +(defmacro transform-position-sequence ((transform) positions-reference) + (let ((pts-sequence '#:position-sequence) + (pts-temp '#:positions) + (original-pts-temp '#:original-positions) (xform '#:transform)) ;;--- is a run-time error check worth it? - `(let ((,pts-sequence ,points-reference) + `(let ((,pts-sequence ,positions-reference) (,xform ,transform)) (assert (evenp (length ,pts-sequence)) () - "Points must be x/y pairs. There are an odd number of elements in ~S" + "Positions must be x/y pairs. There are an odd number of elements in ~S" ,pts-sequence) - (setf ,points-reference + (setf ,positions-reference (let* ((,pts-temp (copy-list ,pts-sequence)) (,original-pts-temp ,pts-temp)) (dorest (pt ,pts-sequence cddr) (let ((x (first pt)) (y (second pt))) (multiple-value-bind (nx ny) - (transform-point* ,xform x y) + (transform-position ,xform x y) (setf (car ,pts-temp) nx ,pts-temp (cdr ,pts-temp) (car ,pts-temp) ny @@ -194,20 +194,20 @@ (assert (evenp (length (rest spec))) () "Points must be listed in x/y pairs. ~S has an odd number of elements." (rest spec)) - (push `(transform-points (,transform) ,@(rest spec)) + (push `(transform-positions (,transform) ,@(rest spec)) clauses)) (rectangle ;; The rest of the spec if a list of left/top/right/bottom 4-tuples. (assert (zerop (mod (length (rest spec)) 4)) () "Rectangles must have four values, left top right bottom. ~S" (rest spec)) - (push `(transform-points (,transform) ,@(rest spec)) + (push `(transform-positions (,transform) ,@(rest spec)) clauses)) (point-sequence ;; Elements of REST are references containing lists of points. (dolist (ps (rest spec)) ;; No compile-time ASSERTion. - (push `(transform-point-sequence (,transform) ,ps) + (push `(transform-position-sequence (,transform) ,ps) clauses))) (distance ;; The rest of the spec is a list of dx/dy pairs indicating a distance @@ -239,7 +239,7 @@ (,sy 0)) (when ,array (multiple-value-bind (,vx ,vy) - (window-viewport-position* ,stream) + (window-viewport-position ,stream) (multiple-value-bind (,sw ,sh) (values-list (array-dimensions ,array)) (translate-positions (mod ,vx ,sw) (mod ,vy ,sh) ,sx ,sy)))) @@ -293,7 +293,7 @@ (when (stream-recording-p stream) ,output-recording-hook (multiple-value-bind (abs-x abs-y) - (point-position* + (point-position (stream-output-history-position stream)) (declare (type coordinate abs-x abs-y)) ;; Adjust the coordinates by the position of the current record @@ -305,9 +305,9 @@ rec (- lf abs-x) (- tp abs-y) (- rt abs-x) (- bt abs-y))) - (multiple-value-bind (cx cy) (stream-cursor-position* stream) + (multiple-value-bind (cx cy) (stream-cursor-position stream) (declare (type coordinate cx cy)) - ;; Doing this directly beats calling OUTPUT-RECORD-SET-START-CURSOR-POSITION* + ;; Doing this directly beats calling OUTPUT-RECORD-SET-START-CURSOR-POSITION (with-slots (start-x start-y) rec (setq start-x (- cx abs-x) start-y (- cy abs-y))) @@ -318,8 +318,8 @@ ,@(when point-sequence-to-convert `((with-slots (,point-sequence-to-convert) rec (setq ,point-sequence-to-convert - (ntranslate-point-sequence (- abs-x) (- abs-y) - ,point-sequence-to-convert)))))) + (ntranslate-position-sequence (- abs-x) (- abs-y) + ,point-sequence-to-convert)))))) (stream-add-output-record stream rec)))) (when (stream-drawing-p stream) (call-next-method))) diff --git a/pre-silica/genera-implementation.lisp b/pre-silica/genera-implementation.lisp index 361d7651..076df200 100644 --- a/pre-silica/genera-implementation.lisp +++ b/pre-silica/genera-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-implementation.lisp,v 1.2 92/02/24 13:07:36 cer Exp $ +;; $fiHeader: genera-implementation.lisp,v 1.3 92/03/04 16:21:40 cer Exp $ (in-package :clim-internals) @@ -100,7 +100,7 @@ (translate-positions wl wt left top right bottom)))) (scl:send window :set-edges left top right bottom))) -(defmethod bounding-rectangle-set-position* :after +(defmethod bounding-rectangle-set-position :after ((stream sheet-implementation-mixin) new-left new-top) (with-slots (window) stream (let ((superior (tv:sheet-superior window))) @@ -201,7 +201,7 @@ (with-slots (update-region) stream (when update-region (multiple-value-bind (vx vy) - (window-viewport-position* stream) + (window-viewport-position stream) (dolist (rectangle update-region) (with-bounding-rectangle* (left top right bottom) rectangle (translate-positions (- vx) (- vy) left top right bottom) @@ -1120,7 +1120,7 @@ (with-bounding-rectangle* (hleft htop hright hbottom) history (declare (ignore hleft hright)) (setq top (min (max htop top) hbottom)))) - (window-set-viewport-position* stream left top)))) + (window-set-viewport-position stream left top)))) (scl:defmethod (:x-scroll-to clim-sheet) (position type) (let* ((stream (sheet-for-genera-window scl:self)) @@ -1131,7 +1131,7 @@ (with-bounding-rectangle* (hleft htop hright hbottom) history (declare (ignore htop hbottom)) (setq left (min (max left hleft) hright)))) - (window-set-viewport-position* stream left top)))) + (window-set-viewport-position stream left top)))) ;;; The window manager should manipulate the highest "CLIM sheet" when invoked ;;; on an inferior. @@ -1197,7 +1197,7 @@ (let ((window (sheet-for-genera-window scl:self))) (setf (slot-value window 'highlighted-presentation) nil) (multiple-value-bind (viewport-x viewport-y) - (bounding-rectangle-position* (window-viewport window)) + (bounding-rectangle-position (window-viewport window)) (frame-replay *application-frame* window (make-bounding-rectangle (+ left viewport-x) (+ top viewport-y) @@ -1407,7 +1407,7 @@ (defmethod invoke-with-clipping-region ((stream sheet-implementation-mixin) continuation (region standard-bounding-rectangle)) (let ((window (slot-value stream 'window))) - (multiple-value-bind (vx vy) (window-viewport-position* stream) + (multiple-value-bind (vx vy) (window-viewport-position stream) (declare (type coordinate vx vy)) (multiple-value-bind (ml mt) (window-margins stream) (declare (type coordinate ml mt)) @@ -1453,7 +1453,7 @@ (setf (pointer-window pointer) (sheet-for-genera-window (tv:window-under-mouse-internal mouse) :error-if-no-match nil)) - (pointer-set-position* pointer (tv:mouse-x mouse) (tv:mouse-y mouse)))) + (pointer-set-position pointer (tv:mouse-x mouse) (tv:mouse-y mouse)))) (defmethod stream-event-handler ((stream sheet-window-stream) &key (timeout nil) (input-wait-test nil)) @@ -1531,7 +1531,6 @@ (let ((pw (sheet-for-genera-window mouse-window))) (setf (pointer-window pointer) pw) (multiple-value-bind (xm ym) (scl:send mouse-window :margins) - ;; X and Y are presumed to be fixnums here (stream-note-pointer-button-press pw pointer (ash 1 (si:mouse-char-button char)) (mouse-char-bits->modifier-state (si:mouse-char-bits char)) @@ -1539,7 +1538,7 @@ (t (queue-put (stream-input-buffer stream) character))))) (:mouse-motion ;; --- - (pointer-set-position* pointer (mouse-x) (mouse-y)) + (pointer-set-position pointer (mouse-x) (mouse-y)) (let ((window (sheet-for-genera-window (tv:window-under-mouse-internal mouse) :error-if-no-match nil))) (setf (pointer-window pointer) window) @@ -1557,7 +1556,7 @@ (defmethod stream-pointer-input-rectangle* ((stream sheet-window-stream) pointer &key left top right bottom) (declare (ignore pointer)) - (multiple-value-bind (dx dy) (window-viewport-position* stream) + (multiple-value-bind (dx dy) (window-viewport-position stream) (setq left (if (typep left 'real) (round left) dx)) (setq top (if (typep top 'real) (round top) dy)) (setq right (if (typep right 'real) (round right) (+ left 50))) @@ -1815,11 +1814,11 @@ new-value) #-Silica -(defmethod cursor-position* ((cursor sheet-text-cursor)) +(defmethod cursor-position ((cursor sheet-text-cursor)) (values (slot-value cursor 'x) (slot-value cursor 'y))) #-Silica -(defmethod cursor-set-position* ((cursor sheet-text-cursor) x y) +(defmethod cursor-set-position ((cursor sheet-text-cursor) x y) (setf (slot-value cursor 'x) x (slot-value cursor 'y) y) (let ((blinker (slot-value cursor 'blinker))) diff --git a/pre-silica/graphics-internals.lisp b/pre-silica/graphics-internals.lisp index 68cf403a..1662bd96 100644 --- a/pre-silica/graphics-internals.lisp +++ b/pre-silica/graphics-internals.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-internals.lisp,v 1.1 92/01/31 14:27:56 cer Exp $ +;; $fiHeader: graphics-internals.lisp,v 1.2 92/02/24 13:07:44 cer Exp $ (in-package :clim-internals) @@ -33,7 +33,7 @@ ((record output-record-mixin) x-offset y-offset) (let ((designs nil)) (flet ((make-design (record) - (multiple-value-bind (xoff yoff) (output-record-position* record) + (multiple-value-bind (xoff yoff) (output-record-position record) (declare (type coordinate xoff yoff)) (let ((design (make-design-from-output-record-1 @@ -57,7 +57,7 @@ (defmethod draw-design ((point standard-point) stream &rest args &key ink line-style) (declare (dynamic-extent args) (ignore ink line-style)) - (multiple-value-bind (x y) (point-position* point) + (multiple-value-bind (x y) (point-position point) (apply #'draw-point* stream x y args))) @@ -142,8 +142,6 @@ (with-slots (x1 y1 x2 y2 line-style) record (or (null line-style) (with-half-thickness (lthickness rthickness) line-style - ;; Don't use LTRB-CONTAINS-POINT*-P, since that expects fixnums - ;;---- Not any more! (not (and (<= (+ x1 rthickness) x) (<= (+ y1 rthickness) y) (>= (- x2 lthickness) x) @@ -205,7 +203,7 @@ ((polygon polygon-displayed-output-record) x-offset y-offset) (with-slots (list-of-xs-and-ys closed line-style ink) polygon (let ((coords (copy-list list-of-xs-and-ys))) - (translate-point-sequence x-offset y-offset coords) + (translate-position-sequence x-offset y-offset coords) (compose-in ink (if (null line-style) diff --git a/pre-silica/postscript-implementation.lisp b/pre-silica/postscript-implementation.lisp index 712009d1..f800589e 100644 --- a/pre-silica/postscript-implementation.lisp +++ b/pre-silica/postscript-implementation.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-implementation.lisp,v 1.1 92/01/31 14:28:01 cer Exp $ +;; $fiHeader: postscript-implementation.lisp,v 1.2 92/02/24 13:08:11 cer Exp $ (in-package :clim-internals) @@ -90,14 +90,15 @@ ;;; This structure is used to represent a PostScript font masquerading as a ;;; CLIM-world entity. They populate the font-map array of the stream. (defstruct (ps-font-compat-kludge (:conc-name psfck-)) - index ;index into stream's array. - style-descriptor ;parse-text-style output. - true-ps-descriptor ;("Times" :italic 6 [pts]) - points ;point-size - clim-height ;equivalent size in CLIM "pixels" - clim-ascent ;top-to-baseline, "pixels" - clim-descent ;baseline-to-bottom - width-table) ;width array or constant #. + index ;index into stream's array. + style-descriptor ;parse-text-style output. + true-ps-descriptor ;("Times" :italic 6 [pts]) + points ;point-size + clim-height ;equivalent size in CLIM "pixels" + clim-ascent ;top-to-baseline, "pixels" + clim-descent ;baseline-to-bottom + width-table ;width array or constant #. + (established nil)) ;T ==> written to the printer ;;; Each element is ((family face) width-or-width-table-array height ascent descent) (defvar *char-width-tables* nil) @@ -262,6 +263,7 @@ (header-comments :initform nil :initarg :header-comments) (orientation :initform :portrait :initarg :orientation) ;; For multi-page output, analogous to a window's scroll position + (multi-page :initform nil :initarg :multi-page) (viewport-x :initform 0) (viewport-y :initform 0))) @@ -546,15 +548,24 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (defmethod postscript-prologue ((stream postscript-implementation-mixin)) (with-slots (printer-stream header-comments display-device-type orientation) stream - (format printer-stream "%! nonconforming~%") - (format printer-stream "%%Creator: CLIM 1.0~%") + (format printer-stream "%!PS-Adobe-2.0 EPSF-2.0~%") + (multiple-value-bind (left top right bottom) + (postscript-bounding-box-edges stream) + (format printer-stream "%%BoundingBox: ~D ~D ~D ~D~%" + left top right bottom)) + (format printer-stream "%%Creator: CLIM 2.0~%") (let ((title (getf header-comments :title))) (when title (format printer-stream "%%Title: ~A~%" title))) (let ((for (or (getf header-comments :for) #+Genera zl:user-id))) (when for (format printer-stream "%%For: ~A~%" for))) - #+Genera (format printer-stream "%%CreationDate: ~\\date\\~%" (get-universal-time)) + (multiple-value-bind (second minute hour date month year) + (decode-universal-time (get-universal-time)) + (format printer-stream "%%CreationDate: ~D-~A-~D ~2,'0D:~2,'0D:~2,'0D~%" + date (svref #("Jan" "Feb" "Mar" "Apr" "May" "Jun" + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec") month) year + hour minute second)) (format printer-stream "%%DocumentFonts: (atend)~%") (format printer-stream "%%EndComments~%") (write-string *postscript-prologue* printer-stream) @@ -570,7 +581,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (format printer-stream "/new-matrix {0 format-y-translation translate format-rotation rotate} def - /new-page {showpage new-matrix} def") + /new-page {showpage new-matrix} def~%") (format printer-stream "%%EndProlog~%") (format printer-stream "~%new-matrix~%"))) @@ -969,21 +980,27 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (format printer-stream ") show~%")) (defmethod get-font-compat-str ((stream postscript-implementation-mixin) text-style) - (with-slots (font-map printer-stream) stream - (let ((styledesc (parse-text-style text-style)) - (al (length font-map))) - (do ((i 0 (1+ i))) - ((>= i al) - (error "Font map overflow for ~S" stream)) - (let ((fcs (aref font-map i))) - (when (null fcs) - (setq fcs (make-new-fcs styledesc i)) - (setf (aref font-map i) fcs) - (format printer-stream "~D ~D /~A estfont~%" - (psfck-index fcs) (psfck-points fcs) (get-ps-fam-face-name fcs)) - (return fcs)) - (when (eq styledesc (psfck-style-descriptor fcs)) - (return fcs))))))) + (with-slots (font-map printer-stream draw-p) stream + (let* ((styledesc (parse-text-style text-style)) + (al (length font-map)) + (fcs + (do ((i 0 (1+ i))) + ((>= i al) + (error "Font map overflow for ~S" stream)) + (let ((fcs (aref font-map i))) + (when (null fcs) + (setq fcs (make-new-fcs styledesc i)) + (setf (aref font-map i) fcs) + (return fcs)) + (when (eq styledesc (psfck-style-descriptor fcs)) + (return fcs)))))) + (when (and fcs + draw-p + (not (psfck-established fcs))) + (format printer-stream "~D ~D /~A estfont~%" + (psfck-index fcs) (psfck-points fcs) (get-ps-fam-face-name fcs)) + (setf (psfck-established fcs) t)) + fcs))) ;; PostScript's "default user space" is measured in printers' points. @@ -1094,15 +1111,19 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (:default-initargs :display-device-type *postscript-device* :default-text-margin 1000)) -(defmethod initialize-instance :after ((stream postscript-stream) &key) - (postscript-prologue stream)) - (defun make-postscript-stream (stream) (make-instance 'postscript-stream :stream stream)) (defmethod close ((stream postscript-stream) &key abort) - (declare (ignore abort)) - (postscript-epilogue stream)) + (unless abort + (postscript-epilogue stream))) + +(defmethod postscript-bounding-box-edges ((stream postscript-stream)) + (with-bounding-rectangle* (left top right bottom) + (stream-output-history stream) + (pixels-to-points left top right bottom) + (values (round left) (round top) + (round right) (round bottom)))) (defmethod window-inside-width ((stream postscript-implementation-mixin)) (with-slots (display-device-type) stream @@ -1129,39 +1150,39 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def ;; Replay some PostScript output, breaking it into multiple pages (defmethod stream-replay ((stream postscript-implementation-mixin) &optional region) (with-slots (output-record record-p draw-p display-device-type - printer-stream orientation viewport-x viewport-y) stream + printer-stream orientation multi-page viewport-x viewport-y) stream (when draw-p (when output-record (letf-globally ((record-p nil)) - (if region + (if (or region (not multi-page)) (replay output-record stream region) - (with-bounding-rectangle* (left top right bottom) output-record - (let* ((page-width - (floor (* (slot-value display-device-type 'page-width) - (slot-value display-device-type 'device-units-per-inch)) - *1-pixel=points*)) - (page-height - (floor (* (slot-value display-device-type 'page-height) - (slot-value display-device-type 'device-units-per-inch)) - *1-pixel=points*)) - (first-page t)) - (setq viewport-x 0 viewport-y 0) - ;; Draw each chunk of output on its own page - (unwind-protect - (do ((y top (+ y page-height))) - ((> y bottom)) - (do ((x left (+ x page-width))) - ((> x right)) - (if first-page - (setq first-page nil) - (format printer-stream "new-page~%")) - (let ((region (make-bounding-rectangle - x y (+ x page-width) (+ y page-height)))) - (replay output-record stream region)) - (incf viewport-x page-width)) - (setf viewport-x 0) - (incf viewport-y page-height)) - (setq viewport-x 0 viewport-y 0)))))))))) + (with-bounding-rectangle* (left top right bottom) output-record + (let* ((page-width + (floor (* (slot-value display-device-type 'page-width) + (slot-value display-device-type 'device-units-per-inch)) + *1-pixel=points*)) + (page-height + (floor (* (slot-value display-device-type 'page-height) + (slot-value display-device-type 'device-units-per-inch)) + *1-pixel=points*)) + (first-page t)) + (setq viewport-x 0 viewport-y 0) + ;; Draw each chunk of output on its own page + (unwind-protect + (do ((y top (+ y page-height))) + ((> y bottom)) + (do ((x left (+ x page-width))) + ((> x right)) + (if first-page + (setq first-page nil) + (format printer-stream "gsave new-page grestore~%")) + (let ((region (make-bounding-rectangle + x y (+ x page-width) (+ y page-height)))) + (replay output-record stream region)) + (incf viewport-x page-width)) + (setf viewport-x 0) + (incf viewport-y page-height)) + (setq viewport-x 0 viewport-y 0)))))))))) (defmacro with-output-to-postscript-stream ((stream-var file-stream &rest args) &body body) @@ -1184,17 +1205,17 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def :stream file-stream :display-device-type display-device :header-comments header-comments - :orientation orientation)) + :orientation orientation + :multi-page multi-page)) (abort-p t)) - (with-output-recording-options (postscript-stream :record t :draw (not multi-page)) + (with-output-recording-options (postscript-stream :record t :draw nil) (unwind-protect (multiple-value-prog1 (funcall continuation postscript-stream) - (when multi-page - ;; In the case of multi-page output, we have not actually output - ;; anything to the printer yet. Do so now, breaking the output - ;; up into multiple pages. - (with-output-recording-options (postscript-stream :record nil :draw t) - (frame-replay *application-frame* postscript-stream))) + (postscript-prologue postscript-stream) + ;; Now do the output to the printer, breaking up the output into + ;; multiple pages if that was requested + (with-output-recording-options (postscript-stream :record nil :draw t) + (frame-replay *application-frame* postscript-stream)) (setq abort-p nil)) (close postscript-stream :abort abort-p))))) diff --git a/pre-silica/protocol-intermediaries.lisp b/pre-silica/protocol-intermediaries.lisp index d4fb65e4..dd4786e7 100644 --- a/pre-silica/protocol-intermediaries.lisp +++ b/pre-silica/protocol-intermediaries.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: protocol-intermediaries.lisp,v 1.1 92/01/31 14:28:04 cer Exp $ +;; $fiHeader: protocol-intermediaries.lisp,v 1.2 92/02/24 13:08:20 cer Exp $ (in-package :clim-internals) @@ -18,29 +18,29 @@ (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y) (call-next-method window pointer button modifier-state nx ny))) -(defmethod stream-pointer-position* :around ((window input-and-window-protocol-intermediary) - &rest args) +(defmethod stream-pointer-position :around ((window input-and-window-protocol-intermediary) + &rest args) (declare (ignore args)) (multiple-value-bind (x y) (call-next-method) (viewport-to-drawing-surface-coordinates window x y))) -(defmethod stream-set-pointer-position* :around +(defmethod stream-set-pointer-position :around ((window input-and-window-protocol-intermediary) x y &key pointer) (multiple-value-bind (nx ny) (viewport-to-drawing-surface-coordinates window x y) (call-next-method window nx ny :pointer pointer))) -(defmethod stream-set-cursor-position* :after ((window input-and-window-protocol-intermediary) - x y) +(defmethod stream-set-cursor-position :after ((window input-and-window-protocol-intermediary) + x y) (let ((cursor (stream-text-cursor window))) (when cursor - (cursor-set-position* cursor x y)))) + (cursor-set-position cursor x y)))) -(defmethod stream-set-cursor-position*-internal :after +(defmethod stream-set-cursor-position-internal :after ((window input-and-window-protocol-intermediary) x y) (let ((cursor (stream-text-cursor window))) (when cursor - (cursor-set-position* cursor x y)))) + (cursor-set-position cursor x y)))) ;;; Methods for streams that are both windows and extended output streams @@ -89,10 +89,10 @@ (not draw) (not (stream-recording-p stream))))) (multiple-value-bind (old-x old-y) - (when restore-p (stream-cursor-position* stream)) + (when restore-p (stream-cursor-position stream)) (unwind-protect (progn (stream-close-text-output-record stream) (call-next-method stream continuation record draw)) - (when restore-p (stream-set-cursor-position* stream old-x old-y)))))) + (when restore-p (stream-set-cursor-position stream old-x old-y)))))) diff --git a/pre-silica/window-protocol.lisp b/pre-silica/window-protocol.lisp index 86abafa0..1cb9d95c 100644 --- a/pre-silica/window-protocol.lisp +++ b/pre-silica/window-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: window-protocol.lisp,v 1.3 92/02/24 13:08:54 cer Exp $ +;; $fiHeader: window-protocol.lisp,v 1.4 92/03/04 16:22:28 cer Exp $ (in-package :clim-internals) @@ -78,7 +78,7 @@ (let ((*synchronous-window-operation-being-processed* T)) (call-next-method))) -(defmethod bounding-rectangle-set-position* :around ((window window-mixin) nx ny) +(defmethod bounding-rectangle-set-position :around ((window window-mixin) nx ny) (declare (ignore nx ny)) (let ((*synchronous-window-operation-being-processed* t)) (call-next-method))) @@ -89,13 +89,25 @@ (call-next-method))) ;;; These methods are needed for hooks on other mixins to work. -(defmethod window-viewport-position* ((window window-mixin)) +(defmethod window-viewport-position ((window window-mixin)) (with-slots (viewport) window - (bounding-rectangle-position* viewport))) + (bounding-rectangle-position viewport))) -(defmethod window-set-viewport-position* ((window window-mixin) x y) +(defmethod window-set-viewport-position ((window window-mixin) x y) (with-slots (viewport) window - (bounding-rectangle-set-position* viewport x y))) + (bounding-rectangle-set-position viewport x y))) + +#+CLIM-1-compatibility +(define-compatibility-function (window-viewport-position* + window-viewport-position) + (window) + (window-viewport-position window)) + +#+CLIM-1-compatibility +(define-compatibility-function (window-set-viewport-position* + window-set-viewport-position) + (window x y) + (window-set-viewport-position window x y)) (defmethod window-with-zero-viewport-position ((window window-mixin) continuation) @@ -103,19 +115,19 @@ ;; Margin components should not respect the stream transform (letf-globally (((medium-transformation window) +identity-transformation+)) (let ((viewport (window-viewport window))) - (multiple-value-bind (x y) (bounding-rectangle-position* viewport) + (multiple-value-bind (x y) (bounding-rectangle-position viewport) (unwind-protect - (progn (bounding-rectangle-set-position* viewport 0 0) + (progn (bounding-rectangle-set-position viewport 0 0) (funcall continuation)) - (bounding-rectangle-set-position* viewport x y)))))) + (bounding-rectangle-set-position viewport x y)))))) (defmethod window-clear ((window window-mixin)) (window-erase-viewport window) (when (extended-output-stream-p window) ;can we assume this? - (stream-set-cursor-position* window 0 0) + (stream-set-cursor-position window 0 0) (setf (stream-baseline window) 0 (stream-current-line-height window) 0)) - (bounding-rectangle-set-position* (window-viewport window) 0 0)) + (bounding-rectangle-set-position (window-viewport window) 0 0)) ;;; Basically a hook for other mixins. (defmethod window-refresh ((window window-mixin)) @@ -128,9 +140,9 @@ ;;; --- This needs to be on window-output... ;(defmethod window-fresh-page ((stream window-mixin)) -; (multiple-value-call #'window-set-viewport-position* +; (multiple-value-call #'window-set-viewport-position ; window -; (window-stream-cursor-position* stream))) +; (window-stream-cursor-position stream))) ; (defun window-size-viewport-to-fit (window) @@ -140,63 +152,60 @@ ;;; Coordinate translations -;;;--- FIXNUM stuff - ;;; The true interfaces: ;;; WINDOW-TO-SCREEN-COORDINATES Window-X Window-Y -> Screen-X Screen-Y (defmethod window-to-screen-coordinates ((window window-mixin) x y) (declare (type coordinate x y)) (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window) (declare (type coordinate dx dy)) - (values (the fixnum (+ x dx)) (the fixnum (+ y dy))))) + (values (the coordinate (+ x dx)) (the coordinate (+ y dy))))) (defmethod screen-to-window-coordinates ((window window-mixin) x y) (declare (type coordinate x y)) (multiple-value-bind (dx dy) (window-to-screen-coordinate-translations window) (declare (type coordinate dx dy)) - (values (the fixnum (- x dx)) (the fixnum (- y dy))))) + (values (the coordinate (- x dx)) (the coordinate (- y dy))))) ;;; An internal routine (defmethod window-to-screen-coordinate-translations ((window window-mixin)) (with-slots (left top viewport parent) window - (declare (fixnum left top)) + (declare (type coordinate left top)) (multiple-value-bind (left-translation top-translation) (window-margins window) - (declare (fixnum left-translation top-translation)) - (setq left-translation (the fixnum (+ left-translation left))) - (setq top-translation (the fixnum (+ top-translation top))) + (declare (type coordinate left-translation top-translation)) + (setq left-translation (the coordinate (+ left-translation left))) + (setq top-translation (the coordinate (+ top-translation top))) (when parent (multiple-value-bind (parent-left parent-top) (window-to-screen-coordinate-translations parent) - (declare (fixnum parent-left parent-top)) - (setq left-translation (the fixnum (+ left-translation parent-left))) - (setq top-translation (the fixnum (+ top-translation parent-top))))) + (declare (type coordinate parent-left parent-top)) + (setq left-translation (the coordinate (+ left-translation parent-left))) + (setq top-translation (the coordinate (+ top-translation parent-top))))) (when viewport (multiple-value-bind (viewport-left viewport-top) - (bounding-rectangle-position* viewport) - (declare (fixnum viewport-left viewport-top)) - (setq left-translation (the fixnum (- left-translation viewport-left))) - (setq top-translation (the fixnum (- top-translation viewport-top))))) + (bounding-rectangle-position viewport) + (declare (type coordinate viewport-left viewport-top)) + (setq left-translation (the coordinate (- left-translation viewport-left))) + (setq top-translation (the coordinate (- top-translation viewport-top))))) (values left-translation top-translation)))) (defmethod drawing-surface-to-viewport-coordinates ((window window-mixin) dsx dsy) - (declare (fixnum dsx dsy)) - (multiple-value-bind (vx vy) (window-viewport-position* window) - (declare (fixnum vx vy)) + (declare (type coordinate dsx dsy)) + (multiple-value-bind (vx vy) (window-viewport-position window) + (declare (type coordinate vx vy)) (multiple-value-bind (ml mt) (window-margins window) - (declare (fixnum ml mt)) - (values (the fixnum (+ (the fixnum (- dsx vx)) ml)) - (the fixnum (+ (the fixnum (- dsy vy)) mt)))))) + (declare (type coordinate ml mt)) + (values (the coordinate (+ (the coordinate (- dsx vx)) ml)) + (the coordinate (+ (the coordinate (- dsy vy)) mt)))))) (defmethod viewport-to-drawing-surface-coordinates ((window window-mixin) x y) - (declare (fixnum x y)) - (multiple-value-bind (vx vy) (window-viewport-position* window) - (declare (fixnum vx vy)) + (declare (type coordinate x y)) + (multiple-value-bind (vx vy) (window-viewport-position window) + (declare (type coordinate vx vy)) (multiple-value-bind (ml mt) (window-margins window) - (declare (fixnum ml mt)) - (values (the fixnum (- (the fixnum (+ x vx)) ml)) - (the fixnum (- (the fixnum (+ y vy)) mt)))))) + (declare (type coordinate ml mt)) + (values (the coordinate (- (the coordinate (+ x vx)) ml)) + (the coordinate (- (the coordinate (+ y vy)) mt)))))) -;;;--- FIXNUM stuff ;;; Hmm. (defmethod bounding-rectangle-set-edges :after ((window window-mixin) left top right bottom) (declare (ignore left top right bottom)) @@ -210,29 +219,30 @@ (defmethod window-inside-size ((window window-mixin)) (multiple-value-bind (left top right bottom) (window-inside-edges window) - (declare (fixnum left top right bottom)) - (values (the fixnum (- right left)) (the fixnum (- bottom top))))) + (declare (type coordinate left top right bottom)) + (values (the coordinate (- right left)) (the coordinate (- bottom top))))) (defmethod window-inside-edges ((stream window-mixin)) (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum lom tom rom bom)) + (declare (type coordinate lom tom rom bom)) (multiple-value-bind (lim tim rim bim) (window-margins stream) - (declare (fixnum lim tim rim bim)) + (declare (type coordinate lim tim rim bim)) (with-bounding-rectangle* (left top right bottom) stream - (values (the fixnum (+ left lom lim)) (the fixnum (+ top tom tim)) - (the fixnum (- right rom rim)) (the fixnum (- bottom bom bim))))))) + (values (the coordinate (+ left lom lim)) (the coordinate (+ top tom tim)) + (the coordinate (- right rom rim)) (the coordinate (- bottom bom bim))))))) (defmethod window-set-inside-edges ((stream window-mixin) new-left new-top new-right new-bottom) - (declare (fixnum new-left new-top new-right new-bottom)) (multiple-value-bind (lom tom rom bom) (host-window-margins stream) - (declare (fixnum lom tom rom bom)) + (declare (type coordinate lom tom rom bom)) (multiple-value-bind (lim tim rim bim) (window-margins stream) - (declare (fixnum lim tim rim bim)) + (declare (type coordinate lim tim rim bim)) (bounding-rectangle-set-edges stream - (the fixnum (- new-left lom lim)) (the fixnum (- new-top tom tim)) - (the fixnum (+ new-right rom rim)) (the fixnum (+ new-bottom bom bim)))))) + (the coordinate (- (coordinate new-left) lom lim)) + (the coordinate (- (coordinate new-top) tom tim)) + (the coordinate (+ (coordinate new-right) rom rim)) + (the coordinate (+ (coordinate new-bottom) bom bim)))))) ;; the port needs to define host-window-margins @@ -317,24 +327,22 @@ ;; for the time being, make the viewport fill the window (window-size-viewport-to-fit window)) -;;;--- FIXNUM stuff - ;;; Offset from root (defun window-offset (stream) (let ((x-offset 0) (y-offset 0)) - (declare (fixnum x-offset y-offset)) + (declare (type coordinate x-offset y-offset)) (do ((s stream (window-parent s))) ((null s) nil) - (multiple-value-bind (x y) (bounding-rectangle-position* s) - (declare (fixnum x y)) + (multiple-value-bind (x y) (bounding-rectangle-position s) + (declare (type coordinate x y)) (multiple-value-bind (ml mt) (host-window-margins s) - (declare (fixnum ml mt)) - (setq x-offset (the fixnum (+ x-offset x ml))) - (setq y-offset (the fixnum (+ y-offset y mt)))))) + (declare (type coordinate ml mt)) + (setq x-offset (the coordinate (+ x-offset x ml))) + (setq y-offset (the coordinate (+ y-offset y mt)))))) (values x-offset y-offset))) -;; This is called by OUTPUT-RECORDING-MIXIN's whopper on set-viewport-position*. +;; This is called by OUTPUT-RECORDING-MIXIN's whopper on SET-VIEWPORT-POSITION. ;; It shifts a region of the "host screen" that's visible to some other visible ;; location. It does NOT do any cleaning up after itself. It does not side-effect ;; the output history of the window. It calls COPY-AREA whose contract is to @@ -373,7 +381,7 @@ (multiple-value-bind (ml mt) (window-margins window) (declare (type coordinate ml mt)) - (translate-fixnum-positions ml mt from-x from-y) + (translate-coordinates ml mt from-x from-y) (copy-area window from-x from-y (+ from-x width) (+ from-y height) @@ -395,11 +403,11 @@ (defmethod stream-advance-cursor-line :after ((stream output-and-window-protocol-intermediary)) (stream-ensure-cursor-visible stream)) -(defmethod stream-set-cursor-position* :after ((stream output-and-window-protocol-intermediary) +(defmethod stream-set-cursor-position :after ((stream output-and-window-protocol-intermediary) new-x new-y) (stream-ensure-cursor-visible stream new-x new-y)) -(defmethod stream-set-cursor-position*-internal :after +(defmethod stream-set-cursor-position-internal :after ((stream output-and-window-protocol-intermediary) new-x new-y) (stream-ensure-cursor-visible stream new-x new-y)) @@ -407,7 +415,7 @@ &optional cx cy) (when (or (not (output-recording-stream-p stream)) (stream-drawing-p stream)) - (unless cy (multiple-value-setq (cx cy) (stream-cursor-position* stream))) + (unless cy (multiple-value-setq (cx cy) (stream-cursor-position stream))) (with-bounding-rectangle* (vleft vtop vright vbottom) (window-viewport stream) (let ((new-x nil) (new-y nil)) @@ -423,7 +431,7 @@ (setf new-x (max 0 (- cx (- vright vleft (* 4 (stream-character-width stream #\W)))))))) (when (or new-x new-y) - (window-set-viewport-position* stream (or new-x vleft) (or new-y vtop))))))) + (window-set-viewport-position stream (or new-x vleft) (or new-y vtop))))))) ;;; Rudimentary audio diff --git a/silica/db-border.lisp b/silica/db-border.lisp index 65545c62..cd834e47 100644 --- a/silica/db-border.lisp +++ b/silica/db-border.lisp @@ -5,7 +5,7 @@ (in-package :silica) -;; $fiHeader: db-border.lisp,v 1.4 92/03/10 10:11:34 cer Exp Locker: cer $ +;; $fiHeader: db-border.lisp,v 1.5 92/04/10 14:26:24 cer Exp Locker: cer $ ;;; Border Panes (defclass border-pane (layout-pane) @@ -32,9 +32,8 @@ (defmacro bordering (options &body contents) `(make-pane 'border-pane - :contents ,@contents - ,@options)) - + :contents ,@contents + ,@options)) (defclass outlined-pane (border-pane) ((background :initform +black+ :accessor pane-background))) @@ -51,14 +50,14 @@ (defmacro outlining (options &body contents) `(make-pane 'outlined-pane - :contents ,@contents - ,@options)) - + :contents ,@contents + ,@options)) (defclass spacing-pane (border-pane) () (:default-initargs :thickness 2)) (defmacro spacing (options &body contents) `(make-pane 'spacing-pane - :contents ,@contents - ,@options)) + :contents ,@contents + ,@options)) + diff --git a/silica/db-box.lisp b/silica/db-box.lisp index 40520483..839978ab 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-box.lisp,v 1.9 92/03/04 16:19:26 cer Exp Locker: cer $ +;; $fiHeader: db-box.lisp,v 1.10 92/04/10 14:26:25 cer Exp Locker: cer $ (in-package :silica) diff --git a/silica/db-button.lisp b/silica/db-button.lisp index 77f51700..e15c3839 100644 --- a/silica/db-button.lisp +++ b/silica/db-button.lisp @@ -1,10 +1,10 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- +;; $fiHeader: db-button.lisp,v 1.4 92/03/24 19:36:24 cer Exp $ + "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;; $fiHeader: db-button.lisp,v 1.4 92/03/24 19:36:24 cer Exp Locker: cer $ - (in-package :silica) @@ -120,7 +120,6 @@ ;; This is done in the (SETF GADGET-VALUE) method because that's where it ;; would be done in, say, Motif. (I.e. we'd pass the SET-GADGET-VALUE off ;; to Motif which would toggle the indicator.) - (defmethod (setf gadget-value) :after (nv (pane toggle-button-pane) &key) (when (port pane) ;; If it's not grafted, don't draw it. @@ -131,8 +130,7 @@ (cx (+ left radius)) (cy (+ top (round (- bottom top) 2)))) (draw-circle* medium cx cy (round radius 2) - :ink (if (gadget-value pane) +foreground-ink+ - +background-ink+))))))) + :ink (if (gadget-value pane) +foreground-ink+ +background-ink+))))))) (defmethod handle-event ((pane toggle-button-pane) (event pointer-button-press-event)) (with-slots (armed) pane @@ -188,6 +186,8 @@ ((selection toggle-button) (client radio-box-pane) gadget-id new-value) (declare (ignore gadget-id)) (let ((old-selection (radio-box-current-selection client))) + ;;--- Note the the Motif version of this sets the current selection + ;;--- to the ID, *not* the new value. Howcum? (cond ((eql selection old-selection) (setf (radio-box-current-selection client) (and new-value selection))) (old-selection @@ -204,14 +204,15 @@ (let ((inferiors (with-look-and-feel-realization (frame-manager frame) (make-pane 'hbox-pane - :spacing 5 - :contents choices)))) + :spacing 5 + :contents choices)))) (sheet-adopt-child pane inferiors) (when selection (setf (gadget-value selection) t)))) ;; This macro is just an example of one possible syntax. The obvious "core" -;; syntax is (make-pane 'radio-box :choices (list ...) :selection ...) +;; syntax is (MAKE-PANE 'RADIO-BOX :CHOICES (LIST ...) :SELECTION ...) + (defmacro with-radio-box ((&rest options) &body body) (declare (ignore options)) (let ((current-selection '#:current-selection) @@ -221,5 +222,5 @@ `(setq ,',current-selection ,form))) (let ((,choices (list ,@body))) (make-pane 'radio-box - :choices ,choices - :selection ,current-selection)))))) + :choices ,choices + :selection ,current-selection)))))) diff --git a/silica/db-layout.lisp b/silica/db-layout.lisp index 5722a524..b6b76ce9 100644 --- a/silica/db-layout.lisp +++ b/silica/db-layout.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-layout.lisp,v 1.10 92/03/24 19:36:26 cer Exp Locker: cer $ +;; $fiHeader: db-layout.lisp,v 1.11 92/03/30 17:52:01 cer Exp $ (in-package :silica) @@ -81,11 +81,10 @@ (defmethod note-space-requirement-changed (parent child) nil) - (defmethod note-sheet-region-changed :after ((pane layout-mixin) &key port-did-it) - (note-layout-mixin-region-changed pane :port port-did-it)) - -(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) + (note-layout-mixin-region-changed pane :port port-did-it)) + +(defmethod note-layout-mixin-region-changed ((pane layout-mixin) &key port) (declare (ignore port)) (multiple-value-bind (width height) (bounding-rectangle-size pane) (allocate-space pane width height))) @@ -258,12 +257,8 @@ slot that defaults to NIL")) (height 0) (min-height height) (max-height height)) - (values width - min-width - max-width - height - min-height - max-height)) + (values width min-width max-width + height min-height max-height)) ;;;; @@ -517,12 +512,10 @@ provided elsewhere")) ()) -;;-- Does this need to be more complicated. -;; What is the correct behavior. Should it take a space requirement?? -;; and just call allocate-space - -(defclass bboard-pane (space-requirement-mixin layout-pane) - ()) +;;--- Does this need to be more complicated? +;;--- What is the correct behavior. Should it take a space requirement? +;;--- and just call ALLOCATE-SPACE? +(defclass bboard-pane (space-requirement-mixin layout-pane) ()) (defmethod allocate-space ((pane bboard-pane) width height) (declare (ignore width height)) @@ -531,4 +524,3 @@ provided elsewhere")) (resize-sheet* child (space-requirement-width space-req) (space-requirement-height space-req))))) - diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index 59dfefb0..e92bf898 100644 --- a/silica/db-scroll.lisp +++ b/silica/db-scroll.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-scroll.lisp,v 1.12 92/04/10 14:26:28 cer Exp Locker: cer $ +;; $fiHeader: db-scroll.lisp,v 1.13 92/04/14 15:29:31 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -16,8 +16,8 @@ wrapping-space-mixin layout-pane) ((scroll-bars :initarg :scroll-bars) - vertical-scrollbar - horizontal-scrollbar + vertical-scroll-bar + horizontal-scroll-bar contents viewport) (:default-initargs :scroll-bars :both)) @@ -38,34 +38,34 @@ 'scroller-pane) (sheet-parent (sheet-parent (sheet-parent x))))) -(defmethod gadget-supplies-scrollbars-p ((gadget t)) +(defmethod gadget-supplies-scroll-bars-p ((gadget t)) nil) ;;--- Ideally we should use a toolkit scrolling window. This will look -;;--- exactly right and will deal with user specified placement of scrollbars. +;;--- exactly right and will deal with user specified placement of scroll-bars. ;;--- However the geometry management problems are quite huge. (defmethod initialize-instance :after ((pane scroller-pane) &key contents frame-manager frame scroll-bars) - (if (gadget-supplies-scrollbars-p contents) + (if (gadget-supplies-scroll-bars-p contents) (sheet-adopt-child pane contents) (progn (check-type scroll-bars (member :both :dynamic :vertical :horizontal)) - (with-slots (vertical-scrollbar horizontal-scrollbar (c contents) viewport) pane + (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport) pane (with-look-and-feel-realization (frame-manager frame) (let ((verticalp (member scroll-bars '(:both :dynamic :vertical))) (horizontalp (member scroll-bars '(:both :dynamic :horizontal)))) - (setf vertical-scrollbar + (setf vertical-scroll-bar (and verticalp (make-pane 'scroll-bar :orientation :vertical :client pane :id :vertical)) - horizontal-scrollbar + horizontal-scroll-bar (and horizontalp (make-pane 'scroll-bar :id :horizontal @@ -76,17 +76,17 @@ (sheet-adopt-child pane (cond ((and horizontalp verticalp) (tabling () - (viewport vertical-scrollbar) - (horizontal-scrollbar + (viewport vertical-scroll-bar) + (horizontal-scroll-bar nil))) (verticalp (horizontally () viewport - vertical-scrollbar)) + vertical-scroll-bar)) (horizontalp (vertically () viewport - horizontal-scrollbar)) + horizontal-scroll-bar)) (t (error "Should not have got here")))) @@ -94,41 +94,40 @@ ;;-- Add callbacks )))))) -(defun update-scrollbars (vp) +(defun update-scroll-bars (vp) ;;-- This is not the most efficient thing in the world (multiple-value-call - #'update-dynamic-scrollbars - vp (compute-dynamic-scrollbar-values vp)) + #'update-dynamic-scroll-bars + vp (compute-dynamic-scroll-bar-values vp)) (with-bounding-rectangle* (minx miny maxx maxy) - (let ((c (sheet-child vp))) - (if (typep c 'clim-internals::output-recording-mixin) - (stream-output-history c) - c)) + (let ((c (sheet-child vp))) + ;;--- This is a major kludge + (if (typep c 'clim-internals::output-recording-mixin) + (stream-output-history c) + c)) (with-bounding-rectangle* (vminx vminy vmaxx vmaxy) (viewport-viewport-region vp) - (with-slots (horizontal-scrollbar vertical-scrollbar) + (with-slots (horizontal-scroll-bar vertical-scroll-bar) (sheet-parent (sheet-parent vp)) - (update-scrollbar vertical-scrollbar + (update-scroll-bar vertical-scroll-bar miny maxy vminy vmaxy) - (update-scrollbar horizontal-scrollbar + (update-scroll-bar horizontal-scroll-bar minx maxx vminx vmaxx))))) - -;;;--- In the case where the viewport is bigger than the window this -;;;code gets things kind a wrong. Checkout the thinkadot puzzl. Its -;;;cos (- (--) (- vminx)) is -ve - -(defun update-scrollbar (scrollbar min max vmin vmax) +;;--- In the case where the viewport is bigger than the window this +;;--- code gets things wrong. Check out the thinkadot demo. It's +;;--- because (- (--) (- vmin)) is negative. +(defun update-scroll-bar (scroll-bar min max vmin vmax) (declare (optimize (safety 0) (speed 3))) - (with-slots (current-size current-value) scrollbar - ;; Kinda bogus benchmark optimization -- if the scrollbar was full size + (with-slots (current-size current-value) scroll-bar + ;; Kinda bogus benchmark optimization -- if the scroll-bar was full size ;; before, and the viewport is bigger than the extent, don't bother with ;; the fancy math. - (let ((range (float (gadget-range scrollbar) 0.0s0))) + (let ((range (float (gadget-range scroll-bar) 0.0s0))) (declare (type single-float range)) (if (and (and current-size (= (the single-float current-size) range)) (> (- vmax vmin) (- max min))) - (return-from update-scrollbar)) + (return-from update-scroll-bar)) (let* ((size (the single-float (* range (the single-float @@ -147,7 +146,7 @@ (the single-float (/ (float (- vmin min) 0.0s0) (float (- (- max min) (- vmax vmin)) 0.0s0)))))))))) - (value (+ (gadget-min-value scrollbar) + (value (+ (gadget-min-value scroll-bar) (* (- range size) pos)))) (declare (type single-float pos size)) (unless (and current-size @@ -156,14 +155,12 @@ (= current-value value)) (setf current-size size current-value value) - (change-scrollbar-values scrollbar + (change-scroll-bar-values scroll-bar :slider-size size :value value)))))) - - -(defmethod scrollbar-value-changed-callback :before - ((sheet scrollbar) +(defmethod scroll-bar-value-changed-callback :before + ((sheet scroll-bar) (client scroller-pane) id value size) @@ -173,14 +170,15 @@ current-value (float value 0.0s0)))) -(defmethod scrollbar-value-changed-callback (sheet +(defmethod scroll-bar-value-changed-callback (sheet (client scroller-pane) id value size) (with-slots (viewport contents) client + ;;--- This TYPEP stuff is a major kludge (let* ((extent (if (typep contents 'clim-internals::output-recording-mixin) - (stream-output-history contents) - contents)) + (stream-output-history contents) + contents)) (vp viewport) (viewport (viewport-viewport-region vp))) (case id @@ -206,34 +204,31 @@ (- (gadget-range sheet) size)))) :y (bounding-rectangle-min-y viewport))))))) -(defun update-region (stream nminx nminy nmaxx nmaxy &key no-repaint) - ;;-- I suspect that we should pass in mins and maxs since this does - ;;-- assume that the window origin is 0,0 and I think that this - ;;-- causes the compass menu test to fail since there are graphics at - ;;-- -ve coordinates. - #-ignore - (with-bounding-rectangle* - (l tt r b) stream - (when (or (< nminx l) - (< nminy tt) - (> nmaxx r) - (> nmaxy b)) - (setf (sheet-region stream) - (make-bounding-rectangle (min nminx l) - (min nminy tt) - (max nmaxx r) - (max nmaxy b))))) - #+ignore - (let ((width (- nmaxx nminx)) - (height (- nmaxy nminy))) - (when (or (> width (bounding-rectangle-width stream)) +(defun update-region (stream nleft ntop nright nbottom &key no-repaint) + ;;--- I suspect that we should pass in mins and maxs since this does + ;;--- assume that the window origin is 0,0 and I think that this + ;;--- causes the compass menu test to fail since there are graphics at + ;;--- negative coordinates. + #---ignore + (with-bounding-rectangle* (left top right bottom) stream + (when (or (< nleft left) + (< ntop top) + (> nright right) + (> nbottom bottom)) + (setf (sheet-region stream) + (make-bounding-rectangle (min nleft left) + (min ntop top) + (max nright right) + (max nbottom bottom))))) + #+++ignore + (let ((width (- nright nleft)) + (height (- nbottom ntop))) + (when (or (> width (bounding-rectangle-width stream)) (> height (bounding-rectangle-height stream))) (setf (sheet-region stream) - (make-bounding-rectangle 0 0 - (max (bounding-rectangle-width stream) width) - (max (bounding-rectangle-height - stream) height)))))) - + (make-bounding-rectangle 0 0 + (max (bounding-rectangle-width stream) width) + (max (bounding-rectangle-height stream) height)))))) (defun scroll-extent (stream &key (x 0) (y 0)) (let ((vp (pane-viewport stream))) @@ -243,68 +238,55 @@ ;;;---- This should actually bash the sheet-transformation (setf (sheet-transformation stream) (make-translation-transformation (- x) (- y))) - (bounding-rectangle-set-position* (viewport-viewport-region vp) x y) - ;;--- Is this the correct place - (update-scrollbars vp) + (bounding-rectangle-set-position (viewport-viewport-region vp) x y) + ;;--- Is this the correct place? + (update-scroll-bars vp) (with-bounding-rectangle* (nleft ntop nright nbottom) - (pane-viewport-region stream) - ;;-- Do we really want to do this here?? + (pane-viewport-region stream) + ;;--- Do we really want to do this here?? (update-region stream nleft ntop nright nbottom) (cond - ;; if some of the stuff that was previously on display is still on display - ;; bitblt it into the proper place and redraw the rest. - ((ltrb-overlaps-ltrb-p left top right bottom - nleft ntop nright nbottom) - ;; move the old stuff to the new position - #+ignore - (break "before shifting ~S" - (list (list left top right bottom) - (list nleft ntop nright nbottom))) - (window-shift-visible-region stream - left top right bottom - nleft ntop nright nbottom) - (let ((rectangles (ltrb-difference nleft ntop nright nbottom - left top right - bottom))) - #+ignore - (break "done shifting") - (with-sheet-medium (medium stream) - (dolist (region rectangles) - (multiple-value-call #'draw-rectangle* - medium - (bounding-rectangle* region) - :ink +background-ink+ :filled t) - #+ignore - (break "cleared region ~s" region) - (when (typep stream 'clim-internals::output-recording-mixin) - (replay (stream-output-history stream) stream - region)) - #+ignore - (break "done replay"))))) - ;; otherwise, just redraw the whole visible viewport - ;; adjust for the left and top margins by hand so clear-area doesn't erase - ;; the margin components. - ((typep stream 'clim-internals::output-recording-mixin) - (let ((region (viewport-viewport-region vp))) - ;;---- we should make the sheet-region bigger at this point - ;; perhaps we do a union of the sheet-region and the viewport - (with-sheet-medium (medium vp) - (draw-rectangle* medium - 0 0 - (bounding-rectangle-width region) - (bounding-rectangle-height region) - :ink +background-ink+ :filled t)) - (replay (stream-output-history stream) stream region))))))))) - + ;; if some of the stuff that was previously on display is still on display + ;; bitblt it into the proper place and redraw the rest. + ((ltrb-overlaps-ltrb-p left top right bottom + nleft ntop nright nbottom) + ;; move the old stuff to the new position + (window-shift-visible-region stream + left top right bottom + nleft ntop nright nbottom) + (let ((rectangles (ltrb-difference nleft ntop nright nbottom + left top right bottom))) + (with-sheet-medium (medium stream) + (dolist (region rectangles) + (multiple-value-call #'draw-rectangle* + medium + (bounding-rectangle* region) + :ink +background-ink+ :filled t) + (when (typep stream 'clim-internals::output-recording-mixin) + (replay (stream-output-history stream) stream region)))))) + ;; otherwise, just redraw the whole visible viewport + ;; adjust for the left and top margins by hand so clear-area doesn't erase + ;; the margin components. + ((typep stream 'clim-internals::output-recording-mixin) + (let ((region (viewport-viewport-region vp))) + ;;---- we should make the sheet-region bigger at this point + ;; perhaps we do a union of the sheet-region and the viewport + (with-sheet-medium (medium vp) + (draw-rectangle* medium + 0 0 + (bounding-rectangle-width region) + (bounding-rectangle-height region) + :ink +background-ink+ :filled t)) + (replay (stream-output-history stream) stream region))))))))) -;;; home-grown scrollbars +;;; Home-grown scroll-bars ;;--- orientation, min-value, max-value, unit-increment, page-increment. (defclass scroll-bar-pane - (scrollbar + (scroll-bar pane - ;;--- add immediate-sheet-input-mixin so that scroll bars + ;;--- Add IMMEDIATE-SHEET-INPUT-MIXIN so that scroll bars ;;--- get handled immediately by the event process? wrapping-space-mixin sheet-permanently-enabled-mixin @@ -319,7 +301,7 @@ (:default-initargs :value 0 :shaft-thickness 10)) -;;--- there should really be a small border around scroll bars so that +;;--- There should really be a small border around scroll bars so that ;;--- they don't butt right up against the viewport's drawing area (defmethod initialize-instance :after ((pane scroll-bar-pane) &key orientation shaft-thickness @@ -333,31 +315,31 @@ (vertically () (setq min-target-pane (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :less-than - :width shaft-thickness - :height shaft-thickness)) + :scroll-bar pane + :end :less-than + :width shaft-thickness + :height shaft-thickness)) (setq shaft-pane (make-pane 'scroll-bar-shaft-pane - :scroll-bar pane - :width shaft-thickness - :height 0 - :max-height +fill+)) + :scroll-bar pane + :width shaft-thickness + :height 0 + :max-height +fill+)) (setq max-target-pane (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :greater-than - :width shaft-thickness - :height shaft-thickness))))) + :scroll-bar pane + :end :greater-than + :width shaft-thickness + :height shaft-thickness))))) (:horizontal (spacing (:thickness 1) (horizontally () (setq min-target-pane (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :less-than - :width shaft-thickness - :height shaft-thickness)) + :scroll-bar pane + :end :less-than + :width shaft-thickness + :height shaft-thickness)) (setq shaft-pane (make-pane 'scroll-bar-shaft-pane :scroll-bar pane @@ -366,13 +348,13 @@ :height shaft-thickness)) (setq max-target-pane (make-pane 'scroll-bar-target-pane - :scroll-bar pane - :end :greater-than - :width shaft-thickness - :height shaft-thickness)))))))) + :scroll-bar pane + :end :greater-than + :width shaft-thickness + :height shaft-thickness)))))))) (sheet-adopt-child pane inferiors))))) -(defmethod change-scrollbar-values ((scrollbar scroll-bar-pane) &rest args +(defmethod change-scroll-bar-values ((scroll-bar scroll-bar-pane) &rest args &key slider-size value) (declare (ignore slider-size value)) ) @@ -404,7 +386,7 @@ (defmethod sheet-region-changed :after ((pane scroll-bar-target-pane) &key) (setf (slot-value pane 'coord-cache) nil)) -#+if-we-had-cheap-xforms... +#+If-we-had-cheap-xforms... (defmethod sheet-region-changed :after ((pane scroll-bar-target-pane) &key) (let ((cursor (sheet-cursor pane))) (ecase cursor @@ -430,7 +412,7 @@ :filled nil) (draw-target pane medium))) -;;; you can pass :filled t to this in order to highlight the target when clicked on... +;;; You can pass :filled T to this in order to highlight the target when clicked on... (defmethod draw-target ((pane scroll-bar-target-pane) medium &key filled (ink +foreground-ink+)) (let ((coord-cache (slot-value pane 'coord-cache))) @@ -601,8 +583,7 @@ (value (compute-symmetric-value min max coord min-value max-value))) (setf (gadget-value scroll-bar) value))) -;;;-- This looks like a value gadget to me - +;;;--- This looks like a value gadget to me (defmethod (setf gadget-value) (nv (pane scroll-bar-pane) &key) (with-slots (value) pane (setf value nv))) diff --git a/silica/db-slider.lisp b/silica/db-slider.lisp index 38fee356..a4534268 100644 --- a/silica/db-slider.lisp +++ b/silica/db-slider.lisp @@ -1,10 +1,11 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- +;; $fiHeader: db-slider.lisp,v 1.4 92/03/24 19:36:30 cer Exp $ + "Copyright (c) 1990, 1991 International Lisp Associates. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." -;; $fiHeader: db-slider.lisp,v 1.4 92/03/24 19:36:30 cer Exp Locker: cer $ - +;; $fiHeader: db-slider.lisp,v 1.5 92/04/03 12:04:13 cer Exp Locker: cer $ (in-package :silica) @@ -148,7 +149,6 @@ (value (compute-symmetric-value min max coord min-value max-value))) (setf (gadget-value pane) value))) - (defmethod (setf gadget-value) :around (nv (pane slider-pane) &key) (declare (ignore nv)) (if (port pane) diff --git a/silica/db-table.lisp b/silica/db-table.lisp index 23bd8d64..c17e3c3f 100644 --- a/silica/db-table.lisp +++ b/silica/db-table.lisp @@ -22,7 +22,7 @@ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. ;;; -;; $fiHeader: db-table.lisp,v 1.8 92/04/10 14:26:29 cer Exp Locker: cer $ +;; $fiHeader: db-table.lisp,v 1.9 92/04/14 15:29:35 cer Exp Locker: cer $ (in-package :silica) @@ -50,8 +50,8 @@ (defmacro tabling (options &body contents) `(make-pane 'table-pane - :contents (list ,@(mapcar #'(lambda (x) `(list ,@x)) contents)) - ,@options)) + :contents (list ,@(mapcar #'(lambda (x) `(list ,@x)) contents)) + ,@options)) (defmethod compose-space ((x table-pane) &key width height) (declare (ignore width height)) diff --git a/silica/event.lisp b/silica/event.lisp index 9a4acf62..1e4ee3eb 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.7 92/03/04 16:19:36 cer Exp $ +;; $fiHeader: event.lisp,v 1.8 92/03/10 10:11:38 cer Exp $ (in-package :silica) @@ -225,8 +225,8 @@ (dotimes (i (fill-pointer v) (fill-pointer v)) (unless (zerop i) (multiple-value-setq (new-x new-y) - (map-sheet-point*-to-child (aref v i) new-x new-y))) - (unless (region-contains-point*-p + (map-sheet-position-to-child (aref v i) new-x new-y))) + (unless (region-contains-position-p (sheet-region (aref v i)) new-x new-y) (return i)))) 0))) @@ -237,14 +237,14 @@ (generate-enter-event (aref v (1- i))))) (setf (fill-pointer v) m))) ;; If its empty initialize it - (when (region-contains-point*-p (sheet-region sheet) x y) + (when (region-contains-position-p (sheet-region sheet) x y) (when (zerop (fill-pointer v)) (vector-push-extend sheet v) (generate-enter-event sheet)) ;; We have to get the sheets into the correct coordinate space (loop for i from (1+ (position sheet v)) below (fill-pointer v) do (multiple-value-setq (x y) - (map-sheet-point*-to-child (aref v i) x y))) + (map-sheet-position-to-child (aref v i) x y))) ;; Add children (let ((new-x x) (new-y y) @@ -253,13 +253,13 @@ (loop (unless (typep sheet 'sheet-parent-mixin) (return nil)) - (setq child (child-containing-point* sheet new-x new-y)) + (setq child (child-containing-position sheet new-x new-y)) (unless child (return nil)) (generate-exit-event sheet) (generate-enter-event child) (multiple-value-setq (new-x new-y) - (map-sheet-point*-to-child child new-x new-y)) + (map-sheet-position-to-child child new-x new-y)) (setq sheet child) (vector-push-extend child v))))))) @@ -275,7 +275,7 @@ (aref v (1- (fill-pointer v))))))) (when (and sheet (port sheet)) (multiple-value-bind (tx ty) - (untransform-point* + (untransform-position (sheet-device-transformation sheet) x y) (dispatch-event sheet diff --git a/silica/framem.lisp b/silica/framem.lisp index 5bef8d40..4a623792 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: framem.lisp,v 1.3 92/03/24 19:36:37 cer Exp Locker: cer $ +;; $fiHeader: framem.lisp,v 1.4 92/04/10 14:26:31 cer Exp Locker: cer $ (in-package :silica) @@ -33,11 +33,11 @@ (defun find-frame-manager (&rest options &key (port (apply #'find-port options)) - &allow-other-keys) + &allow-other-keys) (declare (dynamic-extent options)) (second (or (assoc port *frame-managers*) - (car (push (list port (make-frame-manager port)) - *frame-managers*))))) + (car (push (list port (make-frame-manager port)) + *frame-managers*))))) (defmethod make-frame-manager (port) (cerror "Make a default frame manager" @@ -59,12 +59,10 @@ (let* ((top-pane (frame-panes frame)) (sheet (with-look-and-feel-realization (framem frame) (make-pane 'top-level-sheet - :region (multiple-value-bind (width height) - (bounding-rectangle-size top-pane) - (make-bounding-rectangle - 0 0 width height)) - :parent (find-graft - :port (port frame)))))) + :region (multiple-value-bind (width height) + (bounding-rectangle-size top-pane) + (make-bounding-rectangle 0 0 width height)) + :parent (find-graft :port (port frame)))))) (setf (frame-top-level-sheet frame) sheet (frame-shell frame) (sheet-shell sheet)) (sheet-adopt-child sheet (frame-panes frame))))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index f09a863f..70db1fdd 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.15 92/04/10 14:26:32 cer Exp Locker: cer $ +;; $fiHeader: gadgets.lisp,v 1.16 92/04/14 15:29:37 cer Exp Locker: cer $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -34,18 +34,17 @@ :reader gadget-disarmed-callback))) (defmethod armed-callback ((gadget gadget) (client t) (id t)) - (when (gadget-armed-callback gadget) - (invoke-callback-function (gadget-armed-callback gadget) gadget))) + (invoke-callback-function (gadget-armed-callback gadget) gadget)) (defmethod disarmed-callback ((gadget gadget) (client t) (id t)) - (when (gadget-disarmed-callback gadget) - (invoke-callback-function (gadget-disarmed-callback gadget) gadget))) + (invoke-callback-function (gadget-disarmed-callback gadget) gadget)) (defun invoke-callback-function (function &rest args) (declare (dynamic-extent args)) - (if (consp function) - (apply (car function) (append args (cdr function))) - (apply function args))) + (when function + (if (consp function) + (apply (car function) (append args (cdr function))) + (apply function args)))) (defclass value-gadget (gadget) @@ -55,8 +54,7 @@ :reader gadget-value-changed-callback))) (defmethod value-changed-callback ((gadget value-gadget) (client t) (id t) value) - (when (gadget-value-changed-callback gadget) - (invoke-callback-function (gadget-value-changed-callback gadget) gadget value))) + (invoke-callback-function (gadget-value-changed-callback gadget) gadget value)) (defgeneric gadget-value (gadget)) @@ -74,17 +72,12 @@ (defmethod (setf gadget-value) (nv (gadget value-gadget) &key) (declare (ignore nv))) -;;-- What is the correct default? - +;;--- What is the correct default for INVOKE-CALLBACK? (defmethod (setf gadget-value) :after (nv (gadget value-gadget) &key invoke-callback) (with-slots (value) gadget (setf value nv)) (when invoke-callback - (value-changed-callback - gadget - (gadget-client gadget) - (gadget-id gadget) - nv))) + (value-changed-callback gadget (gadget-client gadget) (gadget-id gadget) nv))) (defclass action-gadget (gadget) @@ -92,8 +85,7 @@ :reader gadget-activate-callback))) (defmethod activate-callback ((gadget action-gadget) (client t) (id t)) - (when (gadget-activate-callback gadget) - (invoke-callback-function (gadget-activate-callback gadget) gadget))) + (invoke-callback-function (gadget-activate-callback gadget) gadget)) ;;; Basic gadgets-mixins @@ -107,9 +99,9 @@ (defclass labelled-gadget () ((label :initarg :label :accessor gadget-label) - (alignment :initarg :x-align + (alignment :initarg :align-x :accessor gadget-alignment)) - (:default-initargs :label nil :x-align :center)) + (:default-initargs :label nil :align-x :center)) ;;--- Do the right thing #---ignore @@ -124,11 +116,10 @@ (values (+ 4 (stream-string-width text text-style medium)) (+ 4 (text-style-height text-style medium)))))) -;;;- We might want a way of changing the range and the value together. - +;;--- We might want a way of changing the range and the value together. (defclass range-gadget-mixin () - ((min-value :initarg :min-value :accessor gadget-min-value) - (max-value :initarg :max-value :accessor gadget-max-value)) + ((min-value :initarg :min-value :accessor gadget-min-value) + (max-value :initarg :max-value :accessor gadget-max-value)) (:default-initargs :min-value 0.0 :max-value 1.0)) (defmethod gadget-range ((gadget range-gadget-mixin)) @@ -138,36 +129,34 @@ (defmethod gadget-range* ((gadget range-gadget-mixin)) (values (gadget-min-value gadget) (gadget-max-value gadget))) + ;;; The intent is that the real implementations inherit from these ;;; Slider - (defclass slider - (value-gadget oriented-gadget range-gadget-mixin labelled-gadget) + (value-gadget oriented-gadget range-gadget-mixin labelled-gadget) ((drag-callback :initarg :drag-callback :initform nil :reader slider-drag-callback) (show-value-p :initarg :show-value-p :accessor gadget-show-value-p)) (:default-initargs :show-value-p nil)) + (defmethod drag-callback ((gadget slider) (client t) (id t) value) - (when (slider-drag-callback gadget) - (invoke-callback-function (slider-drag-callback gadget) gadget value))) + (invoke-callback-function (slider-drag-callback gadget) gadget value)) ;; Scroll bar - -(defclass scrollbar +(defclass scroll-bar (value-gadget range-gadget-mixin oriented-gadget) ((current-value :initform nil) (current-size :initform nil) (drag-callback :initarg :drag-callback :initform nil - :reader scrollbar-drag-callback))) + :reader scroll-bar-drag-callback))) -(defmethod drag-callback ((gadget scrollbar) (client t) (id t) value) - (when (scrollbar-drag-callback gadget) - (invoke-callback-function (scrollbar-drag-callback gadget) gadget value))) +(defmethod drag-callback ((gadget scroll-bar) (client t) (id t) value) + (invoke-callback-function (scroll-bar-drag-callback gadget) gadget value)) ;;; Push-button @@ -204,21 +193,24 @@ (value-gadget oriented-gadget) ((selections :initform nil :reader radio-box-selections) - ;;--- think about this + ;;--- think about this... (value :initform nil - :initarg :current-selection - :initarg :current - :accessor radio-box-current-selection))) + :initarg :current-selection + :accessor radio-box-current-selection))) (defmethod initialize-instance :after ((rb radio-box) &key choices) - (let ((fr (pane-frame rb))) - (with-look-and-feel-realization ((frame-manager fr) fr) + (let ((frame (pane-frame rb))) + (with-look-and-feel-realization ((frame-manager frame) frame) (dolist (choice choices) (make-pane 'toggle-button - :value (equal (radio-box-current-selection rb) choice) - :label (string choice) - :id choice - :parent rb))))) + :value (equal (radio-box-current-selection rb) choice) + :label (if (stringp choice) + (string choice) + (gadget-label choice)) + :id choice + :parent rb))))) + + ;;; Menu-bar @@ -229,16 +221,15 @@ ;; As well as the callback mechanism a we want to specify a binding to commands (defclass text-field (value-gadget action-gadget) - ()) + ()) (defclass text-editor (text-field) - ((ncolumns :initarg :ncolumns - :accessor gadget-columns) - (nlines :initarg :nlines - :accessor gadget-lines)) + ((ncolumns :initarg :ncolumns + :accessor gadget-columns) + (nlines :initarg :nlines + :accessor gadget-lines)) (:default-initargs :ncolumns 1 :nlines 1)) - ;;; Viewport @@ -261,8 +252,7 @@ ;;-- Make sure the child is at least as big as the viewport ;;-- Viewport-region-changed actually does this also (let* ((child (sheet-child viewport))) - (multiple-value-bind - (cwidth cheight) + (multiple-value-bind (cwidth cheight) (bounding-rectangle-size child) (when (or (< cwidth width) (< cheight height)) @@ -273,17 +263,17 @@ (defmethod compose-space ((viewport viewport) &key width height) (declare (ignore width height)) (let ((sr (call-next-method))) - (setq sr (silica::copy-space-requirement sr)) + (setq sr (copy-space-requirement sr)) (setf (space-requirement-min-width sr) 0 (space-requirement-min-height sr) 0) sr)) (defmethod allocate-space :after ((viewport viewport) width height) (bounding-rectangle-set-size - (viewport-viewport-region viewport) width height) + (viewport-viewport-region viewport) width height) ;; At this point it might make sense to move the viewport if it is ;; big enough to contain the contents - (update-scrollbars viewport) + (update-scroll-bars viewport) (viewport-region-changed (sheet-child viewport) viewport)) ;;--- Work on this @@ -293,27 +283,27 @@ (declare (ignore port-did-it)) (multiple-value-bind (changedp - hscrollbar hscrollbar-enabled-p - vscrollbar vscrollbar-enabled-p) - (compute-dynamic-scrollbar-values viewport) + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) + (compute-dynamic-scroll-bar-values viewport) (if changedp - (update-dynamic-scrollbars + (update-dynamic-scroll-bars viewport changedp - hscrollbar hscrollbar-enabled-p - vscrollbar vscrollbar-enabled-p) + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) (call-next-method)))) -(defun update-dynamic-scrollbars (viewport +(defun update-dynamic-scroll-bars (viewport changedp - hscrollbar hscrollbar-enabled-p - vscrollbar vscrollbar-enabled-p) + hscroll-bar hscroll-bar-enabled-p + vscroll-bar vscroll-bar-enabled-p) (when changedp - (when hscrollbar - (setf (sheet-enabled-p hscrollbar) hscrollbar-enabled-p)) - (when vscrollbar - (setf (sheet-enabled-p vscrollbar) vscrollbar-enabled-p)) + (when hscroll-bar + (setf (sheet-enabled-p hscroll-bar) hscroll-bar-enabled-p)) + (when vscroll-bar + (setf (sheet-enabled-p vscroll-bar) vscroll-bar-enabled-p)) (let ((table (sheet-parent viewport))) (clear-space-requirement-caches-in-tree table) (multiple-value-call @@ -321,9 +311,9 @@ table (bounding-rectangle-size table))))) -(defun compute-dynamic-scrollbar-values (viewport) - (with-slots ((hscrollbar horizontal-scrollbar ) - (vscrollbar vertical-scrollbar) +(defun compute-dynamic-scroll-bar-values (viewport) + (with-slots ((hscroll-bar horizontal-scroll-bar ) + (vscroll-bar vertical-scroll-bar) (scroll-bar-policy scroll-bars)) (sheet-parent (sheet-parent viewport)) (if (eq scroll-bar-policy :dynamic) @@ -333,16 +323,16 @@ (cwidth cheight) (bounding-rectangle-size (viewport-contents-extent viewport)) - (let ((ohenp (sheet-enabled-p hscrollbar)) - (ovenp (sheet-enabled-p vscrollbar)) + (let ((ohenp (sheet-enabled-p hscroll-bar)) + (ovenp (sheet-enabled-p vscroll-bar)) (nhenp (> cwidth vwidth)) (nvenp (> cheight vheight))) (values (not (and (eq ohenp nhenp) (eq ovenp nvenp))) - (and (not (eq ohenp nhenp)) hscrollbar) + (and (not (eq ohenp nhenp)) hscroll-bar) nhenp - (and (not (eq ovenp nvenp)) vscrollbar) + (and (not (eq ovenp nvenp)) vscroll-bar) nvenp)))) (values nil nil nil nil nil)))) @@ -352,14 +342,14 @@ (stream-output-history c) c))) -;;--- Need something in update-scrollbars also. +;;--- Need something in update-scroll-bars also. ;;; Then there is the layout stuff and scrolling macros (defmacro scrolling (options &body contents) `(make-pane 'scroller-pane - :contents ,@contents - ,@options)) + :contents ,@contents + ,@options)) (defmethod make-pane-1 ((framem standard-frame-manager) frame name &rest options) (declare (dynamic-extent options)) diff --git a/silica/graphics.lisp b/silica/graphics.lisp index 7cce79fe..0dec8cbe 100644 --- a/silica/graphics.lisp +++ b/silica/graphics.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics.lisp,v 1.7 92/03/24 19:36:41 cer Exp Locker: cer $ +;; $fiHeader: graphics.lisp,v 1.8 92/04/10 14:26:33 cer Exp Locker: cer $ (in-package :silica) @@ -88,51 +88,46 @@ arguments) (declare (ignore spread-arguments)) (list - `(define-compiler-macro ,spread-name - (&whole form - medium-or-stream - ,@spread-argument-names &rest drawing-options-and-keyword-arguments) - (or (transform-graphics-function-call - medium-or-stream - ',medium-graphics-function-name - ',drawing-options - ',other-keyword-arguments - (list ,@spread-argument-names) - drawing-options-and-keyword-arguments) - form)) - `(define-compiler-macro ,name - (&whole form medium-or-stream ,@unspread-argument-names - &rest drawing-options-and-keyword-arguments) - (or (transform-graphics-function-call - medium-or-stream - ',medium-graphics-function-name - ',drawing-options - ',other-keyword-arguments - (list ,@unspread-argument-names) - drawing-options-and-keyword-arguments - ',arguments) - form)))) + `(define-compiler-macro ,spread-name + (&whole form medium-or-stream ,@spread-argument-names + &rest drawing-options-and-keyword-arguments) + (or (transform-graphics-function-call + medium-or-stream + ',medium-graphics-function-name + ',drawing-options + ',other-keyword-arguments + (list ,@spread-argument-names) + drawing-options-and-keyword-arguments) + form)) + `(define-compiler-macro ,name + (&whole form medium-or-stream ,@unspread-argument-names + &rest drawing-options-and-keyword-arguments) + (or (transform-graphics-function-call + medium-or-stream + ',medium-graphics-function-name + ',drawing-options + ',other-keyword-arguments + (list ,@unspread-argument-names) + drawing-options-and-keyword-arguments + ',arguments) + form)))) (defun generate-argument-spreading-code (x) (if (consp x) (destructuring-bind (argname type . names) x (ecase type (point-sequence - (destructuring-bind (new-name) names - (values argname - (list `(unspread-point-sequence ,argname)) - (list new-name)))) + (destructuring-bind (new-name) names + (values argname + (list `(unspread-point-sequence ,argname)) + (list new-name)))) (point - (destructuring-bind (x y) names - (values - argname - (list `(point-x ,argname) - `(point-y ,argname)) - (list x y)))))) - (values - x - (list x) - (list x)))) + (destructuring-bind (x y) names + (values argname + (list `(point-x ,argname) + `(point-y ,argname)) + (list x y)))))) + (values x (list x) (list x)))) (defun decode-graphics-function-arguments (arguments) (let* ((keyn (position '&key arguments)) @@ -142,12 +137,11 @@ spread-arguments spread-argument-names) (dolist (x no-keyword) - (multiple-value-bind - (argname spread-args spread-values) + (multiple-value-bind (argname spread-args spread-values) (generate-argument-spreading-code x) - (push argname unspread-argument-names) + (push argname unspread-argument-names) (dolist (x spread-args) (push x spread-arguments)) - (dolist (x spread-values) (push x spread-argument-names)))) + (dolist (x spread-values) (push x spread-argument-names)))) (values (nreverse unspread-argument-names) (nreverse spread-arguments) (nreverse spread-argument-names) @@ -165,14 +159,13 @@ other-keyword-arguments required-arguments rest-argument - &optional - arguments) + &optional arguments) (let ((drawing-options - (mapcar #'(lambda (x) - (intern x :keyword)) - drawing-options))) + (mapcar #'(lambda (x) + (intern (symbol-name x) :keyword)) + drawing-options))) (flet ((kw-arg-keyword (x) - (intern (if (consp x) (car x) x) :keyword)) + (intern (symbol-name (if (consp x) (car x) x)) :keyword)) (kw-arg-default-value (x) (and (consp x) (second x)))) (when (do ((args rest-argument (cddr args))) @@ -184,96 +177,96 @@ (when (eq (kw-arg-keyword arg) (car args)) (return t))))) (return nil)))) - (let (bindings) + (let ((bindings nil)) (when arguments (setq required-arguments - (mapcan #'(lambda (arg req-arg) - (let ((g (gensym))) - (push (list g req-arg) bindings) - (if (consp arg) - (nth-value - 1 - (generate-argument-spreading-code - (cons g - (cdr arg)))) - (list g)))) - arguments - required-arguments)) + (mapcan #'(lambda (arg req-arg) + (let ((g (gensym))) + (push (list g req-arg) bindings) + (if (consp arg) + (multiple-value-bind (name spread) + (generate-argument-spreading-code + (cons g (cdr arg))) + (declare (ignore name)) + spread) + (list g)))) + arguments + required-arguments)) (setq bindings (nreverse bindings))) (let* ((stuff - (do ((args rest-argument (cddr args)) - (result nil)) - ((null args) - (nreverse result)) - (let ((kw (car args)) - (value (cadr args))) - (push (list kw (gensym) value) result)))) - (medium-or-stream-name (gensym)) + (do ((args rest-argument (cddr args)) + (result nil)) + ((null args) + (nreverse result)) + (let ((kw (car args)) + (value (cadr args))) + (push (list kw (gensymbol kw) value) result)))) + (medium-or-stream-name (gensymbol 'medium)) (call - `(,medium-graphics-function-name - ,medium-or-stream-name - ,@required-arguments - ,@(mapcar #'(lambda (kw-arg) - (or - (second (assoc (kw-arg-keyword kw-arg) stuff)) - (kw-arg-default-value kw-arg))) - other-keyword-arguments))) + `(,medium-graphics-function-name + ,medium-or-stream-name + ,@required-arguments + ,@(mapcar #'(lambda (kw-arg) + (or (second (assoc (kw-arg-keyword kw-arg) stuff)) + (kw-arg-default-value kw-arg))) + other-keyword-arguments))) (supplied-drawing-options - (mapcan #'(lambda (do) - (let ((x (assoc do stuff))) - (and x (list do (second x))))) - drawing-options))) + (mapcan #'(lambda (do) + (let ((x (assoc do stuff))) + (and x (list do (second x))))) + drawing-options))) `(let ((,medium-or-stream-name ,medium-or-stream)) (let ,bindings (let ,(mapcar #'(lambda (x) - (list (second x) (third x))) - stuff) - ,(if supplied-drawing-options - `(with-drawing-options + (list (second x) (third x))) + stuff) + ,(if supplied-drawing-options + `(with-drawing-options (,medium-or-stream-name ,@supplied-drawing-options) - ,call) - call)))))))))) -) ;eval-when + ,call) + call)))))))))) + +) ;eval-when -(defmacro transform-points ((transform) &rest points) - (when points - (assert (evenp (length points)) () - "Points must be x/y pairs. There are an odd number of elements in ~S" - points) +(defmacro transform-positions ((transform) &rest positions) + (when positions + (assert (evenp (length positions)) () + "Positions must be x/y pairs. There are an odd number of elements in ~S" + positions) (let ((xform '#:transform)) `(let ((,xform ,transform)) - ,@(do* ((points points (cddr points)) - (x (first points) (first points)) - (y (second points) (second points)) + ,@(do* ((positions positions (cddr positions)) + (x (first positions) (first positions)) + (y (second positions) (second positions)) (forms nil)) - ((null points) (nreverse forms)) + ((null positions) (nreverse forms)) (push `(multiple-value-setq (,x ,y) - (transform-point* ,xform ,x ,y)) + (transform-position ,xform ,x ,y)) forms)) (values))))) -;;; Update the points list in the reference. -(defmacro transform-point-sequence ((transform) points-reference) - (let ((pts-sequence '#:points-sequence) - (pts-temp '#:points) - (original-pts-temp '#:original-points) +;;; Update the positions list in the reference. +(defmacro transform-position-sequence ((transform) positions-reference) + (let ((pts-sequence '#:position-sequence) + (pts-temp '#:positions) + (original-pts-temp '#:original-positions) (xform '#:transform)) ;;--- is a run-time error check worth it? - `(let ((,pts-sequence ,points-reference) + `(let ((,pts-sequence ,positions-reference) (,xform ,transform)) (assert (evenp (length ,pts-sequence)) () - "Points must be x/y pairs. There are an odd number of elements in ~S" + "Positions must be x/y pairs. There are an odd number of elements in ~S" ,pts-sequence) - (setf ,points-reference + (setf ,positions-reference (let* ((,pts-temp (copy-list ,pts-sequence)) (,original-pts-temp ,pts-temp)) (dorest (pt ,pts-sequence cddr) (let ((x (first pt)) (y (second pt))) (multiple-value-bind (nx ny) - (transform-point* ,xform x y) + (transform-position ,xform x y) (setf (car ,pts-temp) nx ,pts-temp (cdr ,pts-temp) (car ,pts-temp) ny @@ -341,16 +334,6 @@ (setf (get ',name 'args) '((,@spread-argument-names ,@keyword-argument-names) ,@args)) - ,@(write-graphics-function-transformer - name - medium-graphics-function-name - unspread-argument-names - spread-arguments - spread-name - spread-argument-names - drawing-options - other-keyword-arguments - arguments) (defmethod ,medium-graphics-function-name ((sheet sheet) ,@spread-argument-names ,@keyword-argument-names) @@ -364,7 +347,7 @@ (let* ((sheet (medium-sheet medium))) ;; want to tranform stuff, set up clipping region etc etc ,@(and points-to-transform - `((transform-points + `((transform-positions ((medium-transformation medium)) ,@points-to-transform))) ,@(and distances-to-transform @@ -372,22 +355,25 @@ ((medium-transformation medium)) ,@distances-to-transform))) ,@(mapcar #'(lambda (seq) - `(transform-point-sequence + `(transform-position-sequence ((medium-transformation medium)) ,seq)) point-sequences-to-transform) (,port-function-name (port medium) sheet medium ,@spread-argument-names - ,@keyword-argument-names))))))) - - - - - + ,@keyword-argument-names))) + ,@(write-graphics-function-transformer + name + medium-graphics-function-name + unspread-argument-names + spread-arguments + spread-name + spread-argument-names + drawing-options + other-keyword-arguments + arguments))))) - - (define-graphics-function draw-point ((point point x y)) :drawing-options :point @@ -498,7 +484,9 @@ (height (pattern-height pattern))) (if (or clipping-region transformation) (with-drawing-options (medium :clipping-region clipping-region - :transformation transformation)) + :transformation transformation) + (draw-rectangle* medium x y (+ x width) (+ y height) + :filled t :ink pattern)) (draw-rectangle* medium x y (+ x width) (+ y height) :filled t :ink pattern)))) diff --git a/silica/layout.lisp b/silica/layout.lisp index b8575c8a..4fa0521d 100644 --- a/silica/layout.lisp +++ b/silica/layout.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: layout.lisp,v 1.10 92/04/03 12:04:16 cer Exp Locker: cer $ +;; $fiHeader: layout.lisp,v 1.11 92/04/10 14:26:34 cer Exp Locker: cer $ (in-package :silica) @@ -94,34 +94,35 @@ (defmacro vertically (options &body contents) `(make-pane 'vbox-pane - :contents (list ,@contents) - ,@options)) + :contents (list ,@contents) + ,@options)) + (defmacro horizontally (options &body contents) `(make-pane 'hbox-pane - :contents (list ,@contents) - ,@options)) + :contents (list ,@contents) + ,@options)) + (defmethod resize-sheet* ((sheet sheet) width height &key force) (when (or width height) - (with-bounding-rectangle* - (minx miny maxx maxy) sheet - (when (or force - (and width (/= (- maxx minx) width)) - (and height (/= (- maxy miny) height))) - (setf (sheet-region sheet) - (make-bounding-rectangle - minx miny - (if width (+ width minx) maxx) - (if height (+ height miny) maxy))))))) + (with-bounding-rectangle* (minx miny maxx maxy) sheet + (when (or force + (and width (/= (- maxx minx) width)) + (and height (/= (- maxy miny) height))) + (setf (sheet-region sheet) + (make-bounding-rectangle + minx miny + (if width (+ width minx) maxx) + (if height (+ height miny) maxy))))))) (defmethod move-and-resize-sheet* ((sheet sheet) minx miny width height) (resize-sheet* sheet width height) (let ((trans (sheet-transformation sheet))) (multiple-value-bind (x y) - (transform-point* trans 0 0) + (transform-position trans 0 0) (when (or (and minx (/= x minx)) (and miny (/= y miny))) (setf (sheet-transformation sheet) @@ -133,7 +134,7 @@ (defmethod move-sheet* ((sheet sheet) minx miny) (let ((trans (sheet-transformation sheet))) (multiple-value-bind (x y) - (transform-point* trans 0 0) + (transform-position trans 0 0) (when (or (/= x minx) (/= y miny)) (setf (sheet-transformation sheet) @@ -294,43 +295,37 @@ ;;--- CLIM 0.9 has some other methods on top-level sheets -- do we want them? - (defclass top-level-sheet - ( - ;; Have these so that we can use - clim-internals::window-stream - ;; - pane - wrapping-space-mixin - mirrored-sheet-mixin - sheet-multiple-child-mixin) + (;;--- Temporary kludge until we get the protocols correct + ;;--- so that ACCEPT works correctly on a raw sheet + clim-internals::window-stream + pane + wrapping-space-mixin + mirrored-sheet-mixin + sheet-multiple-child-mixin) () - (:default-initargs :text-cursor nil :text-margin 10)) - - -;; invoke-with-recording-options -;; default-text-margin -;; stream-read-gesture + ;;--- More of same... + (:default-initargs :text-cursor nil :text-margin 10)) +;;--- Needed methods include: +;;--- INVOKE-WITH-RECORDING-OPTIONS +;;--- DEFAULT-TEXT-MARGIN +;;--- STREAM-READ-GESTURE (defmethod note-layout-mixin-region-changed ((pane top-level-sheet) &key port) (if port (multiple-value-call #'layout-frame (pane-frame pane) (bounding-rectangle-size pane)) - (call-next-method))) - -;(defmethod allocate-space ((sheet top-level-sheet) width height) -; ;;--- To make openlook windows fill the vertical dimension we need -; ;;--- to do this why???. Actually doing this seems to make a lot of sense -; ;;--- Perhaps what should happen is that if the sheet-region is -; ;;--- changed by the port we should layout the entire frame instead -; (clear-space-requirement-caches-in-tree (first (sheet-children sheet))) -; ;; -; (resize-sheet* (first (sheet-children sheet)) width height)) -; -;(defmethod compose-space ((sheet top-level-sheet) &key width height) -; (compose-space (first (sheet-children sheet)) :width width :height height)) + (call-next-method))) + +#+++ignore +(defmethod allocate-space ((sheet top-level-sheet) width height) + (resize-sheet* (first (sheet-children sheet)) width height)) + +#+++ignore +(defmethod compose-space ((sheet top-level-sheet) &key width height) + (compose-space (first (sheet-children sheet)) :width width :height height)) (defclass leaf-pane diff --git a/silica/macros.lisp b/silica/macros.lisp index 7aa6ddf3..94f94e95 100644 --- a/silica/macros.lisp +++ b/silica/macros.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: macros.lisp,v 1.7 92/03/24 19:36:46 cer Exp Locker: cer $ +;; $fiHeader: macros.lisp,v 1.8 92/04/10 14:26:36 cer Exp Locker: cer $ (in-package :silica) @@ -58,10 +58,14 @@ (setq frame-manager `(frame-manager *application-frame*)) (setq frame `*application-frame*)) `(flet ((make-pane (pane-class &rest pane-options) - (apply #'make-pane-1 ,frame-manager ,frame pane-class pane-options))) + (declare (dynamic-extent pane-options)) + (apply #'make-pane-1 + ,frame-manager ,frame pane-class pane-options))) + (declare (dynamic-extent #'make-pane)) ,@forms)) (defun make-pane (pane-class &rest pane-options) (declare (ignore pane-class pane-options)) - (error "~S not inside a call to ~S" + (warn "~S not inside a call to ~S" 'make-pane 'with-look-and-feel-realization)) + diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 58331ae2..bc51723c 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: mirror.lisp,v 1.13 92/03/24 19:36:47 cer Exp Locker: cer $ +;; $fiHeader: mirror.lisp,v 1.14 92/03/30 17:52:06 cer Exp $ (in-package :silica) @@ -181,6 +181,7 @@ (when (sheet-direct-mirror sheet) (disable-mirror (port sheet) sheet))) + ;;--- What sucks big? (warn "This sucks big") @@ -188,7 +189,8 @@ (when (sheet-direct-mirror sheet) (update-mirror-region (port sheet) sheet))) -(defmethod note-sheet-region-changed :after ((sheet mirrored-sheet-mixin) &key port-did-it) +(defmethod note-sheet-region-changed :after ((sheet mirrored-sheet-mixin) + &key port-did-it) (when (sheet-direct-mirror sheet) (unless port-did-it (update-mirror-region (port sheet) sheet)))) @@ -198,9 +200,10 @@ ;; invalidate-cached-transformations does it anyway. #+ignore -(defmethod note-sheet-transformation-changed :after ((sheet mirrored-sheet-mixin) &key port-did-it) +(defmethod note-sheet-transformation-changed :after ((sheet mirrored-sheet-mixin) + &key port-did-it) (when (sheet-direct-mirror sheet) - (unless port + (unless port-did-it (update-mirror-region (port sheet) sheet)))) (defun sheet-top-level-mirror (sheet) diff --git a/silica/pkg.lisp b/silica/pkg.lisp deleted file mode 100644 index 559af541..00000000 --- a/silica/pkg.lisp +++ /dev/null @@ -1,248 +0,0 @@ -;; -*- mode: common-lisp; package: user -*- -;; -;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. -;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. -;; -;; The software, data and information contained herein are proprietary -;; to, and comprise valuable trade secrets of, Franz, Inc. They are -;; given in confidence by Franz, Inc. pursuant to a written license -;; agreement, and may be stored and used only in accordance with the terms -;; of such license. -;; -;; Restricted Rights Legend -;; ------------------------ -;; Use, duplication, and disclosure of the software, data and information -;; contained herein by any agency, department or entity of the U.S. -;; Government are subject to restrictions of Restricted Rights for -;; Commercial Software developed at private expense as specified in FAR -;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as -;; applicable. -;; -;; $fiHeader: pkg.lisp,v 1.3 92/01/02 15:09:18 cer Exp Locker: cer $ - -(defpackage :silica - (:use clim-lisp clim-utils) - (:export - #:*default-text-style* - #:*null-text-style* - #:*standard-character-set* - #:*undefined-text-style* - #:+fill+ - #:action-gadget - #:activate-gadget-event - #:add-text-style-mapping - #:adopt-child - #:adopt-frame - #:allocate-space - #:application-frame - #:beep - #:canvas - #:char-character-set-and-index - #:char-width - #:click-event - #:compose-space - #:copy-area - #:copy-area* - #:define-character-face - #:define-character-face-added-mappings - #:define-character-face-class - #:define-display-device - #:define-text-style-mappings - #:diacritic-char-p - #:disable-mirror - #:dispatch-event - #:dispatch-repaint - #:display-device - #:distribute-event - #:draw-circle - #:draw-circle* - #:draw-ellipse - #:draw-ellipse* - #:draw-image - #:draw-image* - #:draw-line - #:draw-line* - #:draw-lines - #:draw-lines* - #:draw-point - #:draw-point* - #:draw-points - #:draw-points* - #:draw-polygon - #:draw-polygon* - #:draw-rectangle - #:draw-rectangle* - #:draw-spline - #:draw-spline* - #:draw-text - #:draw-text* - #:draw-text-rectangle - #:draw-text-rectangle* - #:enable-mirror - #:engraft-medium - #:event-modifier-key-state - #:event-sheet - #:find-graft - #:find-port - #:find-port-type - #:frame-manager - #:frame-name - #:frame-panes - #:frame-shell - #:frame-top-level-sheet - #:gadget - #:get-port-canonical-gesture-spec - #:graft - #:graftp - #:handle-repaint - #:intern-text-style - #:key-press-event - #:key-release-event - #:keyboard-event-character - #:keyboard-event-key-name - #:make-frame-manager - #:make-medium - #:make-rectangle* - #:medium - #:medium-background - #:medium-clipping-region - #:medium-default-text-style - #:medium-draw-text - #:medium-foreground - #:medium-ink - #:medium-line-style - #:medium-sheet - #:medium-text-style - #:medium-transformation - #:merge-text-styles - #:merged-text-style - #:mirror-inside-edges* - #:mirror-native-edges* - #:mirror-region - #:mirror-region* - #:mirror-region-updated - #:mirrored-sheet-mixin - #:modifier-keysym - #:mute-repainting-mixin - #:note-frame-disabled - #:note-frame-enabled - #:note-sheet-grafted - #:note-sheet-region-changed - #:parse-gesture-spec - #:parse-text-style - #:permanent-medium-sheet-output-mixin - #:pointer-button-event - #:pointer-enter-event - #:pointer-event-native-x - #:pointer-event-native-y - #:pointer-event-x - #:pointer-event-y - #:pointer-exit-event - #:pointer-motion-event - #:pointer-native-event-x - #:pointer-native-event-y - #:pointer-press-event - #:pointer-release-event - #:port - #:port-color-cache - #:port-draw-line* - #:port-draw-rectangle* - #:port-draw-text* - #:port-event-wait - #:port-force-output - #:port-glyph-for-character - #:port-pointer - #:process-next-event - #:push-button - #:queue-event - #:realize-graft - #:realize-mirror - #:make-pane-internal - #:repaint-sheet - #:set-sheet-mirror-edges* - #:sheet - #:sheet-actual-native-edges - #:sheet-children - #:sheet-device-region - #:sheet-device-transformation - #:sheet-direct-mirror - #:sheet-enabled-p - #:sheet-height - #:sheet-leaf-mixin - #:sheet-medium - #:sheet-mirror - #:sheet-mirrored-ancestor - #:sheet-multiple-child-mixin - #:sheet-mute-input-mixin - #:sheet-native-transformation - #:sheet-parent - #:sheet-permanently-enabled-mixin - #:sheet-region - #:sheet-single-child-mixin - #:sheet-transformation - #:sheet-transformation-mixin - #:sheet-width - #:slider - #:standard-repainting-medium - #:standard-sheet - #:standard-sheet-input-mixin - #:standarize-style - #:stream-glyph-for-character - #:string-height - #:string-width - #:text-field - #:text-style - #:text-style-ascent - #:text-style-components - #:text-style-descent - #:text-style-face - #:text-style-family - #:text-style-height - #:text-style-mapping - #:text-style-scale - #:text-style-size - #:toggle-button - #:transform-point* - #:value-changed-gadget-event - #:value-gadget - #:window-configuration-event - #:window-repaint-event - #:with-drawing-options - #:with-rotation with-scaling - #:with-sheet-medium - #:with-text-face - #:with-text-family - #:with-text-size - #:with-text-style - #:with-translation - #:stream-write-string-internal - #:make-application-frame - #:enable-frame - #:sheet-event-queue - #:port-note-cursor-change - #:update-scrollbars - #:event - #:make-text-style - #:pointer-event-button - #:medium-+y-upward-p - #:define-application-frame - #:run-frame-top-level - #:vertically - #:make-pane - #:space-req-height - #:space-req-width - #:scroller-pane - - #:medium-merged-text-style - #:medium-default-text-style - #:medium-text-style - #:medium-merged-text-style-valid - #:beep - #:port-beep - #:port-server-path - #:change-space-req - )) - - - - diff --git a/silica/port.lisp b/silica/port.lisp index 76285a13..a055a86b 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -19,14 +19,19 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: port.lisp,v 1.8 92/03/10 10:11:43 cer Exp Locker: cer $ +;; $fiHeader: port.lisp,v 1.9 92/03/24 19:36:49 cer Exp $ (in-package :silica) ;; Ports and grafts -(defvar *default-server-path* '(:motif)) +(defvar *default-server-path* #+Allegro '(:motif) + #+Lucid '(:openlook) + #+Genera `(:genera :host ,net:*local-host* + :screen ,tv:main-screen) + #-(or Allegro Lucid Genera) nil) + (defvar *ports* nil) (defvar *port-type-mapping* nil) @@ -67,17 +72,15 @@ (declare (dynamic-extent function)) (mapc function *ports*)) -(defgeneric restart-port (port) - ) +(defgeneric restart-port (port)) (defmethod restart-port ((port port)) (when (port-process port) (destroy-process (port-process port))) (setf (port-process port) - (make-process #'(lambda () (port-event-loop port)) - :name (format nil - "CLIM Event Dispatcher for ~A" - (port-server-path port))))) + (make-process #'(lambda () (port-event-loop port)) + :name (format nil "CLIM Event Dispatcher for ~A" + (port-server-path port))))) (defgeneric port-event-loop (port) (:method ((port port)) @@ -113,11 +116,12 @@ (:method ((x graft)) t) (:method ((x t)) nil)) -(defun find-graft (&key - (server-path *default-server-path*) - (orientation :default) - (units :device) - (port (find-port :server-path server-path))) +(defun find-graft (&key (server-path *default-server-path*) + (port (find-port :server-path server-path)) + (orientation :default) + (units :device)) + (unless port + (setq port (find-port :server-path server-path))) (map-over-grafts #'(lambda (graft) (when (graft-matches-spec graft orientation units) (return-from find-graft graft))) @@ -134,8 +138,6 @@ (pushnew graft (port-grafts port)) (realize-graft port graft)) - - (defmethod update-mirror-region ((port port) (sheet graft)) ;;--- I don't think we ever change the region of a graft... ) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 8db70041..b8bbd381 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: sheet.lisp,v 1.8 92/03/24 19:36:50 cer Exp Locker: cer $ +;; $fiHeader: sheet.lisp,v 1.9 92/03/30 17:52:08 cer Exp $ (in-package :silica) @@ -134,37 +134,35 @@ ;;;; -(defgeneric map-sheet-point*-to-parent (sheet x y) +(defgeneric map-sheet-position-to-parent (sheet x y) (:method (sheet x y) - (transform-point* (sheet-transformation sheet) x y))) + (transform-position (sheet-transformation sheet) x y))) -(defgeneric map-sheet-point*-to-child (sheet x y) +(defgeneric map-sheet-position-to-child (sheet x y) (:method (sheet x y) - (untransform-point* (sheet-transformation sheet) x y))) + (untransform-position (sheet-transformation sheet) x y))) -(defgeneric map-child-bounding-rectangle*-to-parent (sheet min-x min-y max-x max-y) +(defgeneric map-sheet-rectangle*-to-parent (sheet min-x min-y max-x max-y) (:method (sheet min-x min-y max-x max-y) (transform-rectangle* (sheet-transformation sheet) min-x min-y max-x max-y))) -(defgeneric map-parent-bounding-rectangle*-to-child (sheet min-x min-y max-x max-y) +(defgeneric map-sheet-rectangle*-to-child (sheet min-x min-y max-x max-y) (:method (sheet min-x min-y max-x max-y) (untransform-rectangle* (sheet-transformation sheet) min-x min-y max-x max-y))) -(defgeneric child-containing-point (sheet point)) +(defgeneric child-containing-position (sheet x y)) -(defgeneric child-containing-point* (sheet x y)) - -(defmethod child-containing-point* (sheet x y) +(defmethod child-containing-position (sheet x y) (find-if #'(lambda (child) (and (sheet-enabled-p child) (multiple-value-bind (x y) - (untransform-point* (sheet-transformation child) x y) - (region-contains-point*-p (sheet-region child) x y)))) + (untransform-position (sheet-transformation child) x y) + (region-contains-position-p (sheet-region child) x y)))) (sheet-children sheet))) @@ -247,30 +245,33 @@ (or (graftp parent) (sheet-engrafted-p parent))))) -;;--- (defmethod (setf sheet-region) :after (nv sheet) (note-sheet-region-changed sheet)) (defgeneric note-sheet-region-changed (sheet &key port-did-it) - (:method (sheet &key port-did-it) (declare (ignore port-did-it)) nil)) + (:method (sheet &key port-did-it) + (declare (ignore port-did-it)) + nil)) +;;--- (defmethod (setf sheet-transformation) :after (nv sheet) (note-sheet-transformation-changed sheet)) (defgeneric note-sheet-transformation-changed (sheet &key port-did-it) - (:method (sheet &key port-did-it) (declare (ignore port-did-it)) nil)) - + (:method (sheet &key port-did-it) + (declare (ignore port-did-it)) + nil)) (defgeneric invalidate-cached-transformations (sheet) (:method ((sheet t)) nil) (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-transformations (sheet-children sheet)))) + (mapc #'invalidate-cached-transformations (sheet-children sheet)))) (defgeneric invalidate-cached-regions (sheet) - (:method ((sheet t)) nil) + (:method ((sheet t)) nil) (:method :after ((sheet sheet-parent-mixin)) - (mapc #'invalidate-cached-regions (sheet-children sheet)))) + (mapc #'invalidate-cached-regions (sheet-children sheet)))) (defmethod note-sheet-region-changed :before (sheet &key port-did-it) (declare (ignore port-did-it)) @@ -282,7 +283,6 @@ (invalidate-cached-transformations sheet) (invalidate-cached-regions sheet)) - (defgeneric update-native-transformation (port sheet)) (defmethod (setf sheet-enabled-p) :after (nv (sheet sheet)) diff --git a/sys/defsystem.lisp b/sys/defsystem.lisp index a2543564..783f7dfd 100644 --- a/sys/defsystem.lisp +++ b/sys/defsystem.lisp @@ -27,7 +27,7 @@ ;;; ;;;----------------------------------------------------------- -;; $fiHeader: defsystem.lisp,v 1.7 92/03/30 17:52:33 cer Exp Locker: cer $ +;; $fiHeader: defsystem.lisp,v 1.8 92/04/10 14:27:11 cer Exp Locker: cer $ ;; Add a feature for ANSI-adhering Lisps. So far, only Apple's ;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1. @@ -1072,7 +1072,10 @@ pathname fields are evaluated." #-(and ANSI-90 (not Allegro) (not Cloe)) (#+Allegro excl::without-package-locks #-Allegro progn - (defun translate-logical-pathname (path) path)) + +(defun translate-logical-pathname (path) path) + +) ;; Evaluate the BODY with the reader context and default pathname set up as ;; defined by the module. diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 69193d00..6d51331f 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.11 92/04/03 12:04:39 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.12 92/04/10 14:27:13 cer Exp Locker: cer $ (in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user) @@ -277,9 +277,9 @@ ("window-stream") ;; Presentation types - ("completer") ("ptypes1" :load-before-compile ("clim-defs")) + ("completer") ("presentations" :load-before-compile ("ptypes1")) ("translators" @@ -385,7 +385,7 @@ (clim-defsys:defsystem genera-clim (:default-pathname "SYS:CLIM;REL-2;GENERA;" :default-binary-pathname #+Genera "SYS:CLIM;REL-2;GENERA;" - :needed-systems (clim-standalone) +o :needed-systems (clim-standalone) :load-before-compile (clim-standalone)) ("pkgdcl") ("genera-port") @@ -412,9 +412,9 @@ #+(and Silica Allegro) (clim-defsys:defsystem xlib (:default-pathname (frob-pathname "xlib") - :default-binary-pathname (frob-pathname "xlib") - :needed-systems (clim-standalone) - :load-before-compile (clim-standalone)) + :default-binary-pathname (frob-pathname "xlib") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) ("pkg") #+++ignore ("ffi" :eval-after (mapc #'load '("xlib/xlib.lisp" "xlib/x11-keysyms.lisp" "xlib/last.lisp"))) @@ -425,7 +425,6 @@ ("x11-keysyms" :load-before-compile ("ffi")) ("last" :load-before-compile ("load-xlib" "xlib-funs"))) - #+(and Silica Allegro) (clim-defsys:defsystem xt-tk (:default-pathname (frob-pathname "tk") @@ -443,7 +442,7 @@ ("graphics") ;; Toolkit stuff - ;;; ("load-xt") + ;; ("load-xt") ("xtk") ("meta-tk") ("make-classes") @@ -462,11 +461,11 @@ :needed-systems (xt-tk) :load-before-compile (xt-tk)) ;; Motif specific stuff - ("xm-classes") ("load-xm") ;;--- This is really in tk but because of the loading ("xt-funs") ("xm-funs") + ("xm-classes") ("xm-init") ("xm-widgets") ("xm-font-list") @@ -484,9 +483,9 @@ :needed-systems (xt-tk) :load-before-compile (xt-tk)) ;; OpenLook specific stuff - ("ol-classes") ("load-ol") ("xt-funs") + ("ol-classes") ("ol-init") ("ol-callbacks") #+ignore("ol-examples") @@ -620,12 +619,12 @@ #+(and Silica ignore) (clim-defsys:import-into-sct 'motif-clim :subsystem t :pretty-name "Motif CLIM" - :default-pathname "SYS:CLIM;REL-2;XM-SILICA;") + :default-pathname "SYS:CLIM;REL-2;TK-SILICA;") #+(and Silica ignore) (clim-defsys:import-into-sct 'openlook-clim :subsystem t :pretty-name "OpenLook CLIM" - :default-pathname "SYS:CLIM;REL-2;XM-SILICA;") + :default-pathname "SYS:CLIM;REL-2;TK-SILICA;") #+(and Silica ignore) (sct:defsystem clim-tags-table diff --git a/test/test-suite.lisp b/test/test-suite.lisp index c31e9511..6ad6dd10 100644 --- a/test/test-suite.lisp +++ b/test/test-suite.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: test-suite.lisp,v 1.14 92/03/24 19:38:02 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.15 92/04/10 14:27:18 cer Exp Locker: cer $ (in-package :clim-user) @@ -812,7 +812,7 @@ people, shall not perish from the earth. (rect-width (- (floor width 11) 10)) (spacing 8)) (multiple-value-bind (x y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (dotimes (i 11) (stream-set-cursor-position* stream x y) (write-string (format nil "~1$" (float (/ i 10))) stream) @@ -1213,7 +1213,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-table-cell-test stream-cursor-position "multiple-value-bind, draw-rectangle" (multiple-value-bind (x y) - (stream-cursor-position* stream) + (stream-cursor-position stream) (draw-rectangle* stream x y (+ x 10) (+ y 10) :ink +yellow+))) (define-table-cell-test simple-surrounding "create record, query size, surround with rect" @@ -2050,49 +2050,49 @@ Luke Luck licks the lakes Luke's duck likes.")) (y start-y (+ y delta))) ((= y y-excursion)) (declare (fixnum x y)) - (window-set-viewport-position* stream x y) + (window-set-viewport-position stream x y) (force-output stream)) (do ((x start-x) (y y-excursion (- y delta))) ((= y start-y)) (declare (fixnum x y)) - (window-set-viewport-position* stream x y) + (window-set-viewport-position stream x y) (force-output stream)) (do ((x start-x (+ x delta)) (y start-y)) ((= x x-excursion)) (declare (fixnum x y)) - (window-set-viewport-position* stream x y) + (window-set-viewport-position stream x y) (force-output stream)) (do ((x x-excursion (- x delta)) (y start-y)) ((= x start-x)) (declare (fixnum x y)) - (window-set-viewport-position* stream x y) + (window-set-viewport-position stream x y) (force-output stream))) (define-benchmark (text-scrolling) (stream) "Scroll a window full of text, horizontally and vertically" (multiple-value-bind (start-x start-y) - (window-viewport-position* stream) + (window-viewport-position stream) (repeat 25 (write-string "Four score and seven years ago, our fathers..." stream) (terpri stream)) (force-output stream) - (window-set-viewport-position* stream start-x start-y) + (window-set-viewport-position stream start-x start-y) (scroll-kernel stream start-x start-y 400 400 25))) (define-benchmark (graphics-scrolling) (stream) "Scroll a window full of graphics, horizontally and vertically" (multiple-value-bind (start-x start-y) - (window-viewport-position* stream) + (window-viewport-position stream) (line-drawing-kernel stream 20) (shape-drawing-kernel stream 10 nil :clear nil) (scroll-kernel stream start-x start-y 400 400 25))) (defun refresh-kernel (stream iterations start-x start-y) (force-output stream) - (window-set-viewport-position* stream start-x start-y) + (window-set-viewport-position stream start-x start-y) (repeat iterations (window-refresh stream) (force-output stream))) @@ -2100,7 +2100,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (text-refresh) (stream) "Refresh a window full of text" (multiple-value-bind (start-x start-y) - (window-viewport-position* stream) + (window-viewport-position stream) (repeat 25 (write-string "Four score and seven years ago, our fathers..." stream) (terpri stream)) @@ -2109,7 +2109,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (define-benchmark (graphics-refresh) (stream) "Refresh a window full of graphics" (multiple-value-bind (start-x start-y) - (window-viewport-position* stream) + (window-viewport-position stream) (line-drawing-kernel stream 20) (shape-drawing-kernel stream 10 nil :clear nil) (refresh-kernel stream 5 start-x start-y))) @@ -2213,7 +2213,7 @@ Luke Luck licks the lakes Luke's duck likes.")) ((>= y 200)) (do ((x 0 (+ x 15))) ((>= x 450)) - (stream-set-pointer-position* stream x y) + (stream-set-pointer-position stream x y) (highlight-applicable-presentation *application-frame* stream input-context nil))))) @@ -2222,7 +2222,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (defun draw-menu-benchmark (stream) (fresh-line stream) (multiple-value-bind (x0 y0) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (ignore x0)) (formatting-item-list (stream :move-cursor t) (dolist (item '(("Red" :value +red+) @@ -2241,7 +2241,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (fresh-line stream) (force-output stream) (multiple-value-bind (x1 y1) - (stream-cursor-position* stream) + (stream-cursor-position stream) (declare (ignore x1)) (values y0 y1)))) @@ -2254,7 +2254,7 @@ Luke Luck licks the lakes Luke's duck likes.")) (repeat 10 (do ((y y0 (+ y 3))) ((>= y y1)) - (stream-set-pointer-position* stream 20 y) + (stream-set-pointer-position stream 20 y) (highlight-applicable-presentation *application-frame* stream input-context nil)))))) diff --git a/test/test.lisp b/test/test.lisp index a14f6ba8..44f236db 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.18 92/04/03 12:04:42 cer Exp Locker: cer $ +;; $fiHeader: test.lisp,v 1.19 92/04/10 14:27:21 cer Exp Locker: cer $ (in-package :clim-user) @@ -51,13 +51,13 @@ (scrolling () (make-pane 'interactor-pane)))) + (define-application-frame test-frame01 () () (:command-table test-frame) (:pane (scrolling () (make-pane 'interactor-pane)))) - (define-application-frame test-frame2 () () (:command-table test-frame) (:pane @@ -182,9 +182,9 @@ (d 10)) (accepting-values (stream :own-window own-window) (clim-internals::letf-globally (((stream-default-view stream) - (if textual-view - +textual-dialog-view+ - (stream-default-view stream)))) + (if textual-view + +textual-dialog-view+ + (stream-default-view stream)))) (setq a (accept 'boolean :stream stream :default a :prompt "a")) @@ -236,7 +236,7 @@ (setf (car weird) (with-output-as-presentation (stream weird 'some-kinda-gadget) (surrounding-output-with-border (stream) - (clim-internals::with-output-as-gadget (stream) + (with-output-as-gadget (stream) (scrolling () (make-pane 'interactor-pane))))))))) @@ -345,7 +345,6 @@ (defun slider-dragged-callback (slider value) (format t "~&Slider ~A dragged to ~S" (gadget-label slider) value)) - (defun text-field-changed (tf value) (format t "~&Text field ~A changed to ~S" tf value)) @@ -364,6 +363,7 @@ :prompt "Select an insect")) (describe bug)) + (define-application-frame tf100 () () (:command-table test-frame) @@ -381,6 +381,7 @@ :ncolumns 30 :nlines 10))))) + (define-application-frame tf99 () () (:command-table test-frame) (:pane diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 169df93d..f03fa8c5 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,14 +20,14 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.7 92/03/24 19:37:01 cer Exp Locker: cer $ +;; $fiHeader: ol-gadgets.lisp,v 1.8 92/04/10 14:27:47 cer Exp Locker: cer $ (in-package :xm-silica) (defmethod make-pane-class ((framem openlook-frame-manager) class &rest options) (declare (ignore options)) - (second (assoc class '((scroll-bar openlook-scrollbar) + (second (assoc class '((scroll-bar openlook-scroll-bar) (slider openlook-slider) (push-button openlook-push-button) (label-pane openlook-label-pane) @@ -54,26 +54,26 @@ ;;;;;;;;;;;;;;;;;;;; -(defclass openlook-scrollbar (xt-leaf-pane - scrollbar) +(defclass openlook-scroll-bar (xt-leaf-pane + scroll-bar) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) - (sheet openlook-scrollbar)) + (sheet openlook-scroll-bar)) (with-accessors ((orientation gadget-orientation)) sheet - (values 'tk::scrollbar + (values 'tk::scroll-bar (list :orientation orientation)))) -(defmethod (setf silica::scrollbar-size) (nv (sb openlook-scrollbar)) +(defmethod (setf silica::scroll-bar-size) (nv (sb openlook-scroll-bar)) ;; (tk::set-values (sheet-direct-mirror sb) :slider-size nv) nv) -(defmethod (setf silica::scrollbar-value) (nv (sb openlook-scrollbar)) +(defmethod (setf silica::scroll-bar-value) (nv (sb openlook-scroll-bar)) (tk::set-values (sheet-direct-mirror sb) :slider-value nv) nv) -(defmethod change-scrollbar-values ((sb openlook-scrollbar) &rest args +(defmethod change-scroll-bar-values ((sb openlook-scroll-bar) &rest args &key slider-size value) (declare (ignore args)) (tk::set-values @@ -82,24 +82,24 @@ :slider-value value)) -(defmethod add-sheet-callbacks ((port openlook-port) (sheet openlook-scrollbar) (widget t)) +(defmethod add-sheet-callbacks ((port openlook-port) (sheet openlook-scroll-bar) (widget t)) (tk::add-callback widget :slider-moved - 'scrollbar-changed-callback-1 + 'scroll-bar-changed-callback-1 sheet)) -(defmethod scrollbar-changed-callback-1 ((widget t) (sheet openlook-scrollbar)) +(defmethod scroll-bar-changed-callback-1 ((widget t) (sheet openlook-scroll-bar)) (multiple-value-bind (value size) (tk::get-values widget :slider-value :proportion-length) - (scrollbar-value-changed-callback + (scroll-bar-value-changed-callback sheet (gadget-client sheet) (gadget-id sheet) value size))) -(defmethod compose-space ((m openlook-scrollbar) &key width height) +(defmethod compose-space ((m openlook-scroll-bar) &key width height) (let ((x 16)) (ecase (gadget-orientation m) (:vertical @@ -152,7 +152,6 @@ :resize-callback 'sheet-mirror-resized-callback sheet)) - (defmethod find-widget-class-and-initargs-for-sheet ((port openlook-port) (parent t) (sheet openlook-top-level-sheet)) @@ -261,7 +260,6 @@ (command-button-callback button nil frame item)) - ;;; Label pane (defclass openlook-label-pane (xt-leaf-pane silica::label-pane) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 63a210b4..9ca10649 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.20 92/04/10 14:27:50 cer Exp Locker: cer $ +;; $fiHeader: xm-gadgets.lisp,v 1.21 92/04/14 15:30:10 cer Exp Locker: cer $ (in-package :xm-silica) @@ -28,7 +28,7 @@ ;; experiment (outlined-pane motif-frame-pane) ;; - (scroll-bar motif-scrollbar) + (scroll-bar motif-scroll-bar) (slider motif-slider) (push-button motif-push-button) (label-pane motif-label-pane) @@ -251,59 +251,56 @@ (defmethod compose-space ((m motif-slider) &key width height) (declare (ignore width height)) (destructuring-bind - (label scrollbar) (tk::widget-children (sheet-direct-mirror m)) - (declare (ignore scrollbar)) + (label scroll-bar) (tk::widget-children (sheet-direct-mirror m)) + (declare (ignore scroll-bar)) (multiple-value-bind (label-x label-y label-width label-height) - (and (gadget-label m) - (tk::widget-best-geometry label)) + (if (gadget-label m) + (tk::widget-best-geometry label) + (values nil nil 0 0)) (declare (ignore label-x label-y)) ;;-- We need to estimate the space requirements for the value if ;;-- that is shown (let ((fudge 16)) (ecase (gadget-orientation m) (:vertical - (make-space-requirement :width (if (gadget-label m) ; - (+ fudge label-width) - fudge) + (make-space-requirement :width (+ fudge label-width) :min-height fudge :height (max (* 2 fudge) label-height) :max-height +fill+)) (:horizontal - (make-space-requirement :height (if (gadget-label m) ; - (+ fudge label-height) - fudge) + (make-space-requirement :height (+ fudge label-height) :min-width fudge :width (max (* 2 fudge) label-width) :max-width +fill+))))))) -;;; Scrollbar +;;; Scroll-Bar -(defclass motif-scrollbar (xt-leaf-pane - scrollbar) +(defclass motif-scroll-bar (xt-leaf-pane + scroll-bar) ()) (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) - (sheet motif-scrollbar)) + (sheet motif-scroll-bar)) (with-accessors ((orientation gadget-orientation)) sheet ;;-- we should really decide what the min and max resources should be (values 'tk::xm-scroll-bar (list :orientation orientation)))) -(defmethod (setf silica::scrollbar-size) (nv (sb motif-scrollbar)) +(defmethod (setf silica::scroll-bar-size) (nv (sb motif-scroll-bar)) (tk::set-values (sheet-direct-mirror sb) :slider-size (floor nv)) nv) -(defmethod (setf silica::scrollbar-value) (nv (sb motif-scrollbar)) +(defmethod (setf silica::scroll-bar-value) (nv (sb motif-scroll-bar)) (tk::set-values (sheet-direct-mirror sb) :value nv) nv) ;;;--- We should use the motif functions for getting and changing the ;;;--- values -(defmethod change-scrollbar-values ((sb motif-scrollbar) &key slider-size value) +(defmethod change-scroll-bar-values ((sb motif-scroll-bar) &key slider-size value) (let ((mirror (sheet-direct-mirror sb))) (multiple-value-bind (smin smax) (silica::gadget-range* sb) @@ -312,28 +309,28 @@ (tk::set-values mirror :slider-size - (integerize-coordinate + (fix-coordinate (silica::compute-symmetric-value smin smax slider-size mmin mmax)) - :value (integerize-coordinate + :value (fix-coordinate (silica::compute-symmetric-value smin smax value mmin mmax))))))) -(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scrollbar) (widget t)) +(defmethod add-sheet-callbacks ((port motif-port) (sheet motif-scroll-bar) (widget t)) (tk::add-callback widget :value-changed-callback - 'scrollbar-changed-callback-1 + 'scroll-bar-changed-callback-1 sheet)) -(defun scrollbar-changed-callback-1 (widget sheet) +(defun scroll-bar-changed-callback-1 (widget sheet) (multiple-value-bind (smin smax) (silica::gadget-range* sheet) (multiple-value-bind (value size mmin mmax) (tk::get-values widget :value :slider-size :minimum :maximum) - (scrollbar-value-changed-callback + (scroll-bar-value-changed-callback sheet (gadget-client sheet) (gadget-id sheet) @@ -343,7 +340,7 @@ mmin mmax size smin smax))))) -(defmethod compose-space ((m motif-scrollbar) &key width height) +(defmethod compose-space ((m motif-scroll-bar) &key width height) (let ((x 16)) (ecase (gadget-orientation m) (:vertical @@ -357,14 +354,13 @@ :width (* 2 x) :max-width +fill+))))) -;; Should we stick in our preferred scrollbar geometry here? +;; Should we stick in our preferred scroll-bar geometry here? ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass motif-top-level-sheet (top-level-sheet) ()) - (defmethod add-sheet-callbacks :after ((port motif-port) (sheet motif-top-level-sheet) (widget tk::xm-drawing-area)) @@ -466,7 +462,6 @@ (getf initargs :y) (floor top)) initargs)) - (defmethod compose-space ((te motif-text-editor) &key width height) (declare (ignore width height)) (let ((sr (call-next-method))) @@ -475,6 +470,7 @@ (space-requirement-max-height sr) +fill+) sr)) + ;;; Toggle button (defclass motif-toggle-button (xt-leaf-pane @@ -515,7 +511,7 @@ sheet)) -(defun scrollbar-changed-callback (widget which scroller) +(defun scroll-bar-changed-callback (widget which scroller) (let* ((vp (sheet-child scroller)) (viewport (viewport-viewport-region vp)) (extent (stream-output-history (sheet-child vp)))) diff --git a/tk-silica/xm-silica.lisp b/tk-silica/xm-silica.lisp index 67256b84..6235b73e 100644 --- a/tk-silica/xm-silica.lisp +++ b/tk-silica/xm-silica.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-silica.lisp,v 1.12 92/04/03 12:04:54 cer Exp Locker: cer $ +;; $fiHeader: xm-silica.lisp,v 1.13 92/04/10 14:27:53 cer Exp Locker: cer $ (in-package :xm-silica) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 3fa2ce7f..86dc1e50 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.6 92/03/24 19:37:13 cer Exp Locker: cer $ +;; $fiHeader: xt-frames.lisp,v 1.7 92/04/10 14:27:56 cer Exp Locker: cer $ (in-package :xm-silica) @@ -33,34 +33,34 @@ (defmethod frame-wrapper ((framem xt-frame-manager) (frame standard-application-frame) pane) (declare (ignore pane)) - (let ((menu-bar (slot-value frame 'menu-bar))) - (if menu-bar - (with-look-and-feel-realization (framem frame) - (let ((mb (make-pane 'menu-bar - :command-table (if (eq menu-bar t) - (frame-command-table frame) - (find-command-table - menu-bar)))) - (next (call-next-method)) - (pointer - (if (clim-internals::frame-pointer-documentationp frame) - (setf (slot-value frame 'clim-internals::pointer-documentation-pane) - (make-pane - 'clim-internals::pointer-documentation-pane - :max-width +fill+ - ;;-- This should be a better value! - :height 15))))) - (if pointer - (vertically () mb next pointer) - (vertically () mb next)))) - (call-next-method)))) + (with-look-and-feel-realization (framem frame) + (let* ((menu-bar (slot-value frame 'menu-bar)) + (menu-bar-pane + (and menu-bar + (make-pane 'menu-bar + :command-table (if (eq menu-bar t) + (frame-command-table frame) + (find-command-table menu-bar))))) + (pointer-doc-pane + ;;--- Don't like these forward references + (and (clim-internals::frame-pointer-documentation-p frame) + (setf (slot-value frame 'clim-internals::pointer-documentation-pane) + (make-pane + 'clim-internals::pointer-documentation-pane + :max-width +fill+ + ;;--- This should be one line height in some text style + :height 15)))) + (application-panes (call-next-method))) + (cond ((and menu-bar-pane pointer-doc-pane) + (vertically () menu-bar-pane application-panes pointer-doc-pane)) + (menu-bar-pane + (vertically () menu-bar-pane application-panes)) + (pointer-doc-pane + (vertically () application-panes pointer-doc-pane)) + (t + application-panes))))) -(defmethod clim-internals::port-notify-user ((port xt-port) frame format-string &rest format-arguments) - (format excl::*initial-terminal-io* - "Notify ~a~%" - (list frame format-string format-arguments))) - ;;; (defclass presentation-event (event) @@ -87,3 +87,8 @@ :sheet (frame-top-level-sheet frame) :value (second item)))) +(defmethod clim-internals::port-notify-user ((port xt-port) + frame format-string &rest format-arguments) + (format excl::*initial-terminal-io* + "Notify ~a~%" + (list frame format-string format-arguments))) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index eda498c3..91b84420 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -20,21 +20,20 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-gadgets.lisp,v 1.8 92/04/03 12:04:56 cer Exp Locker: cer $ +;; $fiHeader: xt-gadgets.lisp,v 1.9 92/04/10 14:27:57 cer Exp Locker: cer $ (in-package :xm-silica) (defclass ask-widget-for-size-mixin () ()) (defmethod make-pane-1 ((framem xt-frame-manager) - frame abstract-type &rest options) + frame abstract-type &rest options) (let ((type (apply #'make-pane-class framem abstract-type options))) (if type (apply #'make-instance type :frame frame :frame-manager framem - (apply #'make-pane-arglist - framem abstract-type options)) + (apply #'make-pane-arglist framem abstract-type options)) (call-next-method)))) (defmethod compose-space ((pane ask-widget-for-size-mixin) &key width height) @@ -131,6 +130,8 @@ ask-widget-for-size-mixin) ()) +;;--- This isn't really right. Genera and CLX ports have kludges +;;--- for the time being, too. (defmethod sheet-shell (sheet) (do ((w (sheet-mirror sheet) (tk::widget-parent w))) ((typep w '(or tk::shell null)) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 55a526f1..b111efc1 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.14 92/03/30 17:52:48 cer Exp Locker: cer $ +;; $fiHeader: xt-graphics.lisp,v 1.15 92/04/10 14:27:58 cer Exp Locker: cer $ (in-package :xm-silica) @@ -102,8 +102,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (defun color-medium-p (medium) (and *use-color* (let ((display (port-display (port (medium-sheet medium))))) - (> (x11:xdefaultdepth display - (tk::display-screen-number display)) 2)))) + (> (x11:xdefaultdepth display (tk::display-screen-number display)) 2)))) (defun recompute-gcs (medium) (with-slots @@ -342,21 +341,15 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (unless (eq mcr +everywhere+) (setq mcr (transform-region (sheet-device-transformation sheet) mcr)) (setq dr (region-intersection dr (bounding-rectangle mcr)))) - (cond ((or #+ignore t (eq dr +everywhere+)) - (setf (tk::gcontext-clip-mask gc) - :none)) + (cond ((eq dr +everywhere+) + (setf (tk::gcontext-clip-mask gc) :none)) ((eq dr +nowhere+) - (setf (tk::gcontext-clip-mask gc) - :nowhere)) + (setf (tk::gcontext-clip-mask gc) :nowhere)) (t - (with-bounding-rectangle* - (a b c d) dr - (with-stack-list (x - (integerize-coordinate a) - (integerize-coordinate b) - (integerize-coordinate (- c a)) - (integerize-coordinate (- d b))) - (setf (tk::gcontext-clip-mask gc) x)))))) + (with-bounding-rectangle* (a b c d) dr + (with-stack-list (x (fix-coordinate a) (fix-coordinate b) + (fix-coordinate (- c a)) (fix-coordinate (- d b))) + (setf (tk::gcontext-clip-mask gc) x)))))) (when (eq (tk::gcontext-fill-style gc) :tiled) (setf (tk::gcontext-ts-x-origin gc) x-origin @@ -489,7 +482,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (incf npoints)) (t npoints))))) (window (medium-drawable medium)) - ;;--- is this right + ;; These really are fixnums, since we're fixing coordinates below (minx most-positive-fixnum) (miny most-positive-fixnum)) (do ((ps list-of-x-and-ys (cddr ps)) @@ -513,10 +506,10 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (tk::object-display window) window (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx miny) + (decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + minx miny) points npoints x11:complex @@ -525,10 +518,10 @@ U;; -*- mode: common-lisp; package: xm-silica -*- (tk::object-display window) window (adjust-ink medium - (decode-ink (medium-ink medium) medium) - (medium-ink medium) - (medium-line-style medium) - minx miny) + (decode-ink (medium-ink medium) medium) + (medium-ink medium) + (medium-line-style medium) + minx miny) points npoints x11:coordmodeorigin))))) diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp index 0600ef4a..0560b773 100644 --- a/tk-silica/xt-pixmaps.lisp +++ b/tk-silica/xt-pixmaps.lisp @@ -20,15 +20,14 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-pixmaps.lisp,v 1.3 92/02/24 13:06:28 cer Exp $ +;; $fiHeader: xt-pixmaps.lisp,v 1.4 92/03/04 16:20:45 cer Exp Locker: cer $ (in-package :xm-silica) (defmethod port-allocate-pixmap ((port xt-port) sheet width height) (declare (ignore sheet)) - (assert (integerp width)) - (assert (integerp height)) + (fix-coordinates width height) (let ((root (tk::display-root-window (port-display port)))) (make-instance 'tk::pixmap :drawable root diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 2093e51b..61e3e7b7 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-silica.lisp,v 1.17 92/04/03 12:04:58 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.18 92/04/10 14:27:59 cer Exp Locker: cer $ (in-package :xm-silica) @@ -37,7 +37,6 @@ (:default-initargs :allow-loose-text-style-size-mapping t) (:documentation "The port for X intrinsics based ports")) - (defmethod port-copy-gc ((port xt-port)) (with-slots (copy-gc display) port (or copy-gc @@ -46,7 +45,6 @@ :display display :foreign-address (x11:screen-default-gc (x11:xdefaultscreenofdisplay (port-display port)))))))) - (defmacro destructure-x-server-path ((&key display) path &body body) ;;-- Of course the port ends up with an unspecified server-path. ;;-- Perhaps this is OK or perhaps we have to default the components before @@ -70,11 +68,11 @@ (slot-value port 'display) display) (initialize-xlib-port port display)))) -(defvar *clx-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*") - (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*") - (:serif "*-*-charter-*-*-*-*-*-*-*-*-*-*-*-*" - "*-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*" - "*-*-times-*-*-*-*-*-*-*-*-*-*-*-*"))) +(defvar *xt-font-families* '((:fix "*-*-courier-*-*-*-*-*-*-*-*-*-*-*-*") + (:sans-serif "*-*-helvetica-*-*-*-*-*-*-*-*-*-*-*-*") + (:serif "*-*-charter-*-*-*-*-*-*-*-*-*-*-*-*" + "*-*-new century schoolbook-*-*-*-*-*-*-*-*-*-*-*-*" + "*-*-times-*-*-*-*-*-*-*-*-*-*-*-*"))) (defun disassemble-x-font-name (name) (let ((cpos 0) @@ -90,7 +88,7 @@ (reverse tokens))) -(defvar *clx-fallback-font* "8x13" +(defvar *xt-fallback-font* "8x13" "When non NIL and nothing better exists use this as the fallback font") (defmethod initialize-xlib-port (port display) @@ -109,7 +107,7 @@ (point-size (float designed-point-size)) (size (/ point-size 10))) (make-text-style family face size)))) - (dolist (family-stuff *clx-font-families*) + (dolist (family-stuff *xt-font-families*) (let ((family (car family-stuff))) (dolist (font-pattern (cdr family-stuff)) (dolist (xfont (tk::list-font-names display font-pattern)) @@ -123,22 +121,22 @@ )) (let (temp) (cond ((setq temp - (dolist (family *clx-font-families*) + (dolist (family *xt-font-families*) (when (text-style-mapping-exists-p port `(,(car family) :roman 10)) (return (make-text-style (car family) :roman 10))))) (setf (text-style-mapping port (port-undefined-text-style port)) temp)) ;; Perhaps we should look for some other conveniently sized ;; fonts. - (*clx-fallback-font* + (*xt-fallback-font* (setf (text-style-mapping port (port-undefined-text-style port)) (make-instance 'tk::font :display display - :name *clx-fallback-font*))) + :name *xt-fallback-font*))) ;;; Perhaps we should just grab the first font we can find. (t (error "Unable to determine default font")))))) -(defparameter *clx-logical-size-alist* +(defparameter *xt-logical-size-alist* '((:tiny 6) (:very-small 8) (:small 10) @@ -150,13 +148,12 @@ (defmethod standardize-text-style ((port xt-port) style &optional (character-set *standard-character-set*)) (standardize-text-style-1 - port style character-set *clx-logical-size-alist*)) + port style character-set *xt-logical-size-alist*)) (defmethod destroy-mirror ((port xt-port) sheet) ;;-- I dont think that we should do this. - (tk::destroy-widget (sheet-direct-mirror sheet)) - ) + (tk::destroy-widget (sheet-direct-mirror sheet))) (defmethod realize-mirror ((port xt-port) sheet) (let ((parent (find-widget-parent port sheet))) @@ -197,27 +194,25 @@ sheet) nil) (:key-press - (multiple-value-bind - (character keysym) + (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) (make-instance 'key-press-event :key-name keysym :character character :sheet sheet - :modifiers + :modifiers (state->modifiers (x11::xkeyevent-state event) nil)))) (:key-release - (multiple-value-bind - (character keysym) + (multiple-value-bind (character keysym) (lookup-character-and-keysym sheet widget event) (make-instance 'key-release-event :key-name keysym :character character :sheet sheet - :modifiers + :modifiers (state->modifiers (x11::xkeyevent-state event) nil)))) @@ -253,25 +248,25 @@ :button (x-button->silica-button button) :modifiers (state->modifiers - modifiers) + (x11::xkeyevent-state event)) :sheet sheet)) (:enter-notify (make-instance 'pointer-enter-event :native-x native-x :native-y native-y :button (x-button->silica-button button) - :modifiers + :modifiers (state->modifiers - modifiers) + (x11::xkeyevent-state event)) :sheet sheet)) (:motion-notify (make-instance 'pointer-motion-event :native-x native-x :native-y native-y :button (x-button->silica-button button) - :modifiers + :modifiers (state->modifiers - modifiers) + (x11::xkeyevent-state event)) :sheet sheet))))) (when clim-event (distribute-event @@ -320,31 +315,29 @@ (:key-press (distribute-event (port sheet) - (multiple-value-bind - (character keysym) - (lookup-character-and-keysym sheet widget event) - (make-instance 'key-press-event - :key-name keysym - :character character - :sheet sheet - :modifiers - (state->modifiers - (x11::xkeyevent-state event) - nil))))) + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (make-instance 'key-press-event + :key-name keysym + :character character + :sheet sheet + :modifiers + (state->modifiers + (x11::xkeyevent-state event) + nil))))) (:key-release - (distribute-event - (port sheet) - (multiple-value-bind - (character keysym) - (lookup-character-and-keysym sheet widget event) - (make-instance 'key-release-event - :key-name keysym - :character character - :sheet sheet - :modifiers - (state->modifiers - (x11::xkeyevent-state event) - nil))))) + (distribute-event + (port sheet) + (multiple-value-bind (character keysym) + (lookup-character-and-keysym sheet widget event) + (make-instance 'key-release-event + :key-name keysym + :character character + :sheet sheet + :modifiers + (state->modifiers + (x11::xkeyevent-state event) + nil))))) (:button-press (distribute-event (port sheet) @@ -352,7 +345,7 @@ :sheet sheet :x :?? :y :?? - :modifiers + :modifiers (state->modifiers (x11::xkeyevent-state event)) :button (x-button->silica-button @@ -397,10 +390,10 @@ ;;--- We do not want to specify the x,y if this is a top-level ;;sheet. (unless (typep parent 'tk::shell) - (setf (getf initargs :x) (integerize-coordinate left) - (getf initargs :y) (integerize-coordinate top))) - (setf (getf initargs :width) (integerize-coordinate (- right left)) - (getf initargs :height) (integerize-coordinate (- bottom top))))) + (setf (getf initargs :x) (fix-coordinate left) + (getf initargs :y) (fix-coordinate top))) + (setf (getf initargs :width) (fix-coordinate (- right left)) + (getf initargs :height) (fix-coordinate (- bottom top))))) initargs) ;; If we are creating a top level sheet then we have to create a shell for it @@ -518,10 +511,10 @@ target-right target-bottom) (let ((w (- target-right target-left)) (h (- target-bottom target-top))) - (setf target-left (integerize-coordinate target-left) - target-top (integerize-coordinate target-top) - w (integerize-coordinate w) - h (integerize-coordinate h)) + (setf target-left (fix-coordinate target-left) + target-top (fix-coordinate target-top) + w (fix-coordinate w) + h (fix-coordinate h)) (change-widget-geometry ;;--- For top level sheets the sheet-parent is the graft whose ;; mirror is the application shell @@ -621,176 +614,173 @@ (and frame (popup-frame-p frame)))) -;;; Keysym stuff -(defvar *clx-keysym->clim-keysym-table* - (make-hash-table)) +;;; Keysym stuff -(defvar *clim-keysym->clx-keysym-table* (make-hash-table)) +(defvar *xt-keysym->clim-keysym-table* (make-hash-table)) +(defvar *clim-keysym->xt-keysym-table* (make-hash-table)) -(defmacro define-clx-keysym (clx-keysym clim-keysym) +(defmacro define-xt-keysym (xt-keysym clim-keysym) `(progn - (setf (gethash ,clx-keysym *clx-keysym->clim-keysym-table*) ',clim-keysym) - (unless (gethash ,clim-keysym *clim-keysym->clx-keysym-table*) - (setf (gethash ,clim-keysym *clim-keysym->clx-keysym-table*) ',clx-keysym)))) + (setf (gethash ,xt-keysym *xt-keysym->clim-keysym-table*) ',clim-keysym) + (unless (gethash ,clim-keysym *clim-keysym->xt-keysym-table*) + (setf (gethash ,clim-keysym *clim-keysym->xt-keysym-table*) ',xt-keysym)))) -(defun-inline clx-keysym->keysym (clx-keysym) - (gethash clx-keysym *clx-keysym->clim-keysym-table*)) +(defun-inline xt-keysym->keysym (xt-keysym) + (gethash xt-keysym *xt-keysym->clim-keysym-table*)) -(defun-inline keysym->clx-keysym (keysym) - (gethash keysym *clim-keysym->clx-keysym-table*)) +(defun-inline keysym->xt-keysym (keysym) + (gethash keysym *clim-keysym->xt-keysym-table*)) ;; The standard characters -(define-clx-keysym 032 :space) -(define-clx-keysym 033 :\!) -(define-clx-keysym 034 :\") -(define-clx-keysym 035 :\#) -(define-clx-keysym 036 :\$) -(define-clx-keysym 037 :\%) -(define-clx-keysym 038 :\&) -(define-clx-keysym 039 :\') -(define-clx-keysym 040 :\() -(define-clx-keysym 041 :\)) -(define-clx-keysym 042 :\*) -(define-clx-keysym 043 :\+) -(define-clx-keysym 044 :\,) -(define-clx-keysym 045 :\-) -(define-clx-keysym 046 :\.) -(define-clx-keysym 047 :\/) -(define-clx-keysym 048 :\0) -(define-clx-keysym 049 :\1) -(define-clx-keysym 050 :\2) -(define-clx-keysym 051 :\3) -(define-clx-keysym 052 :\4) -(define-clx-keysym 053 :\5) -(define-clx-keysym 054 :\6) -(define-clx-keysym 055 :\7) -(define-clx-keysym 056 :\8) -(define-clx-keysym 057 :\9) -(define-clx-keysym 058 :\:) -(define-clx-keysym 059 :\;) -(define-clx-keysym 060 :\<) -(define-clx-keysym 061 :\=) -(define-clx-keysym 062 :\>) -(define-clx-keysym 063 :\?) -(define-clx-keysym 064 :\@) -(define-clx-keysym 065 :\A) -(define-clx-keysym 097 :\A) -(define-clx-keysym 066 :\B) -(define-clx-keysym 098 :\B) -(define-clx-keysym 067 :\C) -(define-clx-keysym 099 :\C) -(define-clx-keysym 068 :\D) -(define-clx-keysym 100 :\D) -(define-clx-keysym 069 :\E) -(define-clx-keysym 101 :\E) -(define-clx-keysym 070 :\F) -(define-clx-keysym 102 :\F) -(define-clx-keysym 071 :\G) -(define-clx-keysym 103 :\G) -(define-clx-keysym 072 :\H) -(define-clx-keysym 104 :\H) -(define-clx-keysym 073 :\I) -(define-clx-keysym 105 :\I) -(define-clx-keysym 074 :\J) -(define-clx-keysym 106 :\J) -(define-clx-keysym 075 :\K) -(define-clx-keysym 107 :\K) -(define-clx-keysym 076 :\L) -(define-clx-keysym 108 :\L) -(define-clx-keysym 077 :\M) -(define-clx-keysym 109 :\M) -(define-clx-keysym 078 :\N) -(define-clx-keysym 110 :\N) -(define-clx-keysym 079 :\O) -(define-clx-keysym 111 :\O) -(define-clx-keysym 080 :\P) -(define-clx-keysym 112 :\P) -(define-clx-keysym 081 :\Q) -(define-clx-keysym 113 :\Q) -(define-clx-keysym 082 :\R) -(define-clx-keysym 114 :\R) -(define-clx-keysym 083 :\S) -(define-clx-keysym 115 :\S) -(define-clx-keysym 084 :\T) -(define-clx-keysym 116 :\T) -(define-clx-keysym 085 :\U) -(define-clx-keysym 117 :\U) -(define-clx-keysym 086 :\V) -(define-clx-keysym 118 :\V) -(define-clx-keysym 087 :\W) -(define-clx-keysym 119 :\W) -(define-clx-keysym 088 :\X) -(define-clx-keysym 120 :\X) -(define-clx-keysym 089 :\Y) -(define-clx-keysym 121 :\Y) -(define-clx-keysym 090 :\Z) -(define-clx-keysym 122 :\Z) -(define-clx-keysym 091 :\[) -(define-clx-keysym 092 :\\) -(define-clx-keysym 093 :\]) -(define-clx-keysym 094 :\^) -(define-clx-keysym 095 :\_) -(define-clx-keysym 096 :\`) -(define-clx-keysym 123 :\{) -(define-clx-keysym 124 :\|) -(define-clx-keysym 125 :\}) -(define-clx-keysym 126 :\~) +(define-xt-keysym 032 :space) +(define-xt-keysym 033 :\!) +(define-xt-keysym 034 :\") +(define-xt-keysym 035 :\#) +(define-xt-keysym 036 :\$) +(define-xt-keysym 037 :\%) +(define-xt-keysym 038 :\&) +(define-xt-keysym 039 :\') +(define-xt-keysym 040 :\() +(define-xt-keysym 041 :\)) +(define-xt-keysym 042 :\*) +(define-xt-keysym 043 :\+) +(define-xt-keysym 044 :\,) +(define-xt-keysym 045 :\-) +(define-xt-keysym 046 :\.) +(define-xt-keysym 047 :\/) +(define-xt-keysym 048 :\0) +(define-xt-keysym 049 :\1) +(define-xt-keysym 050 :\2) +(define-xt-keysym 051 :\3) +(define-xt-keysym 052 :\4) +(define-xt-keysym 053 :\5) +(define-xt-keysym 054 :\6) +(define-xt-keysym 055 :\7) +(define-xt-keysym 056 :\8) +(define-xt-keysym 057 :\9) +(define-xt-keysym 058 :\:) +(define-xt-keysym 059 :\;) +(define-xt-keysym 060 :\<) +(define-xt-keysym 061 :\=) +(define-xt-keysym 062 :\>) +(define-xt-keysym 063 :\?) +(define-xt-keysym 064 :\@) +(define-xt-keysym 065 :\A) +(define-xt-keysym 097 :\A) +(define-xt-keysym 066 :\B) +(define-xt-keysym 098 :\B) +(define-xt-keysym 067 :\C) +(define-xt-keysym 099 :\C) +(define-xt-keysym 068 :\D) +(define-xt-keysym 100 :\D) +(define-xt-keysym 069 :\E) +(define-xt-keysym 101 :\E) +(define-xt-keysym 070 :\F) +(define-xt-keysym 102 :\F) +(define-xt-keysym 071 :\G) +(define-xt-keysym 103 :\G) +(define-xt-keysym 072 :\H) +(define-xt-keysym 104 :\H) +(define-xt-keysym 073 :\I) +(define-xt-keysym 105 :\I) +(define-xt-keysym 074 :\J) +(define-xt-keysym 106 :\J) +(define-xt-keysym 075 :\K) +(define-xt-keysym 107 :\K) +(define-xt-keysym 076 :\L) +(define-xt-keysym 108 :\L) +(define-xt-keysym 077 :\M) +(define-xt-keysym 109 :\M) +(define-xt-keysym 078 :\N) +(define-xt-keysym 110 :\N) +(define-xt-keysym 079 :\O) +(define-xt-keysym 111 :\O) +(define-xt-keysym 080 :\P) +(define-xt-keysym 112 :\P) +(define-xt-keysym 081 :\Q) +(define-xt-keysym 113 :\Q) +(define-xt-keysym 082 :\R) +(define-xt-keysym 114 :\R) +(define-xt-keysym 083 :\S) +(define-xt-keysym 115 :\S) +(define-xt-keysym 084 :\T) +(define-xt-keysym 116 :\T) +(define-xt-keysym 085 :\U) +(define-xt-keysym 117 :\U) +(define-xt-keysym 086 :\V) +(define-xt-keysym 118 :\V) +(define-xt-keysym 087 :\W) +(define-xt-keysym 119 :\W) +(define-xt-keysym 088 :\X) +(define-xt-keysym 120 :\X) +(define-xt-keysym 089 :\Y) +(define-xt-keysym 121 :\Y) +(define-xt-keysym 090 :\Z) +(define-xt-keysym 122 :\Z) +(define-xt-keysym 091 :\[) +(define-xt-keysym 092 :\\) +(define-xt-keysym 093 :\]) +(define-xt-keysym 094 :\^) +(define-xt-keysym 095 :\_) +(define-xt-keysym 096 :\`) +(define-xt-keysym 123 :\{) +(define-xt-keysym 124 :\|) +(define-xt-keysym 125 :\}) +(define-xt-keysym 126 :\~) ;; The semi-standard characters - - (defmacro keysym (b &rest more) (dolist (n more) (setq b (+ (ash b 8) n))) b) -(define-clx-keysym (keysym 255 013) :return) -(define-clx-keysym (keysym 255 009) :tab) -(define-clx-keysym (keysym 255 255) :rubout) -(define-clx-keysym (keysym 255 008) :backspace) -(define-clx-keysym (keysym 009 227) :page) -(define-clx-keysym (keysym 255 010) :linefeed) +(define-xt-keysym (keysym 255 013) :return) +(define-xt-keysym (keysym 255 009) :tab) +(define-xt-keysym (keysym 255 255) :rubout) +(define-xt-keysym (keysym 255 008) :backspace) +(define-xt-keysym (keysym 009 227) :page) +(define-xt-keysym (keysym 255 010) :linefeed) ;; Other useful characters -(define-clx-keysym (keysym 255 087) :end) -(define-clx-keysym (keysym 255 105) :abort) -(define-clx-keysym (keysym 255 106) :help) -(define-clx-keysym (keysym 255 104) :complete) -(define-clx-keysym (keysym 255 086) :scroll) -(define-clx-keysym (keysym 255 097) :refresh) -(define-clx-keysym (keysym 255 011) :clear-input) +(define-xt-keysym (keysym 255 087) :end) +(define-xt-keysym (keysym 255 105) :abort) +(define-xt-keysym (keysym 255 106) :help) +(define-xt-keysym (keysym 255 104) :complete) +(define-xt-keysym (keysym 255 086) :scroll) +(define-xt-keysym (keysym 255 097) :refresh) +(define-xt-keysym (keysym 255 011) :clear-input) ;; Finally, the shifts ;; snarfed from translate.cl -(defconstant left-shift-keysym (keysym 255 225)) +(defconstant left-shift-keysym (keysym 255 225)) (defconstant right-shift-keysym (keysym 255 226)) -(defconstant left-control-keysym (keysym 255 227)) +(defconstant left-control-keysym (keysym 255 227)) (defconstant right-control-keysym (keysym 255 228)) -(defconstant caps-lock-keysym (keysym 255 229)) +(defconstant caps-lock-keysym (keysym 255 229)) (defconstant shift-lock-keysym (keysym 255 230)) -(defconstant left-meta-keysym (keysym 255 231)) +(defconstant left-meta-keysym (keysym 255 231)) (defconstant right-meta-keysym (keysym 255 232)) -(defconstant left-alt-keysym (keysym 255 233)) +(defconstant left-alt-keysym (keysym 255 233)) (defconstant right-alt-keysym (keysym 255 234)) -(defconstant left-super-keysym (keysym 255 235)) +(defconstant left-super-keysym (keysym 255 235)) (defconstant right-super-keysym (keysym 255 236)) -(defconstant left-hyper-keysym (keysym 255 237)) +(defconstant left-hyper-keysym (keysym 255 237)) (defconstant right-hyper-keysym (keysym 255 238)) -(define-clx-keysym left-shift-keysym :left-shift) -(define-clx-keysym right-shift-keysym :right-shift) -(define-clx-keysym left-control-keysym :left-control) -(define-clx-keysym right-control-keysym :right-control) -(define-clx-keysym caps-lock-keysym :caps-lock) -(define-clx-keysym shift-lock-keysym :shift-lock) -(define-clx-keysym left-meta-keysym :left-meta) -(define-clx-keysym right-meta-keysym :right-meta) -(define-clx-keysym left-super-keysym :left-super) -(define-clx-keysym right-super-keysym :right-super) -(define-clx-keysym left-hyper-keysym :left-hyper) -(define-clx-keysym right-hyper-keysym :right-hyper) +(define-xt-keysym left-shift-keysym :left-shift) +(define-xt-keysym right-shift-keysym :right-shift) +(define-xt-keysym left-control-keysym :left-control) +(define-xt-keysym right-control-keysym :right-control) +(define-xt-keysym caps-lock-keysym :caps-lock) +(define-xt-keysym shift-lock-keysym :shift-lock) +(define-xt-keysym left-meta-keysym :left-meta) +(define-xt-keysym right-meta-keysym :right-meta) +(define-xt-keysym left-super-keysym :left-super) +(define-xt-keysym right-super-keysym :right-super) +(define-xt-keysym left-hyper-keysym :left-hyper) +(define-xt-keysym right-hyper-keysym :right-hyper) (defun lookup-character-and-keysym (sheet mirror event) (declare (ignore sheet mirror)) @@ -829,18 +819,13 @@ cltl1:char-control-bit 0) (if (logtest x +meta-key+) cltl1:char-meta-bit 0)))))) - (values character - (clx-keysym->keysym keysym)))) + (values character (xt-keysym->keysym keysym)))) -(defun state->modifiers (x &optional (shiftit t)) +(defun state->modifiers (x &optional (shift-it t)) (logior - (if (and shiftit (logtest x x11:shiftmask)) +shift-key+ 0) - (if (logtest x x11:controlmask) +control-key+ 0) - (if (logtest x x11:mod1mask) +meta-key+ 0) - (if (logtest x x11:mod2mask) +super-key+ 0) - (if (logtest x x11:mod3mask) +hyper-key+ 0))) - - - - + (if (and shift-it (logtest x x11:shiftmask)) +shift-key+ 0) + (if (logtest x x11:controlmask) +control-key+ 0) + (if (logtest x x11:mod1mask) +meta-key+ 0) + (if (logtest x x11:mod2mask) +super-key+ 0) + (if (logtest x x11:mod3mask) +hyper-key+ 0))) diff --git a/tk/event.lisp b/tk/event.lisp index 6dbb8f82..759f10f9 100644 --- a/tk/event.lisp +++ b/tk/event.lisp @@ -20,11 +20,10 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: event.lisp,v 1.6 92/03/09 17:40:35 cer Exp Locker: cer $ +;; $fiHeader: event.lisp,v 1.7 92/03/30 17:51:31 cer Exp $ (in-package :tk) - (defun simple-event-loop (context) (loop (process-one-event context))) @@ -74,8 +73,6 @@ (defun app-process-event (context mask) (app_process_event context mask)) - - (defvar *event* nil) (defun-c-callable event-handler ((widget :unsigned-long) diff --git a/tk/font.lisp b/tk/font.lisp index 8fe7aa43..e936c9cc 100644 --- a/tk/font.lisp +++ b/tk/font.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: font.lisp,v 1.7 92/03/09 17:40:39 cer Exp $ +;; $fiHeader: font.lisp,v 1.8 92/03/30 17:51:32 cer Exp $ (in-package :tk) @@ -36,7 +36,7 @@ (let ((x (x11:xloadqueryfont display name))) (when (zerop x) (error "Cannot find font: ~S" name)) (setf (foreign-pointer-address f) x) - (register-address f x)))) + (register-address f)))) (defun query-font (display font-id) diff --git a/tk/foreign.lisp b/tk/foreign.lisp index e59353d3..d5ffe848 100644 --- a/tk/foreign.lisp +++ b/tk/foreign.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: foreign.lisp,v 1.7 92/03/30 17:51:33 cer Exp Locker: cer $ +;; $fiHeader: foreign.lisp,v 1.8 92/04/03 12:03:57 cer Exp Locker: cer $ (in-package :tk) @@ -86,5 +86,3 @@ (setf (foreign-pointer-address d) (or display (apply #'open-display args)))) - - diff --git a/tk/gcontext.lisp b/tk/gcontext.lisp index 6f690ccd..9765f84a 100644 --- a/tk/gcontext.lisp +++ b/tk/gcontext.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: gcontext.lisp,v 1.8 92/03/09 17:40:43 cer Exp $ +;; $fiHeader: gcontext.lisp,v 1.9 92/03/30 17:51:35 cer Exp $ (in-package :tk) @@ -78,7 +78,6 @@ (defclass gcontext (display-object) ()) - (defmethod initialize-instance :after ((gcontext gcontext) @@ -93,6 +92,7 @@ exposures clip-x clip-y clip-mask clip-ordering dash-offset dashes) + (unless foreign-address (setf foreign-address (x11::xcreategc display drawable 0 0) (foreign-pointer-address gcontext) foreign-address diff --git a/tk/graphics.lisp b/tk/graphics.lisp index a59ed0e2..8472c13a 100644 --- a/tk/graphics.lisp +++ b/tk/graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: graphics.lisp,v 1.5 92/03/09 17:40:45 cer Exp Locker: cer $ +;; $fiHeader: graphics.lisp,v 1.6 92/03/24 19:36:10 cer Exp $ (in-package :tk) @@ -99,8 +99,7 @@ (- center-y y-radius) (* 2 x-radius) (* 2 y-radius) - start-angle - end-angle)))) + start-angle end-angle)))) (defstub draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex)) @@ -190,7 +189,6 @@ (defun draw-string (drawable gc x y string &optional (start 0) end) (unless start (setq start 0)) (unless end (setq end (length string))) - #-ignore (x11::xdrawstring (object-display drawable) drawable diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index dd26be3f..5458a634 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.11 92/03/30 17:51:42 cer Exp Locker: cer $ +;; $fiHeader: make-classes.lisp,v 1.12 92/04/03 12:04:03 cer Exp Locker: cer $ (in-package :tk) @@ -82,6 +82,7 @@ (defmethod widget-display ((object xt-root-class)) (object-display object)) + (defclass rect (xt-root-class) ()) (defclass un-named-obj (rect) ()) @@ -159,7 +160,7 @@ :resources all-resources :constraints all-constraints :entry-point class-ep - :foreign-address (get-foreign-variable-value class-ep)))) + :foreign-address (get-foreign-variable-value class-ep)))) (register-address class) (add-accessors-for-toolkit-class class) (push class r))))))) @@ -245,7 +246,7 @@ (defun-c-callable toolkit-error-handler ((message :unsigned-long)) - (error "toolkit errror: ~a" (char*-to-string message))) + (error "toolkit error: ~a" (char*-to-string message))) (defun-c-callable toolkit-warning-handler ((message :unsigned-long)) (let ((*error-output* excl:*initial-terminal-io*)) diff --git a/tk/ol-examples.lisp b/tk/ol-examples.lisp index ee732d4d..ef1c6af4 100644 --- a/tk/ol-examples.lisp +++ b/tk/ol-examples.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-examples.lisp,v 1.4 92/01/31 14:55:03 cer Exp $ +;; $fiHeader: ol-examples.lisp,v 1.5 92/02/24 13:03:40 cer Exp Locker: cer $ (in-package :tk) @@ -52,7 +52,7 @@ :height 100 :parent control)) - (setq scrollbar (make-instance 'scrollbar + (setq scroll-bar (make-instance 'scroll-bar :orientation :horizontal :height 100 :parent control)) diff --git a/tk/resources.lisp b/tk/resources.lisp index f9e77af7..c80a7551 100644 --- a/tk/resources.lisp +++ b/tk/resources.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: resources.lisp,v 1.13 92/04/03 12:04:06 cer Exp Locker: cer $ +;; $fiHeader: resources.lisp,v 1.14 92/04/10 14:26:17 cer Exp Locker: cer $ (in-package :tk) @@ -34,8 +34,6 @@ (elt ',elements value)))) - - (defun set-values (widget &rest values) (let ((arglist (make-arglist-for-class (class-of widget) widget values))) (set_values widget @@ -63,6 +61,11 @@ (push (convert-resource-out parent (resource-type resource) value) new-args))))) + +(defmethod convert-resource-out (parent type value) + (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value) + (convert-resource-out parent type value)) + (defmethod convert-resource-out :around (parent type value) (declare (optimize (speed 3)) (ignore parent type value)) @@ -71,11 +74,6 @@ result (ff:foreign-pointer-address result)))) -(defmethod convert-resource-out (parent type value) - (cerror "Try again" "cannot convert-out resource for ~S,~S,~S" parent type value) - (convert-resource-out parent type value)) - - (defmethod convert-resource-out ((parent t) (type (eql 'xm-string)) value) (string_create_l_to_r (string-to-char* value) (string-to-char* ""))) @@ -84,8 +82,6 @@ (:vertical 1) (:horizontal 2))) - - (def-c-type (x-arglist :in-foreign-space) 1 :unsigned-long) (defun get-values (widget &rest resources) diff --git a/tk/widget.lisp b/tk/widget.lisp index 8ace3d9c..af9eb3d4 100644 --- a/tk/widget.lisp +++ b/tk/widget.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: widget.lisp,v 1.14 92/03/30 17:51:51 cer Exp Locker: cer $ +;; $fiHeader: widget.lisp,v 1.15 92/04/10 14:26:19 cer Exp Locker: cer $ (in-package :tk) @@ -46,8 +46,6 @@ :display display args)))) - - (defun create-widget (name widget-class parent &rest args) (apply #'create-widget-1 #'create_widget name widget-class parent @@ -69,40 +67,29 @@ arglist (truncate (length arglist) 2)))) - - (defun realize-widget (widget) (realize_widget widget)) - - (defun manage-child (child) (manage_child child)) - - +(defun unmanage-child (child) + (unmanage_child child)) (defun is-managed-p (widget) (not (zerop (xt_is_managed widget)))) -(defun unmanage-child (child) - (unmanage_child child)) - (defun manage-children (children) (manage_children (map '(simple-array (signed-byte 32)) #'ff:foreign-pointer-address children) (length children))) - - + (defun destroy-widget (widget) (destroy_widget widget)) - - (defun popup (shell) - (_popup shell - 0)) + (_popup shell 0)) (defun popdown (shell) (_popdown shell)) @@ -149,7 +136,7 @@ (defmethod initialize-instance :after ((w xt-root-class) &rest args - &key foreign-address + &key foreign-address parent display &allow-other-keys) (when (or display parent) @@ -239,7 +226,6 @@ (logtest r x11:cwheight) (logtest r x11:cwborderwidth))))) - ;;--- Should call either XtResizeWidget or XtConfigureWidget (defun tk::configure-widget (widget &key x y width height diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 4fb3e593..d0a390a9 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.12 92/03/10 15:39:53 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.13 92/03/30 17:51:52 cer Exp $ (in-package :tk) @@ -80,8 +80,8 @@ (defmethod drawable-backing-store ((window window)) (let ((attrs (x11:make-xwindowattributes))) - (x11:xgetwindowattributes (display-handle (object-display window)) - (object-handle window) + (x11:xgetwindowattributes (object-display window) + window attrs) (not (zerop (x11:xwindowattributes-backing-store attrs))))) @@ -118,7 +118,7 @@ (let ((s (string-to-char* (make-string 1000)))) (x11::xgeterrortext display-handle code s 1000) (char*-to-string s))) - + (defun setup-error-handlers () (x11:xseterrorhandler (register-function 'x-error-handler)) (x11:xsetioerrorhandler (register-function 'x-io-error-handler))) @@ -126,6 +126,7 @@ (eval-when (load) (setup-error-handlers)) + (defmethod display-root-window (display) (intern-object-xid (x11:xdefaultrootwindow display) @@ -148,8 +149,7 @@ (defclass color (ff:foreign-pointer) ()) -(defmethod initialize-instance :after ((x color) &key foreign-address red green - blue) +(defmethod initialize-instance :after ((x color) &key foreign-address red green blue) (unless foreign-address (setq foreign-address (x11::make-xcolor)) (setf (x11::xcolor-red foreign-address) red @@ -164,7 +164,7 @@ (let ((cm o)) (format s "~D,~D,~D" (x11:xcolor-red cm) - (x11:xcolor-green cm) + (x11:xcolor-green cm) (x11:xcolor-blue cm))))) (defun lookup-color (colormap color-name) @@ -181,8 +181,7 @@ (make-instance 'color :foreign-address closest))))) (defun allocate-color (colormap x) - (let ((y (x11::make-xcolor)) - (x x)) + (let ((y (x11::make-xcolor))) (setf (x11:xcolor-red y) (x11:xcolor-red x) (x11:xcolor-green y) (x11:xcolor-green x) (x11:xcolor-blue y) (x11:xcolor-blue x)) @@ -227,11 +226,11 @@ (values t (intern-object-xid - (aref root 0) + (aref root 0) 'window :display display) (intern-object-xid - (aref child 0) + (aref child 0) 'window :display display) (aref root-x 0) @@ -341,7 +340,7 @@ (x11:xlookupstring event buffer - 2 + 2 keysym 0) (prog1 diff --git a/tk/xm-classes.lisp b/tk/xm-classes.lisp index dc2b2725..74f6e479 100644 --- a/tk/xm-classes.lisp +++ b/tk/xm-classes.lisp @@ -20,15 +20,16 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-classes.lisp,v 1.2 92/02/24 13:03:56 cer Exp Locker: cer $ +;; $fiHeader: xm-classes.lisp,v 1.3 92/03/30 17:51:54 cer Exp $ -;;; This has to kept consistent with the Makefile (provide :climxm) (require :climg) (in-package :tk) +;;; This has to kept consistent with the Makefile + (defparameter *motif-classes* '("_applicationShellWidgetClass" "_compositeWidgetClass" "_constraintWidgetClass" diff --git a/utils/clim-macros.lisp b/utils/clim-macros.lisp index a5b5a422..b3fd61a0 100644 --- a/utils/clim-macros.lisp +++ b/utils/clim-macros.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clim-macros.lisp,v 1.2 92/02/24 13:05:18 cer Exp $ +;; $fiHeader: clim-macros.lisp,v 1.3 92/03/04 16:20:03 cer Exp $ (in-package :clim-utils) @@ -93,9 +93,9 @@ `(let ((,cx ,x) (,cy ,y)) (unless (and ,cx ,cy) - (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream))) + (multiple-value-setq (,cx ,cy) (stream-cursor-position ,stream))) (multiple-value-bind (,tx ,ty) - (transform-point* (medium-transformation ,stream) 0 0) + (transform-position (medium-transformation ,stream) 0 0) (with-drawing-options (,stream :transformation (make-translation-transformation (- ,cx ,tx) (- ,cy ,ty))) @@ -110,9 +110,9 @@ `(let ((,cx ,x) (,cy ,y)) (unless (and ,cx ,cy) - (multiple-value-setq (,cx ,cy) (stream-cursor-position* ,stream))) + (multiple-value-setq (,cx ,cy) (stream-cursor-position ,stream))) (multiple-value-bind (,tx ,ty) - (transform-point* (medium-transformation ,stream) 0 0) + (transform-position (medium-transformation ,stream) 0 0) (with-drawing-options ;; Don't flip the stream over if we already have (,stream :transformation (if (silica:medium-+Y-upward-p ,stream) diff --git a/utils/clos.lisp b/utils/clos.lisp index 86636e2d..efc8389e 100644 --- a/utils/clos.lisp +++ b/utils/clos.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: clos.lisp,v 1.3 92/02/24 13:05:23 cer Exp $ +;; $fiHeader: clos.lisp,v 1.4 92/03/04 16:20:08 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -253,7 +253,7 @@ `(funcall #',',setf-function-name ,@store-temps ,@temps) `(,',accessor-name ,@temps)))))) -;; For example, (DEFGENERIC* (SETF POSITION*) (X Y OBJECT)) +;; For example, (DEFGENERIC* (SETF CURSOR-POSITION) (X Y CURSOR)) (defmacro defgeneric* (function-spec lambda-list &body options) (assert (and (listp function-spec) (eq (first function-spec) 'setf) @@ -268,8 +268,8 @@ ,(expand-defsetf-for-defmethod* accessor-name accessor-arg lambda-list setf-function-name)))) -;; For example, (DEFMETHOD* (SETF POSITION*) (NX NY (OBJECT T)) ...) -;; Then (SETF (POSITION* object) (VALUES nx ny)) +;; For example, (DEFMETHOD* (SETF CURSOR-POSITION) (NX NY (CURSOR T)) ...) +;; Then (SETF (CURSOR-POSITION cursor) (VALUES nx ny)) (defmacro defmethod* (name &body quals-lambda-list-and-body) (declare (arglist name [qualifiers]* lambda-list &body body)) #+Genera (declare (zwei:indentation . zwei:indent-for-clos-defmethod)) diff --git a/utils/coral-char-bits.lisp b/utils/coral-char-bits.lisp index 5ae97352..513c7cf7 100644 --- a/utils/coral-char-bits.lisp +++ b/utils/coral-char-bits.lisp @@ -1,7 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- - -;; $fiHeader: coral-char-bits.lisp,v 1.3 92/02/24 13:05:27 cer Exp $ +;; $fiHeader: coral-char-bits.lisp,v 1.4 92/03/10 10:11:48 cer Exp $ (in-package :clim-utils) @@ -11,14 +10,14 @@ ;; there ain't no such thing in ANSI CL. Here in Coral, at least, we ;; can temporarily kludge around it. (defun %set-char-bits (ch b) - (declare (fixnum ch)) ; a lie - (let ((mask (ash b (- 8 3)))) ; fixnums are "shifted left" three bits - (declare (fixnum mask)) - ; I'm so ashamed + (declare (type fixnum ch)) ;a lie + (let ((mask (ash b (- 8 3)))) ;fixnums are "shifted left" three bits + (declare (type fixnum mask)) + ;; I'm so ashamed (logior ch mask))) (defun char-bits (ch) - (declare (fixnum ch)) + (declare (type fixnum ch)) ;; Extremely gross (ccl::lsh (logand ch (ash #x0000FF00 -3)) -5)) @@ -26,7 +25,7 @@ (declaim (inline char=)) (defun char= (ch1 ch2) - (declare (fixnum ch1 ch2)) + (declare (type fixnum ch1 ch2)) ;; Really gross! (ccl::require-type ch1 'character) (ccl::require-type ch2 'character) diff --git a/utils/defun-utilities.lisp b/utils/defun-utilities.lisp index f723717e..c6d84505 100644 --- a/utils/defun-utilities.lisp +++ b/utils/defun-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;;; $fiHeader: defun-utilities.lisp,v 1.5 92/02/24 13:05:30 cer Exp $ +;;; $fiHeader: defun-utilities.lisp,v 1.6 92/03/04 16:20:13 cer Exp $ (in-package :clim-utils) @@ -51,4 +51,45 @@ (return-from process-declarations))))))) (values documentation `((declare ,@declarations)) body))) + +;;; DEFINE-GROUP: defines a "group" of definitions which are related +;;; somehow. In Genera, this causes the function-parents to be set +;;; correctly, for example, and also if you attempt to abort out of the +;;; middle you get told that something might be left inconsistent. +#+Genera +(defmacro define-group (name type &body body) + `(sys:multiple-definition ,name ,type ,@body)) + +#+(and Allegro (version>= 4 1)) +(defmacro define-group (name type &body body) + `(progn + (excl::record-source-file ',name :type ',type) + ,@body)) + +#-(or Genera (and Allegro (version>= 4 1))) +(defmacro define-group (name type &body body) + (declare (ignore name type)) + `(progn ,@body)) + +(defmacro with-warnings-for-definition (name type &body body) + #+Genera `(let ((compiler:default-warning-function ,name) + (compiler:default-warning-definition-type ',type)) + ,@body) + #-Genera `(let () ,@body)) + +(defmacro defun-inline (name lambda-list &body body) + `(define-group ,name defun-inline + (eval-when (compile load eval) (proclaim '(inline ,name))) + (defun ,name ,lambda-list + ,@body))) + +#+Genera +(progn + (setf (get 'defun-inline 'zwei:definition-function-spec-parser) + (zl:::scl:function (:property zl:::scl:defun zwei:definition-function-spec-parser))) + (setf (get 'defun-inline 'zwei:definition-function-spec-type) 'zl:::scl:defun) + (setf (get 'defun-inline 'gprint::formatter) + (zl:::scl:function (:property zl:::scl:defun gprint::formatter))) + (push 'defun-inline zwei:*irrelevant-functions*) + (push 'defun-inline zwei:*irrelevant-defining-forms*)) diff --git a/utils/extended-regions.lisp b/utils/extended-regions.lisp index a3930749..d516b710 100644 --- a/utils/extended-regions.lisp +++ b/utils/extended-regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: extended-regions.lisp $ +;; $fiHeader: extended-regions.lisp,v 1.1 92/02/24 13:13:38 cer Exp $ (in-package :clim-utils) @@ -78,7 +78,7 @@ ;; By using perpendicular-distance from line instead of slope and intercept ;; we don't have to worry about divide by zero in slope and we're also more ;; robust against roundoff error. -(defmethod region-contains-point*-p ((line standard-line) x y) +(defmethod region-contains-position-p ((line standard-line) x y) (with-slots (start-x start-y end-x end-y) line (let ((x1 start-x) (y1 start-y) (x2 end-x) (y2 end-y)) (when (or (<= x1 x x2) @@ -89,8 +89,8 @@ (defmethod region-contains-region-p ((line1 standard-line) (line2 standard-line)) (with-slots (start-x start-y end-x end-y) line2 - (and (region-contains-point*-p line1 start-x start-y) - (region-contains-point*-p line1 end-x end-y)))) + (and (region-contains-position-p line1 start-x start-y) + (region-contains-position-p line1 end-x end-y)))) (defmethod region-intersects-region-p ((line1 standard-line) (line2 standard-line)) (with-slots ((sx1 start-x) (sy1 start-y) (ex1 end-x) (ey1 end-y)) line1 @@ -114,9 +114,9 @@ (defmethod transform-region (transformation (line standard-line)) (with-slots (start-x start-y end-x end-y) line (multiple-value-bind (sx sy) - (transform-point* transformation start-x start-y) + (transform-position transformation start-x start-y) (multiple-value-bind (ex ey) - (transform-point* transformation end-x end-y) + (transform-position transformation end-x end-y) (make-line* sx sy ex ey))))) (defmethod bounding-rectangle* ((line standard-line)) @@ -162,11 +162,11 @@ (when (polyline-closed polygon) (funcall function x y x1 y1))) (multiple-value-bind (x1 y1) - (point-position* (aref points 0)) + (point-position (aref points 0)) (let ((x x1) (y y1)) (dotimes (i (1- (length points))) (multiple-value-bind (nx ny) - (point-position* (aref points (1+ i))) + (point-position (aref points (1+ i))) (funcall function x y nx ny) (psetf x nx y ny))) (when (polyline-closed polygon) @@ -202,7 +202,7 @@ (let ((coords nil)) (flet ((transform-coord (x y) (multiple-value-bind (nx ny) - (transform-point* transformation x y) + (transform-position transformation x y) (push ny coords) (push nx coords)))) (declare (dynamic-extent #'transform-coord)) @@ -228,7 +228,7 @@ (let ((coords nil)) (flet ((transform-coord (x y) (multiple-value-bind (nx ny) - (transform-point* transformation x y) + (transform-position transformation x y) (push ny coords) (push nx coords)))) (declare (dynamic-extent #'transform-coord)) @@ -303,7 +303,7 @@ (with-slots (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle) ellipse (multiple-value-bind (cx cy) - (transform-point* transformation center-x center-y) + (transform-position transformation center-x center-y) (multiple-value-bind (r1-dx r1-dy) (transform-distance transformation radius-1-dx radius-1-dy) (multiple-value-bind (r2-dx r2-dy) @@ -359,7 +359,7 @@ (with-slots (center-x center-y radius-1-dx radius-1-dy radius-2-dx radius-2-dy start-angle end-angle) ellipse (multiple-value-bind (cx cy) - (transform-point* transformation center-x center-y) + (transform-position transformation center-x center-y) (multiple-value-bind (r1-dx r1-dy) (transform-distance transformation radius-1-dx radius-1-dy) (multiple-value-bind (r2-dx r2-dy) diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index 881037c3..0a6d0abc 100644 --- a/utils/lisp-utilities.lisp +++ b/utils/lisp-utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: lisp-utilities.lisp,v 1.6 92/03/10 10:11:52 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.7 92/03/30 17:52:12 cer Exp $ (in-package :clim-utils) @@ -28,7 +28,22 @@ ;;--- Turn this into 'SINGLE-FLOAT after debugging the type declarations #+Silica 't) -;;--- Should this use FLOOR, CEILING, or ROUND? +;; Convert a number of arbitrary type into a COORDINATE +(defmacro coordinate (x &optional (round-direction 'round)) + #+Silica (declare (ignore round-direction)) + #-Silica (ecase round-direction + (round + `(the fixnum (values (floor (+ ,x .5f0))))) + (floor + `(the fixnum (values (floor ,x)))) + (ceiling + `(the fixnum (values (ceiling ,x))))) + #+Silica `(the coordinate (float ,x 0f0))) + +(defconstant +largest-coordinate+ + #-Silica most-positive-fixnum + #+Silica (float (expt 10 (floor (log most-positive-fixnum 10))) 0f0)) + (defmacro integerize-single-float-coordinate (coord) `(the fixnum (values (floor (+ (the single-float ,coord) .5f0))))) @@ -38,10 +53,19 @@ (defmacro integerize-float-coordinate (coord) `(the fixnum (values (floor (+ (the float ,coord) .5))))) -#-allegro -(defun integerize-coordinate (coord) - (declare (optimize (speed 3) (safety 0)) - (:explain :calls :types)) +#+(or Genera Minima) +(defun-inline fix-coordinate (coord) + (if (typep coord 'fixnum) + coord + (the fixnum (values (floor (+ coord .5f0)))))) + +#+Allegro +(defmacro fix-coordinate (coord) + ;; ROUND is good enough in Allegro for 90% of the speed, and it's less filling. + `(the fixnum (round ,coord))) + +#-(or Genera Minima Allegro) +(defun fix-coordinate (coord) (etypecase coord (fixnum coord) (single-float @@ -55,19 +79,58 @@ ;; disallow bignums and other types of numbers )) -#+allegro -(defmacro integerize-coordinate (coord) - ;; Round is good enough in Allegro for 90% of the speed, and it's less - ;; filling. - `(the fixnum (round ,coord))) - - -(defmacro integerize-coordinates (&body coords) +(defmacro fix-coordinates (&body coords) `(progn - ,@(mapcar #'(lambda (x) - `(setq ,x (integerize-coordinate ,x))) + ,@(mapcar #'(lambda (x) `(setq ,x (fix-coordinate ,x))) coords))) +;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just +;;; lifted it from there but I am honest. Not only that but this one is +;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more +;;; like rebuilding Rome. +(defmacro once-only (vars &body body) + (let ((gensym-var (gensym)) + (run-time-vars (gensym)) + (run-time-vals (gensym)) + (expand-time-val-forms ())) + (dolist (var vars) + (push `(if (or (symbolp ,var) + (numberp ,var) + (and (listp ,var) + (member (car ,var) '(quote function)))) + ,var + (let ((,gensym-var (gensym))) + (push ,gensym-var ,run-time-vars) + (push ,var ,run-time-vals) + ,gensym-var)) + expand-time-val-forms)) + `(let* (,run-time-vars + ,run-time-vals + (wrapped-body + (let ,(mapcar #'list vars (reverse expand-time-val-forms)) + ,@body))) + `(let ,(mapcar #'list (reverse ,run-time-vars) + (reverse ,run-time-vals)) + ,wrapped-body)))) + +(defmacro dorest ((var list &optional (by 'cdr)) &body body) + `(do ((,var ,list (,by ,var))) + ((null ,var) nil) + ,@body)) + +;; COORDINATE-PAIRS is a list of pairs of coordinates. +;; The coordinates must be of type COORDINATE +(defmacro translate-coordinates (x-delta y-delta &body coordinate-pairs) + (once-only (x-delta y-delta) + `(progn + ,@(let ((forms nil)) + (dorest (pts coordinate-pairs cddr) + (push `(setf ,(first pts) + (the coordinate (+ ,(first pts) ,x-delta))) forms) + (push `(setf ,(second pts) + (the coordinate (+ ,(second pts) ,y-delta))) forms)) + (nreverse forms))))) + (defmacro convert-to-device-coordinates (transform &body positions) (assert (evenp (length positions)) (positions) "There must be an even number of elements in ~S" positions) @@ -79,8 +142,8 @@ (y (pop positions))) (push `(multiple-value-setq (,x ,y) (multiple-value-bind (nx ny) - (transform-point* ,transform ,x ,y) - (values (integerize-coordinate nx) (integerize-coordinate ny)))) + (transform-position ,transform ,x ,y) + (values (fix-coordinate nx) (fix-coordinate ny)))) forms))))) (defmacro convert-to-device-distances (transform &body positions) @@ -95,7 +158,7 @@ (push `(multiple-value-setq (,x ,y) (multiple-value-bind (nx ny) (transform-distance ,transform ,x ,y) - (values (integerize-coordinate nx) (integerize-coordinate ny)))) + (values (fix-coordinate nx) (fix-coordinate ny)))) forms))))) @@ -375,48 +438,6 @@ (t nil)))) ,@body)))) - -;;; DEFINE-GROUP: defines a "group" of definitions which are related -;;; somehow. In Genera, this causes the function-parents to be set -;;; correctly, for example, and also if you attempt to abort out of the -;;; middle you get told that something might be left inconsistent. -#+Genera -(defmacro define-group (name type &body body) - `(sys:multiple-definition ,name ,type ,@body)) - -#+(and Allegro (version>= 4 1)) -(defmacro define-group (name type &body body) - `(progn - (excl::record-source-file ',name :type ',type) - ,@body)) - -#-(or Genera (and Allegro (version>= 4 1))) -(defmacro define-group (name type &body body) - (declare (ignore name type)) - `(progn ,@body)) - -(defmacro with-warnings-for-definition (name type &body body) - #+Genera `(let ((compiler:default-warning-function ,name) - (compiler:default-warning-definition-type ',type)) - ,@body) - #-Genera `(let () ,@body)) - -(defmacro defun-inline (name lambda-list &body body) - `(define-group ,name defun-inline - (eval-when (compile load eval) (proclaim '(inline ,name))) - (defun ,name ,lambda-list - ,@body))) - -#+Genera -(progn - (setf (get 'defun-inline 'zwei:definition-function-spec-parser) - (zl:::scl:function (:property zl:::scl:defun zwei:definition-function-spec-parser))) - (setf (get 'defun-inline 'zwei:definition-function-spec-type) 'zl:::scl:defun) - (setf (get 'defun-inline 'gprint::formatter) - (zl:::scl:function (:property zl:::scl:defun gprint::formatter))) - (push 'defun-inline zwei:*irrelevant-functions*) - (push 'defun-inline zwei:*irrelevant-defining-forms*)) - ;;; Bindings on the stack. A work in progress. ;;; Which Lisps support this? @@ -630,7 +651,7 @@ (,endd ,(if simple-p `,end `(or ,end (length ,fvector)))) (,index (if ,from-end (1- ,endd) ,startd)) (,limit (if ,from-end (1- ,startd) ,endd))) - (declare (fixnum ,endd ,index ,limit) + (declare (type fixnum ,endd ,index ,limit) ;; Turn on the afterburners... (optimize (speed 3) (safety 0)) ,@(and simple-p `((type simple-vector ,fvector))) @@ -650,11 +671,6 @@ (list (dolist (thing ,sequence) (,fcn thing))) (vector (dovector (thing ,sequence) (,fcn thing))))))) -(defmacro dorest ((var list &optional (by 'cdr)) &body body) - `(do ((,var ,list (,by ,var))) - ((null ,var) nil) - ,@body)) - (defmacro writing-clauses (&body body) (let ((clauses-var (gensymbol 'clauses))) `(let ((,clauses-var nil)) @@ -994,7 +1010,7 @@ (,next-var nil) ,@(when (cdr special-characters) `((,char-var ,(car special-characters))))) - (declare (fixnum ,start-index-var ,end-var ,end-index-var) + (declare (type fixnum ,start-index-var ,end-var ,end-index-var) (type (or fixnum null) ,next-var) (character ,char-var)) (loop @@ -1153,34 +1169,6 @@ `(or (float ,(convert min t) ,(convert max t)) (rational ,(convert min nil) ,(convert max nil))))) -;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just -;;; lifted it from there but I am honest. Not only that but this one is -;;; written in Common Lisp. I feel a lot like bootstrapping, or maybe more -;;; like rebuilding Rome. -(defmacro once-only (vars &body body) - (let ((gensym-var (gensym)) - (run-time-vars (gensym)) - (run-time-vals (gensym)) - (expand-time-val-forms ())) - (dolist (var vars) - (push `(if (or (symbolp ,var) - (numberp ,var) - (and (listp ,var) - (member (car ,var) '(quote function)))) - ,var - (let ((,gensym-var (gensym))) - (push ,gensym-var ,run-time-vars) - (push ,var ,run-time-vals) - ,gensym-var)) - expand-time-val-forms)) - `(let* (,run-time-vars - ,run-time-vals - (wrapped-body - (let ,(mapcar #'list vars (reverse expand-time-val-forms)) - ,@body))) - `(let ,(mapcar #'list (reverse ,run-time-vars) - (reverse ,run-time-vals)) - ,wrapped-body)))) ;;; Use a lambda-list to extract arguments from a list and bind variables. ;;; This "should" signal an error if the list doesn't match the lambda-list. @@ -1359,7 +1347,7 @@ ;;; Simple vector support (defun-inline copy-vector-portion (from-vector from-start to-vector to-start length) - (declare (fixnum from-start to-start length) + (declare (type fixnum from-start to-start length) (type simple-vector from-vector to-vector)) (declare (optimize (speed 3) (safety 0))) (cond (#+Genera (< length 8) #-Genera t @@ -1382,9 +1370,10 @@ ;; (MULTIPLE-VALUE-SETQ (VECTOR FP) (SIMPLE-VECTOR-PUSH-EXTEND ELEMENT VECTOR FP)). (defun simple-vector-push-extend (element vector fill-pointer &optional extension) (declare (values vector fill-pointer)) - (declare (fixnum fill-pointer) (type simple-vector vector)) + (declare (type fixnum fill-pointer) + (type simple-vector vector)) (let ((length (array-dimension vector 0))) - (declare (fixnum length)) + (declare (type fixnum length)) (when (= fill-pointer length) ;; Grow the vector (let ((new-vector (make-array (+ length (max (ash length -1) (or extension 20))) @@ -1398,9 +1387,10 @@ (defun simple-vector-insert-element (element index vector fill-pointer &optional extension) (declare (values vector fill-pointer)) - (declare (fixnum index fill-pointer) (type simple-vector vector)) + (declare (type fixnum index fill-pointer) + (type simple-vector vector)) (let ((length (array-dimension vector 0))) - (declare (fixnum length)) + (declare (type fixnum length)) (cond ((= fill-pointer length) ;; Grow the vector, leaving a hole for the new element (let ((new-vector (make-array (+ length (max (ash length -1) (or extension 20))) @@ -1415,7 +1405,7 @@ #+Minima (declare (type vector vector)) (do ((i fill-pointer (1- i))) ((= i index)) - (declare (fixnum i) + (declare (type fixnum i) (optimize (speed 3) (safety 0))) (setf (svref vector i) (svref vector (1- i))))))) ;; Plug in the new element and return the right values diff --git a/utils/packages.lisp b/utils/packages.lisp index 21429daf..28da544a 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.9 92/04/03 12:04:20 cer Exp Locker: cer $ +;; $fiHeader: packages.lisp,v 1.10 92/04/10 14:26:42 cer Exp Locker: cer $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -1472,11 +1472,12 @@ with-open-stream) (:export - ;; Geometry + ;; Regions +everywhere+ +nowhere+ area areap + coordinate ellipse ellipse-center-point ellipse-center-point* @@ -1511,7 +1512,7 @@ path pathp point - point-position* + point-position point-x point-y pointp @@ -1534,7 +1535,7 @@ rectangle-width rectanglep region - region-contains-point*-p + region-contains-position-p region-contains-region-p region-difference region-equal @@ -1565,7 +1566,7 @@ bounding-rectangle-min-x bounding-rectangle-min-y bounding-rectangle-p - bounding-rectangle-position* + bounding-rectangle-position bounding-rectangle-size bounding-rectangle-width bounding-rectangle-left @@ -1606,7 +1607,7 @@ scaling-transformation-p singular-transformation transform-distance - transform-point* + transform-position transform-rectangle* transform-region transformation @@ -1616,7 +1617,7 @@ transformationp translation-transformation-p untransform-distance - untransform-point* + untransform-position untransform-rectangle* untransform-region @@ -1631,14 +1632,16 @@ +shift-key+ +super-key+ add-watcher + allocate-medium bursting-input-queuer bury-sheet - child-containing-point - child-containing-point* + child-containing-position children-overlapping-rectangle* children-overlapping-region copy-event + deallocate-medium define-sheet-class + degraft-medium delegate-sheet-delegate delegate-sheet-input-mixin delete-watcher @@ -1656,6 +1659,7 @@ distribute-device-event distribute-event enable-mirror + engraft-medium enter-region event event-listen @@ -1699,10 +1703,10 @@ map-over-grafts map-over-ports map-over-sheets - map-sheet-bounding-rectangle*-to-child - map-sheet-bounding-rectangle*-to-parent - map-sheet-point*-to-child - map-sheet-point*-to-parent + map-sheet-position-to-child + map-sheet-position-to-parent + map-sheet-rectangle*-to-child + map-sheet-rectangle*-to-parent medium medium-background medium-clipping-region @@ -1745,12 +1749,13 @@ pointer-event-y pointer-exit-event pointer-motion-event - port-notify-user poll-pointer port port-keyboard-input-focus + port-notify-user port-properties port-server-path + port-type portp primitive-sheet-output-mixin process-next-event @@ -1847,6 +1852,7 @@ ;; Text styles *default-text-style* + *undefined-text-style* invoke-with-text-style make-device-font-text-style make-text-style @@ -1922,7 +1928,7 @@ port-draw-text* with-output-to-pixmap - ;; Color + ;; Colors +background-ink+ +flipping-ink+ +foreground-ink+ @@ -1943,7 +1949,7 @@ opacity-value opacityp - ;; Patterns + ;; Designs compose-in compose-out compose-over @@ -1958,7 +1964,7 @@ cursor cursor-active cursor-focus - cursor-position* + cursor-position cursor-sheet cursor-state cursor-visibility @@ -1975,13 +1981,13 @@ stream-baseline stream-character-width stream-clear-output - stream-cursor-position* + stream-cursor-position stream-end-of-line-action stream-end-of-page-action stream-finish-output stream-force-output stream-fresh-line - stream-increment-cursor-position* + stream-increment-cursor-position stream-line-column stream-line-height stream-start-line-p @@ -2015,18 +2021,18 @@ invoke-with-output-recording-options invoke-with-output-to-output-record make-design-from-output-record - map-over-output-records-containing-point* + map-over-output-records-containing-position map-over-output-records-overlapping-region output-record output-record-children output-record-count - output-record-end-cursor-position* - output-record-hit-detection-rectangle* + output-record-end-cursor-position + output-record-hit-detection-rectangle output-record-p output-record-parent - output-record-position* + output-record-position output-record-refined-sensitivity-test - output-record-start-cursor-position* + output-record-start-cursor-position output-recording-stream output-recording-stream-p recompute-extent-for-changed-child @@ -2146,9 +2152,16 @@ updating-output-record-p ;; Extended input + *abort-gestures* + *accelerator-gestures* *input-wait-handler* *input-wait-test* *pointer-button-press-handler* + abort-gesture + abort-gesture-event + accelerator-gesture + accelerator-gesture-event + accelerator-gesture-numeric-argument add-gesture-name define-gesture-name delete-gesture-name @@ -2164,7 +2177,7 @@ pointer-buttons pointer-cursor pointer-port - pointer-position* + pointer-position pointer-sheet pointerp read-gesture @@ -2176,7 +2189,7 @@ stream-input-wait stream-listen stream-peek-char - stream-pointer-position* + stream-pointer-position stream-pointers stream-primary-pointer stream-read-char @@ -2207,10 +2220,10 @@ accept-method accept-present-default accept-present-default-method + apply-presentation-generic-function and blank-area boolean - call-presentation-generic-function call-presentation-menu call-presentation-translator character @@ -2240,6 +2253,7 @@ float form frame-document-highlighted-presentation + funcall-presentation-generic-function gadget-dialog-view gadget-menu-view gadget-view @@ -2324,14 +2338,12 @@ with-presentation-type-parameters ;; Input editing and completion - *abort-gestures* *activation-gestures* *completion-gestures* *delimiter-gestures* *help-gestures* *possibilities-gestures* *standard-activation-gestures* - abort-gesture activation-gesture-p complete-from-generator complete-from-possibilities @@ -2369,6 +2381,7 @@ write-token ;; Menus + draw-standard-menu menu-choose menu-choose-from-drawer menu-item @@ -2385,6 +2398,7 @@ accept-values-resynchronize accepting-values display-exit-boxes + invoke-accept-values-command-button ;; Command processor *command-argument-delimiters* @@ -2465,6 +2479,7 @@ application-pane client-setting command-enabled + command-menu-pane default-frame-top-level define-application-frame disable-frame @@ -2487,6 +2502,7 @@ frame-input-context-button-press-handler frame-maintain-presentation-histories frame-manager + frame-manager-frames frame-name frame-named-panes frame-pane @@ -2516,8 +2532,6 @@ pane-name pane-needs-redisplay panes-need-redisplay - pane-viewport - pane-viewport-region read-frame-command reconfigure-frame redisplay-frame-command-menu @@ -2532,102 +2546,134 @@ window-erase-viewport window-refresh window-viewport - window-viewport-position* + window-viewport-position with-application-frame with-frame-manager ;; Panes +fill+ + allocate-space + bboard-pane + border-pane bordering change-space-requirement changing-space-requirements clim-stream-pane clim-stream-sheet + compose-space + hbox-pane horizontal-divider horizontally + hrack-pane + label-pane labelled lowering make-clim-pane + make-pane + make-pane-1 + make-space-requirement + note-space-requirement-changed + outlined-pane outlining pane pane-background pane-foreground + pane-scroller pane-text-style + pane-viewport + pane-viewport-region raising make-pane make-pane-1 restraining + restraining-pane + scroller-pane scrolling + space-requirement + space-requirement-height + space-requirement-max-height + space-requirement-max-width + space-requirement-min-height + space-requirement-min-width + space-requirement-width spacing + spacing-pane + table-pane tabling - text-editor - text-field text-stream-pane top-level-sheet + vbox-pane vertical-divider vertically viewport + viewport-viewport-region + vrack-pane with-look-and-feel-realization - ;; Adaptive toolkit + ;; Gadgets + action-gadget activate-callback + activate-gadget armed-callback - cascade-button-menu-group deactivate-gadget disarmed-callback drag-callback gadget - gadget-alignment + gadget-activate-callback + gadget-armed-callback gadget-client + gadget-disarmed-callback gadget-id gadget-indicator-type gadget-label + gadget-label-align-x + gadget-label-align-y + gadget-label-text-style + gadget-min-value + gadget-max-value + gadget-orientation + gadget-output-record gadget-orientation gadget-min-value gadget-max-value gadget-range gadget-range* gadget-value + gadget-value-changed-callback gadget-show-value-p label-pane + labelled-gadget menu-bar + menu-button + menu-button-pane note-gadget-activated note-gadget-deactivated + oriented-gadget push-button - push-button-show-as-default + push-button-pane + push-button-show-as-default-p radio-box radio-box-current-selection + radio-box-pane radio-box-selections - scrollbar scroll-bar - scroll-bar-max-value - scroll-bar-min-value - scroll-bar-orientation - scroll-bar-page-increment - scroll-bar-unit-increment + scroll-bar-drag-callback + scroll-bar-pane slider - slider-max-value - slider-min-value - slider-orientation - slider-show-value + slider-pane + slider-show-value-p + text-editor + text-editor-pane text-field + text-field-pane toggle-button + toggle-button-indicator-type + toggle-button-pane value-changed-callback + value-gadget + with-output-as-gadget with-radio-box - - ;; Pane layout - allocate-space - compose-space - make-space-requirement - note-space-requirement-changed - space-requirement - space-requirement-height - space-requirement-max-height - space-requirement-max-width - space-requirement-min-height - space-requirement-min-width - space-requirement-width - + ;; Encapsulating streams *original-stream* encapsulating-stream @@ -2774,19 +2820,16 @@ ;; Need to export these since we don't hack SETF* yet (:export - output-record-set-position* - cursor-set-position* - stream-set-cursor-position* - stream-set-pointer-position* - window-set-viewport-position*) + cursor-set-position + output-record-set-position + pointer-set-position + stream-set-cursor-position + stream-set-pointer-position + window-set-viewport-position) ;; Some extensions until we decide what to do... (:export - *accelerator-gestures* +iconic-view+ - accelerator-gesture - accelerator-gesture-event - accelerator-gesture-numeric-argument accept-values-command-parser catch-abort-gestures convert-from-absolute-to-relative-coordinates @@ -2796,15 +2839,17 @@ convert-to-stream-coordinates copy-textual-output-history #+Genera define-genera-application - draw-standard-menu draw-triangle draw-triangle* drawing-surface-to-viewport-coordinates + fix-coordinate + fix-coordinates iconic-view open-root-window open-window-stream position-window-near-carefully stream-pointer-position-in-window-coordinates + translate-coordinates translate-positions viewport-to-drawing-surface-coordinates window-children @@ -2846,10 +2891,14 @@ add-output-record-element add-text-style-mapping blip-character-p + bounding-rectangle-position* + call-presentation-generic-function command-enabled-p compose-rotation-transformation compose-scaling-tansformation compose-translation-transformation + cursor-position* + cursor-set-position* delete-output-record-element dialog-view disable-command @@ -2867,6 +2916,8 @@ map-over-output-record-elements-overlapping-region menu-view output-record-end-position* + output-record-position* + output-record-set-position* output-record-set-end-position* output-record-set-start-position* output-record-start-position @@ -2874,11 +2925,21 @@ output-recording-stream-current-output-record-stack output-recording-stream-output-history output-recording-stream-replay + point-position* + pointer-set-position* pointer-event-shift-mask + pointer-position* set-frame-layout + stream-cursor-position* + stream-set-cursor-position* stream-draw-p + stream-increment-cursor-position* + stream-pointer-position* + stream-set-pointer-position* stream-record-p stream-vsp + window-viewport-position* + window-set-viewport-position* with-activation-characters with-blip-characters with-frame-state-variables)) @@ -2982,7 +3043,6 @@ compile-time-property convert-to-device-coordinates convert-to-device-distances - coordinate define-class-mixture define-constructor define-constructor-using-prototype-instance @@ -3003,8 +3063,7 @@ gensymbol get-compile-time-local-property ignore-arglist - integerize-coordinate - integerize-coordinates + +largest-coordinate+ lambda-list-variables-used-in-body letf-globally letf-globally-if @@ -3114,15 +3173,15 @@ bounding-rectangle-position-difference bounding-rectangle-position-equal bounding-rectangle-set-edges - bounding-rectangle-set-position* + bounding-rectangle-set-position bounding-rectangle-set-size bounding-rectangle-shift-position bounding-rectangle-size-equal - position-difference* + position-difference ;; LTRBs ltrb-contains-ltrb-p - ltrb-contains-point*-p + ltrb-contains-position-p ltrb-difference ltrb-equals-ltrb-p ltrb-intersection @@ -3196,31 +3255,24 @@ (:export *all-drawing-options* - *default-text-style* *modifier-keys* *null-text-style* *pointer-buttons* *standard-character-set* *undefined-text-style* +highlighting-line-style+ - action-gadget activate-gadget-event add-sheet-callbacks all-drawing-options-lambda-list - allocate-medium - bboard-pane - border-pane bury-mirror canvas - change-scrollbar-values + change-scroll-bar-values char-character-set-and-index char-width clear-space-requirement-caching-in-ancestors clear-space-requirement-caches-in-tree click-event client-overridability - command-menu-pane - deallocate-medium default-space-requirements define-character-face define-character-face-added-mappings @@ -3229,30 +3281,18 @@ define-graphics-function define-text-style-mappings define-text-style-mappings-1 - degraft-medium diacritic-char-p display-device - engraft-medium - event - event-modifier-key-state find-port-type fit-region*-in-region* - frame-manager-frames frame-shell frame-wrapper - gadget-activate-callback - gadget-armed-callback - gadget-disarmed-callback - gadget-value-changed-callback get-drawing-function-description get-port-canonical-gesture-spec grid-pane - hbox-pane - hrack-pane intern-text-style invoke-callback-function label-button-pane - labelled-gadget line-editor-pane list-pane make-frame-manager @@ -3272,10 +3312,7 @@ move-sheet* mute-repainting-mixin non-drawing-option-keywords - oriented-gadget one-of-pane - outlined-pane - pane-scroller parse-gesture-spec permanent-medium-sheet-output-mixin pointer-press-event @@ -3296,23 +3333,16 @@ port-modifier-state port-note-cursor-change port-pointer - port-server-path - port-type port-undefined-text-style port-write-char-1 port-write-string-1 process-event-locally - push-button-pane - radio-box-pane radio-button-pane - restraining-pane raise-mirror resize-sheet* - scrollbar-value-changed-callback - scroll-bar-pane scroll-extent scrollable-pane - scroller-pane + scroll-bar-value-changed-callback set-sheet-mirror-edges* shadow-pane sheet-actual-native-edges* @@ -3321,10 +3351,8 @@ sheet-shell sheet-top-level-mirror sheet-with-graphics-state - slider-pane space-requirement-components space-requirement-mixin - spacing-pane standard-sheet standard-sheet-input-mixin standardize-text-style @@ -3334,21 +3362,14 @@ stream-write-string-1 string-height string-width - table-pane - text-field-pane text-style-scale - toggle-button-pane transform-distances - transform-point-sequence - transform-points + transform-position-sequence + transform-positions update-region - update-scrollbars + update-scroll-bars value-changed-gadget-event - value-gadget - vbox-pane viewport-region-changed - viewport-viewport-region - vrack-pane window-configuration-event window-repaint-event window-shift-visible-region)) diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp index d3330eaf..b015b5b3 100644 --- a/utils/region-arithmetic.lisp +++ b/utils/region-arithmetic.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: region-arithmetic.lisp,v 1.4 92/03/04 16:20:22 cer Exp $ +;; $fiHeader: region-arithmetic.lisp,v 1.5 92/03/10 10:11:59 cer Exp $ (in-package :clim-utils) @@ -193,7 +193,7 @@ (and (= (- right1 left1) (- right2 left2)) (= (- bottom1 top1) (- bottom2 top2)))) -(defun ltrb-contains-point*-p (left top right bottom x y) +(defun ltrb-contains-position-p (left top right bottom x y) (declare (type coordinate left top right bottom x y)) (and (<= left x) (<= top y) diff --git a/utils/regions.lisp b/utils/regions.lisp index aa1a5362..2df2fa2e 100644 --- a/utils/regions.lisp +++ b/utils/regions.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: regions.lisp,v 1.4 92/02/24 13:05:57 cer Exp $ +;; $fiHeader: regions.lisp,v 1.5 92/03/04 16:20:23 cer Exp $ (in-package :clim-utils) @@ -11,14 +11,14 @@ (defgeneric transform-region (transformation region)) (defgeneric untransform-region (transformation region)) -(defgeneric point-position* (point) +(defgeneric point-position (point) (declare (values x y))) (defgeneric point-x (point)) (defgeneric point-y (point)) ;;--- Many of these methods could stand to be written... (defgeneric region-equal (region1 region2)) -(defgeneric region-contains-point*-p (region x y)) +(defgeneric region-contains-position-p (region x y)) (defgeneric region-contains-region-p (region1 region2)) (defgeneric region-intersects-region-p (region1 region2)) @@ -69,7 +69,7 @@ (declare (values left top right bottom))) (defgeneric bounding-rectangle-set-edges (region left top right bottom) (declare (values region))) -(defgeneric bounding-rectangle-set-position* (region x y) +(defgeneric bounding-rectangle-set-position (region x y) (declare (values region))) (defgeneric bounding-rectangle-set-size (region width height) (declare (values region))) @@ -79,19 +79,11 @@ (defmethod ,name (,region1 ,region2) ,@body) (defmethod ,name (,region2 ,region1) ,@body))) -#-Silica (defmacro fix-rectangle (left top right bottom) - `(values (the fixnum (floor ,left)) - (the fixnum (floor ,top)) - (the fixnum (ceiling ,right)) - (the fixnum (ceiling ,bottom)))) - -#+Silica -(defmacro fix-rectangle (left top right bottom) - `(values (float ,left 0f0) - (float ,top 0f0) - (float ,right 0f0) - (float ,bottom 0f0))) + `(values (the coordinate (coordinate ,left 'floor)) + (the coordinate (coordinate ,top 'floor)) + (the coordinate (coordinate ,right 'ceiling)) + (the coordinate (coordinate ,bottom 'ceiling)))) ;;; The basic design protocol classes @@ -119,10 +111,6 @@ (define-protocol-class region (design)) -(defmethod transform-region ((transformation identity-transformation) region) region) - -(defmethod untransform-region ((transformation identity-transformation) region) region) - (defmethod untransform-region ((transformation transformation) region) (transform-region (invert-transformation transformation) region)) @@ -136,7 +124,7 @@ (defmethod region-equal ((nowhere1 nowhere) (nowhere2 nowhere)) t) -(defmethod region-contains-point*-p ((nowhere nowhere) x y) +(defmethod region-contains-position-p ((nowhere nowhere) x y) (declare (ignore x y)) nil) @@ -166,7 +154,7 @@ (defmethod region-equal ((everywhere1 everywhere) (everywhere2 everywhere)) t) -(defmethod region-contains-point*-p ((everywhere everywhere) x y) +(defmethod region-contains-position-p ((everywhere everywhere) x y) (declare (ignore x y)) t) @@ -212,16 +200,21 @@ (with-slots (x y) point `(make-point ,x ,y))) -(defmethod point-position* ((point standard-point)) +(defmethod point-position ((point standard-point)) (with-slots (x y) point (values x y))) +#+CLIM-1-compatibility +(define-compatibility-function (point-position* point-position) + (point) + (point-position point)) + (defmethod region-equal ((point1 standard-point) (point2 standard-point)) (with-slots ((x1 x) (y1 y)) point1 (with-slots ((x2 x) (y2 y)) point2 (and (= x1 x2) (= y1 y2))))) -(defmethod region-contains-point*-p ((point standard-point) x y) +(defmethod region-contains-position-p ((point standard-point) x y) (with-slots ((px x) (py y)) point (and (= px x) (= py y)))) @@ -232,7 +225,7 @@ (defmethod region-contains-region-p ((region region) (point standard-point)) (with-slots (x y) point - (region-contains-point*-p region x y))) + (region-contains-position-p region x y))) (defmethod region-intersects-region-p ((point1 standard-point) (point2 standard-point)) (with-slots ((x1 x) (y1 y)) point1 @@ -242,7 +235,7 @@ (define-symmetric-region-method region-intersects-region-p ((point standard-point) (region region)) (with-slots ((px x) (py y)) point - (region-contains-point*-p region px py))) + (region-contains-position-p region px py))) (defmethod region-intersection ((point1 standard-point) (point2 standard-point)) (with-slots ((x1 x) (y1 y)) point1 @@ -252,7 +245,7 @@ (defmethod transform-region (transformation (point standard-point)) (with-slots (x y) point (multiple-value-bind (x y) - (transform-point* transformation x y) + (transform-position transformation x y) (make-point-1 x y)))) (defmethod bounding-rectangle* ((point standard-point)) @@ -303,8 +296,8 @@ :min-x min-x :min-y min-y :max-x max-x :max-y max-y :points points) (defun make-rectangle (min-point max-point) - (multiple-value-bind (min-x min-y) (point-position* min-point) - (multiple-value-bind (max-x max-y) (point-position* max-point) + (multiple-value-bind (min-x min-y) (point-position min-point) + (multiple-value-bind (max-x max-y) (point-position max-point) (assert (<= min-x max-x)) (assert (<= min-y max-y)) (make-rectangle-1 min-x min-y max-x max-y @@ -375,9 +368,9 @@ (ltrb-equals-ltrb-p sx1 sy1 ex1 ey1 sx2 sy2 ex2 ey2)))) -(defmethod region-contains-point*-p ((rectangle standard-rectangle) x y) +(defmethod region-contains-position-p ((rectangle standard-rectangle) x y) (with-slots (min-x min-y max-x max-y) rectangle - (ltrb-contains-point*-p min-x min-y max-x max-y x y))) + (ltrb-contains-position-p min-x min-y max-x max-y x y))) (defmethod region-contains-region-p ((rect1 standard-rectangle) (rect2 standard-rectangle)) (with-slots ((sx1 min-x) (sy1 min-y) (ex1 max-x) (ey1 max-y)) rect1 @@ -395,14 +388,14 @@ (with-slots (min-x min-y max-x max-y) rectangle (if (rectilinear-transformation-p transformation) (multiple-value-bind (x1 y1) - (transform-point* transformation min-x min-y) + (transform-position transformation min-x min-y) (multiple-value-bind (x2 y2) - (transform-point* transformation max-x max-y) + (transform-position transformation max-x max-y) (make-rectangle* x1 y1 x2 y2))) (let ((coords nil)) (flet ((transform-coord (x y) (multiple-value-bind (nx ny) - (transform-point* transformation x y) + (transform-position transformation x y) (push ny coords) (push nx coords)))) (declare (dynamic-extent #'transform-coord)) @@ -429,10 +422,10 @@ ;;--- Can we simply inherit from STANDARD-RECTANGLE and flush some ;;--- of the methods below? (defclass standard-bounding-rectangle (region bounding-rectangle) - ((left :initarg :left :accessor rectangle-min-x) - (top :initarg :top :accessor rectangle-min-y) - (right :initarg :right :accessor rectangle-max-x) - (bottom :initarg :bottom :accessor rectangle-max-y))) + ((left :initarg :left :accessor rectangle-min-x :type coordinate) + (top :initarg :top :accessor rectangle-min-y :type coordinate) + (right :initarg :right :accessor rectangle-max-x :type coordinate) + (bottom :initarg :bottom :accessor rectangle-max-y :type coordinate))) (defmethod print-object ((object standard-bounding-rectangle) stream) (print-unreadable-object (object stream :type t :identity t) @@ -446,12 +439,11 @@ (left top right bottom) :left left :top top :right right :bottom bottom) -#-Silica (defun make-bounding-rectangle (x1 y1 x2 y2) - (let ((x1 (floor x1)) - (y1 (floor y1)) - (x2 (floor x2)) - (y2 (floor y2))) + (let ((x1 (coordinate x1)) + (y1 (coordinate y1)) + (x2 (coordinate x2)) + (y2 (coordinate y2))) (declare (type coordinate x1 y1 x2 y2)) (when (> x1 x2) (rotatef x1 x2)) (when (> y1 y2) (rotatef y1 y2)) @@ -526,9 +518,9 @@ (ltrb-equals-ltrb-p sx1 sy1 ex1 ey1 sx2 sy2 ex2 ey2)))) -(defmethod region-contains-point*-p ((rectangle standard-bounding-rectangle) x y) +(defmethod region-contains-position-p ((rectangle standard-bounding-rectangle) x y) (with-slots (left top right bottom) rectangle - (ltrb-contains-point*-p left top right bottom x y))) + (ltrb-contains-position-p left top right bottom x y))) (defmethod region-contains-region-p ((rect1 standard-bounding-rectangle) (rect2 standard-bounding-rectangle)) @@ -569,6 +561,7 @@ ;; Set the edges of the rectangle, and return the rectangle as the value ;; LEFT, TOP, RIGHT, and BOTTOM had better be of type COORDINATE +;;--- Or should this coerce to COORDINATE? (defmethod bounding-rectangle-set-edges ((rectangle standard-bounding-rectangle) left top right bottom) (declare (type coordinate left top right bottom)) @@ -627,18 +620,13 @@ (declare (ignore min-x min-y)) (make-point max-x max-y))) -(defun-inline bounding-rectangle-position* (region) +(defun-inline bounding-rectangle-position (region) (with-bounding-rectangle* (left top right bottom) region (declare (ignore right bottom)) (values left top))) -(defun bounding-rectangle-position (region) - (with-bounding-rectangle* (left top right bottom) region - (declare (ignore right bottom)) - (make-point left top))) - ;; Set the position of the rectangle, and return the rectangle as the value -(defmethod bounding-rectangle-set-position* ((rectangle standard-bounding-rectangle) x y) +(defmethod bounding-rectangle-set-position ((rectangle standard-bounding-rectangle) x y) (declare (type coordinate x y)) (with-slots (left top right bottom) rectangle (declare (type coordinate left top right bottom)) @@ -651,6 +639,18 @@ bottom (+ y height)))) rectangle) +#+CLIM-1-compatibility +(define-compatibility-function (bounding-rectangle-position* + bounding-rectangle-position) + (region) + (bounding-rectangle-position region)) + +#+CLIM-1-compatibility +(define-compatibility-function (bounding-rectangle-set-position* + bounding-rectangle-set-position) + (region x y) + (bounding-rectangle-set-position region)) + ;; Make a new bounding rectangle for the region, and shift its position by DX,DY, ;; and return the new rectangle. (defun bounding-rectangle-shift-position (region dx dy &optional reuse-rectangle) @@ -666,9 +666,9 @@ rectangle)) (defun bounding-rectangle-position-equal (region1 region2) - (multiple-value-bind (x1 y1) (bounding-rectangle-position* region1) + (multiple-value-bind (x1 y1) (bounding-rectangle-position region1) (declare (type coordinate x1 y1)) - (multiple-value-bind (x2 y2) (bounding-rectangle-position* region2) + (multiple-value-bind (x2 y2) (bounding-rectangle-position region2) (declare (type coordinate x2 y2)) (and (= x1 x2) (= y1 y2))))) @@ -682,16 +682,16 @@ (= bottom1 bottom2))))) ;; This should only be used to compare COORDINATEs -(defun-inline position-difference* (x1 y1 x2 y2) +(defun-inline position-difference (x1 y1 x2 y2) (declare (type coordinate x1 y1 x2 y2)) (values (- x1 x2) (- y1 y2))) (defun bounding-rectangle-position-difference (region1 region2) - (multiple-value-bind (x1 y1) (bounding-rectangle-position* region1) + (multiple-value-bind (x1 y1) (bounding-rectangle-position region1) (declare (type coordinate x1 y1)) - (multiple-value-bind (x2 y2) (bounding-rectangle-position* region2) + (multiple-value-bind (x2 y2) (bounding-rectangle-position region2) (declare (type coordinate x2 y2)) - (position-difference* x1 y1 x2 y2)))) + (position-difference x1 y1 x2 y2)))) (defun-inline bounding-rectangle-width (region) (with-bounding-rectangle* (left top right bottom) region @@ -795,12 +795,12 @@ ;;--- How to do this? ) -(defmethod region-contains-point*-p ((region-set region-set) x y) - (flet ((contains-point*-p (region) - (when (region-contains-point*-p region x y) - (return-from region-contains-point*-p t)))) - (declare (dynamic-extent #'contains-point*-p)) - (map-over-region-set-regions #'contains-point*-p region-set)) +(defmethod region-contains-position-p ((region-set region-set) x y) + (flet ((contains-position-p (region) + (when (region-contains-position-p region x y) + (return-from region-contains-position-p t)))) + (declare (dynamic-extent #'contains-position-p)) + (map-over-region-set-regions #'contains-position-p region-set)) nil) (defmethod region-contains-region-p ((region-set region-set) (other-region region)) diff --git a/utils/transformations.lisp b/utils/transformations.lisp index 04b6af6e..d471d84d 100644 --- a/utils/transformations.lisp +++ b/utils/transformations.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: transformations.lisp,v 1.3 92/02/24 13:05:59 cer Exp $ +;; $fiHeader: transformations.lisp,v 1.4 92/03/04 16:20:26 cer Exp $ (in-package :clim-utils) @@ -25,9 +25,9 @@ (defgeneric compose-scaling-with-transformation (transform mx my &optional origin)) (defgeneric compose-rotation-with-transformation (transform angle &optional origin)) -(defgeneric transform-point* (transform x y) +(defgeneric transform-position (transform x y) (declare (values x y))) -(defgeneric untransform-point* (transform x y) +(defgeneric untransform-position (transform x y) (declare (values x y))) (defgeneric transform-distance (transform dx dy) @@ -682,10 +682,10 @@ ;;; Transforming and untransforming of points -(defmethod transform-point* ((transform identity-transformation) x y) +(defmethod transform-position ((transform identity-transformation) x y) (values x y)) -(defmethod transform-point* ((transform translation-transformation) x y) +(defmethod transform-position ((transform translation-transformation) x y) (declare (type real x y)) (let ((x (float x 0f0)) (y (float y 0f0))) @@ -694,7 +694,7 @@ (declare (type single-float tx ty)) (values (+ x tx) (+ y ty))))) -(defmethod transform-point* ((transform standard-transformation) x y) +(defmethod transform-position ((transform standard-transformation) x y) (declare (type real x y)) (let ((x (float x 0f0)) (y (float y 0f0))) @@ -704,11 +704,16 @@ (values (+ (* x mxx) (* y mxy) tx) (+ (* x myx) (* y myy) ty))))) +#+CLIM-1-compatibility +(define-compatibility-function (transform-point* transform-position) + (transform x y) + (transform-position transform x y)) -(defmethod untransform-point* ((transform identity-transformation) x y) + +(defmethod untransform-position ((transform identity-transformation) x y) (values x y)) -(defmethod untransform-point* ((transform translation-transformation) x y) +(defmethod untransform-position ((transform translation-transformation) x y) (declare (type real x y)) (let ((x (float x 0f0)) (y (float y 0f0))) @@ -717,9 +722,14 @@ (declare (type single-float tx ty)) (values (- x tx) (- y ty))))) -(defmethod untransform-point* ((transform standard-transformation) x y) +(defmethod untransform-position ((transform standard-transformation) x y) (declare (type real x y)) - (transform-point* (slot-value transform 'inverse) x y)) + (transform-position (slot-value transform 'inverse) x y)) + +#+CLIM-1-compatibility +(define-compatibility-function (untransform-point* untransform-position) + (transform x y) + (transform-position transform x y)) ;;; Transforming and untransforming of distances diff --git a/utils/utilities.lisp b/utils/utilities.lisp index 618e8bb4..5a2fe80f 100644 --- a/utils/utilities.lisp +++ b/utils/utilities.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: utilities.lisp,v 1.3 92/02/24 13:06:01 cer Exp $ +;; $fiHeader: utilities.lisp,v 1.4 92/03/04 16:20:27 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -56,18 +56,18 @@ #+Allegro `(let ((temp ,array)) (etypecase temp (simple-vector temp) - ((vector t) (let ((temp2 (excl::ah_data temp))) - (setq temp2 (if (consp temp2) - (cdr temp2) - temp2)) - (assert (and - (zerop (the fixnum - (excl::ah_displacement temp))) - (typep temp2 'simple-vector)) - () - "Arrays passed to ~S must be non-displaced" - 'with-fast-vector-references) - temp2)))) + ((vector t) + (let ((temp2 (excl::ah_data temp))) + (setq temp2 (if (consp temp2) + (cdr temp2) + temp2)) + (assert (and + (zerop (the fixnum (excl::ah_displacement temp))) + (typep temp2 'simple-vector)) + () + "Arrays passed to ~S must be non-displaced" + 'with-fast-vector-references) + temp2)))) #+Genera array #-(or Allegro Genera) array) (internal-binding-declarations (variables) diff --git a/xlib/ffi.lisp b/xlib/ffi.lisp index 83fcaa1d..8afdd297 100644 --- a/xlib/ffi.lisp +++ b/xlib/ffi.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ffi.lisp,v 1.8 92/03/24 19:37:20 cer Exp Locker: cer $ +;; $fiHeader: ffi.lisp,v 1.9 92/03/30 17:52:16 cer Exp $ (in-package :x11) @@ -93,9 +93,23 @@ (:pointer `(* ,(second type))) (:array (destructuring-bind - (ignore type indicies) type - (declare (ignore ignore)) - `(,@indicies ,type)))))) + (ignore type indicies) type + (declare (ignore ignore)) + `(,@indicies ,type)))))) + +#+ignore +(defmacro def-exported-foreign-function ((name &rest options) &rest args) + `(foreign-functions:defforeign + ',name + :arguments ',(mapcar #'(lambda (x) x t) args) + :call-direct t + :callback nil + :arg-checking nil + :return-type 'integer + :entry-point ,(second (assoc :name options)))) + + +;;; Delay version (defun trans-arg-type (type) (excl:if* (consp type) @@ -126,20 +140,6 @@ (:signed-32bit :integer) (t :unsigned-integer)))) -#+ignore -(defmacro def-exported-foreign-function ((name &rest options) &rest args) - `(foreign-functions:defforeign - ',name - :arguments ',(mapcar #'(lambda (x) x t) args) - :call-direct t - :callback nil - :arg-checking nil - :return-type 'integer - :entry-point ,(second (assoc :name options)))) - - -;;; Delay version - (defmacro def-exported-foreign-function ((name &rest options) &rest args) `(progn (eval-when (eval load compile) diff --git a/xlib/xlib-defs.lisp b/xlib/xlib-defs.lisp index 61114e44..991c384f 100644 --- a/xlib/xlib-defs.lisp +++ b/xlib/xlib-defs.lisp @@ -1,5 +1,5 @@ ;; -*- mode: common-lisp; package: x11 -*- -;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. +;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;;; $fiHeader$ +;;; $fiHeader: xlib-defs.lisp,v 1.1 92/03/06 17:06:59 cer Exp $ (in-package :x11) diff --git a/xlib/xlib-funs.lisp b/xlib/xlib-funs.lisp index 11a7a261..5d77f694 100644 --- a/xlib/xlib-funs.lisp +++ b/xlib/xlib-funs.lisp @@ -1,5 +1,5 @@ ;; -*- mode: common-lisp; package: x11 -*- -;;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. +;; (c) Copyright 1990 Sun Microsystems, Inc. All Rights Reserved. ;; ;; copyright (c) 1985, 1986 Franz Inc, Alameda, Ca. All rights reserved. ;; copyright (c) 1986-1991 Franz Inc, Berkeley, Ca. All rights reserved. @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;;; $fiHeader: xlib-funs.lisp,v 1.2 92/03/24 19:37:22 cer Exp Locker: cer $ +;;; $fiHeader: xlib-funs.lisp,v 1.3 92/03/30 17:52:19 cer Exp $ (in-package :x11) -- GitLab