diff --git a/cloe/cloe-port.lisp b/cloe/cloe-port.lisp index 92c7a74c57c80c2a9291bd5124f13dae67c6bf8d..1ef9829818bd5749fd5e5e8e33fa419c67e24a7c 100644 --- a/cloe/cloe-port.lisp +++ b/cloe/cloe-port.lisp @@ -1,18 +1,111 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLOE-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: cloe-port.lisp,v 1.1 92/10/01 10:03:56 cer Exp $ +;; $fiHeader: cloe-port.lisp,v 1.2 92/10/28 11:32:31 cer Exp $ (in-package :cloe-clim) "Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." +(defparameter *vk->keysym* + `( + ;; The semi-standard characters + (#x0d #\newline :enter :newline #\return :return) + (#x20 #\space :space) + (#x09 #\tab :tab) + (#x2e :delete) + (#x08 #\backspace :backspace :rubout) + ;;(???? :page) + ;;(???? :linefeed) + (#x1b #\escape :escape :abort) + ;; The shifts + (#x10 :left-shift) + (#x11 :left-control) + (#x14 :caps-lock) + (#x12 :left-meta) + (#x90 :num-lock) + ;; Non-standard keys + (#x03 :cancel) + (#x0c :clear :clear-input) + (#x13 :pause) + (#x21 :page-up) + (#x22 :page-down :scroll) + (#x23 :end) + (#x24 :home) + (#x25 :left) + (#x26 :up) + (#x27 :right) + (#x28 :down) + (#x29 :select) + (#x2b :execute) + (#x2c :print-screen) + (#x2d :insert) + (#x2f :help) + (#x60 :keypad-0) + (#x61 :keypad-1) + (#x62 :keypad-2) + (#x63 :keypad-3) + (#x64 :keypad-4) + (#x65 :keypad-5) + (#x66 :keypad-6) + (#x67 :keypad-7) + (#x68 :keypad-8) + (#x69 :keypad-9) + (#x6a :keypad-multiply) + (#x6b :keypad-add) + (#x6c :keypad-separator) + (#x6d :keypad-subtract) + (#x6e :keypad-decimal) + (#x6f :keypad-divide) + (#x70 :f1) + (#x71 :f2) + (#x72 :f3) + (#x73 :f4) + (#x74 :f5) + (#x75 :f6) + (#x76 :f7) + (#x77 :f8) + (#x78 :f9) + (#x79 :f10) + (#x7a :f11) + (#x7b :f12) + (#x7c :f13) + (#x7d :f14) + (#x7e :f15) + (#x7f :f16) + (#x80 :f17) + (#x81 :f18) + (#x82 :f19) + (#x83 :f20) + (#x84 :f21) + (#x85 :f22) + (#x86 :f23) + (#x87 :f24) + (#x91 :scroll-lock) + ;;(???? :complete) + ;;(???? :refresh) + )) + +(defparameter *char->keysym* + (let ((array (make-array 256 :initial-element nil))) + (dolist (char '(#\newline #\escape #\backspace #\tab #\space #\return)) + (setf (svref array (char-code char)) + (intern (string-upcase (char-name char)) "KEYWORD"))) + (loop for code from (char-code #\!) to (char-code #\~) + do (setf (svref array code) + (intern (string (char-upcase (code-char code))) "KEYWORD"))) + array)) + + + (defvar *cloe-port* nil) (defclass cloe-port (basic-port) ((text-style->cloe-font-mapping :initform (make-hash-table)) (font-cache-style :initform nil) (font-cache-font :initform nil) + (vk->keysym :initform (make-hash-table)) + (keysym->keysym :initform (make-hash-table)) logpixelsy (event-queue :initform (make-queue)) (pointer-sheet :initform nil) @@ -29,11 +122,11 @@ ;;--- Eventually do better than this (defclass cloe-palette (basic-palette) ()) -(defmethod make-palette ((port cloe-port) &key color-p mutable-p) +(defmethod make-palette ((port cloe-port) &key color-p dynamic-p) (make-instance 'cloe-palette :port port :color-p color-p - :mutable-p mutable-p)) + :dynamic-p dynamic-p)) (defmethod initialize-instance :before ((port cloe-port) &key) @@ -42,12 +135,22 @@ (setf *cloe-port* port)) (defmethod initialize-instance :after ((port cloe-port) &key) - (initialize-dc) - (setf (slot-value port 'logpixelsy) (win::get-device-caps *dc* 90)) - (setf (slot-value port 'silica::default-palette) - (make-palette port :color-p t)) + (with-slots (logpixelsy silica::default-palette vk->keysym) port + (initialize-dc) + (setf logpixelsy (win::get-device-caps *dc* win::logpixelsy)) + (setf silica::default-palette (make-palette port :color-p t)) + (loop for (vk . keysym) in *vk->keysym* do + (setf (gethash vk vk->keysym) keysym)) + (loop for code from (char-code #\!) to (char-code #\~) + for char = (code-char code) + do (push char (gethash (win::get-keymap char) vk->keysym))) + ) nil) +(defmethod destroy-port :before ((port cloe-port)) + (when (eq port *cloe-port*) + (setf *cloe-port* nil))) + (defstruct (cloe-font) @@ -73,23 +176,6 @@ family font-width-table) -;;; Fill up the font width table for a variable width font -;;; by asking windows the width of each character. -;;; This doesn't quite work in the face of kerning. -(defun initialize-font-width-table (font window) - ;; only need to run this on variable-width fonts. - (select-font (cloe-font-index font)) - (let ((array (make-array (1+ (- 126 32))))) - (with-temporary-string (string :length 1) - (setf (fill-pointer string) 1) - (loop for i from 32 to 126 do - (setf (aref string 0) (code-char i)) - (multiple-value-bind (width height) - (win::get-text-extent window string) - (declare (ignore height )) - (setf (aref array (- i 32)) width)))) - (setf (cloe-font-font-width-table font) array))) - (defparameter *cloe-logical-size-alist* '((:tiny 6) (:very-small 7) @@ -251,64 +337,232 @@ -#|| -(defvar *vk->keysym* (make-array 256 :initial-element nil)) -(defvar *keysym->vk* (make-hash-table)) - -(defmacro define-vk (vk keysym) - `(progn - (setf (svref *vk->keysym* vk) keysym) - (setf (gethash ,keysym *keysym->vk*) ,vk))) - -(defun-inline vk->keysym (vk) - (svref *vk->keysym* vk)) - -(defun-inline keysym->vk (keysym) - (gethash keysym *keysym->vk*)) - -;; The semi-standard characters -(define-vk 0x0d :return) -(define-vk ???? :newline) -(define-vk 0x09 :tab) -(define-vk 0x2e :rubout) -(define-vk 0x08 :backspace) -(define-vk ???? :page) -(define-vk ???? :linefeed) -(define-vk 0x1b :escape) - -;; Other useful characters -(define-vk 0x23 :end) -(define-vk ???? :abort) -(define-vk 0x2f :help) -(define-vk ???? :complete) -(define-vk 0x22 :scroll) -(define-vk ???? :refresh) -(define-vk ???? :clear-input) - -;; Finally, the shifts -(define-vk 0x19 :left-shift) -(define-vk ???? :right-shift) -(define-vk 0x11 :left-control) -(define-vk ???? :right-control) -(define-vk 0x14 :caps-lock) -(define-vk ???? :shift-lock) -(define-vk 0x12 :left-meta) -(define-vk ???? :right-meta) -(define-vk ???? :left-super) -(define-vk ???? :right-super) -(define-vk ???? :left-hyper) -(define-vk ???? :right-hyper) - -;; Non-standard keys found on Sun keyboards - -(define-vk 0x70 :f1) -(define-vk 0x71 :f2) -(define-vk 0x72 :f3) -(define-vk 0x73 :f4) -(define-vk 0x74 :f5) -(define-vk 0x75 :f6) -(define-vk 0x76 :f7) -(define-vk 0x77 :f8) -(define-vk 0x78 :f9) -(define-vk 0x79 :f10) -||# +(defmethod port-canonicalize-gesture-spec + ((port cloe-port) gesture-spec &optional modifier-state) + (with-slots (vk->keysym) port + (multiple-value-bind (keysym shifts) + (if modifier-state + (values gesture-spec modifier-state) + (parse-gesture-spec gesture-spec)) + (let ((char (typecase keysym + (symbol + (let ((code (position keysym *char->keysym*))) + (and code + (code-char code)))) + (character + (shiftf keysym (svref *char->keysym* (char-code keysym))))))) + (loop for keysyms being the hash-values of vk->keysym using (hash-key vk) + when (member (or char keysym) keysyms) + do (setf keysym (first keysyms)) + (when (characterp keysym) + (setf keysym (svref *char->keysym* (char-code keysym)))) + (when (logtest #x100 vk) + (setf shifts (logior shifts +shift-key+))) + (return)) + (cons keysym shifts))))) + + + +(defun-inline sign-extend-16 (n) + (dpb n (byte 15 0) (- (ldb (byte 1 15) n)))) + +(defmethod note-pointer-motion ((port cloe-port) sheet x y) + (with-slots (pointer-sheet pointer-x pointer-y) port + (setf pointer-sheet sheet) + (setf pointer-x x) + (setf pointer-y y))) + +(defmethod flush-pointer-motion ((port cloe-port)) + (with-slots (event-queue pointer-sheet pointer-x pointer-y) port + (when pointer-sheet + (let ((pointer (port-pointer port))) + (when pointer + (queue-put event-queue + (allocate-event 'pointer-motion-event + :native-x pointer-x + :native-y pointer-y + :modifier-state (port-modifier-state port) + :pointer pointer + :sheet pointer-sheet)))) + (setf pointer-sheet nil)))) + +;;; Convert a MS Windows shift mask into a CLIM modifier-state +(defun windows-mask->modifier-state (mask) + (if (logtest win::mk_shift mask) + (if (logtest win::mk_control mask) + (make-modifier-state :shift :control) + (make-modifier-state :shift)) + (if (logtest win::mk_control mask) + (make-modifier-state :control) + (make-modifier-state)))) + +(defmethod event-handler ((port cloe-port) args) + (with-slots (event-queue pointer-sheet pointer-x pointer-y vk->keysym) port + (let ((sheet (mirror->sheet port (win::get-16bit args 0))) + (message (win::get-16bit args 2))) + (declare (fixnum message)) + (when sheet + (cond ((eql message win::wm_mousemove) + (note-pointer-motion port sheet (win::get-16bit args 6) (win::get-16bit args 8))) + + ((eql message win::wm_paint) + (let ((ileft (win::get-16bit args 4)) + (itop (win::get-16bit args 6)) + (iright (win::get-16bit args 8)) + (ibottom (win::get-16bit args 10))) + (unless (or (= ileft iright) (= itop ibottom)) ;seems to happen alot + (queue-put event-queue + (allocate-event 'window-repaint-event + ;;--- Should this be (MIRROR-REGION PORT SHEET), as + ;;--- it is in the :CONFIGURE-NOTIFY case? + :native-region (sheet-native-region sheet) + :region (make-bounding-rectangle ileft itop iright ibottom) + :sheet sheet))))) + + #|| + ;; scrolling + ((or (eql message win::wm_hscroll) + (eql message win::wm_vscroll)) + (let ((type (win::get-16bit args 4)) + (position (win::get-16bit args 6)) + (message (cond ((eql message win::wm_hscroll) :x) + ((eql message win::wm_vscroll) :y)))) + (declare (fixnum type position)) + (multiple-value-bind (type position) + (cond ((eql type win::sb_lineup) + (values :relative-jump -1)) + ((eql type win::sb_linedown) + (values :relative-jump +1)) + ((eql type win::sb_pageup) + (values :screenful -1)) + ((eql type win::sb_pagedown) + (values :screenful +1)) + ((eql type win::sb_thumbposition) + (values :percentage position)) + ((eql type win::sb_top) + (values :percentage 0)) + ((eql type win::sb_bottom) + (values :percentage 100))) + (when type + (queue-put pending-scrolls (list message type position)) + (pushnew stream *cloe-windows-with-deferred-events*))))) + ||# + + ;; resizing + ((or (eql message win::wm_move) + (eql message win::wm_size)) + (queue-put event-queue + (allocate-event 'window-configuration-event + :sheet sheet))) + + ;; character typed + ((or (eql message win::wm_keydown) + (eql message win::wm_syskeydown) + (eql message win::wm_keyup) + (eql message win::wm_syskeyup)) + (flush-pointer-motion port) + (let ((code (win::get-16bit args 4))) + (let ((vk (ldb (byte 8 0) code))) + ;; CAPS LOCK + (when (and (logtest #x0800 code) + (<= #x41 vk #x5a)) + (setf code (logior #x100 code))) + ;; NUM LOCK + (when (and (logtest #x1000 code) + (<= #x60 vk #x69)) + (setf code (logior #x100 code)))) + (let ((keysym (or (gethash (ldb (byte 9 0) code) vk->keysym) + (gethash (ldb (byte 8 0) code) vk->keysym))) + (char nil)) + (when (consp keysym) + (setf keysym (first keysym))) + (when (characterp keysym) + (when (zerop (ldb (byte 2 9) code)) + (setf char keysym)) + (setf keysym (svref *char->keysym* (char-code keysym)))) + (queue-put event-queue + (allocate-event + (cond ((or (eql message win::wm_keydown) + (eql message win::wm_syskeydown)) + 'key-press-event) + ((or (eql message win::wm_keyup) + (eql message win::wm_syskeyup)) + 'key-release-event)) + :key-name keysym + :character char + :modifier-state (setf (port-modifier-state port) + (ldb (byte 3 8) code)) + :sheet sheet))))) + + ;; button press or release + ((or (eql message win::wm_lbuttondown) + (eql message win::wm_rbuttondown) + (eql message win::wm_mbuttondown) + (eql message win::wm_lbuttonup) + (eql message win::wm_rbuttonup) + (eql message win::wm_mbuttonup)) + (let ((modifier-state (windows-mask->modifier-state (win::get-16bit args 4))) + (pointer (port-pointer port))) + (when pointer + (flush-pointer-motion port) + (setf (port-modifier-state port) modifier-state) + (multiple-value-bind (key button) + (cond ((eql message win::wm_lbuttondown) + (values 'pointer-button-press-event +pointer-left-button+)) + ((eql message win::wm_mbuttondown) + (values 'pointer-button-press-event +pointer-middle-button+)) + ((eql message win::wm_rbuttondown) + (values 'pointer-button-press-event +pointer-right-button+)) + ((eql message win::wm_lbuttonup) + (values 'pointer-button-release-event +pointer-left-button+)) + ((eql message win::wm_mbuttonup) + (values 'pointer-button-release-event +pointer-middle-button+)) + ((eql message win::wm_rbuttonup) + (values 'pointer-button-release-event +pointer-right-button+))) + (queue-put event-queue + (allocate-event key + :native-x (win::get-16bit args 6) + :native-y (win::get-16bit args 8) + :button button + :modifier-state modifier-state + :pointer pointer + :sheet sheet)))))) + ))))) + +(defun win::vanilla-event (code length args) + (declare (ignore code length)) ;because I don't know what they are! + (event-handler *cloe-port* args)) + +;;; + +(defmethod process-next-event ((port cloe-port) + &key (timeout nil) (wait-function nil) + (state "Windows Event")) + (declare (ignore state)) + (with-slots (event-queue) port + (let ((end-time (and timeout (+ (get-internal-real-time) + (* internal-time-units-per-second timeout))))) + (win::await-response -1 nil nil) + (loop + (flush-pointer-motion port) + (let ((event (queue-get event-queue))) + (when event + (distribute-event port event) + (return t))) + (when (and wait-function + (funcall wait-function)) + (return nil)) + (when (and end-time (>= (get-internal-real-time) end-time)) + (return nil)) + (win::await-response -1 t t))))) + +(defmethod distribute-event :around ((port cloe-port) (event window-configuration-event)) + (let* ((sheet (event-sheet event)) + (mirror (sheet-mirror sheet))) + (unless (win::is-iconic mirror) + (let ((native-region (mirror-region port sheet))) + (setf (slot-value event 'pyrex::native-region) native-region) + (setf (slot-value event 'pyrex::region) + (untransform-region (sheet-native-transformation sheet) + native-region))) + (call-next-method)))) diff --git a/compatibility/clim1-compatibility.lisp b/compatibility/clim1-compatibility.lisp index 8272c4889518ab7be8d0c65971c56dac892a342c..966266083e02c826f1dd50dfda3e65c252f363f7 100644 --- a/compatibility/clim1-compatibility.lisp +++ b/compatibility/clim1-compatibility.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes; Patch-File: Yes -*- -;; $fiHeader: clim1-compatibility.lisp,v 1.3 92/09/24 09:40:43 cer Exp $ +;; $fiHeader: clim1-compatibility.lisp,v 1.4 92/10/02 15:21:25 cer Exp $ (in-package :clim-internals) @@ -904,14 +904,14 @@ (cons (setq view (apply #'make-instance view)))) (setq view (decode-indirect-view type view (frame-manager stream))) - ;; Call methods to do the work + ;; Call STREAM-ACCEPT to do the work. It would be nice if we could + ;; call PROMPT-FOR-ACCEPT to generate the real query-id here, but we + ;; can't because we want to be able to decide exactly how it is called + ;; on a case-by-case basis. For example, within ACCEPTING-VALUES... (with-keywords-removed (accept-args accept-args '(:stream :view)) - (let ((query-identifier - (apply #'prompt-for-accept - (or *original-stream* stream) type view accept-args))) - (apply #'stream-accept (or *original-stream* stream) type - :view view :query-identifier query-identifier - accept-args)))) + (apply #'stream-accept (encapsulated-stream stream) type + :view view :query-identifier query-identifier + accept-args))) (define-compiler-macro accept (&whole form @@ -1571,20 +1571,21 @@ (defgeneric menu-choose (items &rest keys - &key associated-window default-item default-style + &key associated-window text-style default-item label printer presentation-type cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing cell-align-x cell-align-y pointer-documentation + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing)) ;; Are these reasonable defaults for UNIQUE-ID, CACHE-VALUE, ID-TEST, and CACHE-TEST? (defmethod menu-choose ((items t) &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type (cache nil) (unique-id items) (id-test #'equal) (cache-value items) (cache-test #'equal) @@ -1592,15 +1593,17 @@ x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) pointer-documentation + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) (declare (values value chosen-item gesture)) (declare (ignore associated-window - default-item default-style + text-style default-item label printer presentation-type cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing cell-align-x cell-align-y + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing pointer-documentation)) @@ -1639,7 +1642,7 @@ ((framem standard-frame-manager) items &rest keys &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type (cache nil) (unique-id items) (id-test #'equal) (cache-value items) (cache-test #'equal) @@ -1647,11 +1650,15 @@ x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) pointer-documentation + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) (declare (values value chosen-item gesture)) (declare (ignore keys)) #+CLIM-1-compatibility + (when default-style + (setq text-style default-style)) + #+CLIM-1-compatibility (when (or inter-row-spacing inter-column-spacing) (setq x-spacing inter-column-spacing y-spacing inter-row-spacing)) @@ -1664,10 +1671,9 @@ ;; Lucid production compiler tries to use an undefined internal ;; variable if this LET isn't done. #+Lucid (items items)) - (with-menu (menu associated-window) - (setf (window-label menu) label) + (with-menu (menu associated-window :label label) (reset-frame (pane-frame menu) :title label) - (with-text-style (menu default-style) + (with-text-style (menu text-style) (with-end-of-line-action (menu :allow) (loop (multiple-value-bind (item gesture) @@ -1700,7 +1706,7 @@ (defun hierarchical-menu-choose (items &key (associated-window (frame-top-level-sheet *application-frame*)) - default-item default-style + text-style default-item label printer presentation-type x-position y-position (cache nil) @@ -1709,10 +1715,14 @@ max-width max-height n-rows n-columns x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) (declare (values value chosen-item gesture)) #+CLIM-1-compatibility + (when default-style + (setq text-style default-style)) + #+CLIM-1-compatibility (when (or inter-row-spacing inter-column-spacing) (setq x-spacing inter-column-spacing y-spacing inter-row-spacing)) @@ -1722,9 +1732,8 @@ (let ((item-printer (cond (presentation-type #'present-item) (printer printer) (t #'print-menu-item)))) - (with-menu (menu associated-window) - (setf (window-label menu) label) - (with-text-style (menu default-style) + (with-menu (menu associated-window :label label) + (with-text-style (menu text-style) (multiple-value-bind (item gesture) (flet ((menu-choose-body (stream presentation-type) (draw-standard-menu stream presentation-type items default-item @@ -1749,7 +1758,7 @@ (hierarchical-menu-choose (menu-item-items item) :associated-window associated-window - :default-style default-style + :text-style text-style :x-position mr :y-position mt :cache cache :unique-id unique-id :id-test id-test @@ -1865,11 +1874,12 @@ (defmacro define-static-menu (name root-window items &rest keys - &key default-item default-style + &key text-style default-item printer presentation-type max-width max-height n-rows n-columns x-spacing y-spacing (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility default-style #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing) (declare (ignore max-width max-height n-rows n-columns @@ -1877,10 +1887,11 @@ #+CLIM-1-compatibility inter-row-spacing #+CLIM-1-compatibility inter-column-spacing)) (with-keywords-removed (drawer-keys keys - '(:default-item :default-style :printer :presentation-type)) + '(:text-style :default-item :printer :presentation-type + #+CLIM-1-compatibility :default-style)) `(defvar ,name (define-static-menu-1 ',name ,root-window ',items :default-item ',default-item - :default-style ',default-style + :text-style (or ',default-style ',text-style) :presentation-type ',presentation-type :printer ',printer :drawer-args ,(copy-list drawer-keys))))) diff --git a/demo/browser.lisp b/demo/browser.lisp index 6619d9766f9ad984d468b03627a7e367e7724527..af43ecc6b25319700af58cc580130e2f2d05775f 100644 --- a/demo/browser.lisp +++ b/demo/browser.lisp @@ -3,7 +3,7 @@ ;;; Simple extensible browser ;;; Scott McKay -;; $fiHeader: browser.lisp,v 1.14 92/10/07 14:43:16 cer Exp Locker: cer $ +;; $fiHeader: browser.lisp,v 1.15 92/10/28 11:32:51 cer Exp $ (in-package :clim-browser) @@ -713,20 +713,20 @@ ;;; The browser itself (define-application-frame browser () - ((graph-type :initform :graphical) - (browser-type :initform nil) - (browser-subtype :initform nil) - (browser-ptype :initform nil) - (browser-options :initform nil) - (node-maker :initform #'false) - (root-node-maker :initform #'false) - (grapher-args :initform nil) - (tree-depth :initform 1) - (merge-duplicate-nodes :initform t) - (root-nodes :initform nil) - (all-nodes :initform nil) - (auto-snapshot :initform t) - (snapshots :initform nil)) + ((graph-type :initform :graphical) + (browser-type :initform nil) + (browser-subtype :initform nil) + (browser-ptype :initform nil) + (browser-options :initform nil) + (node-maker :initform #'false) + (root-node-maker :initform #'false) + (grapher-args :initform nil) + (tree-depth :initform 1) + (merge-duplicate-nodes :initform t) + (root-nodes :initform nil) + (all-nodes :initform nil) + (auto-snapshot :initform t) + (snapshots :initform nil)) (:command-definer t) (:command-table (browser :inherit-from (accept-values-pane))) (:panes @@ -755,7 +755,6 @@ (1/2 interactor) (:fill control-panel))))))) - #+genera (define-genera-application browser :select-key #\Triangle) #+genera (zwei:defindentation (define-browser-command 0 3 1 3 2 1)) @@ -1442,4 +1441,3 @@ (run-frame-top-level frame))) (define-demo "Graphical Browser" do-browser) - diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp index d082545e4d1cdf74db6aaccc66ae44c99e89210d..5f6066fa751bdad3b68664c8e1e6e2bf4f5cb829 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.18 92/10/02 15:20:33 cer Exp $ +;; $fiHeader: cad-demo.lisp,v 1.19 92/10/07 14:43:18 cer Exp $ (in-package :clim-demo) @@ -850,7 +850,7 @@ (make-drawing *application-frame*) (com-refresh)) -(define-cad-demo-command (com-exit-CAD-demo :menu "Exit" :keystroke #\X) +(define-cad-demo-command (com-exit-cad-demo :menu "Exit" :keystroke #\X) () (frame-exit *application-frame*)) diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp index 6b5f3c89bae73bb69e4df0227f50cc9391b33863..6c81f9d16b9eff2a87a0ac5615cca2f1e6c540ab 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: demo-driver.lisp,v 1.16 92/10/28 11:32:55 cer Exp Locker: cer $ +;; $fiHeader: demo-driver.lisp,v 1.17 92/11/05 17:15:49 cer Exp $ (in-package :clim-demo) @@ -41,9 +41,9 @@ (demo-menu-choose (list) (with-menu (menu (typecase port (frame-manager (graft port)) - (t (find-graft :port port)))) - (setf (window-label menu) - '("Clim Demonstrations" :text-style (:fix :bold :normal))) + (t (find-graft :port port))) + :label '("Clim Demonstrations" + :text-style (:serif :bold :normal))) (menu-choose-from-drawer menu 'demo-menu-item #'(lambda (stream type) diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp index 5b434ba583e8d13717cb051f6ff42f3a23c56107..b51d61263ed0fcd4ff4c3f0332d32027a4cf9889 100644 --- a/demo/graphics-editor.lisp +++ b/demo/graphics-editor.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-GRAPHICS-EDITOR; Base: 10; Lowercase: Yes -*- -;; $fiHeader: graphics-editor.lisp,v 1.13 92/10/28 13:17:33 cer Exp $ +;; $fiHeader: graphics-editor.lisp,v 1.14 92/10/29 16:55:29 cer Exp $ (in-package :clim-graphics-editor) @@ -173,12 +173,12 @@ (+ xoff (- left 3)) (+ yoff (- top 3)) (+ xoff right 3) (+ yoff bottom 3) :ink (make-flipping-ink - (if (palette-color-p - (frame-palette (pane-frame stream))) - +red+ - +foreground-ink+) - +background-ink+) - :line-style (make-line-style :thickness 2) + (if (palette-color-p + (frame-palette (pane-frame stream))) + +red+ + +foreground-ink+) + +background-ink+) + :line-style (make-line-style :thickness 2) :filled nil)))) (defmethod move-object :after ((object box) x y) @@ -425,12 +425,12 @@ (last-box (slot-value *application-frame* 'last-box)) (style (slot-value *application-frame* 'style)) (shape (slot-value *application-frame* 'shape)) - (flipping-ink #+allegro - (make-flipping-ink (if (palette-color-p - (frame-palette *application-frame*)) - +blue+ - +foreground-ink+) - +background-ink+) + (flipping-ink #+allegro (make-flipping-ink + (if (palette-color-p + (frame-palette *application-frame*)) + +blue+ + +foreground-ink+) + +background-ink+) #-allegro +flipping-ink+)) ;;--- Zdrava supplies primitives to input basic objects such as ;;--- points, lines, rectangles and polygons, circles and ellipses, diff --git a/demo/ico.lisp b/demo/ico.lisp index 66bbc55bb81bdd07223f5a507066248559a69c77..920b594708727e5ab58e84f1dd4aa12cd5417927 100644 --- a/demo/ico.lisp +++ b/demo/ico.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: ico.lisp,v 1.12 92/10/28 13:17:35 cer Exp $ +;; $fiHeader: ico.lisp,v 1.13 92/10/29 16:55:32 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -72,52 +72,53 @@ :prompt "Line style"))) (when (palette-dynamic-p (frame-palette frame)) (formatting-cell (pane) - (multiple-value-bind (buffering ptype changed) - (accept '(member :single :double :triple) - :default (svref #(:single :double :triple) (1- ico-buffers)) - :stream pane - :prompt "Buffering") - (declare (ignore ptype)) - (when changed - (with-slots (ico-color-set2 ico-color-set3 - inks0 inks1 inks2 inks3) frame - (case buffering - (:single - (setf ico-buffers 1 - inks0 (vector *background-color*) - inks1 (vector *line-color*) - inks2 (vector *face1-color*) - inks3 (vector *face2-color*))) - (:double - (let ((g (or ico-color-set2 - (setf ico-color-set2 - (make-layered-color-set 4 4))))) - (setf ico-buffers 2 - inks0 (vector (layered-color g 0 nil) - (layered-color g nil 0)) - inks1 (vector (layered-color g 1 nil) - (layered-color g nil 1)) - inks2 (vector (layered-color g 2 nil) - (layered-color g nil 2)) - inks3 (vector (layered-color g 3 nil) - (layered-color g nil 3))))) - (:triple - (let ((g (or ico-color-set3 - (setf ico-color-set3 - (make-layered-color-set 4 4 4))))) - (setf ico-buffers 3 - inks0 (vector (layered-color g 0 nil nil) - (layered-color g nil 0 nil) - (layered-color g nil nil 0)) - inks1 (vector (layered-color g 1 nil nil) - (layered-color g nil 1 nil) - (layered-color g nil nil 1)) - inks2 (vector (layered-color g 2 nil nil) - (layered-color g nil 2 nil) - (layered-color g nil nil 2)) - inks3 (vector (layered-color g 3 nil nil) - (layered-color g nil 3 nil) - (layered-color g nil nil 3)))))))))))))) + (multiple-value-bind (buffering ptype changed) + (accept '(member :single :double :triple) + :default (svref #(:single :double :triple) (1- ico-buffers)) + :stream pane + :prompt "Buffering") + (declare (ignore ptype)) + (when changed + (with-slots (ico-color-set2 ico-color-set3 + inks0 inks1 inks2 inks3) frame + (case buffering + (:single + (setf ico-buffers 1 + inks0 (vector *background-color*) + inks1 (vector *line-color*) + inks2 (vector *face1-color*) + inks3 (vector *face2-color*))) + (:double + (let ((g (or ico-color-set2 + (setf ico-color-set2 + (make-layered-color-set 4 4))))) + (setf ico-buffers 2 + inks0 (vector (layered-color g 0 nil) + (layered-color g nil 0)) + inks1 (vector (layered-color g 1 nil) + (layered-color g nil 1)) + inks2 (vector (layered-color g 2 nil) + (layered-color g nil 2)) + inks3 (vector (layered-color g 3 nil) + (layered-color g nil 3))))) + (:triple + (let ((g (or ico-color-set3 + (setf ico-color-set3 + (make-layered-color-set 4 4 4))))) + (setf ico-buffers 3 + inks0 (vector (layered-color g 0 nil nil) + (layered-color g nil 0 nil) + (layered-color g nil nil 0)) + inks1 (vector (layered-color g 1 nil nil) + (layered-color g nil 1 nil) + (layered-color g nil nil 1)) + inks2 (vector (layered-color g 2 nil nil) + (layered-color g nil 2 nil) + (layered-color g nil nil 2)) + inks3 (vector (layered-color g 3 nil nil) + (layered-color g nil 3 nil) + (layered-color g nil nil 3)))))))))))))) + (define-ico-frame-command (com-ico-throw-ball :menu "Throw ball" :keystroke #\t) () (with-application-frame (frame) @@ -133,10 +134,10 @@ (let ((palette (frame-palette frame))) (catch-ball frame) (when ico-color-set2 - (remove-from-palette palette ico-color-set2) + (remove-color-from-palette palette ico-color-set2) (setf ico-color-set2 nil)) (when ico-color-set3 - (remove-from-palette palette ico-color-set3) + (remove-color-from-palette palette ico-color-set3) (setf ico-color-set3 nil)) (frame-exit frame))))) diff --git a/demo/listener.lisp b/demo/listener.lisp index 8f50f015cced3a5a1d3e74426f9555e0c1e5c948..484c65952f444b5e51c3bf3ddb1515f4f9474041 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.21 92/10/07 14:43:36 cer Exp $ +;; $fiHeader: listener.lisp,v 1.22 92/10/28 11:33:00 cer Exp $ (in-package :clim-demo) @@ -220,14 +220,14 @@ (with-output-recording-options (*lisp-listener-io* :draw t :record t) (lisp-listener-top-level *application-frame*)))) -(define-presentation-type restart-name ()) - (defvar *enter-debugger* '#:enter-debugger) (defun enter-debugger (stream) #+Genera (clim-internals::with-debug-io-selected (stream) (cl:break "Debugger break for ~A" (frame-pretty-name (pane-frame stream))))) +(define-presentation-type restart-name ()) + (define-presentation-method presentation-typep (object (type restart-name)) (or (eql object *enter-debugger*) (typep object 'restart))) @@ -239,7 +239,7 @@ (prin1 (restart-name object) stream))) (define-lisp-listener-command (com-invoke-restart :name t) - ((restart 'restart :gesture :select)) + ((restart 'restart-name :gesture :select)) (if (eql restart *enter-debugger*) (enter-debugger *standard-input*) (invoke-restart restart))) @@ -266,7 +266,7 @@ (fresh-line stream) (formatting-table (stream :x-spacing '(2 :character)) (dolist (restart restarts) - (with-output-as-presentation (stream restart 'restart + (with-output-as-presentation (stream restart 'restart-name :single-box t :allow-sensitive-inferiors nil) (formatting-row (stream) (formatting-cell (stream) stream) @@ -276,7 +276,7 @@ (formatting-cell (stream) (format stream "~A" restart))))) #+Genera - (with-output-as-presentation (stream *enter-debugger* 'restart + (with-output-as-presentation (stream *enter-debugger* 'restart-name :single-box t :allow-sensitive-inferiors nil) (formatting-row (stream) (formatting-cell (stream) stream) diff --git a/demo/plot.lisp b/demo/plot.lisp index f695ee3612f292ae271bf1da2f620093df4b5fa1..209306eea087ae819b397ca7f083db9e3728c5fe 100644 --- a/demo/plot.lisp +++ b/demo/plot.lisp @@ -21,7 +21,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: plot.lisp,v 1.14 92/10/29 15:02:50 cer Exp Locker: cer $ +;; $fiHeader: plot.lisp,v 1.15 92/10/29 16:55:34 cer Exp $ (in-package :clim-demo) @@ -195,33 +195,32 @@ (updating-output (stream :unique-id 'captions :cache-value (cons type (copy-list y-labels)) :cache-test #'equalp) - (let ((n-lines (length y-labels)) - (ascent (text-style-ascent (medium-text-style stream) stream)) - (descent (text-style-descent (medium-text-style stream) stream)) - (i 0)) - (surrounding-output-with-border (stream) - (formatting-table (stream) - (dolist (label y-labels) - (updating-output (stream :unique-id label :id-test #'equalp) - (formatting-row (stream) - (updating-output (stream :unique-id (cons :ink label) :id-test #'equalp) - (formatting-cell (stream) - (if (eq type :plot) - (progn - (draw-rectangle* stream 0 0 20 (+ ascent descent) - :ink +background-ink+) - (draw-line* stream 0 (/ ascent 2) 20 (/ ascent 2) - :ink (get-contrasting-inks stream n-lines i) - :line-dashes - (get-contrasting-dash-patterns stream n-lines i))) - (draw-rectangle* stream 0 0 20 (+ ascent descent) - :ink - (get-contrasting-inks stream n-lines i))))) - (updating-output (stream :unique-id (cons :text label) :id-test #'equalp) - (formatting-cell (stream) - (write-string label stream))))) - (incf i))))))) - + (let ((n-lines (length y-labels)) + (ascent (text-style-ascent (medium-text-style stream) stream)) + (descent (text-style-descent (medium-text-style stream) stream)) + (i 0)) + (surrounding-output-with-border (stream) + (formatting-table (stream) + (dolist (label y-labels) + (updating-output (stream :unique-id label :id-test #'equalp) + (formatting-row (stream) + (updating-output (stream :unique-id (cons :ink label) :id-test #'equalp) + (formatting-cell (stream) + (if (eq type :plot) + (progn + (draw-rectangle* stream 0 0 20 (+ ascent descent) + :ink +background-ink+) + (draw-line* stream 0 (/ ascent 2) 20 (/ ascent 2) + :ink (get-contrasting-inks stream n-lines i) + :line-dashes (get-contrasting-dash-patterns + stream n-lines i))) + (draw-rectangle* stream 0 0 20 (+ ascent descent) + :ink + (get-contrasting-inks stream n-lines i))))) + (updating-output (stream :unique-id (cons :text label) :id-test #'equalp) + (formatting-cell (stream) + (write-string label stream))))) + (incf i))))))) (defun draw-axis (stream type width height x-min y-min x-max y-max x-labels y-labels diff --git a/genera/genera-medium.lisp b/genera/genera-medium.lisp index c677d4da927a4e561dfd35ff9bad460af9c2c237..953feb39f8e0d2975855be1e1d4570628a7704c8 100644 --- a/genera/genera-medium.lisp +++ b/genera/genera-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: GENERA-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: genera-medium.lisp,v 1.12 92/09/24 09:39:50 cer Exp $ +;; $fiHeader: genera-medium.lisp,v 1.13 92/10/28 11:32:39 cer Exp $ (in-package :genera-clim) @@ -974,18 +974,27 @@ (when towards-x (incf towards-x x-adjust) (incf towards-y y-adjust))) - (invoke-with-appropriate-drawing-state medium ink nil - #'(lambda (window alu) - (declare (sys:downward-function)) - (tv:prepare-sheet (window) - (let ((x (+ x (tv:sheet-left-margin-size window))) - (y (+ y (tv:sheet-top-margin-size window)))) - (tv:sheet-draw-glyph (char-code character) font x y alu window))) - (scl:send window :draw-glyph (char-code character) font x y alu)) - #'(lambda (window) - (declare (sys:downward-function)) - (funcall (flavor:generic graphics:draw-glyph) window - (char-code character) font x y))))))) + (macrolet ((with-diacritic ((character font) &body body) + ;; I am dumbfounded. It seems that we need to bind the + ;; fill pointer of the font structure beyond its usual + ;; length if we want to output a diacritic character. + `(if (diacritic-char-p ,character) + (letf-globally (((tv:font-fill-pointer ,font) #o320)) + ,@body) + ,@body))) + (invoke-with-appropriate-drawing-state medium ink nil + #'(lambda (window alu) + (declare (sys:downward-function)) + (tv:prepare-sheet (window) + (let ((x (+ x (tv:sheet-left-margin-size window))) + (y (+ y (tv:sheet-top-margin-size window)))) + (with-diacritic (character font) + (tv:sheet-draw-glyph (char-code character) font x y alu window))))) + #'(lambda (window) + (declare (sys:downward-function)) + (with-diacritic (character font) + (funcall (flavor:generic graphics:draw-glyph) window + (char-code character) font x y))))))))) (defmethod medium-draw-text* ((medium genera-medium) string-or-char x y start end diff --git a/misc/compile-1.lisp b/misc/compile-1.lisp index 5bd2a5f7926bf39696bfdc2c6e6c23360816a75f..6b363878120e36af9f21052bc8c8043dca863994 100644 --- a/misc/compile-1.lisp +++ b/misc/compile-1.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: compile-1.lisp,v 1.13 92/10/29 15:02:54 cer Exp Locker: cer $ +;; $fiHeader: compile-1.lisp,v 1.14 92/11/05 17:15:56 cer Exp $ (in-package :user) @@ -77,6 +77,7 @@ (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") (clim-defsys::compile-system 'clim-toys)) + (load "compatibility/sysdcl.lisp") #+ignore (clim-defsys::compile-system 'clim-compatibility :propagate t)) diff --git a/misc/dev-load-1.lisp b/misc/dev-load-1.lisp index 796bbdbc3140c8abe784b4d9893f6ec193968aed..2f4258dc708759d55b2aed6fd5cbcd70eab73f06 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.17 92/10/29 15:02:55 cer Exp Locker: cer $ +;; $fiHeader: dev-load-1.lisp,v 1.18 92/11/05 17:15:57 cer Exp $ ;;;; This should not matter ;;;; (setq *ignore-package-name-case* t) @@ -52,7 +52,6 @@ (load "clim-debug.fasl") (load "clim-debugol.fasl"))) - ;;-- What would be good is to mark the files in the system as having ;;-- been loaded @@ -63,6 +62,7 @@ (compile-file-if-needed "test/test-suite") + (load "test/test-suite") (load "demo/sysdcl") @@ -72,8 +72,8 @@ (when (probe-file "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") (load "/usr/tech/cer/stuff/climtoys/sysdcl.lisp") (tenuring (clim-defsys::load-system 'clim-toys))) - (ignore-errors (require :composer)) + (ignore-errors (load (case sys diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index d291925e8cb8ce0a59e502ad90f3a39e7588fdac..dd439f698fe55442a7fb03ce2072dedcb3c30072 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-port.lisp,v 1.8 92/10/02 15:21:17 cer Exp $ +;; $fiHeader: postscript-port.lisp,v 1.9 92/10/28 11:33:29 cer Exp $ (in-package :postscript-clim) @@ -255,7 +255,8 @@ (current-color :initform nil) ;for decoding stippled inks (features-sent :initform nil) (curfont :initform nil) ;a psfck structure - (ch1buf :initform (make-array 1 :element-type 'character)) ;used for char ops. + (ch1buf :initform (make-array 1 :element-type #+ANSI-90 'character + #-ANSI-90 'string-char)) (header-comments :initform nil :initarg :header-comments) (orientation :initform :portrait :initarg :orientation))) @@ -271,12 +272,6 @@ (defmethod medium-clear-output ((medium postscript-medium)) (clear-output (slot-value medium 'printer-stream))) -;;; Methods that might be needed: -;;; what about other "window" protocols? -;;; host-window-margins -;;; window-margins (being flushed, should return (values 0 0 0 0)) -;;; window-beep -;;; window-clear (do a fresh-page?) ;;; Support routines @@ -376,7 +371,8 @@ (negative-p nil)) (when (minusp n) (setq negative-p t)) - (with-stack-array (string from :element-type 'character) + (with-stack-array (string from :element-type #+ANSI-90 'character + #-ANSI-90 'string-char) (macrolet ((add-char (char) `(setf (aref string (decf from)) ,char))) (when (/= frac 0) @@ -641,7 +637,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (make-instance 'postscript-palette :port port :color-p t - :mutable-p nil)) + :dynamic-p nil)) (defmethod standardize-text-style ((port postscript-port) style &optional character-set) (declare (ignore character-set)) diff --git a/silica/db-scroll.lisp b/silica/db-scroll.lisp index cf049926d8174369b70a23cd89110341ff49934c..77e6c18d6908e90c78349d44f13c28f4433952a7 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.32 92/09/24 09:37:33 cer Exp $ +;; $fiHeader: db-scroll.lisp,v 1.33 92/10/02 15:18:15 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright(c) 1991, 1992 International Lisp Associates. @@ -110,14 +110,14 @@ scroller) (progn (check-type scroll-bars - (member :both :dynamic :vertical :horizontal)) + (member t :both :dynamic :vertical :horizontal)) (with-slots (vertical-scroll-bar horizontal-scroll-bar (c contents) viewport foreground background) pane (with-look-and-feel-realization (frame-manager frame) (let ((verticalp - (member scroll-bars '(:both :dynamic :vertical))) + (member scroll-bars '(t :both :dynamic :vertical))) (horizontalp - (member scroll-bars '(:both :dynamic :horizontal)))) + (member scroll-bars '(t :both :dynamic :horizontal)))) (setf vertical-scroll-bar (and verticalp (make-pane 'scroll-bar diff --git a/silica/event.lisp b/silica/event.lisp index 73ade3148df9f023c783d5fe9c4020f7014ce283..a8adf16f11a19058beb13feb5a91932aab71d041 100644 --- a/silica/event.lisp +++ b/silica/event.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: event.lisp,v 1.26 92/10/28 11:30:45 cer Exp Locker: cer $ +;; $fiHeader: event.lisp,v 1.27 92/11/05 17:15:24 cer Exp $ (in-package :silica) @@ -562,23 +562,18 @@ (process-event-locally sheet (event-read sheet)))) (defun port-event-wait (port waiter - &key (wait-reason #+Genera si:*whostate-awaiting-user-input* - #-Genera "CLIM Input") + &key (wait-reason #+Genera si:*whostate-awaiting-user-input* + #-Genera "CLIM Input") timeout) (cond (*multiprocessing-p* (process-wait-with-timeout wait-reason timeout waiter) (values)) (t ;; Single process, so run the event processing loop right here - (let ((finish-time (when timeout (+ (* timeout internal-time-units-per-second) - (get-internal-real-time))))) - (loop - (when (or (and timeout (> (get-internal-real-time) finish-time)) - (funcall waiter)) - (return-from port-event-wait (values))) - (process-next-event port - :wait-function waiter - :state wait-reason)))))) + (process-next-event port + :timeout timeout + :wait-function waiter + :state wait-reason)))) ;;; Event resources diff --git a/silica/framem.lisp b/silica/framem.lisp index c6f067ceb415cfe4cc41107cefc4972dba3bbdf6..eb4fc26cad83669ec1e62a9e218d40b0cc8f74d3 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: framem.lisp,v 1.21 92/10/28 11:30:47 cer Exp Locker: cer $ +;; $fiHeader: framem.lisp,v 1.22 92/10/28 13:17:08 cer Exp $ (in-package :silica) @@ -21,7 +21,11 @@ (unless palette (setf palette (port-default-palette port))))) -;;--- This is most likely wrong +(defmethod find-named-color (name (framem standard-frame-manager) &key (errorp t)) + (find-named-color name (frame-manager-palette framem) :errorp errorp)) + +;;--- This is most likely wrong, since it forces a 1-to-1 mapping +;;--- between ports and grafts (defmethod graft ((framem standard-frame-manager)) (car (port-grafts (port framem)))) @@ -187,9 +191,9 @@ (label-pane generic-label-pane) (text-field text-field-pane) (text-editor text-editor-pane) + (list-pane generic-list-pane) + (option-pane generic-option-pane) ;;--- Need to do these - (list-pane) - (option-pane) (horizontal-divider-pane) (vertical-divider-pane) )))) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index bc4d698d71f25d3ec7fbd3c1e777986a9fdb836c..49920e939814999e13261e7843afde0c754070b2 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.36 92/10/02 15:18:21 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.37 92/10/28 11:30:48 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -437,17 +437,6 @@ (defmethod viewportp ((x t)) nil) (defmethod viewportp ((x viewport)) t) -(defmethod allocate-space ((viewport viewport) width height) - ;; 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) - (bounding-rectangle-size child) - (when (or (< cwidth width) - (< cheight height)) - (resize-sheet - child (max width cwidth) (max height cheight)))))) - (defmethod compose-space ((viewport viewport) &key width height) (declare (ignore width height)) (let ((sr (call-next-method))) @@ -459,6 +448,17 @@ :width width :min-width 0 :max-width max-width :height height :min-height 0 :max-height max-height)))) +(defmethod allocate-space ((viewport viewport) width height) + ;; 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) + (bounding-rectangle-size child) + (when (or (< cwidth width) + (< cheight height)) + (resize-sheet + child (max width cwidth) (max height cheight)))))) + (defmethod allocate-space :after ((viewport viewport) width height) (let ((vr (viewport-viewport-region viewport))) (multiple-value-bind (owidth oheight) (bounding-rectangle-size vr) diff --git a/silica/medium.lisp b/silica/medium.lisp index 8268ad1fdef9c611928db8d67f1c1aad4cf62dc4..dfde5fc89be2fac1665ad5926b62efa794e6d27c 100644 --- a/silica/medium.lisp +++ b/silica/medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: medium.lisp,v 1.27 92/10/28 13:17:09 cer Exp $ +;; $fiHeader: medium.lisp,v 1.28 92/10/29 16:54:58 cer Exp $ (in-package :silica) @@ -314,30 +314,6 @@ (setf (medium-sheet medium) nil) (push medium (port-medium-cache port))) - -;;; Support for colors - -;;--- Not clear that these should be here - -(defmethod sheet-palette ((sheet basic-sheet)) - (let* ((frame (pane-frame sheet)) - (framem (and frame (frame-manager frame)))) - (if framem - (frame-manager-palette framem) - (port-default-palette (port sheet))))) - -(defmethod medium-palette ((medium basic-medium)) - (sheet-palette (medium-sheet medium))) - -(defmethod find-named-color (name (port basic-port)) - (find-named-color name (port-default-palette port))) - -(defmethod find-named-color (name (sheet basic-sheet)) - (find-named-color name (sheet-palette sheet))) - -(defmethod find-named-color (name (medium basic-medium)) - (find-named-color name (medium-palette medium))) - ;; Make sheets do the medium protocol diff --git a/silica/port.lisp b/silica/port.lisp index 7946a1acd99125ffb5a77db3aee850ac61e28d03..dcbe8b42dab98cca5aab7e5b3cd1ea7d21247664 100644 --- a/silica/port.lisp +++ b/silica/port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: port.lisp,v 1.22 92/10/28 11:30:53 cer Exp $ +;; $fiHeader: port.lisp,v 1.23 92/10/29 16:55:00 cer Exp $ (in-package :silica) @@ -32,9 +32,6 @@ (return-from find-port port)))) (make-port :server-path server-path)) -(defmethod find-named-color (name (port port)) - (find-named-color name (port-default-palette port))) - #+Genera (scl:add-initialization "Reset ports" '(progn @@ -75,6 +72,9 @@ (restart-port port)) +(defmethod find-named-color (name (port basic-port) &key (errorp t)) + (find-named-color name (port-default-palette port) :errorp errorp)) + (defmethod port-pointer ((port basic-port)) (with-slots (pointer grafts) port (or pointer @@ -248,3 +248,4 @@ (defgeneric graft-height (graft)) (defgeneric graft-pixels-per-millimeter (graft)) (defgeneric graft-pixels-per-inch (graft)) + diff --git a/silica/sheet.lisp b/silica/sheet.lisp index 578ca09a931e23d54d8e85e968cfad13085b4d78..eff6e15bba5dc3ada741cfa6551e68e4a9a3c56e 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sheet.lisp,v 1.29 92/10/02 15:18:33 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.30 92/10/28 11:30:54 cer Exp $ (in-package :silica) @@ -34,7 +34,7 @@ (defmethod sheet-child ((sheet basic-sheet)) (let ((children (sheet-children sheet))) - (unless (and children (null (cdr children))) + (when (cdr children) (error "The sheet ~S has more than one child" sheet)) (car children))) diff --git a/silica/text-style.lisp b/silica/text-style.lisp index 7f4717ee7ddb8d869c65a9aff92daec987886e33..da1a6ef756be872d9b6dd17b25223e8bd5e4cfeb 100644 --- a/silica/text-style.lisp +++ b/silica/text-style.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: text-style.lisp,v 1.13 92/09/24 09:37:55 cer Exp Locker: cer $ +;; $fiHeader: text-style.lisp,v 1.14 92/10/02 15:18:36 cer Exp $ (in-package :silica) @@ -165,7 +165,7 @@ (member size *valid-text-style-sizes*) (eq size :smaller) (eq size :larger)) - (error "The size ~S is not valid." size)) + (error "The size ~S is not valid" size)) ;; This needs to be fleshed out with error handlers, etc. (values family face size nil original-face)) @@ -314,7 +314,7 @@ (defun add-text-face-class (name class) (let ((alist (assoc class *face->face-code-cache*))) (when (null alist) - (error "Can't define face ~S in unknown face class ~S." name class)) + (error "Can't define face ~S in unknown face class ~S" name class)) (unless (member name (cdr alist)) (nconc alist (list name))))) diff --git a/sys/sysdcl.lisp b/sys/sysdcl.lisp index 92172c26395b85c92c45797fdacad4b570f83b7f..80dbf905569b94269283c8247e9915507026ef43 100644 --- a/sys/sysdcl.lisp +++ b/sys/sysdcl.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sysdcl.lisp,v 1.28 92/09/30 18:03:56 cer Exp Locker: cer $ +;; $fiHeader: sysdcl.lisp,v 1.29 92/10/02 15:20:16 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :cl-user) @@ -303,6 +303,8 @@ :load-before-compile ("frames")) ("db-menu" :load-before-compile ("frames")) + ("db-list" + :load-before-compile ("db-menu")) ("db-text" :load-before-compile ("frames")) ("noting-progress" diff --git a/test/test-suite.lisp b/test/test-suite.lisp index b538804224bc109729595d946705d593e8fc11a8..21070df5533afa4b9c447e50abe550d59fa8d2c6 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.41 92/10/28 08:19:47 cer Exp Locker: cer $ +;; $fiHeader: test-suite.lisp,v 1.42 92/10/28 11:32:18 cer Exp $ (in-package :clim-user) @@ -712,19 +712,20 @@ people, shall not perish from the earth. (define-test (colored-inks graphics) (stream) "Test colors" - (with-text-style (stream '(:sans-serif :italic :normal)) - (format stream "~&~%~A~%" "Named Colors") - (formatting-table (stream) - (dolist (name *named-colors*) - (let ((color (if (symbolp name) - (symbol-value name) - (find-named-color name stream)))) - (when color - (formatting-row (stream) - (formatting-cell (stream) - (write-string (string name) stream)) - (formatting-cell (stream) - (draw-rectangle* stream 0 0 200 10 :ink color))))))))) + (let ((palette (frame-palette *application-frame*))) + (with-text-style (stream '(:sans-serif :italic :normal)) + (format stream "~&~%~A~%" "Named Colors") + (formatting-table (stream) + (dolist (name *named-colors*) + (let ((color (if (symbolp name) + (symbol-value name) + (find-named-color name palette :errorp nil)))) + (when color + (formatting-row (stream) + (formatting-cell (stream) + (write-string (string name) stream)) + (formatting-cell (stream) + (draw-rectangle* stream 0 0 200 10 :ink color)))))))))) (define-test (patterned-graphics-shapes graphics) (stream) "Test patterned graphics shapes" @@ -888,14 +889,14 @@ people, shall not perish from the earth. "Write some strings separated by horizontal cursor motion. After refreshing, the output should look the same." (terpri stream) (let* ((width (bounding-rectangle-width stream)) - (rect-width (- (floor width 11) 10)) - (spacing 8)) + (rect-width (- (floor width 11) 10))) (multiple-value-bind (x y) (stream-cursor-position stream) - (dotimes (i 11) - (stream-set-cursor-position stream x y) - (write-string (format nil "~1$" (float (/ i 10))) stream) - (incf x (+ rect-width spacing)))) + (with-end-of-line-action (stream :allow) + (dotimes (i 11) + (stream-set-cursor-position stream x y) + (write-string (format nil "~1$" (float (/ i 10))) stream) + (incf x rect-width)))) (terpri stream) (stream-force-output stream) (sleep 2) @@ -1677,12 +1678,14 @@ Luke Luck licks the lakes Luke's duck likes.")) (graphics-dialog-internal stream t)) (defun graphics-dialog-internal (stream &optional own-window) - (labels ((display-color (object stream) + (labels ((display-color (object stream &key acceptably) + (declare (ignore acceptably)) (with-room-for-graphics (stream) (draw-rectangle* stream 0 0 30 10 :ink (color-name-color object)))) (color-name-color (name) (ecase name + (:foreground +foreground-ink+) (:red +red+) (:green +green+) (:blue +blue+)))) @@ -1693,49 +1696,50 @@ Luke Luck licks the lakes Luke's duck likes.")) (draw-/-diagonal t) (draw-\\-diagonal t) (line-thickness 1) - (color-name :red) + (color-name :foreground) (line-thickness-units :normal)) (accepting-values (stream :own-window own-window :label "Graphics Dialog") - (setq square-dimension - (accept 'number :stream stream - :prompt "Size of square" :default square-dimension)) + (setq square-dimension + (accept 'number :stream stream + :prompt "Size of square" :default square-dimension)) (terpri stream) (setq draw-circle - (accept 'boolean :stream stream - :prompt "Draw the circle" :default draw-circle)) + (accept 'boolean :stream stream + :prompt "Draw the circle" :default draw-circle)) (terpri stream) (setq draw-square - (accept 'boolean :stream stream - :prompt "Draw the square" :default draw-square)) + (accept 'boolean :stream stream + :prompt "Draw the square" :default draw-square)) (terpri stream) (setq draw-point - (accept 'boolean :stream stream - :prompt "Draw point" :default draw-point)) + (accept 'boolean :stream stream + :prompt "Draw point" :default draw-point)) (terpri stream) (setq draw-/-diagonal - (accept 'boolean :stream stream - :prompt "Draw / diagonal" :default draw-/-diagonal)) + (accept 'boolean :stream stream + :prompt "Draw / diagonal" :default draw-/-diagonal)) (terpri stream) (setq draw-\\-diagonal - (accept 'boolean :stream stream - :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) + (accept 'boolean :stream stream + :prompt "Draw \\ diagonal" :default draw-\\-diagonal)) (terpri stream) (setq line-thickness - (accept 'number :stream stream - :prompt "Line thickness" :default line-thickness)) + (accept 'number :stream stream + :prompt "Line thickness" :default line-thickness)) (terpri stream) (setq line-thickness-units - (accept '(member :normal :point) :stream stream - :prompt "Line style units" :default line-thickness-units)) + (accept '(member :normal :point) :stream stream + :prompt "Line style units" :default line-thickness-units)) (terpri stream) (setq color-name - (accept `((completion (:red :green :blue)) - :name-key ,#'identity - :printer ,#'display-color) - :view '(radio-box-view - :toggle-button-options (:indicator-type nil)) - :stream stream - :prompt "Color" :default color-name)) + (accept `((completion (:foreground :red :green :blue)) + :name-key ,#'identity + :printer ,#'display-color) + :view #+allegro '(radio-box-view + :toggle-button-options (:indicator-type nil)) + #-allegro (stream-default-view stream) + :stream stream + :prompt "Color" :default color-name)) (terpri stream) (with-drawing-options (stream :ink (color-name-color color-name)) (with-room-for-graphics (stream) @@ -2796,12 +2800,12 @@ Luke Luck licks the lakes Luke's duck likes.")) menus-and-dialogs benchmarks) :menu (("Graphics" :menu graphics) + ("Redisplay" :menu redisplay) + ("Benchmarks" :menu benchmarks) ("Output Recording" :menu output-recording) ("Formatted Output" :menu formatted-output) - ("Redisplay" :menu redisplay) ("Presentations" :menu presentations) ("Menus and Dialogs" :menu menus-and-dialogs) - ("Benchmarks" :menu benchmarks) ("Exit" :command (exit-clim-tests))))) (:command-definer nil) (:panes diff --git a/tk-silica/ol-frames.lisp b/tk-silica/ol-frames.lisp index 1ed1c2b635bb3125247f99c848ea27a8f1cb1952..395185c7187a598f7c21a2ddc49e86a82038fc07 100644 --- a/tk-silica/ol-frames.lisp +++ b/tk-silica/ol-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-frames.lisp,v 1.14 92/09/30 18:04:26 cer Exp $ +;; $fiHeader: ol-frames.lisp,v 1.15 92/10/28 11:33:14 cer Exp $ (in-package :xm-silica) @@ -57,9 +57,9 @@ printer presentation-type associated-window - default-style + text-style label) - (declare (ignore default-style)) + (declare (ignore text-style)) (let* (value-returned return-value (simplep (and (null printer) diff --git a/tk-silica/xm-dialogs.lisp b/tk-silica/xm-dialogs.lisp index 8ca13f30fbcc3ae529b6ececba3553b4613479b8..446753854f3015721d7b946c4883f50bd2574784 100644 --- a/tk-silica/xm-dialogs.lisp +++ b/tk-silica/xm-dialogs.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader$ +;; $fiHeader: xm-dialogs.lisp,v 1.1 92/09/08 10:40:50 cer Exp $ (in-package :clim-internals) @@ -126,10 +126,7 @@ ; ;; This requires formatting-table and friends to return their bodies' values properly. ; (with-slots (stream continuation resynchronize-every-pass check-overlapping ; selected-item initially-select-query-identifier -; own-window own-window-x-position own-window-y-position -; own-window-width own-window-height -; own-window-right-margin own-window-bottom-margin -; exit-button-stream) frame +; own-window own-window-properties exit-button-stream) frame ; ; (unless own-window (return-from accept-values-top-level (call-next-method))) ; diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index fd03a643b475e4235dd2ef07cee82bb4089d7afa..597b305d5b3aff89d289d2cbc00c0d4fd0aa1bcb 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.35 92/10/28 11:33:17 cer Exp Locker: cer $ +;; $fiHeader: xm-frames.lisp,v 1.36 92/11/05 17:15:59 cer Exp $ (in-package :xm-silica) @@ -287,9 +287,9 @@ printer presentation-type associated-window - default-style + text-style label) - (declare (ignore default-style)) + (declare (ignore text-style)) (let* (value-returned return-value (simplep (and (null printer) diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index 3b953da767b64f1b0760d2197d45b24c3383a269..08b4a2a55d370b974827dee9aa23514d48f5403d 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.52 92/10/28 11:33:18 cer Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.53 92/11/06 14:32:44 colin Exp $ (in-package :xm-silica) @@ -454,17 +454,17 @@ ;; comes up in the right place. ((popup-frame-p sheet) (values 'tk::xm-bulletin-board - (list :margin-width 0 :margin-height 0 - ;; Prevents buttons from deactivating dialog - :auto-unmanage nil - ;; We specify NIL for accelerators otherwise the - ;; bulletin board messes with the event handling of - ;; its drawing area children - :accelerators nil - :resize-policy :none - :name (if (pane-frame sheet) - (string (frame-name (pane-frame sheet))) - "a CLIM pop-up")))) + (list :margin-width 0 :margin-height 0 + ;; We specify NIL for accelerators otherwise the + ;; bulletin board messes with the event handling of + ;; its drawing area children + :accelerators nil + ;; Prevents buttons from deactivating dialog + :auto-unmanage nil + :resize-policy :none + :name (if (pane-frame sheet) + (string (frame-name (pane-frame sheet))) + "a CLIM pop-up")))) (t (values 'tk::xm-my-drawing-area (list :resize-policy :none diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index ffe6c764d3fa1f50aaa8c8407b976d0fc055ff7f..cab40906029892152aac10f6baa279bcdab8ef50 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.19 92/10/02 15:21:05 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.20 92/10/28 11:33:20 cer Exp $ (in-package :xm-silica) @@ -88,7 +88,7 @@ &key printer presentation-type (associated-window (frame-top-level-sheet *application-frame*)) - default-style label + text-style label cache (unique-id items) (id-test 'equal) @@ -122,7 +122,7 @@ printer presentation-type associated-window - default-style + text-style label)) (when cache (push (list unique-id menu closure) diff --git a/tk-silica/xt-graphics.lisp b/tk-silica/xt-graphics.lisp index 8dd29d6fa2e09a733fa79729f2c77546621ab496..c191ef1f9281249a830eecb1a7099626ab661e45 100644 --- a/tk-silica/xt-graphics.lisp +++ b/tk-silica/xt-graphics.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-graphics.lisp,v 1.48 92/10/29 16:55:44 cer Exp $ +;; $fiHeader: xt-graphics.lisp,v 1.49 92/11/06 10:01:19 colin Exp $ (in-package :tk-silica) @@ -94,12 +94,10 @@ (make-xt-palette port (tk::create-colormap (port-display port)))) (defmethod medium-palette ((medium xt-medium)) - (let* ((sheet (medium-sheet medium)) - (frame (pane-frame sheet)) - (framem (and frame (frame-manager frame)))) - (if framem - (frame-manager-palette framem) - (port-default-palette (port sheet))))) + (let ((frame (pane-frame (medium-sheet medium)))) + (if frame + (frame-palette frame) + (port-default-palette (port sheet))))) #+ignore (defmethod (setf frame-manager-palette) :after @@ -123,7 +121,7 @@ :green (truncate (* x green)) :blue (truncate (* x blue))))))))) -(defmethod find-named-color (name (palette xt-palette)) +(defmethod find-named-color (name (palette xt-palette) &key (errorp t)) (let ((named-color-cache (palette-named-color-cache palette))) ;;-- What is the correct thing to do? ;;-- CLIM has names containing dashes instead of spaces @@ -183,24 +181,24 @@ (defmethod allocate-color ((color layered-color) (palette xt-palette)) (allocate-color (layered-color-set color) palette)) -(defmethod free-color ((color color) (palette xt-palette)) +(defmethod deallocate-color ((color color) (palette xt-palette)) (let* ((color-cache (palette-color-cache palette)) (pixel (gethash color color-cache))) (when pixel (tk::free-color-cells (palette-colormap palette) pixel 0) (remhash color color-cache)))) -(defmethod free-color ((color dynamic-color) (palette xt-palette)) +(defmethod deallocate-color ((color dynamic-color) (palette xt-palette)) (let* ((dynamic-color-cache (palette-dynamic-color-cache palette)) (pixel (gethash color dynamic-color-cache))) (when pixel (tk::free-color-cells (palette-colormap palette) pixel 0) (remhash color dynamic-color-cache)))) -(defmethod free-color ((color layered-color) (palette xt-palette)) - (free-color (layered-color-set color) palette)) +(defmethod deallocate-color ((color layered-color) (palette xt-palette)) + (deallocate-color (layered-color-set color) palette)) -(defmethod free-color ((set layered-color-set) (palette xt-palette)) +(defmethod deallocate-color ((set layered-color-set) (palette xt-palette)) (let* ((layered-color-cache (palette-layered-color-cache palette)) (pixel-planes (gethash set layered-color-cache))) (when pixel-planes @@ -234,7 +232,6 @@ ;; 1. medium's sheet's device region changes ;; 2. medium's clipping region changes ;; 3. medium's sheet's device transformation changes - (defmethod medium-clip-mask ((medium xt-medium)) (with-slots (sheet clip-mask) medium (or clip-mask @@ -607,10 +604,7 @@ and on color servers, unless using white or black") (defmethod decode-ink ((ink pattern) medium) (xt-decode-pattern ink medium)) - -(defmethod decode-color ((medium xt-medium) (design design)) - (error "Drawing with design: ~A not yet implemented" design)) (defmethod decode-color ((design design) (medium xt-medium)) (decode-color-in-palette design (medium-palette medium))) @@ -667,7 +661,7 @@ and on color servers, unless using white or black") (or (gethash color layered-color-cache) (setf (gethash color layered-color-cache) (let* ((set (layered-color-set color)) - (pixel-planes (gethash set layered-color-cache))) + (pixel-planes (gethash set layered-color-cache))) (unless pixel-planes (setq pixel-planes (decode-layered-color-set set palette))) (multiple-value-list @@ -717,7 +711,7 @@ and on color servers, unless using white or black") (incf count)) (push plane-masks planes))) (let ((pixel-planes (cons pixel planes))) - (map-over-layered-colors + (map-over-layered-colors #'(lambda (dimensions) (let ((dynamic-color (apply #'aref dynamic-array dimensions)) (pixel (decode-layered-color dimensions @@ -734,6 +728,7 @@ and on color servers, unless using white or black") (make-color-for-contrasting-ink ink) (make-gray-color-for-contrasting-ink ink)) medium))) + (defvar *default-dashes* '(4 4)) (defun adjust-ink (gc medium line-style x-origin y-origin) diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index 14cf0085bf7b81f3da7e7abc4a3f76bf3959bb16..919e85ecaecfb305e4c6d7a67af8d47da6c1addc 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.54 92/10/29 16:55:47 cer Exp Locker: cer $ +;; $fiHeader: xt-silica.lisp,v 1.55 92/11/05 17:16:01 cer Exp $ (in-package :xm-silica) @@ -199,7 +199,7 @@ (make-instance 'tk::font :display display :name *xt-fallback-font*))) - ;;; Perhaps we should just grab the first font we can find. + ;;; Perhaps we should just grab the first font we can find. (t (error "Unable to determine default font")))))) (setup-opacities port display)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index 6c574d661ab4a1d8b2840c1c839739f2f2e04e90..e894490d58a8992b1d9867c7f8b3d1a32e32ad8d 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.31 92/10/28 13:17:01 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.32 92/10/29 16:54:51 cer Exp $ (in-package :tk) @@ -339,7 +339,6 @@ (values (x11:xcolor-pixel y) (make-instance 'color :foreign-address y)))))) - (defvar *pixel-array* (make-array 1 :initial-element 0 :element-type '(unsigned-byte 32))) @@ -352,6 +351,7 @@ 1 planes)) + (defun allocate-named-color (colormap name) (let ((exact (x11::make-xcolor :in-foreign-space t)) (closest (x11::make-xcolor :in-foreign-space t))) diff --git a/utils/base-designs.lisp b/utils/base-designs.lisp index 469e7ad3d0b4cc3d7127cc3378136bc99b3db59a..044ab24410678ba887b7e729af09a10b6406b538 100644 --- a/utils/base-designs.lisp +++ b/utils/base-designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: base-designs.lisp,v 1.3 92/10/28 11:30:57 cer Exp $ +;; $fiHeader: base-designs.lisp,v 1.4 92/10/29 16:55:03 cer Exp $ (in-package :clim-utils) @@ -29,7 +29,7 @@ ((value :type single-float :initarg :value :reader opacity-value))) (define-constructor make-standard-opacity-1 standard-opacity (value) - :value value) + :value value) (defmethod make-load-form ((design standard-opacity)) (with-slots (value) design @@ -43,7 +43,7 @@ :reader gray-color-luminosity))) (define-constructor make-gray-color-1 gray-color (luminosity) - :luminosity luminosity) + :luminosity luminosity) (defmethod make-load-form ((color gray-color)) (with-slots (luminosity) color @@ -64,13 +64,14 @@ (with-slots (red green blue) color `(make-rgb-color ,red ,green ,blue))) + (defclass ihs-color (color) ((intensity :type single-float :initarg :intensity) (hue :type single-float :initarg :hue) (saturation :type single-float :initarg :saturation))) (define-constructor make-ihs-color-1 ihs-color (intensity hue saturation) - :intensity intensity :hue hue :saturation saturation) + :intensity intensity :hue hue :saturation saturation) (defmethod make-load-form ((color ihs-color)) (with-slots (intensity hue saturation) color @@ -91,7 +92,7 @@ (layered-color-cache :reader palette-layered-color-cache :initform (make-hash-table)) (delayed-recolors :reader palette-delayed-recolors - :initform (make-array 32 :adjustable t :fill-pointer 0)))) + :initform (make-array 32 :adjustable t :fill-pointer 0)))) (defgeneric make-palette (port &key)) @@ -113,7 +114,7 @@ :accessor dynamic-color-palettes))) (define-constructor make-dynamic-color dynamic-color (color) - :color color) + :color color) (defmethod make-load-form ((color dynamic-color)) (with-slots (color) color @@ -123,23 +124,26 @@ ;;; Layered Colors (defclass layered-color-set () - ((layers :initform nil :reader layered-color-set-layers :initarg :layers) - (cache :initform (make-hash-table :test #'equal) :reader layered-color-set-cache) - (dynamic-array :reader layered-color-set-dynamic-array :initarg :dynamic-array))) + ((layers :initform nil :initarg :layers + :reader layered-color-set-layers) + (cache :initform (make-hash-table :test #'equal) + :reader layered-color-set-cache) + (dynamic-array :initarg :dynamic-array + :reader layered-color-set-dynamic-array))) (define-constructor make-layered-color-set layered-color-set (&rest layers) - :layers layers - :dynamic-array (make-array layers)) + :layers (copy-list layers) + :dynamic-array (make-array layers)) (defgeneric layered-color (layered-color-set &rest layers)) (defclass layered-color (design) - ((set :reader layered-color-set :initarg :set) - (layers :initform nil :reader layered-color-layers :initarg :layers) - (dynamics :initform nil))) + ((set :initarg :set :reader layered-color-set) + (layers :initarg :layers :initform nil :reader layered-color-layers) + (dynamic-colors :initform nil))) (define-constructor make-layered-color layered-color (set layers) - :set set :layers layers) + :set set :layers layers) ;;; Foreground and background (indirect) inks @@ -163,7 +167,7 @@ (design2 :type design :initarg :design2))) (define-constructor make-flipping-ink-1 flipping-ink (design1 design2) - :design1 design1 :design2 design2) + :design1 design1 :design2 design2) (defmethod make-load-form ((design flipping-ink)) (with-slots (design1 design2) design @@ -177,7 +181,7 @@ (which-one :type integer :initarg :which-one))) (define-constructor make-contrasting-ink-1 contrasting-ink (which-one how-many) - :which-one which-one :how-many how-many) + :which-one which-one :how-many how-many) (defmethod make-load-form ((design contrasting-ink)) (with-slots (which-one how-many) design diff --git a/utils/clos.lisp b/utils/clos.lisp index f273adee431e1cdc2ba5d3878c52061d0f369f47..b36df8b5e33b9e898fa666b7d244c97c00dfc55d 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.6 92/05/22 19:27:07 cer Exp $ +;; $fiHeader: clos.lisp,v 1.7 92/07/01 15:45:28 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -18,22 +18,26 @@ ;;; hook into that mechanism. #+PCL -(defmacro define-constructor (name class lambda-list &rest initialization-arguments) - `(pcl::defconstructor ,name ,class ,lambda-list ,@initialization-arguments)) +(defmacro define-constructor (name class lambda-list &body initargs) + `(pcl::defconstructor ,name ,class ,lambda-list ,@initargs)) #+(and PCL (not VDPCL)) (pushnew 'compile pcl::*defclass-times*) #+Allegro-v4.0-constructors -(defmacro define-constructor (name class lambda-list &rest initialization-arguments) - `(clos::defconstructor ,name ,class ,lambda-list ,@initialization-arguments)) +(defmacro define-constructor (name class lambda-list &body initargs) + `(clos::defconstructor ,name ,class ,lambda-list ,@initargs)) #-(or PCL Allegro-v4.0-constructors) -(defmacro define-constructor (name class lambda-list &rest initialization-arguments) - `(progn - (eval-when (compile load eval) (proclaim '(inline ,name))) - (defun ,name ,lambda-list - (make-instance ',class ,@initialization-arguments)))) +;; NB: any &REST argument is declared to have dynamic extent! +(defmacro define-constructor (name class lambda-list &body initargs) + (let ((rest-arg (member '&rest lambda-list))) + `(progn + (eval-when (compile load eval) (proclaim '(inline ,name))) + (defun ,name ,lambda-list + ,@(when rest-arg + `((declare (dynamic-extent ,(second rest-arg))))) + (make-instance ',class ,@initargs))))) #+(and Genera PCL) (scl:defmethod (:fasd-form #-VDPCL pcl::std-instance #+VDPCL pcl::iwmc-class) () @@ -87,9 +91,9 @@ (name class args &body tuples) `(define-group ,name define-constructor-using-prototype-instance (define-constructor ,name ,class ,args - ,@(mapcan #'(lambda (tuple) - (list (second tuple) (third tuple))) - tuples)))) + ,@(mapcan #'(lambda (tuple) + (list (second tuple) (third tuple))) + tuples)))) diff --git a/utils/designs.lisp b/utils/designs.lisp index 7cf1a54f5051e87d2248ee35fde629b4dd371c1f..fa30145adc2cc769fef8c053df4b4bfccd3f395b 100644 --- a/utils/designs.lisp +++ b/utils/designs.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: designs.lisp,v 1.9 92/10/28 13:17:12 cer Exp $ +;; $fiHeader: designs.lisp,v 1.10 92/10/29 16:55:05 cer Exp $ (in-package :clim-utils) @@ -122,17 +122,27 @@ (define-primary-color +yellow+ 1 1 0) -(defvar *default-named-color-table* (make-hash-table :test #+Genera #'string-equal - #-Genera #'equalp)) +(defvar *default-named-color-table* + (make-hash-table :test #+(or Genera Cloe-Runtime) #'string-equal + #-(or Genera Cloe-Runtime) #'equalp)) (defmacro define-named-color (color-name r g b) `(setf (gethash ,color-name *default-named-color-table*) (make-rgb-color ,(/ r 255.0) ,(/ g 255.0) ,(/ b 255.0)))) +(define-condition color-not-found (error) + ((color :initarg :color :reader color-not-found-color)) + (:report (lambda (condition stream) + (format stream "The color named ~S was not found" + (color-not-found-color condition))))) + ;; Simplest possible palette returns canned, silly X Windows colors -(defmethod find-named-color (name (palette basic-palette)) - (let ((name (if (symbolp name) (symbol-name name) name))) - (values (gethash name *default-named-color-table*)))) +(defmethod find-named-color (name (palette basic-palette) &key (errorp t)) + (let ((name (if (symbolp name) (symbol-name name) name)) + (color (gethash name *default-named-color-table*))) + (if (and (null color) errorp) + (error 'color-not-found :color name) + color))) ;; Default values for named colors (define-named-color "snow" 255 250 250) @@ -294,29 +304,36 @@ (defmethod color-ihs ((color ihs-color)) (with-slots (intensity hue saturation) color (values intensity hue saturation))) + -;;; Palettes +;;; Palettes -(define-condition palette-full (serious-condition) ()) +(define-condition palette-full (error) + ((palette :initarg :palette :reader palette-full-palette)) + (:report (lambda (condition stream) + (format stream "The palette ~S is full" + (palette-full-palette condition))))) -(defmethod add-to-palette ((palette basic-palette) &rest colors) +(defmethod add-colors-to-palette ((palette basic-palette) &rest colors) + (declare (dynamic-extent colors)) (let ((colors-done nil)) (dolist (color colors) (handler-case - (progn - (push color colors-done) - (allocate-color color palette)) + (progn + (push color colors-done) + (allocate-color color palette)) (palette-full (condition) - (dolist (color colors-done) - (free-color color palette)) - (error condition)))))) + (dolist (color colors-done) + (deallocate-color color palette)) + (error condition)))))) -(defmethod remove-from-palette ((palette basic-palette) &rest colors) +(defmethod remove-colors-from-palette ((palette basic-palette) &rest colors) + (declare (dynamic-extent colors)) (dolist (color colors) - (free-color color palette))) + (deallocate-color color palette))) -;;; Dynamic Colors +;;; Dynamic Colors (defmethod print-object ((color dynamic-color) stream) (print-unreadable-object (color stream :type t :identity t) @@ -330,7 +347,7 @@ (defvar *doing-delayed-recolors* nil) -(defmethod recolor-dynamic ((dynamic-color dynamic-color) (color color)) +(defmethod recolor-dynamic-color ((dynamic-color dynamic-color) (color color)) (if *doing-delayed-recolors* (dolist (palette (dynamic-color-palettes dynamic-color)) (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette))) @@ -338,13 +355,13 @@ (without-scheduling (vector-push-extend cell recolors) (vector-push-extend color recolors)))) - (dolist (palette (dynamic-color-palettes dynamic-color)) - (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette)))) - (update-palette-entry palette cell color))))) + (dolist (palette (dynamic-color-palettes dynamic-color)) + (let ((cell (gethash dynamic-color (palette-dynamic-color-cache palette)))) + (update-palette-entry palette cell color))))) (defmethod (setf dynamic-color-color) :after ((color color) (dynamic-color dynamic-color)) - (recolor-dynamic dynamic-color color)) + (recolor-dynamic-color dynamic-color color)) ;; Note that the actual color recoloring occurs on exiting the outermost ;; call to WITH-DELAYED-RECOLORING @@ -380,10 +397,10 @@ (progn (setf (car dims) layer) (iterate rest-layers rest-set-layers rest-dims)) - (dotimes (i set-layer) - (setf (car dims) i) - (iterate rest-layers rest-set-layers rest-dims)))) - (funcall function dimensions)))) + (dotimes (i set-layer) + (setf (car dims) i) + (iterate rest-layers rest-set-layers rest-dims)))) + (funcall function dimensions)))) (iterate layers set-layers dimensions)))) (defmethod initialize-instance :after ((set layered-color-set) &key dynamic-array) @@ -402,26 +419,25 @@ (make-layered-color set layers)))))) (defmethod (setf layered-color-color) - ((color color) (layered-color layered-color)) + ((color color) (layered-color layered-color)) (with-delayed-recoloring - (dolist (dynamic-color (layered-color-dynamics layered-color)) - (setf (dynamic-color-color dynamic-color) color)))) + (dolist (dynamic-color (layered-color-dynamic-colors layered-color)) + (setf (dynamic-color-color dynamic-color) color)))) -;; LAYERED-COLOR-DYNAMICS should not be exported to the user. It is important -;; that these dynamics are not drawn with. Instead the fully specified layered -;; colors should be used -(defmethod layered-color-dynamics ((layered-color layered-color)) - (with-slots (set layers dynamics) layered-color - (or dynamics - (setf dynamics - (let ((dynamic-array (layered-color-set-dynamic-array set)) - dynamics) - (map-over-layered-colors - #'(lambda (dimensions) - (push (apply #'aref dynamic-array dimensions) dynamics)) - set - layers) - dynamics))))) +;; LAYERED-COLOR-DYNAMIC-COLORS should not be exported to the user. It +;; is important that these dynamics are not drawn with. Instead, the +;; fully specified layered is used. +(defmethod layered-color-dynamic-colors ((layered-color layered-color)) + (with-slots (set layers dynamic-colors) layered-color + (or dynamic-colors + (setf dynamic-colors + (let ((dynamic-array (layered-color-set-dynamic-array set)) + (dynamics nil)) + (map-over-layered-colors + #'(lambda (dimensions) + (push (apply #'aref dynamic-array dimensions) dynamics)) + set layers) + dynamics))))) ;;; Foreground and background (indirect) inks diff --git a/utils/lisp-utilities.lisp b/utils/lisp-utilities.lisp index b6960f3b11505fb59d1aea4b2f57d505d8b0e4fb..f25fa9779d08a3a2e5006bba2ee675b821d971e0 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.20 92/10/02 15:18:50 cer Exp $ +;; $fiHeader: lisp-utilities.lisp,v 1.21 92/10/28 11:31:05 cer Exp $ (in-package :clim-utils) @@ -1223,10 +1223,17 @@ (defun realp (x) (typep x 'real)) +#+(or Allegro Cloe-Runtime) +(deftype eql (x) `(member ,x)) + (defconstant *end-of-file-marker* :eof) (deftype end-of-file-marker () - #+Allegro '(member :eof) - #-Allegro '(eql :eof)) + '(eql :eof)) + +#+Cloe-Runtime +(defmacro load-time-value (form &optional read-only-p) + (declare (ignore read-only-p)) + form) ;;; Use a lambda-list to extract arguments from a list and bind variables. diff --git a/utils/packages.lisp b/utils/packages.lisp index c2be0da98b142f2cd10d7cd4f50ca8382d68a5bb..c2edca7685c7fd3d501f4438541d85343fad6e8b 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.35 92/10/28 13:17:14 cer Exp $ +;; $fiHeader: packages.lisp,v 1.36 92/10/29 16:55:06 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -2023,23 +2023,24 @@ +foreground-ink+ color color-ihs + color-not-found color-rgb colorp contrasting-inks-limit design designp + dynamic-color-color find-named-color layered-color layered-color-color - make-layered-color-set make-contrasting-inks + make-dynamic-color make-flipping-ink make-gray-color make-ihs-color - make-dynamic-color + make-layered-color-set make-opacity make-rgb-color - dynamic-color-color opacity opacity-value opacityp @@ -2058,18 +2059,18 @@ pattern-width ;; Palettes + add-color-to-palette frame-manager-palette frame-palette make-palette palette palette-color-p palette-dynamic-p + palette-full palettep port-default-palette - palette-full - add-to-palette - remove-from-palette - + remove-color-from-palette + ;; Extended output beep cursor @@ -2123,6 +2124,7 @@ copy-textual-output-history delete-output-record displayed-output-record + displayed-output-record-ink displayed-output-record-p erase-output-record graphics-displayed-output-record @@ -2388,6 +2390,7 @@ highlight-presentation highlight-presentation-method integer + input-context-type keyword list-pane-view make-presentation-type-specifier @@ -2657,6 +2660,7 @@ frame-drag-and-drop-highlighting frame-error-output frame-exit + frame-exit-frame frame-find-innermost-applicable-presentation frame-input-context-button-press-handler frame-maintain-presentation-histories @@ -2720,7 +2724,6 @@ ;; Meta-frames, aka activities *activity* activity - activity-exit activity-frame activity-frame-window-close activity-frame-window-select @@ -2940,7 +2943,6 @@ translate-positions viewport-to-drawing-surface-coordinates window-children - window-clear-area window-expose window-inside-bottom window-inside-edges @@ -2953,10 +2955,8 @@ window-label window-label-size window-margins - window-name window-parent window-root - window-set-inside-edges window-set-inside-size window-stack-on-bottom window-stack-on-top @@ -3021,7 +3021,7 @@ graphic-char-p alpha-char-p) - #+(and ANSI-90 Genera) + #+(or (and ANSI-90 Genera) Cloe-Runtime) (:import-from lisp string-char char-bits) @@ -3029,7 +3029,7 @@ (:shadowing-import-from cltl1 string-char char-bits) - #+(or Allegro (and ANSI-90 Genera)) + #+(or Allegro (and ANSI-90 Genera) Cloe-Runtime) (:export string-char char-bits) @@ -3155,7 +3155,7 @@ delete-timer make-timer - ;; From PROTOCOLS + ;; From PROTOCOLS, DEFPROTOCOL, and CLIM-STREAMS *outer-self* define-protocol-class define-slot-trampoline-template @@ -3163,6 +3163,7 @@ defoperation defprotocol defrole + encapsulated-stream find-protocol find-role generate-trampolines @@ -3248,37 +3249,37 @@ *all-palettes* allocate-color basic-palette - layered-color-set - layered-color-set-layers - layered-color-set-dynamic-array color-luminosity composite-in composite-out composite-over contrasting-ink contrasting-ink-index + deallocate-color decode-flipping-ink decode-pattern decode-rectangular-tile decode-tile-as-stipple + dynamic-color + dynamic-color-palettes + flipping-ink flipping-ink - flipping-ink - free-color gray-color gray-color-luminosity - layered-color-layers ihs-color + layered-color-layers + layered-color-set + layered-color-set-layers + layered-color-set-dynamic-array make-color-for-contrasting-ink make-design-from-output-record make-flipping-ink make-gray-color-for-contrasting-ink - map-over-layered-colors - dynamic-color - dynamic-color-palettes + map-over-layered-colors palette-color-cache + palette-delayed-recolors palette-dynamic-color-cache palette-layered-color-cache - palette-delayed-recolors pattern rectangular-tile rgb-color @@ -3391,6 +3392,8 @@ gadget-supplied-scrolling gadget-visible-items generic-label-pane + generic-list-pane + generic-option-pane generic-scroller-pane get-drawing-function-description graft-mm-height diff --git a/utils/protocols.lisp b/utils/protocols.lisp index 1316a1be6088dcbac7cd371ae566fcf4187618b9..4f12c01c6f5049736bc1e18c981ee35a3b2a8f46 100644 --- a/utils/protocols.lisp +++ b/utils/protocols.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-UTILS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: protocols.lisp,v 1.3 92/02/24 13:05:50 cer Exp $ +;; $fiHeader: protocols.lisp,v 1.4 92/07/01 15:45:43 cer Exp $ ;;; ;;; Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. @@ -195,6 +195,8 @@ (setf (,writer ,player-var) (values ,@values-vars))))))))))) (role-slots (find-role role-name))))))) +;; If you change this to maintain a more complex mapping than a simple +;; binding of *ORIGINAL-STREAM*, change ENCAPSULATED-STREAM too. (defmacro generate-trampolines (protocol-name role-name role-player delegate-form &optional (outer-self '*outer-self*)) `(progn diff --git a/utils/region-arithmetic.lisp b/utils/region-arithmetic.lisp index 7b9d4429b471fd2cbf662cf94f4f46836f7aec4a..6359faa5026bd662492da21323601634da7faa6a 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.7 92/05/07 13:11:43 cer Exp $ +;; $fiHeader: region-arithmetic.lisp,v 1.8 92/07/20 15:59:44 cer Exp $ (in-package :clim-utils) @@ -12,7 +12,7 @@ ((regions :type list :initarg :regions))) (define-constructor make-region-union-1 standard-region-union (regions) - :regions regions) + :regions regions) (defun make-region-union (&rest regions) (declare (dynamic-extent regions)) @@ -72,7 +72,7 @@ ((regions :type list :initarg :regions))) (define-constructor make-region-intersection-1 standard-region-intersection (regions) - :regions regions) + :regions regions) (defun make-region-intersection (&rest regions) (declare (dynamic-extent regions)) @@ -128,7 +128,7 @@ (regions :type list))) (define-constructor make-region-difference standard-region-difference - (region1 region2) + (region1 region2) :region1 region1 :region2 region2) (defmethod region-set-function ((region standard-region-difference)) 'set-difference) @@ -341,8 +341,8 @@ (define-constructor make-rectangle-set-1 standard-rectangle-set (rectangles left top right bottom) - :rectangles rectangles - :left left :top top :right right :bottom bottom) + :rectangles rectangles + :left left :top top :right right :bottom bottom) (defun make-rectangle-set (&rest rectangles) (declare (dynamic-extent rectangles))