February 2005 - mcclim-cvs@common-lisp.net

[mcclim-cvs] CVS update: mcclim/frames.lisp mcclim/package.lisp mcclim/ports.lisp
by ahefner＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13053 Modified Files: frames.lisp package.lisp ports.lisp Log Message: Fix mixed up arguments to set-port-keyboard-focus. Renamed set-port-keyboard-focus to %set-port-keyboard-focus to avoid confusion with the CLIM 2.0 function port-keyboard-input-focus. Added a timestamp keyword to %set-port-keyboard-focus (not used by any callers yet). Added some comments about how the keyboard focus functions are connected. Date: Tue Feb 22 04:14:26 2005 Author: ahefner Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.105 mcclim/frames.lisp:1.106 --- mcclim/frames.lisp:1.105 Wed Feb 2 12:33:58 2005 +++ mcclim/frames.lisp Tue Feb 22 04:14:17 2005 @@ -1280,7 +1280,7 @@ (declare (ignore pane state))) (defmethod (setf keyboard-input-focus) :after (focus frame) - (set-port-keyboard-focus focus (port frame))) + (%set-port-keyboard-focus (port frame) focus)) (defmethod (setf client-setting) (value frame setting) (setf (getf (client-settings frame) setting) value)) Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.47 mcclim/package.lisp:1.48 --- mcclim/package.lisp:1.47 Tue Jan 11 14:35:18 2005 +++ mcclim/package.lisp Tue Feb 22 04:14:26 2005 @@ -1942,7 +1942,7 @@ #:port-set-sheet-region #:port-set-sheet-transformation #:port-ungrab-pointer - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor #:synthesize-pointer-motion-event #:text-style-character-width Index: mcclim/ports.lisp diff -u mcclim/ports.lisp:1.47 mcclim/ports.lisp:1.48 --- mcclim/ports.lisp:1.47 Sun Jul 11 21:48:16 2004 +++ mcclim/ports.lisp Tue Feb 22 04:14:26 2005 @@ -72,9 +72,26 @@ )) ;; Keyboard focus is now managed per-frame rather than per-port, -;; which makes a lot of sense. The CLIM spec suggests this in a -;; "Minor Issue". So, redirect PORT-KEYBOARD-INPUT-FOCUS to the -;; current application frame for compatibility. +;; which makes a lot of sense (less sense in the presense of +;; multiple top-level windows, but no one does that yet). The CLIM +;; spec suggests this in a "Minor Issue". So, redirect +;; PORT-KEYBOARD-INPUT-FOCUS to the current application frame +;; for compatibility. + +;; Note: This would prevent you from using the function the +;; function to query who currently has the focus. I don't +;; know if this is an intended use or not. + +;; The big picture: +;; PORT-KEYBOARD-INPUT-FOCUS is defined by CLIM 2.0 +;; Our default method on this delegates to KEYBOARD-INPUT-FOCUS +;; on the current application frame. +;; %SET-PORT-KEYBOARD-FOCUS is the function which +;; should be implemented in a McCLIM backend and +;; does the work of changing the focus. +;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together, +;; calling %SET-PORT-KEYBOARD-FOCUS. + (defmethod port-keyboard-input-focus (port) (declare (ignore port)) (when *application-frame* @@ -84,14 +101,14 @@ (when focus (if (pane-frame focus) (setf (keyboard-input-focus (pane-frame focus)) focus) - (set-port-keyboard-focus focus port)))) + (%set-port-keyboard-focus port focus)))) ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus) ;; now calls (setf keyboard-input-focus), we need something concrete the ;; backend can implement to set the focus. -(defmethod set-port-keyboard-focus (focus port) - (declare (ignore focus)) - (warn "SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) +(defmethod %set-port-keyboard-focus (port focus &key timestamp) + (declare (ignore focus)) + (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port)) (defun find-port (&key (server-path *default-server-path*))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/util.lisp
by ahefner＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv13017/Apps/Listener Modified Files: util.lisp Log Message: Applied patch to directoryp for ACL from rpgoldman. Date: Tue Feb 22 04:10:28 2005 Author: ahefner Index: mcclim/Apps/Listener/util.lisp diff -u mcclim/Apps/Listener/util.lisp:1.16 mcclim/Apps/Listener/util.lisp:1.17 --- mcclim/Apps/Listener/util.lisp:1.16 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/util.lisp Tue Feb 22 04:10:27 2005 @@ -54,6 +54,8 @@ ; There has to be a better way.. (defun directoryp (pathname) "Returns pathname when supplied with a directory, otherwise nil" + #+allegro (excl:file-directory-p pathname) + #-allegro (if (or (pathname-name pathname) (pathname-type pathname)) nil pathname))

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp
by ahefner＠common-lisp.net 22 Feb '05

22 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12992 Modified Files: panes.lisp Log Message: Dummy implementation of restraining-pane. It doesn't really work, but it should if the layout protocol worked as specified. This is still an improvement over the previous version, which didn't display its children at all. Date: Tue Feb 22 04:09:18 2005 Author: ahefner Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.149 mcclim/panes.lisp:1.150 --- mcclim/panes.lisp:1.149 Tue Feb 1 04:08:27 2005 +++ mcclim/panes.lisp Tue Feb 22 04:09:18 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.149 2005/02/01 03:08:27 ahefner Exp $ +;;; $Id: panes.lisp,v 1.150 2005/02/22 03:09:18 ahefner Exp $ (in-package :clim-internals) @@ -1679,13 +1679,16 @@ ;;; RESTRAINING PANE -(defclass restraining-pane (composite-pane) ()) +(defclass restraining-pane (single-child-composite-pane) ()) (defun restraining-pane-p (pane) (typep pane 'restraining-pane)) (defmacro restraining ((&rest options) &body contents) `(make-pane 'restraining-pane ,@options :contents (list ,@contents))) + +(defmethod note-space-requirements-changed ((pane restraining-pane) child) + (declare (ignore pane child))) ;;; BBOARD PANE

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv9838 Modified Files: mcclim.asd Log Message: Backends/CLX/image.lisp depends on .../package.lisp. Spotted by Christophe Rhodes. Date: Mon Feb 21 17:36:35 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.1 mcclim/mcclim.asd:1.2 --- mcclim/mcclim.asd:1.1 Wed Feb 16 21:43:25 2005 +++ mcclim/mcclim.asd Mon Feb 21 17:36:30 2005 @@ -4,7 +4,7 @@ ;;; (c) copyright 2000 by ;;; Robert Strandh (strandh(a)labri.u-bordeaux.fr) ;;; (c) copyright 2005 by -;;; Andreas Fuchs (asf(a)boinkor.net +;;; Andreas Fuchs (asf(a)boinkor.net) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -221,7 +221,7 @@ :pathname #.(make-pathname :directory '(:relative "Backends" "CLX")) :components ((:file "package") - (:file "image") + (:file "image" :depends-on ("package")) (:file "keysyms-common" :depends-on ("package")) (:file "keysyms" :depends-on ("keysyms-common" "package")) (:file "keysymdef" :depends-on ("keysyms-common" "package")) @@ -375,4 +375,4 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :depends-on (:clim-looks)) \ No newline at end of file + :depends-on (:clim-looks))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/image.lisp
by crhodes＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv32404/Backends/beagle Modified Files: image.lisp Log Message: Patch for image:write-pnm (from me, as corrected by Milan Zamazal) Since the patch applied cleanly to Backends/beagle/image.lisp, apply it there too, but if anyone out there is interested in the beagle backend, fixing this ridiculous duplication of code might be a plan. Date: Mon Feb 21 14:32:52 2005 Author: crhodes Index: mcclim/Backends/beagle/image.lisp diff -u mcclim/Backends/beagle/image.lisp:1.1 mcclim/Backends/beagle/image.lisp:1.2 --- mcclim/Backends/beagle/image.lisp:1.1 Sun Jul 11 21:48:16 2004 +++ mcclim/Backends/beagle/image.lisp Mon Feb 21 14:32:52 2005 @@ -108,12 +108,13 @@ `(the (unsigned-byte 8) (logand ,pixel 255))) (defmethod write-pnm ((image truecolor-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-ppm-p3 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image @@ -149,9 +150,11 @@ 0) (defmethod write-pnm ((image 256-gray-level-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pgm-p2 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,9 +170,11 @@ (make-instance 'binary-image :pixels pixels)) (defmethod write-pnm ((image binary-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pbm-p1 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image))))) @@ -179,46 +184,48 @@ (defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) - (width (cadr (array-dimensions picture)))) - (format stream "P~A~%" ,magic-number) - (format stream "~A ~A~%" width height) - (when ,max-value - (format stream "~A~%" ,max-value)) + (width (cadr (array-dimensions picture)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "P~A~%~A~%~A~%~@[~A~%~]" + ,magic-number width height ,max-value)) (loop for r from 0 below height do - (loop for c from 0 below width do - ,@body)) + (loop for c from 0 below width do + ,@body)) nil)) (defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) - (format stream "~A ~A ~A~%" - (red-component rgb) - (green-component rgb) - (blue-component rgb))))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A ~A ~A~%" + (red-component rgb) + (green-component rgb) + (blue-component rgb)))))) (defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) - (write-char (code-char (red-component rgb)) stream) - (write-char (code-char (green-component rgb)) stream) - (write-char (code-char (blue-component rgb)) stream)))) + (write-byte (red-component rgb) stream) + (write-byte (green-component rgb) stream) + (write-byte (blue-component rgb) stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/image.lisp
by crhodes＠common-lisp.net 21 Feb '05

21 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv32404/Backends/CLX Modified Files: image.lisp Log Message: Patch for image:write-pnm (from me, as corrected by Milan Zamazal) Since the patch applied cleanly to Backends/beagle/image.lisp, apply it there too, but if anyone out there is interested in the beagle backend, fixing this ridiculous duplication of code might be a plan. Date: Mon Feb 21 14:32:51 2005 Author: crhodes Index: mcclim/Backends/CLX/image.lisp diff -u mcclim/Backends/CLX/image.lisp:1.19 mcclim/Backends/CLX/image.lisp:1.20 --- mcclim/Backends/CLX/image.lisp:1.19 Sun Sep 14 19:55:56 2003 +++ mcclim/Backends/CLX/image.lisp Mon Feb 21 14:32:49 2005 @@ -108,12 +108,13 @@ `(the (unsigned-byte 8) (logand ,pixel 255))) (defmethod write-pnm ((image truecolor-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-ppm-p3 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-ppm-p3 stream (image-pixels image)) (write-ppm-p6 stream (image-pixels image))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; colormap image @@ -149,9 +150,11 @@ 0) (defmethod write-pnm ((image 256-gray-level-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pgm-p2 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pgm-p2 stream (image-pixels image)) (write-pgm-p5 stream (image-pixels image))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -167,9 +170,11 @@ (make-instance 'binary-image :pixels pixels)) (defmethod write-pnm ((image binary-image) filename output-format) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (if (eq output-format :ascii) - (write-pbm-p1 stream (image-pixels image)) + (with-open-file (stream filename + :direction :output :if-exists :supersede + :element-type '(unsigned-byte 8)) + (if (eq output-format :ascii) + (write-pbm-p1 stream (image-pixels image)) (write-pbm-p4 stream (image-pixels image))))) @@ -179,46 +184,48 @@ (defmacro with-write-pnm-loop ((magic-number max-value) &body body) `(let ((height (car (array-dimensions picture))) - (width (cadr (array-dimensions picture)))) - (format stream "P~A~%" ,magic-number) - (format stream "~A ~A~%" width height) - (when ,max-value - (format stream "~A~%" ,max-value)) + (width (cadr (array-dimensions picture)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "P~A~%~A~%~A~%~@[~A~%~]" + ,magic-number width height ,max-value)) (loop for r from 0 below height do - (loop for c from 0 below width do - ,@body)) + (loop for c from 0 below width do + ,@body)) nil)) (defun write-pbm-p1 (stream picture) (with-write-pnm-loop (1 nil) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pbm-p4 (stream picture) ; bad! (with-write-pnm-loop (4 nil) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-pgm-p2 (stream picture) (with-write-pnm-loop (2 255) - (format stream "~A~%" (aref picture r c)))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A~%" (aref picture r c))))) (defun write-pgm-p5 (stream picture) (with-write-pnm-loop (5 255) - (write-char (code-char (aref picture r c)) stream))) + (write-byte (aref picture r c) stream))) (defun write-ppm-p3 (stream picture) (with-write-pnm-loop (3 255) (let ((rgb (aref picture r c))) - (format stream "~A ~A ~A~%" - (red-component rgb) - (green-component rgb) - (blue-component rgb))))) + (map nil (lambda (x) (write-byte (char-code x) stream)) + (format nil "~A ~A ~A~%" + (red-component rgb) + (green-component rgb) + (blue-component rgb)))))) (defun write-ppm-p6 (stream picture) (with-write-pnm-loop (6 255) (let ((rgb (aref picture r c))) - (write-char (code-char (red-component rgb)) stream) - (write-char (code-char (green-component rgb)) stream) - (write-char (code-char (blue-component rgb)) stream)))) + (write-byte (red-component rgb) stream) + (write-byte (green-component rgb) stream) + (write-byte (blue-component rgb) stream)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/medium.lisp
by tmoore＠common-lisp.net 17 Feb '05

17 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv491 Modified Files: medium.lisp Log Message: Alastair Bridgewater's fix to medium-clear-area. Fixes Paolo bug clx-medium-clear-area-transform Date: Thu Feb 17 22:23:29 2005 Author: tmoore Index: mcclim/Backends/CLX/medium.lisp diff -u mcclim/Backends/CLX/medium.lisp:1.65 mcclim/Backends/CLX/medium.lisp:1.66 --- mcclim/Backends/CLX/medium.lisp:1.65 Tue Jan 18 14:35:26 2005 +++ mcclim/Backends/CLX/medium.lisp Thu Feb 17 22:23:29 2005 @@ -965,13 +965,19 @@ (xlib:display-force-output (clx-port-display (port medium)))) (defmethod medium-clear-area ((medium clx-medium) left top right bottom) - (let ((min-x (round-coordinate (min left right))) - (min-y (round-coordinate (min top bottom))) - (max-x (round-coordinate (max left right))) - (max-y (round-coordinate (max top bottom)))) - (xlib:clear-area (port-lookup-mirror (port medium) (medium-sheet medium)) - :x min-x :y min-y - :width (- max-x min-x) :height (- max-y min-y)))) + (let ((tr (sheet-native-transformation (medium-sheet medium)))) + (with-transformed-position (tr left top) + (with-transformed-position (tr right bottom) + (let ((min-x (round-coordinate (min left right))) + (min-y (round-coordinate (min top bottom))) + (max-x (round-coordinate (max left right))) + (max-y (round-coordinate (max top bottom)))) + (xlib:clear-area (port-lookup-mirror (port medium) + (medium-sheet medium)) + :x (max #x-8000 (min #x7fff min-x)) + :y (max #x-8000 (min #x7fff min-y)) + :width (max 0 (min #xffff (- max-x min-x))) + :height (max 0 (min #xffff (- max-y min-y))))))))) (defmethod medium-beep ((medium clx-medium)) (xlib:bell (clx-port-display (port medium))))

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 16 Feb '05

16 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv19230 Added Files: mcclim.asd Log Message: Adding the ASDF-only dependency-aware mcclim.asd file. This file buys McCLIM ASDF-INSTALLability, among other things. Date: Wed Feb 16 21:43:26 2005 Author: afuchs

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by pscott＠common-lisp.net 15 Feb '05

15 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv15800 Modified Files: inspector.lisp Log Message: Major changes: Added with-heading-style macro which currently bolds its output, and changed a bunch of things to use this everywhere we have headings. This makes the inspector look *much* nicer. Minor change: turned a (loop for foo in bar do ...) into a DOLIST, which uses less indentation and is arguably clearer. Date: Wed Feb 16 00:12:08 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.21 mcclim/Apps/Inspector/inspector.lisp:1.22 --- mcclim/Apps/Inspector/inspector.lisp:1.21 Fri Feb 11 22:41:25 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 16 00:12:07 2005 @@ -128,6 +128,12 @@ (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) +(defmacro with-heading-style ((stream) &body body) + "Cause text output from BODY to be formatted in a heading font. This +could be boldface, or a different style, or even another font." + `(with-text-face (,stream :bold) + ,@body)) + (defmacro inspector-table (header &body body) "Present OBJECT (captured from environment) in tabular form, with HEADER printed in a box at the top. BODY should output the rows of the @@ -140,7 +146,8 @@ (formatting-column (pane) (formatting-cell (pane) (surrounding-output-with-border (pane) - ,header)) + (with-heading-style (pane) + ,header))) (formatting-cell (pane) (formatting-table (pane) ,@body)))) @@ -151,7 +158,8 @@ environment created by INSPECTOR-TABLE." `(formatting-row (pane) (formatting-cell (pane :align-x :right) - ,left) + (with-heading-style (pane) + ,left)) (formatting-cell (pane) ,right))) @@ -159,7 +167,9 @@ "Print OBJECT's documentation, if any, to PANE" (when (handler-bind ((warning #'muffle-warning)) (documentation object t)) - (format pane "~&Documentation: ~A" (documentation object t)))) + (with-heading-style (pane) + (format pane "~&Documentation: ")) + (princ (documentation object t) pane))) (defun inspect-structure-or-object (object pane) "Inspect a structure or an object. Since both can be inspected in @@ -171,13 +181,13 @@ (print (class-name class) pane) (when (clim-mop:class-direct-superclasses class) (inspector-table-row - (format pane "Superclasses") + (princ "Superclasses" pane) (dolist (superclass (clim-mop:class-direct-superclasses class)) (inspect-object superclass pane) (terpri pane)))) (when (clim-mop:class-direct-subclasses class) (inspector-table-row - (format pane "Subclasses") + (princ "Subclasses" pane) (dolist (subclass (clim-mop:class-direct-subclasses class)) (inspect-object subclass pane) (terpri pane)))) @@ -191,6 +201,8 @@ (inspect-object (slot-value object slot-name) pane) (format pane "#<unbound slot>")))))))) +;; Try to print the normal, textual representation of an object, but +;; if that's too long, make an abbreviated "instance of ~S" version. ;; FIXME: should this be removed? It's really ugly. (defparameter *object-representation-max-length* 300 "Maximum number of characters of an object's textual representation @@ -208,9 +220,6 @@ (error () (format pane "#<unprintable ~S>" (class-name (class-of object))))))) -;; Try to print the normal, textual representation of an object, but -;; if that's too long, make an abbreviated "instance of ~S" version. - (defmethod inspect-object-briefly ((object standard-object) pane) (inspect-structure-or-object-briefly object pane)) @@ -319,24 +328,24 @@ (inspector-table (format pane "Generic Function: ~s" (clim-mop:generic-function-name object)) - (loop for method in (clim-mop:generic-function-methods object) - do (with-output-as-presentation - (pane method (presentation-type-of method)) - (formatting-row (pane) - (formatting-cell (pane) - (print (method-qualifiers method))) - (loop for specializer in (clim-mop:method-specializers method) - do (formatting-cell (pane) - (if (typep specializer 'clim-mop:eql-specializer) - (progn - (princ "(EQL " pane) - (inspect-object - (clim-mop:eql-specializer-object - specializer) - pane) - (princ ")" pane)) - (inspect-object (class-name specializer) - pane))))))))) + (dolist (method (clim-mop:generic-function-methods object)) + (with-output-as-presentation + (pane method (presentation-type-of method)) + (formatting-row (pane) + (formatting-cell (pane) + (print (method-qualifiers method))) + (loop for specializer in (clim-mop:method-specializers method) + do (formatting-cell (pane) + (if (typep specializer 'clim-mop:eql-specializer) + (progn + (princ "(EQL " pane) + (inspect-object + (clim-mop:eql-specializer-object + specializer) + pane) + (princ ")" pane)) + (inspect-object (class-name specializer) + pane))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -362,12 +371,15 @@ (defmethod inspect-object ((object function) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "Function: ~A" - (pretty-print-function object)) + (with-heading-style (pane) + (princ "Function: " pane)) + (princ (pretty-print-function object) pane) #+sbcl (unless (typep object 'generic-function) - (format pane "~&Type: ~A" - (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)))) + (with-heading-style (pane) + (format pane "~&Type: ")) + (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) + pane)) (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) @@ -386,8 +398,13 @@ (inspect-object nick pane))) (inspector-table-row (princ "Used by:") + ;; FIXME: This should use some sort of list formatting, so that + ;; it can obey conventions about *print-length* and reuse code + ;; for modifying it. To support this, list printing should + ;; support delimiterless, one-item-per-line display. (dolist (used-by (package-used-by-list object)) - (inspect-object used-by pane))) + (fresh-line pane) + (inspect-object used-by pane))) (inspector-table-row (princ "Uses:") (dolist (uses (package-use-list object)) @@ -580,19 +597,24 @@ (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name)))) (when documentation - (format stream "~&Documentation: ~A~%" documentation)) - (format stream "~&Type: ~S~%" - (clim-mop:slot-definition-type slot-object)) - (format stream "~&Allocation: ~S~%" - (clim-mop:slot-definition-allocation slot-object)) + (with-heading-style (stream) + (format stream "~&Documentation: ")) + (format stream "~A~%" documentation)) + (with-heading-style (stream) + (format stream "~&Type: ")) + (format stream "~S~%" (clim-mop:slot-definition-type slot-object)) + (with-heading-style (stream) + (format stream "~&Allocation: ")) + (format stream "~S~%" (clim-mop:slot-definition-allocation slot-object)) ;; slot-definition-{readers,writers} only works for direct slot ;; definitions (let ((readers (clim-mop:slot-definition-readers slot-object))) (when readers - (format stream "~&Readers: ") + (with-heading-style (stream) + (format stream "~&Readers: ")) (present readers (presentation-type-of readers) :stream stream))) (let ((writers (clim-mop:slot-definition-writers slot-object))) (when writers - (format stream "~&Writers: ") + (with-heading-style (stream) + (format stream "~&Writers: ")) (present writers (presentation-type-of writers) :stream stream)))))) -

1 0

[mcclim-cvs] CVS update: mcclim/recording.lisp
by crhodes＠common-lisp.net 15 Feb '05

15 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv10043 Modified Files: recording.lisp Log Message: Maybe fix circle/ellipse drawing in with-room-for-graphics and with-first-quadrant-coordinates. (Weirdest. Coordinate. System. Ever.) Date: Tue Feb 15 12:28:11 2005 Author: crhodes Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.117 mcclim/recording.lisp:1.118 --- mcclim/recording.lisp:1.117 Fri Feb 11 10:10:36 2005 +++ mcclim/recording.lisp Tue Feb 15 12:28:11 2005 @@ -1570,6 +1570,8 @@ ;; will break other things. -Hefner (setf start-angle (untransform-angle transform start-angle)) (setf end-angle (untransform-angle transform end-angle)) + (when (reflection-transformation-p transform) + (rotatef start-angle end-angle)) (multiple-value-bind (min-x min-y max-x max-y) (bounding-rectangle* (make-ellipse* center-x center-y radius-1-dx radius-1-dy

1 0