From afuchs at common-lisp.net Tue Mar 1 15:46:15 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Tue, 1 Mar 2005 16:46:15 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/mcclim.asd Message-ID: <20050301154615.CD59D8866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28245 Modified Files: mcclim.asd Log Message: without-package-locks is in cmucl's EXTENSIONS package. Date: Tue Mar 1 16:46:14 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.3 mcclim/mcclim.asd:1.4 --- mcclim/mcclim.asd:1.3 Mon Feb 28 17:23:20 2005 +++ mcclim/mcclim.asd Tue Mar 1 16:46:13 2005 @@ -39,8 +39,8 @@ (unless (ignore-errors (ext:search-list "gray-streams:")) (setf (ext:search-list "gray-streams:") '("target:pcl/" "library:subsystems/"))) - (if (fboundp 'without-package-locks) - (without-package-locks + (if (fboundp 'extensions:without-package-locks) + (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) #-clx From afuchs at common-lisp.net Fri Mar 4 07:35:40 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 4 Mar 2005 08:35:40 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/beagle/events.lisp Message-ID: <20050304073540.0E0FF8866C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv19834 Modified Files: events.lisp Log Message: Commit Tom Winchester's patch to make events.lisp compile with the new backend protocol. Date: Fri Mar 4 08:35:40 2005 Author: afuchs Index: mcclim/Backends/beagle/events.lisp diff -u mcclim/Backends/beagle/events.lisp:1.4 mcclim/Backends/beagle/events.lisp:1.5 --- mcclim/Backends/beagle/events.lisp:1.4 Sat Aug 21 22:51:28 2004 +++ mcclim/Backends/beagle/events.lisp Fri Mar 4 08:35:39 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.4 2004/08/21 20:51:28 duncan Exp $ +$Id: events.lisp,v 1.5 2005/03/04 07:35:39 afuchs Exp $ All these are copied pretty much from CLX/port.lisp @@ -334,7 +334,7 @@ (target-sheet (port-lookup-sheet-for-view *beagle-port* target-view))) (unless (null target-sheet) (format *debug-io* "Setting focus in *beagle-port* onto (hopefully correct) sheet: ~S~%" target-sheet) - (set-port-keyboard-focus target-sheet *beagle-port*)))))) + (%set-port-keyboard-focus target-sheet *beagle-port*)))))) ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidExposeNotification") (setf return-event (make-instance 'window-repaint-event :timestamp (incf timestamp) @@ -720,7 +720,7 @@ ;;; Cocoa note: the Frame (NSWindow) must be made key for us to receive events; but they ;;; must then be sent to the Sheet that has focus. -(defmethod set-port-keyboard-focus (focus (port beagle-port)) +(defmethod %set-port-keyboard-focus (focus (port beagle-port) &key timestamp) (let ((mirror (sheet-mirror focus))) (debug-log 2 "events.lisp:set-port-keyboard-focus - got mirror ~S~%" mirror) (when mirror From afuchs at common-lisp.net Fri Mar 4 07:54:43 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Fri, 4 Mar 2005 08:54:43 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/beagle/package.lisp Message-ID: <20050304075443.AF2EE8866C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv20688 Modified Files: package.lisp Log Message: Tom Winchester's patch to package.lisp to adapt the beagle to the new backend protocol Date: Fri Mar 4 08:54:43 2005 Author: afuchs Index: mcclim/Backends/beagle/package.lisp diff -u mcclim/Backends/beagle/package.lisp:1.1 mcclim/Backends/beagle/package.lisp:1.2 --- mcclim/Backends/beagle/package.lisp:1.1 Sun Jul 11 21:48:16 2004 +++ mcclim/Backends/beagle/package.lisp Fri Mar 4 08:54:42 2005 @@ -43,7 +43,7 @@ #:port-disable-sheet #:port-motion-hints #:port-force-output - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; #:port-set-mirror-region From pscott at common-lisp.net Fri Mar 4 21:32:09 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 4 Mar 2005 22:32:09 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050304213209.192E68867B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv3338 Modified Files: inspector.lisp Log Message: Fixed a bunch of little bugs. Added some comments. Package display was ugly in one place I forgot to change earlier, so I changed it. Numbers and strings had some weird display problems, which I've mostly fixed (and I can only hope that I didn't introduce minor bugs in some other part of the program). I think this is ready for the Mothering Sunday release! Date: Fri Mar 4 22:32:09 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.22 mcclim/Apps/Inspector/inspector.lisp:1.23 --- mcclim/Apps/Inspector/inspector.lisp:1.22 Wed Feb 16 00:12:07 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Mar 4 22:32:08 2005 @@ -304,9 +304,10 @@ (formatting-cell (pane) (inspect-object car pane))))))) (defmethod inspect-object ((object cons) pane) + ;; Decide how to display the cons by looking in cons-cell-dico (if (gethash object (cons-cell-dico *application-frame*)) - (inspect-cons-as-cells object pane) - (inspect-cons-as-list object pane))) + (inspect-cons-as-cells object pane) + (inspect-cons-as-list object pane))) (defmethod inspect-object-briefly ((object hash-table) pane) @@ -383,9 +384,13 @@ (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) + ;; Display as 'Package: "PACKAGE-NAME"'. We're doing something a + ;; little unusual here by not bolding the "Package:" part. This may + ;; be a tad inconsistent, but the other way looks very odd. (with-output-as-presentation (pane object (presentation-type-of object)) (format pane "Package: ~S" (package-name object)))) + (defmethod inspect-object ((object package) pane) (inspector-table (format pane "Package: ~S" (package-name object)) @@ -408,7 +413,8 @@ (inspector-table-row (princ "Uses:") (dolist (uses (package-use-list object)) - (inspect-object uses pane))))) + (fresh-line pane) + (inspect-object uses pane))))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation @@ -423,15 +429,27 @@ (formatting-cell (pane) (princ ")" pane)))))) +;; For some strange reason, objects that are displayed with PRINT are +;; slightly wider than those displayed with PRIN1. Generally, PRIN1 is +;; what you want, and to prevent strings and numbers from getting +;; slightly wider when they're toggled to full inspection, the +;; INSPECT-OBJECT methods for them call the INSPECT-OBJECT-BRIEFLY +;; methods which do the right thing. (defmethod inspect-object-briefly ((object string) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object))) + (prin1 object))) + +(defmethod inspect-object ((object string) pane) + (inspect-object-briefly object pane)) (defmethod inspect-object-briefly ((object number) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object))) + (prin1 object))) + +(defmethod inspect-object ((object number) pane) + (inspect-object-briefly object pane)) (defun inspect-complex (object pane) "Inspect a complex number. Since complex numbers should be inspected From pscott at common-lisp.net Sat Mar 5 15:48:19 2005 From: pscott at common-lisp.net (Peter Scott) Date: Sat, 5 Mar 2005 16:48:19 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050305154819.4040B8866C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv999 Modified Files: inspector.lisp Log Message: Fixed PRIN1 bugs that I introduced with the last "bugfix" commit. Thanks to Vincent Arkesteijn for pointing them out. I thought I tested that code! Really! Date: Sat Mar 5 16:48:18 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.23 mcclim/Apps/Inspector/inspector.lisp:1.24 --- mcclim/Apps/Inspector/inspector.lisp:1.23 Fri Mar 4 22:32:08 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Mar 5 16:48:18 2005 @@ -429,27 +429,15 @@ (formatting-cell (pane) (princ ")" pane)))))) -;; For some strange reason, objects that are displayed with PRINT are -;; slightly wider than those displayed with PRIN1. Generally, PRIN1 is -;; what you want, and to prevent strings and numbers from getting -;; slightly wider when they're toggled to full inspection, the -;; INSPECT-OBJECT methods for them call the INSPECT-OBJECT-BRIEFLY -;; methods which do the right thing. (defmethod inspect-object-briefly ((object string) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (prin1 object))) -(defmethod inspect-object ((object string) pane) - (inspect-object-briefly object pane)) - (defmethod inspect-object-briefly ((object number) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (prin1 object))) - -(defmethod inspect-object ((object number) pane) - (inspect-object-briefly object pane)) (defun inspect-complex (object pane) "Inspect a complex number. Since complex numbers should be inspected From afuchs at common-lisp.net Sun Mar 6 18:57:22 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 19:57:22 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/INSTALL.ASDF mcclim/INSTALL.CLISP mcclim/INSTALL.CMU mcclim/INSTALL.OPENMCL mcclim/INSTALL.SBCL Message-ID: <20050306185722.0DDEC8866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29201 Modified Files: INSTALL.CLISP INSTALL.CMU INSTALL.OPENMCL INSTALL.SBCL Added Files: INSTALL.ASDF Log Message: Install documentation update to reflect the ASDF changes & recommend mcclim.asd Date: Sun Mar 6 19:57:18 2005 Author: afuchs Index: mcclim/INSTALL.CLISP diff -u mcclim/INSTALL.CLISP:1.1 mcclim/INSTALL.CLISP:1.2 --- mcclim/INSTALL.CLISP:1.1 Mon Dec 20 16:51:26 2004 +++ mcclim/INSTALL.CLISP Sun Mar 6 19:57:18 2005 @@ -1,6 +1,12 @@ Install instructions for GNU CLISP ---------------------------------- +:::NOTE::: +These install instructions refer to the "system.lisp" installation +approach. If you have ASDF available, we recommend you follow the +install instructions in INSTALL.ASDF. +:::NOTE::: + 1. Get clisp-20041218 or newer. Build it with option --with-module=clx/mit-clx. 2. Get a copy of the ASDF package. Compile it: Index: mcclim/INSTALL.CMU diff -u mcclim/INSTALL.CMU:1.16 mcclim/INSTALL.CMU:1.17 --- mcclim/INSTALL.CMU:1.16 Sun Aug 22 17:48:17 2004 +++ mcclim/INSTALL.CMU Sun Mar 6 19:57:18 2005 @@ -1,7 +1,13 @@ Install instructions for CMU Common Lisp ---------------------------------------- -McCLIM has been tested with CMUCL 18e. +:::NOTE::: +These install instructions refer to the "system.lisp" installation +approach. If you have ASDF available, we recommend you follow the +install instructions in INSTALL.ASDF. +:::NOTE::: + +McCLIM has been tested with CMUCL 19a. 1. Make sure you have a Lisp core file that includes Index: mcclim/INSTALL.OPENMCL diff -u mcclim/INSTALL.OPENMCL:1.3 mcclim/INSTALL.OPENMCL:1.4 --- mcclim/INSTALL.OPENMCL:1.3 Wed Mar 24 10:30:29 2004 +++ mcclim/INSTALL.OPENMCL Sun Mar 6 19:57:18 2005 @@ -1,6 +1,12 @@ Install instructions for OpenMCL on Mac OS X -------------------------------------------- +:::NOTE::: +These install instructions refer to the "system.lisp" installation +approach. If you have ASDF available, we recommend you follow the +install instructions in INSTALL.ASDF. +:::NOTE::: + McCLIM has been tested with OpenMCL 0.13.6 and OpenMCL 0.14.1-p1 (which is recommended). Index: mcclim/INSTALL.SBCL diff -u mcclim/INSTALL.SBCL:1.3 mcclim/INSTALL.SBCL:1.4 --- mcclim/INSTALL.SBCL:1.3 Wed Nov 19 14:51:17 2003 +++ mcclim/INSTALL.SBCL Sun Mar 6 19:57:18 2005 @@ -1,6 +1,13 @@ Install instructions for SBCL ----------------------------- +:::NOTE::: +These install instructions refer to the "system.lisp" installation +approach. If you have ASDF available, we recommend you follow the +install instructions in INSTALL.ASDF. +:::NOTE::: + + 1. Get a recent SBCL, it will be equipped with ASDF, which you will need. From afuchs at common-lisp.net Sun Mar 6 18:57:24 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 19:57:24 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/beagle/README.txt Message-ID: <20050306185724.3E1DC88677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv29201/Backends/beagle Modified Files: README.txt Log Message: Install documentation update to reflect the ASDF changes & recommend mcclim.asd Date: Sun Mar 6 19:57:22 2005 Author: afuchs Index: mcclim/Backends/beagle/README.txt diff -u mcclim/Backends/beagle/README.txt:1.6 mcclim/Backends/beagle/README.txt:1.7 --- mcclim/Backends/beagle/README.txt:1.6 Sun Aug 22 00:42:51 2004 +++ mcclim/Backends/beagle/README.txt Sun Mar 6 19:57:20 2005 @@ -43,42 +43,29 @@ changes in the OpenMCL Cocoa Bridge. Compiling and running the back end currently is a straight-forward (if -rather limiting [see note #3]) task: - -Optional: - -1. Create a symbolic link from .../McCLIM/Backends/beagle/load-clim.lisp - to your home directory. -2. Ditto for load-clx.lisp (if you intend to run the clx backend too... there - are other ways to do this, but this is how I'm doing it at the moment) -3. Ditto for load-beagle.lisp - -Then: +rather limiting [see note #2]) task: +1. Install McCLIM according to INSTALL.ASDF in the McCLIM root + directory. 2. Start OpenMCL 3. Evaluate '(require "COCOA")' The following are evaluated from the 'OpenMCL Listener' that opens: 4. Evaluate '(require "ASDF")' -5. Evaluate '(load "home:load-clim")' [See note #1] -6. Evaluate '(load "home:load-beagle")' [See note #4] +5. Evaluate '(asdf:oos 'asdf:load-op :clim-beagle)' +6. Evaluate '(asdf:oos 'asdf:load-op :mcclim)' [See note #3] The McCLIM Listener should now be able to be started from the OpenMCL Listener by evaluating '(clim-listener:run-listener)'. See the McCLIM -installation notes for other things you might want to do. [See note #2] - -Note #1: If you did not create the symbolic link in (1), load the - "load-clim.lisp" file from whereever it is; for example, - - '(load "/Users/me/McCLIM/Backends/beagle/load-clim")' +installation notes for other things you might want to do. [See note #1] -Note #2: Some of the examples provided with McCLIM do not execute when using +Note #1: Some of the examples provided with McCLIM do not execute when using the Beagle back end, either because of unimplemented features in the back end or because of lossage in the back end. Reports and patches would be appreciated! -Note #3: Yes, this is a little silly. For a while the Beagle back end could +Note #2: Yes, this is a little silly. For a while the Beagle back end could be built into its own bundle by making use of Mikel Evins' Bosco framework. This framework is currently undergoing some change in any case so I decided to make the initial CVS version available @@ -89,10 +76,11 @@ currently-executing (non-graphical) application can have an event loop. -Note #4: If you'd rather run with the CLX back end, do a load-clx instead - here. Hopefully it will (soon?) be possible to run with multiple - ports simultaneously so that both a CLX and a Beagle Listener can - be run side by side for comparative purposes. +Note #3: If you'd rather run with the CLX back end, load CLX + instead here. Hopefully it will (soon?) be possible to run + with multiple ports simultaneously so that both a CLX and a + Beagle Listener can be run side by side for comparative + purposes. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% From afuchs at common-lisp.net Sun Mar 6 19:57:13 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 20:57:13 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/INSTALL.ASDF Message-ID: <20050306195713.2566E8866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv32551 Modified Files: INSTALL.ASDF Log Message: antifuchs: in INSTALL.ASDF: asdf:*central-repository* --> asdf:*central-registry* (three times) (argh.) Date: Sun Mar 6 20:57:12 2005 Author: afuchs Index: mcclim/INSTALL.ASDF diff -u mcclim/INSTALL.ASDF:1.1 mcclim/INSTALL.ASDF:1.2 --- mcclim/INSTALL.ASDF:1.1 Sun Mar 6 19:57:18 2005 +++ mcclim/INSTALL.ASDF Sun Mar 6 20:57:12 2005 @@ -5,13 +5,13 @@ first time, perform these steps: 1. Symlink mcclim.asd to a directory in your - asdf:*central-repository* list. E.g., for SBCL, that would be: + asdf:*central-registry* list. E.g., for SBCL, that would be: $ ln -sf /path/to/mcclim.asd ~/.sbcl/systems/ 2. If you are using a Lisp implementation that requires a separate CLX to be installed, do this now and symlink the clx's .asd file - to your asdf:*central-repository*, as above. If your + to your asdf:*central-registry*, as above. If your implementation's CLX doesn't come with a clx.asd file, you will have to load CLX via (require :clx) or a similar mechanism yourself. @@ -30,7 +30,7 @@ Installing mcclim.asd if you were using ASDF & system.lisp before ================================================================= -Make sure to remove all symlinks in your asdf:*central-repository* to +Make sure to remove all symlinks in your asdf:*central-registry* to system.lisp and replace them with symlinks to mcclim.asd. Keeping the old links around will break loading the McCLIM system in subtle ways. From ahefner at common-lisp.net Sun Mar 6 20:23:14 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Sun, 6 Mar 2005 21:23:14 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Listener/cmu-hacks.lisp Message-ID: <20050306202314.B42A28866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv1772 Modified Files: cmu-hacks.lisp Log Message: Apply package lock patch from Paolo Amoroso. Date: Sun Mar 6 21:23:13 2005 Author: ahefner Index: mcclim/Apps/Listener/cmu-hacks.lisp diff -u mcclim/Apps/Listener/cmu-hacks.lisp:1.4 mcclim/Apps/Listener/cmu-hacks.lisp:1.5 --- mcclim/Apps/Listener/cmu-hacks.lisp:1.4 Sun Aug 1 07:39:41 2004 +++ mcclim/Apps/Listener/cmu-hacks.lisp Sun Mar 6 21:23:13 2005 @@ -2,6 +2,11 @@ (in-package :climi) +#+cmu19a +(progn (setf (ext:package-definition-lock (find-package "DEBUG")) nil) + (setf (ext:package-definition-lock (find-package "COMMON-LISP")) nil) + (setf (ext:package-definition-lock (find-package "EXT")) nil)) + ;; a patch (defmethod stream-listen ((stream standard-extended-input-stream)) (with-encapsulating-stream (estream stream) From ahefner at common-lisp.net Sun Mar 6 20:35:41 2005 From: ahefner at common-lisp.net (Andy Hefner) Date: Sun, 6 Mar 2005 21:35:41 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Examples/method-browser.lisp Message-ID: <20050306203541.291848866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory common-lisp.net:/tmp/cvs-serv2663 Modified Files: method-browser.lisp Log Message: Support for EQL specializers on SBCL and CMUCL. Date: Sun Mar 6 21:35:40 2005 Author: ahefner Index: mcclim/Examples/method-browser.lisp diff -u mcclim/Examples/method-browser.lisp:1.1 mcclim/Examples/method-browser.lisp:1.2 --- mcclim/Examples/method-browser.lisp:1.1 Mon Jan 31 07:24:24 2005 +++ mcclim/Examples/method-browser.lisp Sun Mar 6 21:35:40 2005 @@ -22,7 +22,8 @@ ;;; -------------------------------------------------------------------- ;;; This is an example of how to write a CLIM application with a -;;; "normal" GUI. McCLIM can do more than just command lines.. +;;; "normal" GUI, where "normal" is a completely event driven app +;;; built using gadgets and not using the command-oriented framework. ;;; Running the method-browser: ;;; (clim-demo::run-test 'clim-demo::method-browser) @@ -45,7 +46,7 @@ ;;; * Portable MOP provided by CLIM-MOP package ;;; TODO: -;;; * EQL specializers (not portable according to AMOP) +;;; * EQL specializers on implementations other than SBCL/CMUCL ;;; * Nicer, more clever display of methods than simply listing them in a row. ;;; To do this right really involes some nonportable fun and a codewalker. ;;; You could probably write something that just understood the standard @@ -66,6 +67,28 @@ collect (remove-duplicates (mapcar (lambda (specs) (nth index specs)) specializers))))) +(defun classp (x) + (or (typep x 'cl:class) + #+CMU (typep x 'pcl::class))) + +(defun eql-specializer-p (x) + #+SBCL (typep x 'sb-mop:eql-specializer) + #+CMU (typep x 'pcl:eql-specializer)) + +(defun eql-specializer-object (x) + #+SBCL (sb-mop:eql-specializer-object x) + #+CMU (pcl::eql-specializer-object x)) + +(defun compute-applicable-methods-from-specializers (gf specializers) + (clim-mop:compute-applicable-methods gf + (mapcar (lambda (spec) + (cond ((eql-specializer-p spec) + (eql-specializer-object spec)) + ((classp spec) + (clim-mop:class-prototype spec)) + (t (error "Can't compute effective methods, specializer ~A is not understood." spec)))) + specializers))) + ;; FIXME: Support EQL specializers. ;; This is hard to do ideally, and I'm not really trying. ;; So we just make sure that T ends up at the head of the list. @@ -77,8 +100,23 @@ (cond ((eql a (find-class t)) t) ((eql b (find-class t)) nil) - (t (string< (class-name a) - (class-name b))))))) + ((and (classp a) + (classp b)) + (string< (class-name a) + (class-name b))) + ((and (eql-specializer-p a) + (not (eql-specializer-p b))) + nil) + ((and (not (eql-specializer-p a)) + (eql-specializer-p b)) + t) + ((and (eql-specializer-p a) + (eql-specializer-p b)) + (string< + (princ-to-string (eql-specializer-object a)) + (princ-to-string (eql-specializer-object b)))) + (t (warn "Received specializer of unknown type") + nil) )))) (compute-gf-specializers gf))) (defun simple-generic-function-lambda-list (gf) @@ -95,9 +133,10 @@ (defun specializer-pretty-name (spec) "Pretty print the name of a method specializer" - (cond ((or (typep spec 'class) - #+CMU (typep spec 'pcl::class)) + (cond ((classp spec) (princ-to-string (class-name spec))) + ((eql-specializer-p spec) + (format nil "(EQL '~A)" (eql-specializer-object spec))) (t (princ-to-string spec)))) (defun maybe-find-gf (name) @@ -274,10 +313,10 @@ "Generates the display of applicable methods in the output-pane" (when (gf frame) (let* ((gf (gf frame)) - (methods (clim-mop:compute-applicable-methods-using-classes gf (arg-types frame))) + (methods (compute-applicable-methods-from-specializers gf (arg-types frame))) (combination (clim-mop:generic-function-method-combination gf)) (effective-methods (clim-mop:compute-effective-method gf combination methods)) - (serial-methods (walk-em-form effective-methods))) + (serial-methods (walk-em-form effective-methods))) ;; Print the header (fresh-line) (with-drawing-options (pane :text-style (make-text-style :sans-serif :bold :large) From afuchs at common-lisp.net Sun Mar 6 22:02:16 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 23:02:16 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/ReleaseNotes/0-9-1-mothering-sunday Message-ID: <20050306220216.D037388677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory common-lisp.net:/tmp/cvs-serv7711/ReleaseNotes Added Files: 0-9-1-mothering-sunday Log Message: Commit the release tarball & the release notes. Date: Sun Mar 6 23:02:12 2005 Author: afuchs From afuchs at common-lisp.net Sun Mar 6 22:02:24 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 23:02:24 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Webpage/downloads/mcclim-0.9.1.tar.gz Message-ID: <20050306220224.4C7DC88677@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv7711/Webpage/downloads Added Files: mcclim-0.9.1.tar.gz Log Message: Commit the release tarball & the release notes. Date: Sun Mar 6 23:02:19 2005 Author: afuchs From afuchs at common-lisp.net Sun Mar 6 22:13:30 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 6 Mar 2005 23:13:30 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Webpage/downloads/mcclim-0.9.1.tar.gz.asc Message-ID: <20050306221330.E8D0B8866E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory common-lisp.net:/tmp/cvs-serv7991 Added Files: mcclim-0.9.1.tar.gz.asc Log Message: add the GPG signature to make ASDF-INSTALL work. Date: Sun Mar 6 23:13:29 2005 Author: afuchs From pscott at common-lisp.net Mon Mar 7 20:45:12 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 7 Mar 2005 21:45:12 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/disassembly.lisp Message-ID: <20050307204512.3137A8866D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv19444 Added Files: disassembly.lisp Log Message: Initial commit. Date: Mon Mar 7 21:45:09 2005 Author: pscott From pscott at common-lisp.net Mon Mar 7 20:46:44 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 7 Mar 2005 21:46:44 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050307204644.D36268866D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv20223 Modified Files: inspector.lisp Log Message: The inspector now uses monospaced fonts for certain things, which looks nicer. Formatting of package lists is cleaned up, with the addition of a new function to display a list vertically without parentheses. Functions can now be disassembled, and the disassembly can be displayed in implementation-specific ways. Currently the only implementation that has a specific format is SBCL, and it might be broken on more recent versions if they've changed the disassembly format significantly since 0.8.16 without telling me. Date: Mon Mar 7 21:46:44 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.24 mcclim/Apps/Inspector/inspector.lisp:1.25 --- mcclim/Apps/Inspector/inspector.lisp:1.24 Sat Mar 5 16:48:18 2005 +++ mcclim/Apps/Inspector/inspector.lisp Mon Mar 7 21:46:43 2005 @@ -31,6 +31,9 @@ (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) + (disassembly-dico :initform (make-hash-table) :reader disassembly-dico + :documentation "A hash table specifying which +functions should display disassembly") (print-length :initform (make-hash-table) :reader print-length :documentation "A hash table mapping list objects to their specific print lengths, if they have one.") @@ -111,7 +114,7 @@ (defmethod inspect-object (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object pane))) + (prin1 object pane))) (define-presentation-type settable-slot () @@ -182,15 +185,13 @@ (when (clim-mop:class-direct-superclasses class) (inspector-table-row (princ "Superclasses" pane) - (dolist (superclass (clim-mop:class-direct-superclasses class)) - (inspect-object superclass pane) - (terpri pane)))) + (inspect-vertical-list (clim-mop:class-direct-superclasses class) + pane))) (when (clim-mop:class-direct-subclasses class) (inspector-table-row (princ "Subclasses" pane) - (dolist (subclass (clim-mop:class-direct-subclasses class)) - (inspect-object subclass pane) - (terpri pane)))) + (inspect-vertical-list (clim-mop:class-direct-subclasses class) + pane))) (loop for slot in (reverse (clim-mop:class-slots class)) do (let ((slot-name (clim-mop:slot-definition-name slot))) (inspector-table-row @@ -211,14 +212,15 @@ (defun inspect-structure-or-object-briefly (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (handler-case - (let ((representation (with-output-to-string (string) - (prin1 object string)))) - (if (< (length representation) *object-representation-max-length*) - (princ representation pane) - (format pane "#<~S ...>" (class-name (class-of object))))) - (error () - (format pane "#" (class-name (class-of object))))))) + (with-text-family (pane :fix) + (handler-case + (let ((representation (with-output-to-string (string) + (prin1 object string)))) + (if (< (length representation) *object-representation-max-length*) + (princ representation pane) + (format pane "#<~S ...>" (class-name (class-of object))))) + (error () + (format pane "#" (class-name (class-of object)))))))) (defmethod inspect-object-briefly ((object standard-object) pane) (inspect-structure-or-object-briefly object pane)) @@ -271,13 +273,48 @@ (formatting-cell (pane) (inspect-object (cdr object) pane)))))) +(defun inspect-vertical-list (object pane) + "Inspect a list without the parentheses, putting each element on a +new line. This is useful for showing things like direct class +subclasses, since displaying those as a plain list looks ugly and is +inconvenient to use." + ;; Ordinarily this would be taken care of in the :around method for + ;; INSPECT-OBJECT, but since this is not a normal inspection view, + ;; we need to do it ourselves. Yes, it would be better if we could + ;; find another way to do this. + (let ((*print-length* (or (gethash object (print-length + *application-frame*)) + *print-length*))) + (with-output-as-presentation + (pane object 'cons) + (formatting-table (pane) + (formatting-column (pane) + (do + ((length 0 (1+ length)) + (cdr (cdr object) (cdr cdr)) + (car (car object) (car cdr))) + ((cond ((eq nil cdr) + (formatting-cell (pane) (inspect-object car pane)) + t) + ((not (consp cdr)) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "." pane)) + (formatting-cell (pane) (inspect-object cdr pane)) + t) + ((and *print-length* (>= length *print-length*)) + (with-output-as-presentation (pane object 'long-list-tail) + (formatting-cell (pane) (princ "..." pane))) + t) + (t nil))) + (formatting-cell (pane) (inspect-object car pane)))))))) + (defun inspect-cons-as-list (object pane) "Inspect a cons cell in a traditional, plain-text format. The only difference between this and simply using the Lisp printer is that this code takes advantage of CLIM's tables and presentations to make the list as interactive as you would expect." (with-output-as-presentation - (pane object 'cons) + (pane object 'cons) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) @@ -334,7 +371,8 @@ (pane method (presentation-type-of method)) (formatting-row (pane) (formatting-cell (pane) - (print (method-qualifiers method))) + (with-text-family (pane :fix) + (print (clim-mop:method-qualifiers method) pane))) (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) (if (typep specializer 'clim-mop:eql-specializer) @@ -369,19 +407,29 @@ ;; please add code for it and send patches. #-sbcl (generic-print fun))) +;; This is ugly. I think CLIM requires there to be a presentation type +;; for every class, so we should use FUNCTION---but I'm not sure how +;; well that will work. +(define-presentation-type inspected-function () + :inherit-from t) + (defmethod inspect-object ((object function) pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'inspected-function) (with-heading-style (pane) (princ "Function: " pane)) - (princ (pretty-print-function object) pane) + (with-text-family (pane :fix) + (princ (pretty-print-function object) pane)) #+sbcl (unless (typep object 'generic-function) (with-heading-style (pane) (format pane "~&Type: ")) - (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) - pane)) - (print-documentation object pane))) + (with-text-family (pane :fix) + (princ (sb-kernel:%simple-fun-type (sb-kernel:%closure-fun object)) + pane))) + (print-documentation object pane) + (when (gethash object (disassembly-dico *application-frame*)) + (display-disassembly object pane)))) (defmethod inspect-object-briefly ((object package) pane) ;; Display as 'Package: "PACKAGE-NAME"'. We're doing something a @@ -389,7 +437,9 @@ ;; be a tad inconsistent, but the other way looks very odd. (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "Package: ~S" (package-name object)))) + (princ "Package: " pane) + (with-text-family (pane :fix) + (princ (package-name object) pane)))) (defmethod inspect-object ((object package) pane) (inspector-table @@ -399,22 +449,13 @@ (inspect-object (package-name object) pane)) (inspector-table-row (princ "Nicknames:" pane) - (dolist (nick (package-nicknames object)) - (inspect-object nick pane))) + (inspect-vertical-list (package-nicknames object) 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)) - (fresh-line pane) - (inspect-object used-by pane))) + (inspect-vertical-list (package-used-by-list object) pane)) (inspector-table-row (princ "Uses:") - (dolist (uses (package-use-list object)) - (fresh-line pane) - (inspect-object uses pane))))) + (inspect-vertical-list (package-use-list object) pane)))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation @@ -483,7 +524,8 @@ (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (prin1 object))) + (with-text-family (pane :fix) + (prin1 object)))) (defmethod inspect-object ((object symbol) pane) (inspector-table @@ -624,3 +666,17 @@ (with-heading-style (stream) (format stream "~&Writers: ")) (present writers (presentation-type-of writers) :stream stream)))))) + +(define-inspector-command (com-disassemble :name t) + ((obj 'inspected-function + :menu "Disassemble" + :prompt "Select a function")) + (when (typep obj 'function) + (togglef (gethash obj (disassembly-dico *application-frame*))))) + +(define-presentation-to-command-translator disassemble-function + (inspected-function com-disassemble inspector + :documentation "Toggle Disassembly" + :menu t) + (object) + (list object)) \ No newline at end of file From pscott at common-lisp.net Mon Mar 7 20:47:09 2005 From: pscott at common-lisp.net (Peter Scott) Date: Mon, 7 Mar 2005 21:47:09 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd Message-ID: <20050307204709.343578866D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv20244 Modified Files: clouseau.asd Log Message: Added disassembly.lisp Date: Mon Mar 7 21:47:09 2005 Author: pscott Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.3 mcclim/Apps/Inspector/clouseau.asd:1.4 --- mcclim/Apps/Inspector/clouseau.asd:1.3 Fri Feb 4 23:37:21 2005 +++ mcclim/Apps/Inspector/clouseau.asd Mon Mar 7 21:47:09 2005 @@ -27,7 +27,8 @@ #:inspect-object-briefly #:define-inspector-command)) -(asdf::defsystem clouseau +(asdf:defsystem clouseau :serial t :components - ((:file "inspector"))) + ((:file "disassembly") + (:file "inspector"))) \ No newline at end of file From tmoore at common-lisp.net Tue Mar 8 10:46:20 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Tue, 8 Mar 2005 11:46:20 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp Message-ID: <20050308104620.C402588669@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv1782 Modified Files: incremental-redisplay.lisp Log Message: Added a slot in updating output records for the bounding box of the old children, which is set at the beginning of redisplay. The bounding rectangle of the old children may become invalid if the positions of display records are setf'ed explicitly e.g., by table layout. Use this saved bounding rectangle in compute-difference-set. Date: Tue Mar 8 11:46:17 2005 Author: tmoore Index: mcclim/incremental-redisplay.lisp diff -u mcclim/incremental-redisplay.lisp:1.45 mcclim/incremental-redisplay.lisp:1.46 --- mcclim/incremental-redisplay.lisp:1.45 Tue Feb 22 15:00:10 2005 +++ mcclim/incremental-redisplay.lisp Tue Mar 8 11:46:16 2005 @@ -134,6 +134,15 @@ (explode-map-hash map) (setf (tester-function map) :mismatch))) +(defgeneric clear-map (map)) + +(defmethod clear-map ((map updating-output-map-mixin)) + (setf (id-map map) nil) + (setf (id-counter map) 0) + (setf (element-count map) 0)) + +;;; Perhaps these should be generic functions, but in the name of premature +;;; optimization they're not :) (defun get-from-map (map value test) (when (eq (tester-function map) 'none) (return-from get-from-map nil)) @@ -203,6 +212,9 @@ (when deleted (decf (element-count map))))) +;;; Reset the ID counter so that updating output records without explicit IDs +;;; can be assigned one during a run of the code. I'm not sure about using +;;; reinitialize-instance for this... (defmethod shared-initialize :after ((obj updating-output-map-mixin) slot-names &key) (declare (ignore slot-names)) @@ -236,6 +248,11 @@ (or (not (pane-incremental-redisplay pane)) (not *enable-updating-output*)))))) +(defmethod window-clear :after ((pane updating-output-stream-mixin)) + "Get rid of any updating output records stored in the stream; they're gone + from the screen." + (clear-map pane)) + ;;; INCREMENTAL-DISPLAY takes as input the difference set computed by ;;; COMPUTE-DIFFERENCE-SET and updates the screen. The 5 kinds of updates are ;;; not very well defined in the spec. I understand their semantics thus: @@ -385,6 +402,10 @@ updating-output-parent above this one in the tree.") ;; Results of (setf output-record-position) while updating (explicit-moves :accessor explicit-moves) + (old-bounds :accessor old-bounds + :initform (make-bounding-rectangle 0.0d0 0.0d0 0.0d0 0.0d0) + :documentation "Holds the old bounds of an updating output + record if that can no longer be determined from the old-children.") ;; on-screen state? )) @@ -502,11 +523,14 @@ (defmethod compute-new-output-records ((record standard-updating-output-record) stream) (with-output-recording-options (stream :record t :draw nil) - (map-over-updating-output #'(lambda (r) - (setf (old-children r) (sub-record r)) - (setf (output-record-dirty r) :updating)) - record - nil) + (map-over-updating-output + #'(lambda (r) + (setf (old-children r) (sub-record r)) + (setf (output-record-dirty r) :updating) + (setf (rectangle-edges* (old-bounds r)) + (rectangle-edges* (sub-record r)))) + record + nil) (finish-output stream) ;; Why is this binding here? We need the "environment" in this call that ;; computes the new records of an outer updating output record to resemble @@ -543,45 +567,6 @@ &rest initargs &key unique-id unique-id-test)) -(defgeneric find-equal-display-record (root use-old-elements record)) - -(defmethod find-equal-display-record ((root standard-updating-output-record) - use-old-elements - record) - (cond ((eq (output-record-dirty root) :clean) - nil) - (use-old-elements - (when (slot-boundp root 'old-children) - (find-equal-display-record (old-children root) - use-old-elements - record))) - (t (find-equal-display-record (sub-record root) - use-old-elements - record)))) - -(defmethod find-equal-display-record ((root compound-output-record) - use-old-elements - record) - (when (region-intersects-region-p root record) - (flet ((mapper (r) - (let ((result (find-equal-display-record r - use-old-elements - record))) - (when result - (return-from find-equal-display-record result))))) - (declare (dynamic-extent #'mapper)) - (map-over-output-records-overlapping-region #'mapper root record))) - nil) - - -(defmethod find-equal-display-record ((root displayed-output-record) - use-old-elements - record) - (declare (ignore use-old-elements)) - (if (output-record-equal root record) - root - nil)) - (defgeneric map-over-displayed-output-records (function root use-old-elements clean clip-region) (:documentation "Call function on all displayed-output-records in ROOT's @@ -771,11 +756,12 @@ (visible-region (pane-viewport-region stream)) (old-children (if (slot-boundp record 'old-children) (old-children record) - nil))) + nil)) + (old-bounds (old-bounds record))) (unless (or (null visible-region) (region-intersects-region-p visible-region record) (and old-children - (region-intersects-region-p visible-region old-children))) + (region-intersects-region-p visible-region old-bounds))) (return-from compute-difference-set (values nil nil nil nil nil))) ;; XXX This means that compute-difference-set can't be called repeatedly on ;; the same tree; ugh. On the other hand, if we don't clear explicit-moves, From pscott at common-lisp.net Tue Mar 8 22:11:35 2005 From: pscott at common-lisp.net (Peter Scott) Date: Tue, 8 Mar 2005 23:11:35 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050308221135.326748866C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv8325 Modified Files: inspector.lisp Log Message: Now you can trace and untrace fbound symbols. Date: Tue Mar 8 23:11:30 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.25 mcclim/Apps/Inspector/inspector.lisp:1.26 --- mcclim/Apps/Inspector/inspector.lisp:1.25 Mon Mar 7 21:46:43 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Mar 8 23:11:28 2005 @@ -669,7 +669,6 @@ (define-inspector-command (com-disassemble :name t) ((obj 'inspected-function - :menu "Disassemble" :prompt "Select a function")) (when (typep obj 'function) (togglef (gethash obj (disassembly-dico *application-frame*))))) @@ -677,6 +676,45 @@ (define-presentation-to-command-translator disassemble-function (inspected-function com-disassemble inspector :documentation "Toggle Disassembly" + :gesture :menu :menu t) + (object) + (list object)) + +(defun tracedp (symbol) + "Is SYMBOL currently traced?" + (member symbol (trace))) + +(define-inspector-command (com-trace :name t) + ((obj 'symbol + :prompt "Select an fbound symbol")) + (when (fboundp obj) + (eval `(trace ,obj)))) + +(define-inspector-command (com-untrace :name t) + ((obj 'symbol + :prompt "Select an fbound symbol")) + (when (fboundp obj) + (eval `(untrace ,obj)))) + +(define-presentation-to-command-translator trace-symbol + (symbol com-trace inspector + :documentation "Trace" + :gesture :menu + :menu t + :tester ((object) (and object + (fboundp object) + (not (tracedp object))))) + (object) + (list object)) + +(define-presentation-to-command-translator untrace-symbol + (symbol com-untrace inspector + :documentation "Untrace" + :gesture :menu + :menu t + :tester ((object) (and object + (fboundp object) + (tracedp object)))) (object) (list object)) From pscott at common-lisp.net Wed Mar 9 21:05:04 2005 From: pscott at common-lisp.net (Peter Scott) Date: Wed, 9 Mar 2005 22:05:04 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050309210504.D458288665@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21238 Modified Files: inspector.lisp Log Message: It seemed unforgivably messy for INSPECTOR-TABLE and INSPECTOR-TABLE-ROW to capture OBJECT and PANE from the surrounding environment, and it also made the code look a little odd. So, I added some new options to both which let you specify values for those things. I then went through the rest of the code and changed it to give the new options. As a note to emacs users, you may want to put this in your .emacs file to get these macros to indent right: (put 'inspector-table 'lisp-indent-function 1) (put 'inspector-table-row 'lisp-indent-function 1) Date: Wed Mar 9 22:05:04 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.26 mcclim/Apps/Inspector/inspector.lisp:1.27 --- mcclim/Apps/Inspector/inspector.lisp:1.26 Tue Mar 8 23:11:28 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Mar 9 22:05:03 2005 @@ -136,35 +136,40 @@ could be boldface, or a different style, or even another font." `(with-text-face (,stream :bold) , at body)) - -(defmacro inspector-table (header &body body) - "Present OBJECT (captured from environment) in tabular form, with +;; FIXMEFIXME!!!!! +(defmacro inspector-table ((object pane) header &body body) + "Present OBJECT in tabular form on PANE, with HEADER printed in a box at the top. BODY should output the rows of the -table using INSPECTOR-TABLE-ROW. Also capured from the macro's -environment is PANE, which is the pane on which the table will be -drawn." - `(with-output-as-presentation - (pane object (presentation-type-of object)) - (formatting-table (pane) - (formatting-column (pane) - (formatting-cell (pane) - (surrounding-output-with-border (pane) - (with-heading-style (pane) - ,header))) - (formatting-cell (pane) - (formatting-table (pane) - , at body)))) - (print-documentation object pane))) - -(defmacro inspector-table-row (left right) - "Output a table row with two items, LEFT and RIGHT, in the -environment created by INSPECTOR-TABLE." - `(formatting-row (pane) - (formatting-cell (pane :align-x :right) - (with-heading-style (pane) - ,left)) - (formatting-cell (pane) - ,right))) +table using INSPECTOR-TABLE-ROW." + (let ((evaluated-pane (gensym "pane")) + (evaluated-object (gensym "object"))) + `(let ((,evaluated-pane ,pane) + (,evaluated-object ,object)) + (with-output-as-presentation + (pane ,evaluated-object + (presentation-type-of ,evaluated-object)) + (formatting-table (,evaluated-pane) + (formatting-column (,evaluated-pane) + (formatting-cell (,evaluated-pane) + (surrounding-output-with-border (,evaluated-pane) + (with-heading-style (,evaluated-pane) + ,header))) + (formatting-cell (,evaluated-pane) + (formatting-table (,evaluated-pane) + , at body)))) + (print-documentation ,evaluated-object ,evaluated-pane))))) + +(defmacro inspector-table-row ((pane) left right) + "Output a table row with two items, LEFT and RIGHT, on PANE. This +should be used only within INSPECTOR-TABLE." + (let ((evaluated-pane (gensym "pane"))) + `(let ((,evaluated-pane ,pane)) + (formatting-row (,evaluated-pane) + (formatting-cell (,evaluated-pane :align-x :right) + (with-heading-style (,evaluated-pane) + ,left)) + (formatting-cell (,evaluated-pane) + ,right))))) (defun print-documentation (object pane) "Print OBJECT's documentation, if any, to PANE" @@ -180,27 +185,27 @@ called by the INSPECT-OBJECT methods for both standard objects and structure objects." (let ((class (class-of object))) - (inspector-table - (print (class-name class) pane) - (when (clim-mop:class-direct-superclasses class) - (inspector-table-row - (princ "Superclasses" pane) - (inspect-vertical-list (clim-mop:class-direct-superclasses class) - pane))) - (when (clim-mop:class-direct-subclasses class) - (inspector-table-row - (princ "Subclasses" pane) - (inspect-vertical-list (clim-mop:class-direct-subclasses class) - pane))) - (loop for slot in (reverse (clim-mop:class-slots class)) - do (let ((slot-name (clim-mop:slot-definition-name slot))) - (inspector-table-row - (with-output-as-presentation - (pane (cons object slot-name) 'settable-slot) - (format pane "~a:" slot-name)) - (if (slot-boundp object slot-name) - (inspect-object (slot-value object slot-name) pane) - (format pane "#")))))))) + (inspector-table (object pane) + (print (class-name class) pane) + (when (clim-mop:class-direct-superclasses class) + (inspector-table-row (pane) + (princ "Superclasses" pane) + (inspect-vertical-list (clim-mop:class-direct-superclasses class) + pane))) + (when (clim-mop:class-direct-subclasses class) + (inspector-table-row (pane) + (princ "Subclasses" pane) + (inspect-vertical-list (clim-mop:class-direct-subclasses class) + pane))) + (loop for slot in (reverse (clim-mop:class-slots class)) + do (let ((slot-name (clim-mop:slot-definition-name slot))) + (inspector-table-row (pane) + (with-output-as-presentation + (pane (cons object slot-name) 'settable-slot) + (format pane "~a:" slot-name)) + (if (slot-boundp object slot-name) + (inspect-object (slot-value object slot-name) pane) + (format pane "#")))))))) ;; Try to print the normal, textual representation of an object, but ;; if that's too long, make an abbreviated "instance of ~S" version. @@ -352,8 +357,8 @@ (pane object (presentation-type-of object)) (princ 'hash-table pane))) (defmethod inspect-object ((object hash-table) pane) - (inspector-table - (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (inspector-table (object pane) + (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) (loop for key being the hash-keys of object do (formatting-row (pane) (formatting-cell (pane :align-x :right) @@ -363,9 +368,9 @@ (inspect-object (gethash key object) pane)))))) (defmethod inspect-object ((object generic-function) pane) - (inspector-table - (format pane "Generic Function: ~s" - (clim-mop:generic-function-name object)) + (inspector-table (object pane) + (format pane "Generic Function: ~s" + (clim-mop:generic-function-name object)) (dolist (method (clim-mop:generic-function-methods object)) (with-output-as-presentation (pane method (presentation-type-of method)) @@ -442,18 +447,18 @@ (princ (package-name object) pane)))) (defmethod inspect-object ((object package) pane) - (inspector-table + (inspector-table (object pane) (format pane "Package: ~S" (package-name object)) - (inspector-table-row + (inspector-table-row (pane) (princ "Name:" pane) (inspect-object (package-name object) pane)) - (inspector-table-row + (inspector-table-row (pane) (princ "Nicknames:" pane) (inspect-vertical-list (package-nicknames object) pane)) - (inspector-table-row + (inspector-table-row (pane) (princ "Used by:") (inspect-vertical-list (package-used-by-list object) pane)) - (inspector-table-row + (inspector-table-row (pane) (princ "Uses:") (inspect-vertical-list (package-use-list object) pane)))) @@ -504,22 +509,22 @@ (inspect-complex object pane)) (defmethod inspect-object ((object float) pane) - (inspector-table + (inspector-table (object pane) (format pane "float ~S" object) (multiple-value-bind (significand exponent sign) (decode-float object) - (inspector-table-row + (inspector-table-row (pane) (princ "sign:") (inspect-object sign pane)) - (inspector-table-row + (inspector-table-row (pane) (princ "significand:") (inspect-object significand pane)) - (inspector-table-row + (inspector-table-row (pane) (princ "exponent:") (inspect-object exponent pane))) - (inspector-table-row - (princ "radix:") - (inspect-object (float-radix object) pane)))) + (inspector-table-row (pane) + (princ "radix:") + (inspect-object (float-radix object) pane)))) (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation @@ -528,33 +533,33 @@ (prin1 object)))) (defmethod inspect-object ((object symbol) pane) - (inspector-table + (inspector-table (object pane) (format pane "Symbol ~S" (symbol-name object)) - (inspector-table-row - (princ "value:") - (if (boundp object) - (inspect-object (symbol-value object) pane) - (princ "unbound"))) - (inspector-table-row - (princ "function:") - (if (fboundp object) - (inspect-object (symbol-function object) pane) - (princ "unbound"))) + (inspector-table-row (pane) + (princ "value:") + (if (boundp object) + (inspect-object (symbol-value object) pane) + (princ "unbound"))) + (inspector-table-row (pane) + (princ "function:") + (if (fboundp object) + (inspect-object (symbol-function object) pane) + (princ "unbound"))) ;; This is not, strictly speaking, a property of the ;; symbol. However, this is useful enough that I think it's worth ;; including here, since it can eliminate some minor annoyances. - (inspector-table-row - (princ "class:") - (if (find-class object nil) - (inspect-object (find-class object) pane) - (princ "unbound"))) - (inspector-table-row - (princ "package:") - (inspect-object (symbol-package object) pane)) - (inspector-table-row - (princ "propery list:") - (dolist (property (symbol-plist object)) - (inspect-object property pane))))) + (inspector-table-row (pane) + (princ "class:") + (if (find-class object nil) + (inspect-object (find-class object) pane) + (princ "unbound"))) + (inspector-table-row (pane) + (princ "package:") + (inspect-object (symbol-package object) pane)) + (inspector-table-row (pane) + (princ "propery list:") + (dolist (property (symbol-plist object)) + (inspect-object property pane))))) ;; Characters are so short that displaying them as "..." takes almost ;; as much space as just showing them, and this way is more @@ -564,17 +569,17 @@ (pane object (presentation-type-of object)) (print object pane))) (defmethod inspect-object ((object character) pane) - (inspector-table + (inspector-table (object pane) (format pane "Character ~S" object) - (inspector-table-row - (princ "code:" pane) - (inspect-object (char-code object) pane)) - (inspector-table-row - (princ "int:" pane) - (inspect-object (char-int object) pane)) - (inspector-table-row - (princ "name:" pane) - (inspect-object (char-name object) pane)))) + (inspector-table-row (pane) + (princ "code:" pane) + (inspect-object (char-code object) pane)) + (inspector-table-row (pane) + (princ "int:" pane) + (inspect-object (char-int object) pane)) + (inspector-table-row (pane) + (princ "name:" pane) + (inspect-object (char-name object) pane)))) (defun display-app (frame pane) "Display the APP frame of the inspector" From pscott at common-lisp.net Wed Mar 9 22:25:55 2005 From: pscott at common-lisp.net (Peter Scott) Date: Wed, 9 Mar 2005 23:25:55 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd Message-ID: <20050309222555.648DE88665@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv25365 Modified Files: clouseau.asd Log Message: Exported INSPECTOR-TABLE and INSPECTOR-TABLE-ROW symbols from :clouseau package. I think they should be available to users who want to extend the inspector in application-specific ways, so that changes in the standard inspector's look and feel for inspector tables will also affect extensions, maintaining consistency. It also saves quite a bit of work for extenders. Date: Wed Mar 9 23:25:54 2005 Author: pscott Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.4 mcclim/Apps/Inspector/clouseau.asd:1.5 --- mcclim/Apps/Inspector/clouseau.asd:1.4 Mon Mar 7 21:47:09 2005 +++ mcclim/Apps/Inspector/clouseau.asd Wed Mar 9 23:25:54 2005 @@ -25,7 +25,9 @@ (:export #:inspector #:inspect-object #:inspect-object-briefly - #:define-inspector-command)) + #:define-inspector-command + #:inspector-table + #:inspector-table-row)) (asdf:defsystem clouseau :serial t From pscott at common-lisp.net Thu Mar 10 22:45:56 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 10 Mar 2005 23:45:56 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Doc/manual.tex Message-ID: <20050310224556.026B088663@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv10401 Modified Files: manual.tex Log Message: Added new part, "Utility Programs", which covers things like the Listener and Clouseau. The listener chapter is blank, but the Clouseau chapter contains information on how to get started, some tips, and a tutorial on how to extend it. Date: Thu Mar 10 23:45:56 2005 Author: pscott Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.23 mcclim/Doc/manual.tex:1.24 --- mcclim/Doc/manual.tex:1.23 Tue Dec 28 10:17:07 2004 +++ mcclim/Doc/manual.tex Thu Mar 10 23:45:55 2005 @@ -1488,6 +1488,366 @@ Loads a description of a font from the specified AFM file. +\part{Utility Programs} + +\chapter{Listener} + +\chapter{Inspector: Clouseau} + +The inspector, called ``Clouseau'', is used for interactively +inspecting objects. It lets you look inside objects, inspect slots, +disassemble and trace functions, view keys and values in hash tables, +and quite a few other things as well. It can be extended to aid in +debugging of specific programs, similar to the way the Lisp printer +can be extended with \genfun{print-object}. + +\section{Usage} + +\subsection{Quick Start} + +To get up and running quickly with Clouseau: + +\begin{enumerate} +\item With ASDF and McCLIM loaded, load the file + + \texttt{mcclim/Apps/Inspector/inspector.asd}. +\item Load Clouseau with: + +\texttt{(asdf:operate 'asdf:load-op :clouseau)} +\item Inspect an object with \texttt{(clouseau:inspector + \textit{object})}. If you use a multithreaded Lisp implementation, + you can also include the \cl{:new-process} keyword argument. If it + is \cl{t}, then Clouseau is started in a seperate process. This + should be relatively safe; it is even possible to have an inspector + inspecting another running inspector. +\end{enumerate} + +\subsection{The Basics} + +Once you inspect something, you will see a full representation of the +object you are inspecting and short representations of objects +contained within it. This short representation may be something like +\cl{\#} or something as short as ``\dots''. +To see these objects inspected more fully, left-click on them and they +will be expanded. To shrink expanded objects, left-click on them again +and they will go back to a brief form. + +That's really all you need to know to get started. The best way to +learn how to use Clouseau is to start inspecting your own objects. + +\subsection{Handling of Specific Data Types} + +Clouseau can handle numerous data types in different ways. Here are +some handy features you might miss if you don't know to look for them: + +\subsubsection{Standard Objects} + +Standard objects have their slots shown, and by left-clicking on the +name of a slot you can change the slot's value. You can see various +slot attributes by middle clicking on a slot name. + +\subsubsection{Structures} + +Structures are inspected the same way as standard objects. + +\subsubsection{Generic Functions} + +You can remove methods from generic functions with the \texttt{Remove +Method} command. + +\subsubsection{Functions} + +You can disassemble functions with the \texttt{Toggle Disassembly} +command. If the disassembly is already shown, this command hides it. + +\subsubsection{Symbols} + +If a symbol is fbound, you can use the \texttt{Trace} and +\texttt{Untrace} commands to trace and untrace the function bound to +it. + +\subsubsection{Lists and Conses} + +Lists and conses can be displayed in either the classic format (such +as \texttt{(1 3 (4 . 6) "Hello" 42)}) or a more graphical cons-cell +diagram format. The default is the classic format, but this can be +toggled with the \texttt{Toggle Show List Cells} command. + +\section{Extending Clouseau} + +Sometimes Clouseau's built-in inspection abilities aren't enough, and +you want to be able to extend it to inspect one of your own classes in +a special way. Clouseau supports this, and it's fairly simple and +straightforward. + +Suppose that you're writing a statistics program and you want to +specialize the inspector for your application. When you're looking at +a sample of some characteristic of a population, you want to be able +to inspect it and see some statistics about it, like the average. This +is easy to do. + +We define a class for a statistical sample. We're keeping this very +basic, so it'll just contain a list of numbers: + +\begin{alltt} +(in-package :clim-user) +(use-package :clouseau) + +(defclass sample () + ((data :initarg :data + :accessor data + :type list :initform '())) + (:documentation "A statistical sample")) + +(defgeneric sample-size (sample) + (:documentation "Return the size of a statistical sample")) + +(defmethod sample-size ((sample sample)) + (length (data sample))) +\end{alltt} + +The \genfun{print-object} function we define will print samples +unreadably, just showing their sample size. For example, a sample with +nine numbers will print as \texttt{\#} We create such a +sample and call it \cl{*my-sample*}. + +\begin{alltt} +(defmethod print-object ((object sample) stream) + (print-unreadable-object (object stream :type t) + (format stream "n=~D" (sample-size object)))) + +(defparameter *my-sample* + (make-instance 'sample + :data '(12.8 3.7 14.9 15.2 13.66 + 8.97 9.81 7.0 23.092))) +\end{alltt} + +We need some basic statistics functions. First, we'll do sum: + +\begin{alltt} +(defgeneric sum (sample) + (:documentation "The sum of all numbers in a statistical +sample")) + +(defmethod sum ((sample sample)) + (reduce #'+ (data sample))) +\end{alltt} + +Next, we want to be able to compute the mean. This is just the +standard average that everyone learns: add up all the numbers and +divide by how many of them there are. It's written $\overline{x}$. + +\begin{alltt} +(defgeneric mean (sample) + (:documentation "The mean of the numbers in a statistical +sample")) + +(defmethod mean ((sample sample)) + (/ (sum sample) + (sample-size sample))) +\end{alltt} + +Finally, to be really fancy, we'll throw in a function to compute the +standard deviation. You don't need to understand this, but the +standard deviation is a measurement of how spread out or bunched +together the numbers in the sample are. It's written as $\sigma$, and +it's computed like this: + +$$ \sigma = \sqrt{\frac{1}{N} \sum_{i=1}^N (x_i - \overline{x})^2} $$ + +\begin{alltt} +(defgeneric standard-deviation (sample) + (:documentation "Find the standard deviation of the numbers in a +sample. This measures how spread out they are.")) + +(defmethod standard-deviation ((sample sample)) + (let ((mean (mean sample))) + (sqrt (/ (loop for x in (data sample) + sum (expt (- x mean) 2)) + (sample-size sample))))) +\end{alltt} + +This is all very nice, but when we inspect \cl{*my-sample*} all we see +is a distinctly inconvenient display of the class, its superclass, and +its single slot, which we actually need to \emph{click on} to see. In +other words, there's a lot of potential being missed here. How do we +take advantage of it? + +We can define our own inspection functions. To do this, we have two +methods that we can define. To change how sample objects are inspected +compactly, before they are clicked on, we can define an +\genfun{inspect-object-briefly} method for our \cl{sample} class. To +change the full, detailed inspection of samples, we define +\genfun{inspect-object} for the class. Both of these methods take two +arguments: the object to inspect and a CLIM output stream. They are +expected to print a representation of the object to the stream. + +Because we defined \genfun{print-object} for the \cl{sample} class to +be as informative as we want the simple representation to be, we don't +need to define a special \genfun{inspect-object-briefly} method. We +should, however, define \genfun{inspect-object}. + +\begin{alltt} +(defmethod inspect-object ((object sample) pane) + (inspector-table (object pane) + ;; This is the header + (format pane "SAMPLE n=~D" (sample-size object)) + ;; Now the body + (inspector-table-row (pane) + (princ "mean" pane) + (princ (mean object) pane)) + (inspector-table-row (pane) + (princ "std. dev." pane) + (princ (standard-deviation object) pane)))) +\end{alltt} + +Here, we introduce two new macros. \macro{inspector-table} sets up a +box in which we can display our representation of the sample. It +handles quite a bit of CLIM work for us. When possible, you should use +it instead of making your own, since using the standard facilities +helps ensure consistency. + +The second macro, \macro{inspector-table-row}, creates a row with the +output of one form bolded on the left and the output of the other on +the right. This gives us a reasonable output; try it yourself and see. + +% FIXME: SCREENSHOT, and remove ``;try it yourself...'' + +But what we really want is something more closely adapted to our +needs. It would be nice if we could just have a table of things like +$ \overline{x} = 12.125776 $ and have them come out formatted +nicely. Before we attempt mathematical symbols, let's focus on getting +the basic layout right. For this, we can use CLIM's table formatting. + +\begin{alltt} +(defmethod inspect-object ((object sample) pane) + (flet ((x=y (x y) + (formatting-row (pane) + (formatting-cell (pane :align-x :right) + (princ x pane)) + (formatting-cell (pane) (princ "=" pane)) + (formatting-cell (pane) + (inspect-object y pane))))) + (inspector-table (object pane) + ;; This is the header + (format pane "SAMPLE n=~D" (sample-size object)) + ;; Now the body + (x=y "mean" (mean object)) + (x=y "std. dev." (standard-deviation object))))) +\end{alltt} + +In this version, we define a local function \cl{x=y} which outputs a +row showing something in the form ``label = value''. If you look +closely, you'll notice that we print the label with \cl{princ} but we +print the value with \genfun{inspect-object}. This makes the value +inspectable, as it should be. + +Then, in the \macro{inspector-table} body, we insert a couple of calls +to \cl{x=y} and we're done. Have a look and see. %It looks like this: + +% FIXME: SCREENSHOT + +Finally, for our amusement and further practice, we'll try to get some +mathematical symbols. We could get $\sigma$ most easily by using a +Lisp that supports Unicode, but we'll just use the letter S instead. + +\begin{alltt} +(defun xbar (stream) + "Draw an x with a bar over it" + (with-room-for-graphics (stream) + (with-text-face (stream :italic) + (princ \#\textbackslash{}x stream) + (draw-line* stream 0 0 + (text-style-width *default-text-style* + stream) 0)))) + +(defmethod inspect-object ((object sample) pane) + (flet ((x=y (x y) + (formatting-row (pane) + (formatting-cell (pane :align-x :right) + ;; Call functions, print everything else in italic + (if (functionp x) + (funcall x pane) + (with-text-face (pane :italic) + (princ x pane)))) + (formatting-cell (pane) (princ "=" pane)) + (formatting-cell (pane) + (inspect-object y pane))))) + (inspector-table (object pane) + ;; This is the header + (format pane "SAMPLE n=~D" (sample-size object)) + ;; Now the body + (x=y \#'xbar (mean object)) + (x=y \#\textbackslash{}S (standard-deviation object))))) +\end{alltt} + +Finally, to illustrate the proper use of +\genfun{inspect-object-briefly}, suppose that we want the "n=9" (or +whatever the sample size $n$ equals) part to have an itlicised $n$. We +can fix this easily: + +\begin{alltt} +(defmethod inspect-object-briefly ((object sample) pane) + (with-output-as-presentation (pane object 'sample) + (with-text-family (pane :fix) + (print-unreadable-object (object pane :type t) + (with-text-family (pane :serif) + (with-text-face (pane :italic) + (princ "n" pane))) + (format pane "=~D" (sample-size object)))))) +\end{alltt} + +Notice that the body of \genfun{inspect-object-briefly} just prints a +representation to a stream, like \genfun{inspect-object} but shorter. +It should wrap its output in \macro{with-output-as-presentation}. +\genfun{inspect-object} does this too, but it's hidden in the +\macro{inspector-table} macro. + +For more examples of how to extend the inspector, you can look at +\texttt{inspector.lisp}. + +\section{API} + +The following symbols are exported from the \cl{clouseau} package: + +\defun {inspector} {object \key new-process} + +Inspect \cl{object}. If \cl{new-process} is \cl{t}, Clouseau will be +run in a new process. + +\defgeneric {inspect-object} {object pane} + +Display inspected representation of \cl{object} to the extended output +stream \cl{pane}. This requires that \cl{*application-frame*} be bound +to an inspector application frame, so it isn't safe to use in other +applications. + +\defgeneric {inspect-object-briefly} {object pane} + +A brief version of \genfun{inspect-object}. The output should be +short, and should try to fit on one line. + +\defgeneric {define-inspector-command} {name args \rest body} + +This is just an inspector-specific version of +\genfun{define-command}. If you want to define an inspector command +for some reason, use this. + +\defmacro {inspector-table} {(object pane) header \body body} + +Present \cl{object} in tabular form on \cl{pane}, with \cl{header} +evaluated to print a label in a box at the top. \cl{body} should +output the rows of the table, possibly using \cl{inspector-table-row}. + +\defmacro {inspector-table-row} {(pane) left right} + +Output a table row with two items, produced by evaluating \cl{left} +and \cl{right}, on \cl{pane}. This should be used only within +\cl{inspector-table}. + +When possible, you should try to use this and \cl{inspector-table} for +consistency, and because they handle quite a bit of effort for you. + \part{Auxiliary Material} \chapter{Glossary} From pscott at common-lisp.net Thu Mar 10 23:00:59 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 11 Mar 2005 00:00:59 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050310230059.5313988694@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv10943 Modified Files: inspector.lisp Log Message: Made minor changes to a few docstrings and removed a "FIXMEFIXME" comment that got left in by mistake. Date: Fri Mar 11 00:00:54 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.27 mcclim/Apps/Inspector/inspector.lisp:1.28 --- mcclim/Apps/Inspector/inspector.lisp:1.27 Wed Mar 9 22:05:03 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Mar 11 00:00:52 2005 @@ -136,11 +136,11 @@ could be boldface, or a different style, or even another font." `(with-text-face (,stream :bold) , at body)) -;; FIXMEFIXME!!!!! + (defmacro inspector-table ((object pane) header &body body) - "Present OBJECT in tabular form on PANE, with -HEADER printed in a box at the top. BODY should output the rows of the -table using INSPECTOR-TABLE-ROW." + "Present OBJECT in tabular form on PANE, with HEADER evaluated to +print a label in a box at the top. BODY should output the rows of the +table, possibly using INSPECTOR-TABLE-ROW." (let ((evaluated-pane (gensym "pane")) (evaluated-object (gensym "object"))) `(let ((,evaluated-pane ,pane) @@ -160,8 +160,8 @@ (print-documentation ,evaluated-object ,evaluated-pane))))) (defmacro inspector-table-row ((pane) left right) - "Output a table row with two items, LEFT and RIGHT, on PANE. This -should be used only within INSPECTOR-TABLE." + "Output a table row with two items, produced by evaluating LEFT and +RIGHT, on PANE. This should be used only within INSPECTOR-TABLE." (let ((evaluated-pane (gensym "pane"))) `(let ((,evaluated-pane ,pane)) (formatting-row (,evaluated-pane) From pscott at common-lisp.net Fri Mar 11 19:54:13 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 11 Mar 2005 20:54:13 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Doc/manual.tex Message-ID: <20050311195413.4513D88665@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv16979 Modified Files: manual.tex Log Message: Fixed minor issues of mathematical accuracy in my statistics example. I was mixing sample statistics and population statistics, and while this wasn't a major problem, it is a little embarassing. As a bonus, the material is now slightly easier to understand! Date: Fri Mar 11 20:54:09 2005 Author: pscott Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.24 mcclim/Doc/manual.tex:1.25 --- mcclim/Doc/manual.tex:1.24 Thu Mar 10 23:45:55 2005 +++ mcclim/Doc/manual.tex Fri Mar 11 20:54:07 2005 @@ -1650,10 +1650,10 @@ Finally, to be really fancy, we'll throw in a function to compute the standard deviation. You don't need to understand this, but the standard deviation is a measurement of how spread out or bunched -together the numbers in the sample are. It's written as $\sigma$, and +together the numbers in the sample are. It's called $s$, and it's computed like this: -$$ \sigma = \sqrt{\frac{1}{N} \sum_{i=1}^N (x_i - \overline{x})^2} $$ +$$ s = \sqrt{\frac{1}{N-1} \sum_{i=1}^N (x_i - \overline{x})^2} $$ \begin{alltt} (defgeneric standard-deviation (sample) @@ -1664,7 +1664,7 @@ (let ((mean (mean sample))) (sqrt (/ (loop for x in (data sample) sum (expt (- x mean) 2)) - (sample-size sample))))) + (1- (sample-size sample)))))) \end{alltt} This is all very nice, but when we inspect \cl{*my-sample*} all we see @@ -1748,8 +1748,8 @@ % FIXME: SCREENSHOT Finally, for our amusement and further practice, we'll try to get some -mathematical symbols. We could get $\sigma$ most easily by using a -Lisp that supports Unicode, but we'll just use the letter S instead. +mathematical symbols---in this case we'll just need $\overline{x}$. We +can get this by printing an italic $x$ and drawing a line over it: \begin{alltt} (defun xbar (stream) From pscott at common-lisp.net Fri Mar 11 21:25:30 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 11 Mar 2005 22:25:30 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/test.lisp Message-ID: <20050311212530.C5FF688665@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv21985 Added Files: test.lisp Log Message: Made inspection of STANDARD-CLASS and BUILT-IN-CLASS instances non-annoying. Specifically, I factored out a bunch of class inspection code and wrote a special version which displays all lists vertically. This really is an improvement. The downside is that I haven't figured out how to undisplay them once expanded yet. This patch is still better than nothing, though. Date: Fri Mar 11 22:25:29 2005 Author: pscott From pscott at common-lisp.net Fri Mar 11 22:35:02 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 11 Mar 2005 23:35:02 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Doc/inspect-object-1.eps mcclim/Doc/inspect-object-2.eps mcclim/Doc/inspect-object-3.eps mcclim/Doc/inspect-as-cells.eps mcclim/Doc/manual.tex Message-ID: <20050311223502.8775F88665@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv26070 Modified Files: manual.tex Added Files: inspect-object-1.eps inspect-object-2.eps inspect-object-3.eps inspect-as-cells.eps Log Message: Added several new figures to the manual Date: Fri Mar 11 23:35:00 2005 Author: pscott Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.25 mcclim/Doc/manual.tex:1.26 --- mcclim/Doc/manual.tex:1.25 Fri Mar 11 20:54:07 2005 +++ mcclim/Doc/manual.tex Fri Mar 11 23:34:59 2005 @@ -1573,6 +1573,12 @@ diagram format. The default is the classic format, but this can be toggled with the \texttt{Toggle Show List Cells} command. +The new cons cell diagram format looks like this: + +\begin{center} +\includegraphics{inspect-as-cells.eps} +\end{center} + \section{Extending Clouseau} Sometimes Clouseau's built-in inspection abilities aren't enough, and @@ -1657,8 +1663,8 @@ \begin{alltt} (defgeneric standard-deviation (sample) - (:documentation "Find the standard deviation of the numbers in a -sample. This measures how spread out they are.")) + (:documentation "Find the standard deviation of the numbers +in a sample. This measures how spread out they are.")) (defmethod standard-deviation ((sample sample)) (let ((mean (mean sample))) @@ -1709,9 +1715,11 @@ The second macro, \macro{inspector-table-row}, creates a row with the output of one form bolded on the left and the output of the other on -the right. This gives us a reasonable output; try it yourself and see. +the right. This gives us some reasonably nice-looking output: -% FIXME: SCREENSHOT, and remove ``;try it yourself...'' +\begin{center} +\includegraphics{inspect-object-1.eps} +\end{center} But what we really want is something more closely adapted to our needs. It would be nice if we could just have a table of things like @@ -1743,9 +1751,11 @@ inspectable, as it should be. Then, in the \macro{inspector-table} body, we insert a couple of calls -to \cl{x=y} and we're done. Have a look and see. %It looks like this: +to \cl{x=y} and we're done. It looks like this: -% FIXME: SCREENSHOT +\begin{center} +\includegraphics{inspect-object-2.eps} +\end{center} Finally, for our amusement and further practice, we'll try to get some mathematical symbols---in this case we'll just need $\overline{x}$. We @@ -1782,7 +1792,7 @@ \end{alltt} Finally, to illustrate the proper use of -\genfun{inspect-object-briefly}, suppose that we want the "n=9" (or +\genfun{inspect-object-briefly}, suppose that we want the ``n=9'' (or whatever the sample size $n$ equals) part to have an itlicised $n$. We can fix this easily: @@ -1802,6 +1812,12 @@ It should wrap its output in \macro{with-output-as-presentation}. \genfun{inspect-object} does this too, but it's hidden in the \macro{inspector-table} macro. + +Our final version looks like this: + +\begin{center} +\includegraphics{inspect-object-3.eps} +\end{center} For more examples of how to extend the inspector, you can look at \texttt{inspector.lisp}. From tmoore at common-lisp.net Mon Mar 14 22:03:06 2005 From: tmoore at common-lisp.net (Timothy Moore) Date: Mon, 14 Mar 2005 23:03:06 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/panes.lisp mcclim/utils.lisp Message-ID: <20050314220306.BD6D288441@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv12867 Modified Files: panes.lisp utils.lisp Log Message: Start removing uses of the infamous dada macro. Date: Mon Mar 14 23:03:05 2005 Author: tmoore Index: mcclim/panes.lisp diff -u mcclim/panes.lisp:1.151 mcclim/panes.lisp:1.152 --- mcclim/panes.lisp:1.151 Tue Feb 22 08:02:18 2005 +++ mcclim/panes.lisp Mon Mar 14 23:03:05 2005 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.151 2005/02/22 07:02:18 ahefner Exp $ +;;; $Id: panes.lisp,v 1.152 2005/03/14 22:03:05 tmoore Exp $ (in-package :clim-internals) @@ -536,6 +536,66 @@ (defclass standard-space-requirement-options-mixin (space-requirement-options-mixin) ()) +(defun merge-one-option + (pane foo user-foo user-min-foo user-max-foo min-foo max-foo) + + + ;; NOTE: The defaulting for :min-foo and :max-foo is different from MAKE-SPACE-REQUIREMENT. + ;; MAKE-SPACE-REQUIREMENT has kind of &key foo (min-foo 0) (max-foo +fill+) + ;; While user space requirements has &key foo (min-foo foo) (max-foo foo). + ;; I as a user would pretty much expect the same behavior, therefore I'll take the + ;; following route: + ;; When the :foo option is given, I'll let MAKE-SPACE-REQUIREMENT decide. + ;; + ;; old code: + ;; + ;; ;; Then we resolve defaulting. sec 29.3.1 says: + ;; ;; | If either of the :max-width or :min-width options is not + ;; ;; | supplied, it defaults to the value of the :width option. If + ;; ;; | either of the :max-height or :min-height options is not + ;; ;; | supplied, it defaults to the value of the :height option. + ;; (setf user-max-foo (or user-max-foo user-foo) + ;; user-min-foo (or user-min-foo user-foo)) + ;; --GB 2003-01-23 + + (when (and (null user-max-foo) (not (null user-foo))) + (setf user-max-foo (space-requirement-max-width + (make-space-requirement + :width (spacing-value-to-device-units pane foo))))) + (when (and (null user-min-foo) (not (null user-foo))) + (setf user-min-foo (space-requirement-min-width + (make-space-requirement + :width (spacing-value-to-device-units pane foo))))) + + ;; when the user has no idea about the preferred size just take the + ;; panes preferred size. + (setf user-foo (or user-foo foo)) + (setf user-foo (spacing-value-to-device-units pane user-foo)) + + ;; dito for min/max + (setf user-min-foo (or user-min-foo min-foo) + user-max-foo (or user-max-foo max-foo)) + + ;; | :max-width, :min-width, :max-height, and :min-height can + ;; | also be specified as a relative size by supplying a list of + ;; | the form (number :relative). In this case, the number + ;; | indicates the number of device units that the pane is + ;; | willing to stretch or shrink. + (labels ((resolve-relative (dimension sign base) + (if (and (consp dimension) (eq (car dimension) :relative)) + (+ base (* sign (cadr dimension))) + (spacing-value-to-device-units pane dimension)))) + (setf user-min-foo (and user-min-foo + (resolve-relative user-min-foo -1 user-foo)) + user-max-foo (and user-max-foo + (resolve-relative user-max-foo +1 user-foo)))) + + ;; Now we have two space requirements which need to be 'merged'. + (setf min-foo (clamp user-min-foo min-foo max-foo) + max-foo (clamp user-max-foo min-foo max-foo) + foo (clamp user-foo min-foo max-foo)) + (values foo min-foo max-foo)) + (defmethod merge-user-specified-options ((pane space-requirement-options-mixin) sr) ;; ### I want proper error checking and in case there is an error we @@ -543,74 +603,30 @@ ;; garbage passed in here. (multiple-value-bind (width min-width max-width height min-height max-height) (space-requirement-components sr) - - (dada ((foo width height)) - (let ((user-foo (pane-user-foo pane)) - (user-min-foo (pane-user-min-foo pane)) - (user-max-foo (pane-user-max-foo pane))) - - '(format *trace-output* - "~&~S: ~S: [~S ~S ~S]" pane 'user-foo user-min-foo user-foo user-max-foo) - - ;; NOTE: The defaulting for :min-foo and :max-foo is different from MAKE-SPACE-REQUIREMENT. - ;; MAKE-SPACE-REQUIREMENT has kind of &key foo (min-foo 0) (max-foo +fill+) - ;; While user space requirements has &key foo (min-foo foo) (max-foo foo). - ;; I as a user would pretty much expect the same behavior, therefore I'll take the - ;; following route: - ;; When the :foo option is given, I'll let MAKE-SPACE-REQUIREMENT decide. - ;; - ;; old code: - ;; - ;; ;; Then we resolve defaulting. sec 29.3.1 says: - ;; ;; | If either of the :max-width or :min-width options is not - ;; ;; | supplied, it defaults to the value of the :width option. If - ;; ;; | either of the :max-height or :min-height options is not - ;; ;; | supplied, it defaults to the value of the :height option. - ;; (setf user-max-foo (or user-max-foo user-foo) - ;; user-min-foo (or user-min-foo user-foo)) - ;; --GB 2003-01-23 - - (when (and (null user-max-foo) (not (null user-foo))) - (setf user-max-foo (space-requirement-max-width - (make-space-requirement :width (spacing-value-to-device-units pane foo))))) - (when (and (null user-min-foo) (not (null user-foo))) - (setf user-min-foo (space-requirement-min-width - (make-space-requirement :width (spacing-value-to-device-units pane foo))))) - - ;; when the user has no idea about the preferred size just take the - ;; panes preferred size. - (setf user-foo (or user-foo foo)) - (setf user-foo (spacing-value-to-device-units pane user-foo)) - - ;; dito for min/max - (setf user-min-foo (or user-min-foo min-foo) - user-max-foo (or user-max-foo max-foo)) - - ;; | :max-width, :min-width, :max-height, and :min-height can - ;; | also be specified as a relative size by supplying a list of - ;; | the form (number :relative). In this case, the number - ;; | indicates the number of device units that the pane is - ;; | willing to stretch or shrink. - (labels ((resolve-relative (dimension sign base) - (if (and (consp dimension) (eq (car dimension) :relative)) - (+ base (* sign (cadr dimension))) - (spacing-value-to-device-units pane dimension)))) - (setf user-min-foo (and user-min-foo (resolve-relative user-min-foo -1 user-foo)) - user-max-foo (and user-max-foo (resolve-relative user-max-foo +1 user-foo)))) - - ;; Now we have two space requirements which need to be 'merged'. - (setf min-foo (clamp user-min-foo min-foo max-foo) - max-foo (clamp user-max-foo min-foo max-foo) - foo (clamp user-foo min-foo max-foo)))) - - ;; done! - (make-space-requirement - :width width - :min-width min-width - :max-width max-width - :height height - :min-height min-height - :max-height max-height) )) + (multiple-value-bind (new-width new-min-width new-max-width) + (merge-one-option pane + width + (pane-user-width pane) + (pane-user-min-width pane) + (pane-user-max-width pane) + min-width + max-width) + (multiple-value-bind (new-height new-min-height new-max-height) + (merge-one-option pane + height + (pane-user-height pane) + (pane-user-min-height pane) + (pane-user-max-height pane) + min-height + max-height) + (make-space-requirement + :width new-width + :min-width new-min-width + :max-width new-max-width + :height new-height + :min-height new-min-height + :max-height new-max-height))))) + (defmethod compose-space :around ((pane space-requirement-options-mixin) &key width height) @@ -1239,108 +1255,113 @@ ;;;; -(dada - ((major width height) - (minor height width) - (xbox hbox vbox) - (xrack hrack vrack) - (xically horizontally vertically) - (xical horizontal vertical) - (major-spacing x-spacing y-spacing) - (minor-spacing x-spacing y-spacing) ) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun make-box-macro-contents (contents) + (loop + for content in contents + collect (if (and (consp content) + (or (realp (car content)) + (member (car content) '(+fill+ :fill)))) + `(list ',(car content) ,(cadr content)) + content)))) + +(macrolet ((frob (macro-name box rack equalize-arg equalize-key) + (let ((equalize-key (make-keyword equalize-arg))) + `(defmacro ,macro-name ((&rest options + &key (,equalize-arg t) + &allow-other-keys) + &body contents) + (with-keywords-removed (options (,equalize-key)) + `(make-pane (if ,,equalize-arg + ',',rack + ',',box) + , at options + :contents (list ,@(make-box-macro-contents + contents)))))))) + (frob horizontally hbox-pane hrack-pane equalize-height :equalize-height) + (frob vertically vbox-pane vrack-pane equalize-width :equalize-width)) + +(defclass box-pane (box-layout-mixin + composite-pane + permanent-medium-sheet-output-mixin ;arg! + ) + () + (:documentation "Superclass for hbox-pane and vbox-pane that provides the + initialization common to both.")) + +(defmethod initialize-instance :after ((pane box-pane) &key contents) + (labels ((parse-box-content (content) + "Parses a box/rack content and returns a BOX-CLIENT instance." + ;; ### we need to parse more + (cond + ;; + ((panep content) + (make-instance 'box-client :pane content)) + ;; +fill+ + ((or (eql content +fill+) + (eql content '+fill+) + (eql content :fill)) + (make-instance 'box-client + :pane nil + :fillp t)) + ;; (+fill+ ) + ((and (consp content) + (or (member (car content) '(+fill+ :fill)) + (eql (car content) +fill+))) + (make-instance 'box-client + :pane (cadr content) + :fillp t)) + ;; + ;; + ;; what about something like (30 :mm) ? + ;; + ((and (realp content) (>= content 0)) + (make-instance 'box-client + :pane nil + :fixed-size content)) + + ;; ( pane) + ((and (consp content) + (realp (car content)) + (>= (car content) 0) + (consp (cdr content)) + (panep (cadr content)) + (null (cddr content))) + (let ((number (car content)) + (child (cadr content))) + (if (< number 1) + (make-instance 'box-client + :pane child + :proportion number) + (make-instance 'box-client + :pane child + :fixed-size number)))) + + (t + (error "~S is not a valid element in the ~S option of ~S." + content :contents pane)) ))) + + (let* ((clients (mapcar #'parse-box-content contents)) + (children (remove nil (mapcar #'box-client-pane clients)))) + ;; + (setf (box-layout-mixin-clients pane) clients) + (mapc (curry #'sheet-adopt-child pane) children)))) + +(defclass hbox-pane (box-pane) + () + (:default-initargs :box-layout-orientation :horizontal)) + +(defclass vbox-pane (box-pane) + () + (:default-initargs :box-layout-orientation :vertical)) - (defmacro xically ((&rest options - &key (equalize-minor t) - &allow-other-keys) - &body contents) - (remf options :equalize-minor) - `(make-pane ',(if equalize-minor - 'xrack-pane - 'xbox-pane) - , at options - :contents (list ,@(mapcar (lambda (content) - (cond ((and (consp content) - (or (realp (first content)) - (member (first content) '(+fill+ :fill)))) - `(list ',(first content) - ,(second content))) - (t - content))) - contents)))) - ; here is where they are created - (defclass xbox-pane (box-layout-mixin - composite-pane - permanent-medium-sheet-output-mixin ;arg! - ) +(defclass hrack-pane (rack-layout-mixin hbox-pane) () - (:documentation "") - (:default-initargs - :box-layout-orientation :xical)) - - (defmethod initialize-instance :after ((pane xbox-pane) &key contents &allow-other-keys) - ;; - (labels ((parse-box-content (content) - "Parses a box/rack content and returns a BOX-CLIENT instance." - ;; ### we need to parse more - (cond - ;; - ((panep content) - (make-instance 'box-client :pane content)) - ;; +fill+ - ((or (eql content +fill+) - (eql content '+fill+) - (eql content :fill)) - (make-instance 'box-client - :pane nil - :fillp t)) - ;; (+fill+ ) - ((and (consp content) - (or (member (car content) '(+fill+ :fill)) - (eql (car content) +fill+))) - (make-instance 'box-client - :pane (cadr content) - :fillp t)) - ;; - ;; - ;; what about something like (30 :mm) ? - ;; - ((and (realp content) (>= content 0)) - (make-instance 'box-client - :pane nil - :fixed-size content)) - - ;; ( pane) - ((and (consp content) - (realp (car content)) - (>= (car content) 0) - (consp (cdr content)) - (panep (cadr content)) - (null (cddr content))) - (let ((number (car content)) - (child (cadr content))) - (if (< number 1) - (make-instance 'box-client - :pane child - :proportion number) - (make-instance 'box-client - :pane child - :fixed-size number)))) - - (t - (error "~S is not a valid element in the ~S option of ~S." - content :contents pane)) ))) - - (let* ((clients (mapcar #'parse-box-content contents)) - (children (remove nil (mapcar #'box-client-pane clients)))) - ;; - (setf (box-layout-mixin-clients pane) clients) - (mapc (curry #'sheet-adopt-child pane) children)))) + (:default-initargs :box-layout-orientation :horizontal)) - (defclass xrack-pane (rack-layout-mixin xbox-pane) +(defclass vrack-pane (rack-layout-mixin vbox-pane) () - (:default-initargs - :box-layout-orientation :xical)) - ) + (:default-initargs :box-layout-orientation :vertical)) ;;; TABLE PANE Index: mcclim/utils.lisp diff -u mcclim/utils.lisp:1.40 mcclim/utils.lisp:1.41 --- mcclim/utils.lisp:1.40 Wed Feb 2 12:33:59 2005 +++ mcclim/utils.lisp Mon Mar 14 23:03:05 2005 @@ -585,3 +585,13 @@ and collect var into new-arg-list end finally (return (values bindings new-arg-list)))) + +(defun make-keyword (obj) + "Turn OBJ into a keyword" + (etypecase obj + (keyword + obj) + (symbol + (intern (symbol-name obj) :keyword)) + (string + (intern (string-upcase obj) :keyword)))) From pscott at common-lisp.net Thu Mar 17 22:49:53 2005 From: pscott at common-lisp.net (Peter Scott) Date: Thu, 17 Mar 2005 23:49:53 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050317224953.85C2688700@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv6161 Modified Files: inspector.lisp Log Message: Added detailed inspection of integers. The format and the idea were both blatantly stolen from the SLIME inspector. Also went through with my new and improved emacs indentation rules and improved the indentation. Here's what I have in my .emacs file, if you're interested: (put 'inspector-table 'lisp-indent-function 2) (put 'inspector-table-row 'lisp-indent-function 2) Date: Thu Mar 17 23:49:50 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.28 mcclim/Apps/Inspector/inspector.lisp:1.29 --- mcclim/Apps/Inspector/inspector.lisp:1.28 Fri Mar 11 00:00:52 2005 +++ mcclim/Apps/Inspector/inspector.lisp Thu Mar 17 23:49:49 2005 @@ -91,7 +91,7 @@ (cond ((member object *inspected-objects*) (with-output-as-presentation (pane object (presentation-type-of object)) - (princ "==="))) ; Prevent infinite loops + (princ "===" pane))) ; Prevent infinite loops ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) (t @@ -109,7 +109,7 @@ (defmethod inspect-object-briefly (object pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (princ "..."))) + (princ "..." pane))) (defmethod inspect-object (object pane) (with-output-as-presentation @@ -125,9 +125,9 @@ :inherit-from t) (define-presentation-method present (object (type settable-slot) - stream - (view textual-view) - &key acceptably for-context-type) + stream + (view textual-view) + &key acceptably for-context-type) (declare (ignore acceptably for-context-type)) (format stream "~s" (cdr object))) @@ -135,7 +135,7 @@ "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) - , at body)) + , at body)) (defmacro inspector-table ((object pane) header &body body) "Present OBJECT in tabular form on PANE, with HEADER evaluated to @@ -179,6 +179,41 @@ (format pane "~&Documentation: ")) (princ (documentation object t) pane))) +(defun display-class-superclasses (class pane) + "Display the superclasses of CLASS with an INSPECTOR-TABLE-ROW" + (when (clim-mop:class-direct-superclasses class) + (inspector-table-row (pane) + (princ "Superclasses" pane) + (inspect-vertical-list (clim-mop:class-direct-superclasses class) + pane)))) + +(defun display-class-subclasses (class pane) + "Display the subclasses of CLASS with an INSPECTOR-TABLE-ROW" + (when (clim-mop:class-direct-subclasses class) + (inspector-table-row (pane) + (princ "Subclasses" pane) + (inspect-vertical-list (clim-mop:class-direct-subclasses class) + pane)))) + +(defun display-object-slot (object slot pane &key display-lists-vertically) + "Display a slot of OBJECT onto PANE in the way normally used when +inspecting standard objects. SLOT must be a MOP SLOT-DEFINITION +object. If DISPLAY-LISTS-VERTICALLY is t and the slot value is a list, +it will be displayed with INSPECT-VERTICAL-LIST." + (let ((slot-name (clim-mop:slot-definition-name slot))) + (inspector-table-row (pane) + (with-output-as-presentation + (pane (cons object slot-name) 'settable-slot) + (format pane "~a:" slot-name)) + (if (slot-boundp object slot-name) + (let ((slot-value (slot-value object slot-name))) + (if (and display-lists-vertically + (listp slot-value)) + (inspect-vertical-list slot-value pane + :honor-dico t) + (inspect-object slot-value pane))) + (format pane "#"))))) + (defun inspect-structure-or-object (object pane) "Inspect a structure or an object. Since both can be inspected in roughly the same way, the common code is in this function, which is @@ -186,26 +221,26 @@ structure objects." (let ((class (class-of object))) (inspector-table (object pane) - (print (class-name class) pane) - (when (clim-mop:class-direct-superclasses class) - (inspector-table-row (pane) - (princ "Superclasses" pane) - (inspect-vertical-list (clim-mop:class-direct-superclasses class) - pane))) - (when (clim-mop:class-direct-subclasses class) - (inspector-table-row (pane) - (princ "Subclasses" pane) - (inspect-vertical-list (clim-mop:class-direct-subclasses class) - pane))) - (loop for slot in (reverse (clim-mop:class-slots class)) - do (let ((slot-name (clim-mop:slot-definition-name slot))) - (inspector-table-row (pane) - (with-output-as-presentation - (pane (cons object slot-name) 'settable-slot) - (format pane "~a:" slot-name)) - (if (slot-boundp object slot-name) - (inspect-object (slot-value object slot-name) pane) - (format pane "#")))))))) + (print (class-name class) pane) + ;; Display superclasses and subclasses + (display-class-superclasses class pane) + (display-class-subclasses class pane) + (dolist (slot (reverse (clim-mop:class-slots class))) + (display-object-slot object slot pane))))) + +(defun inspect-standard-class (object pane) + "Inspect a STANDARD-CLASS. This works almost the same way as +inspecting a standard object, but with a few differences. This should +also be used to inspect BUILD-IN-CLASSes." + (let ((class (class-of object))) + (inspector-table (object pane) + (print (class-name class) pane) + ;; Display superclasses and subclasses + (display-class-superclasses class pane) + (display-class-subclasses class pane) + (dolist (slot (reverse (clim-mop:class-slots class))) + (display-object-slot object slot pane + :display-lists-vertically t))))) ;; Try to print the normal, textual representation of an object, but ;; if that's too long, make an abbreviated "instance of ~S" version. @@ -242,6 +277,12 @@ (defmethod inspect-object ((object structure-object) pane) (inspect-structure-or-object object pane)) +(defmethod inspect-object ((object standard-class) pane) + (inspect-standard-class object pane)) + +(defmethod inspect-object ((object built-in-class) pane) + (inspect-standard-class object pane)) + (defmethod inspect-object ((object condition) pane) (inspect-structure-or-object object pane)) @@ -278,11 +319,12 @@ (formatting-cell (pane) (inspect-object (cdr object) pane)))))) -(defun inspect-vertical-list (object pane) +(defun inspect-vertical-list (object pane &key honor-dico) "Inspect a list without the parentheses, putting each element on a new line. This is useful for showing things like direct class subclasses, since displaying those as a plain list looks ugly and is -inconvenient to use." +inconvenient to use. If HONOR-DICO is t, this will respect DICO and +display '...' if OBJECT is not in DICO." ;; Ordinarily this would be taken care of in the :around method for ;; INSPECT-OBJECT, but since this is not a normal inspection view, ;; we need to do it ourselves. Yes, it would be better if we could @@ -290,28 +332,32 @@ (let ((*print-length* (or (gethash object (print-length *application-frame*)) *print-length*))) - (with-output-as-presentation - (pane object 'cons) - (formatting-table (pane) - (formatting-column (pane) - (do - ((length 0 (1+ length)) - (cdr (cdr object) (cdr cdr)) - (car (car object) (car cdr))) - ((cond ((eq nil cdr) - (formatting-cell (pane) (inspect-object car pane)) - t) - ((not (consp cdr)) - (formatting-cell (pane) (inspect-object car pane)) - (formatting-cell (pane) (princ "." pane)) - (formatting-cell (pane) (inspect-object cdr pane)) - t) - ((and *print-length* (>= length *print-length*)) - (with-output-as-presentation (pane object 'long-list-tail) - (formatting-cell (pane) (princ "..." pane))) - t) - (t nil))) - (formatting-cell (pane) (inspect-object car pane)))))))) + (if (and honor-dico + (not (gethash object (dico *application-frame*)))) + (inspect-object-briefly object pane) + (with-output-as-presentation + (pane object 'cons) + (formatting-table (pane) + (formatting-column (pane) + (do + ((length 0 (1+ length)) + (cdr (cdr object) (cdr cdr)) + (car (car object) (car cdr))) + ((cond ((eq nil cdr) + (formatting-cell (pane) (inspect-object car pane)) + t) + ((not (consp cdr)) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "." pane)) + (formatting-cell (pane) (inspect-object cdr pane)) + t) + ((and *print-length* (>= length *print-length*)) + (with-output-as-presentation + (pane object 'long-list-tail) + (formatting-cell (pane) (princ "..." pane))) + t) + (t nil))) + (formatting-cell (pane) (inspect-object car pane))))))))) (defun inspect-cons-as-list (object pane) "Inspect a cons cell in a traditional, plain-text format. The only @@ -325,24 +371,24 @@ (formatting-cell (pane) (princ "(" pane)) (do - ((length 0 (1+ length)) - (cdr (cdr object) (cdr cdr)) - (car (car object) (car cdr))) - ((cond ((eq nil cdr) - (formatting-cell (pane) (inspect-object car pane)) - (formatting-cell (pane) (princ ")" pane)) - t) - ((not (consp cdr)) - (formatting-cell (pane) (inspect-object car pane)) - (formatting-cell (pane) (princ "." pane)) - (formatting-cell (pane) (inspect-object cdr pane)) - (formatting-cell (pane) (princ ")" pane)) - t) - ((and *print-length* (>= length *print-length*)) - (with-output-as-presentation (pane object 'long-list-tail) - (formatting-cell (pane) (princ "...)" pane))) - t) - (t nil))) + ((length 0 (1+ length)) + (cdr (cdr object) (cdr cdr)) + (car (car object) (car cdr))) + ((cond ((eq nil cdr) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ ")" pane)) + t) + ((not (consp cdr)) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "." pane)) + (formatting-cell (pane) (inspect-object cdr pane)) + (formatting-cell (pane) (princ ")" pane)) + t) + ((and *print-length* (>= length *print-length*)) + (with-output-as-presentation (pane object 'long-list-tail) + (formatting-cell (pane) (princ "...)" pane))) + t) + (t nil))) (formatting-cell (pane) (inspect-object car pane))))))) (defmethod inspect-object ((object cons) pane) @@ -358,7 +404,7 @@ (princ 'hash-table pane))) (defmethod inspect-object ((object hash-table) pane) (inspector-table (object pane) - (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) + (format pane "~A (test: ~A)" 'hash-table (hash-table-test object)) (loop for key being the hash-keys of object do (formatting-row (pane) (formatting-cell (pane :align-x :right) @@ -369,8 +415,8 @@ (defmethod inspect-object ((object generic-function) pane) (inspector-table (object pane) - (format pane "Generic Function: ~s" - (clim-mop:generic-function-name object)) + (format pane "Generic Function: ~s" + (clim-mop:generic-function-name object)) (dolist (method (clim-mop:generic-function-methods object)) (with-output-as-presentation (pane method (presentation-type-of method)) @@ -420,7 +466,7 @@ (defmethod inspect-object ((object function) pane) (with-output-as-presentation - (pane object 'inspected-function) + (pane object 'inspected-function) (with-heading-style (pane) (princ "Function: " pane)) (with-text-family (pane :fix) @@ -448,18 +494,18 @@ (defmethod inspect-object ((object package) pane) (inspector-table (object pane) - (format pane "Package: ~S" (package-name object)) + (format pane "Package: ~S" (package-name object)) (inspector-table-row (pane) - (princ "Name:" pane) + (princ "Name:" pane) (inspect-object (package-name object) pane)) (inspector-table-row (pane) - (princ "Nicknames:" pane) + (princ "Nicknames:" pane) (inspect-vertical-list (package-nicknames object) pane)) (inspector-table-row (pane) - (princ "Used by:") + (princ "Used by:") (inspect-vertical-list (package-used-by-list object) pane)) (inspector-table-row (pane) - (princ "Uses:") + (princ "Uses:") (inspect-vertical-list (package-use-list object) pane)))) (defmethod inspect-object ((object vector) pane) @@ -510,22 +556,59 @@ (defmethod inspect-object ((object float) pane) (inspector-table (object pane) - (format pane "float ~S" object) + (format pane "Float ~S" object) (multiple-value-bind (significand exponent sign) (decode-float object) (inspector-table-row (pane) - (princ "sign:") + (princ "sign:" pane) (inspect-object sign pane)) (inspector-table-row (pane) - (princ "significand:") + (princ "significand:" pane) (inspect-object significand pane)) (inspector-table-row (pane) - (princ "exponent:") + (princ "exponent:" pane) (inspect-object exponent pane))) (inspector-table-row (pane) - (princ "radix:") + (princ "radix:" pane) (inspect-object (float-radix object) pane)))) +(defmethod inspect-object ((object integer) pane) + (inspector-table (object pane) + (format pane "Integer ~S" object) + (inspector-table-row (pane) + (princ "value:" pane) + (formatting-table (pane) + (formatting-row (pane) + (formatting-cell (pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (princ object pane))) + (formatting-cell (pane) + (princ "=" pane)) + (formatting-cell (pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (write object :radix t :base 16 :stream pane))) + (formatting-cell (pane) + (princ "=" pane)) + (formatting-cell (pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (write object :radix t :base 8 :stream pane))) + (formatting-cell (pane) + (princ "=" pane)) + (formatting-cell (pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (write object :radix t :base 2 :stream pane)))))) + (when (<= 0 object 255) + (inspector-table-row (pane) + (princ "character:" pane) + (inspect-object (code-char object) pane))) + (inspector-table-row (pane) + (princ "length:" pane) + (inspect-object (integer-length object) pane)))) + (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -534,14 +617,14 @@ (defmethod inspect-object ((object symbol) pane) (inspector-table (object pane) - (format pane "Symbol ~S" (symbol-name object)) + (format pane "Symbol ~S" (symbol-name object)) (inspector-table-row (pane) - (princ "value:") + (princ "value:") (if (boundp object) (inspect-object (symbol-value object) pane) (princ "unbound"))) (inspector-table-row (pane) - (princ "function:") + (princ "function:") (if (fboundp object) (inspect-object (symbol-function object) pane) (princ "unbound"))) @@ -549,15 +632,15 @@ ;; symbol. However, this is useful enough that I think it's worth ;; including here, since it can eliminate some minor annoyances. (inspector-table-row (pane) - (princ "class:") + (princ "class:") (if (find-class object nil) (inspect-object (find-class object) pane) (princ "unbound"))) (inspector-table-row (pane) - (princ "package:") + (princ "package:") (inspect-object (symbol-package object) pane)) (inspector-table-row (pane) - (princ "propery list:") + (princ "propery list:") (dolist (property (symbol-plist object)) (inspect-object property pane))))) @@ -570,15 +653,15 @@ (print object pane))) (defmethod inspect-object ((object character) pane) (inspector-table (object pane) - (format pane "Character ~S" object) + (format pane "Character ~S" object) (inspector-table-row (pane) - (princ "code:" pane) + (princ "code:" pane) (inspect-object (char-code object) pane)) (inspector-table-row (pane) - (princ "int:" pane) + (princ "int:" pane) (inspect-object (char-int object) pane)) (inspector-table-row (pane) - (princ "name:" pane) + (princ "name:" pane) (inspect-object (char-name object) pane)))) (defun display-app (frame pane) From pscott at common-lisp.net Fri Mar 18 20:51:30 2005 From: pscott at common-lisp.net (Peter Scott) Date: Fri, 18 Mar 2005 21:51:30 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp Message-ID: <20050318205130.E898888669@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv17025 Modified Files: inspector.lisp Log Message: Added inspection for pathnames. Added INSPECTOR-TABLE-ROWS macro which makes many uses of INSPECTOR-TABLE-ROW much shorter and more readable, and converted some code to use it. Added ability to show integers as universal times. Also did some refactoring of the integer inspection code, so now it does more but has less code. Its format was improved a bit. Date: Fri Mar 18 21:51:30 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.29 mcclim/Apps/Inspector/inspector.lisp:1.30 --- mcclim/Apps/Inspector/inspector.lisp:1.29 Thu Mar 17 23:49:49 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Mar 18 21:51:29 2005 @@ -171,6 +171,17 @@ (formatting-cell (,evaluated-pane) ,right))))) +(defmacro inspector-table-rows ((pane) &body rows) + "Output a bunch of rows with INSPECTOR-TABLE-ROW on PANE. Each row +is a list of a label and a value." + (let ((evaluated-pane (gensym "pane"))) + `(let ((,evaluated-pane ,pane)) + ,@(loop for row in rows + collect (destructuring-bind (label value) row + `(inspector-table-row (,evaluated-pane) + (princ ,label ,evaluated-pane) + (inspect-object ,value ,evaluated-pane))))))) + (defun print-documentation (object pane) "Print OBJECT's documentation, if any, to PANE" (when (handler-bind ((warning #'muffle-warning)) @@ -559,55 +570,62 @@ (format pane "Float ~S" object) (multiple-value-bind (significand exponent sign) (decode-float object) - (inspector-table-row (pane) - (princ "sign:" pane) - (inspect-object sign pane)) - (inspector-table-row (pane) - (princ "significand:" pane) - (inspect-object significand pane)) - (inspector-table-row (pane) - (princ "exponent:" pane) - (inspect-object exponent pane))) - (inspector-table-row (pane) - (princ "radix:" pane) - (inspect-object (float-radix object) pane)))) + (inspector-table-rows (pane) + ("sign:" sign) + ("significand:" significand) + ("exponent:" exponent))) + (inspector-table-rows (pane) + ("radix:" (float-radix object))))) + +(defun iso-8601-format (time) + "Return the given universal time in ISO 8601 format. This will raise +an error if the given time is not a decodable universal time." + (multiple-value-bind (sec min hour date month year) + (decode-universal-time time) + (format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0DZ" + year month date hour min sec))) (defmethod inspect-object ((object integer) pane) - (inspector-table (object pane) - (format pane "Integer ~S" object) - (inspector-table-row (pane) - (princ "value:" pane) - (formatting-table (pane) - (formatting-row (pane) - (formatting-cell (pane) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (princ object pane))) - (formatting-cell (pane) - (princ "=" pane)) - (formatting-cell (pane) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (write object :radix t :base 16 :stream pane))) - (formatting-cell (pane) - (princ "=" pane)) - (formatting-cell (pane) - (with-output-as-presentation - (pane object (presentation-type-of object)) - (write object :radix t :base 8 :stream pane))) - (formatting-cell (pane) - (princ "=" pane)) - (formatting-cell (pane) + (flet ((present-in-base (base &key (radix t) (family :fix)) + (with-text-family (pane family) + (formatting-cell (pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (write object :radix radix :base base :stream pane))))) + (print-equals-cell () + (formatting-cell (pane) + (princ "=" pane)))) + (inspector-table (object pane) + (format pane "Integer ~S" object) + (inspector-table-row (pane) + (princ "value:" pane) + (formatting-table (pane) + (formatting-row (pane) + ;; Base 10 should be displayed normally, without the + ;; fixed-width font and without the radix. + (present-in-base 10 :radix nil :family :sans-serif) + (print-equals-cell) ; = + (present-in-base 16) ; Hexadecimal + (print-equals-cell) ; = + (present-in-base 8) ; Octal + (print-equals-cell) ; = + (present-in-base 2)))) ; Binary + (when (<= 0 object 255) + (inspector-table-row (pane) + (princ "character:" pane) + (inspect-object (code-char object) pane))) + (inspector-table-row (pane) + (princ "length:" pane) + (inspect-object (integer-length object) pane)) + ;; Sometimes we get numbers that can't be interpreted as a + ;; time. Those throw an error, and this just isn't printed. + (ignore-errors + (inspector-table-row (pane) + (princ "as time:" pane) + (with-text-family (pane :fix) (with-output-as-presentation (pane object (presentation-type-of object)) - (write object :radix t :base 2 :stream pane)))))) - (when (<= 0 object 255) - (inspector-table-row (pane) - (princ "character:" pane) - (inspect-object (code-char object) pane))) - (inspector-table-row (pane) - (princ "length:" pane) - (inspect-object (integer-length object) pane)))) + (princ (iso-8601-format object) pane)))))))) (defmethod inspect-object-briefly ((object symbol) pane) (with-output-as-presentation @@ -619,28 +637,28 @@ (inspector-table (object pane) (format pane "Symbol ~S" (symbol-name object)) (inspector-table-row (pane) - (princ "value:") + (princ "value:" pane) (if (boundp object) (inspect-object (symbol-value object) pane) - (princ "unbound"))) + (princ "unbound" pane))) (inspector-table-row (pane) - (princ "function:") + (princ "function:" pane) (if (fboundp object) (inspect-object (symbol-function object) pane) - (princ "unbound"))) + (princ "unbound" pane))) ;; This is not, strictly speaking, a property of the ;; symbol. However, this is useful enough that I think it's worth ;; including here, since it can eliminate some minor annoyances. (inspector-table-row (pane) - (princ "class:") + (princ "class:" pane) (if (find-class object nil) (inspect-object (find-class object) pane) - (princ "unbound"))) + (princ "unbound" pane))) (inspector-table-row (pane) - (princ "package:") + (princ "package:" pane) (inspect-object (symbol-package object) pane)) (inspector-table-row (pane) - (princ "propery list:") + (princ "propery list:" pane) (dolist (property (symbol-plist object)) (inspect-object property pane))))) @@ -654,15 +672,29 @@ (defmethod inspect-object ((object character) pane) (inspector-table (object pane) (format pane "Character ~S" object) - (inspector-table-row (pane) - (princ "code:" pane) - (inspect-object (char-code object) pane)) - (inspector-table-row (pane) - (princ "int:" pane) - (inspect-object (char-int object) pane)) - (inspector-table-row (pane) - (princ "name:" pane) - (inspect-object (char-name object) pane)))) + (inspector-table-rows (pane) + ("code:" (char-code object)) + ("int:" (char-int object)) + ("name:" (char-name object))))) + +(defmethod inspect-object ((object pathname) pane) + (inspector-table (object pane) + (princ (if (wild-pathname-p object) + "Wild pathname" + "Pathname")) + (inspector-table-rows (pane) + ("namestring:" (namestring object)) + ("host:" (pathname-host object)) + ("device:" (pathname-device object)) + ("directory:" (pathname-directory object)) + ("name:" (pathname-name object)) + ("type:" (pathname-type object)) + ("version:" (pathname-version object))) + (unless (or (wild-pathname-p object) + (not (probe-file object))) + (inspector-table-row (pane) + (princ "truename:" pane) + (inspect-object (truename object) pane))))) (defun display-app (frame pane) "Display the APP frame of the inspector" From crhodes at common-lisp.net Tue Mar 22 12:31:22 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 22 Mar 2005 13:31:22 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/package.lisp mcclim/text-selection.lisp Message-ID: <20050322123122.DDCC2886FE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31416 Modified Files: package.lisp text-selection.lisp Log Message: I think this is a slightly more ICCCMly correct implementation of sending selections to requestors. We support all the required targets except MULTIPLE, select an appropriate property if TEXT is requested, refuse to send bad characters to a STRING target, and avoid printing to *trace-output* to deal with the fact that Klipper, at least, polls the TIMESTAMP property to find out if the selection has changed. Requesting PRIMARY from selection owners is moderately broken, unfortunately; it works for ASCII but not for much else. Date: Tue Mar 22 13:31:19 2005 Author: crhodes Index: mcclim/package.lisp diff -u mcclim/package.lisp:1.48 mcclim/package.lisp:1.49 --- mcclim/package.lisp:1.48 Tue Feb 22 04:14:26 2005 +++ mcclim/package.lisp Tue Mar 22 13:31:18 2005 @@ -1988,6 +1988,7 @@ #:text-style-width ;; Text selection protocol #:selection-owner + #:selection-timestamp #:selection-event #:selection-clear-event #:selection-notify-event Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.5 mcclim/text-selection.lisp:1.6 --- mcclim/text-selection.lisp:1.5 Mon Feb 28 00:07:36 2005 +++ mcclim/text-selection.lisp Tue Mar 22 13:31:18 2005 @@ -244,7 +244,8 @@ :sheet owner :selection :primary)))) (when (bind-selection (port pane) pane (event-timestamp event)) - (setf (selection-owner (port pane)) pane))))) + (setf (selection-owner (port pane)) pane) + (setf (selection-timestamp (port pane)) (event-timestamp event)))))) (defun repaint-markings (pane old-markings new-markings) (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings) From crhodes at common-lisp.net Tue Mar 22 12:31:25 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Tue, 22 Mar 2005 13:31:25 +0100 (CET) Subject: [mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp Message-ID: <20050322123125.0200388704@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv31416/Backends/CLX Modified Files: port.lisp Log Message: I think this is a slightly more ICCCMly correct implementation of sending selections to requestors. We support all the required targets except MULTIPLE, select an appropriate property if TEXT is requested, refuse to send bad characters to a STRING target, and avoid printing to *trace-output* to deal with the fact that Klipper, at least, polls the TIMESTAMP property to find out if the selection has changed. Requesting PRIMARY from selection owners is moderately broken, unfortunately; it works for ASCII but not for much else. Date: Tue Mar 22 13:31:23 2005 Author: crhodes Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.108 mcclim/Backends/CLX/port.lisp:1.109 --- mcclim/Backends/CLX/port.lisp:1.108 Mon Feb 28 00:07:41 2005 +++ mcclim/Backends/CLX/port.lisp Tue Mar 22 13:31:22 2005 @@ -165,7 +165,8 @@ (design-cache :initform (make-hash-table :test #'eq)) (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) - (selection-owner :initform nil :accessor selection-owner))) + (selection-owner :initform nil :accessor selection-owner) + (selection-timestamp :initform nil :accessor selection-timestamp))) (defun parse-clx-server-path (path) (pop path) @@ -1314,19 +1315,23 @@ ;; we at least want to support: -;; :TEXT, :STRING -;; -;; :UTF8_STRING -;; As seen from xterm [make that the prefered encoding] -;; -;; :COMPOUND_TEXT -;; Perhaps relatively easy to produce, hard to grok. -;; - +;;; :TEXT, :STRING +;;; +;;; :UTF8_STRING +;;; As seen from xterm [make that the preferred encoding] +;;; +;;; :COMPOUND_TEXT +;;; Perhaps relatively easy to produce, hard to grok. +;;; +;;; :TARGETS +;;; Clients want legitimately to find out what we support. +;;; +;;; :TIMESTAMP +;;; Clients want to know when we took ownership of the selection. ;;; Utilities -(defun utf-8-encode (code-points) +(defun utf8-string-encode (code-points) (let ((res (make-array (length code-points) :adjustable t :fill-pointer 0))) @@ -1379,7 +1384,8 @@ (xlib:set-selection-owner (clx-port-display port) :primary nil time) - (setf (selection-owner port) nil)) + (setf (selection-owner port) nil) + (setf (selection-timestamp port) nil)) (defmethod request-selection ((port clx-port) requestor time) (xlib:convert-selection :primary :STRING requestor :bounce time)) @@ -1399,50 +1405,88 @@ ;; Incredibly crappy broken unportable Latin 1 encoder which should be ;; replaced by various implementation-specific versions. -(defun latin1-encode (string) - (delete-if (lambda (x) (or (< x 0) - (> x 255))) - (map 'vector #'char-code string))) - -;; TODO: INCR property? -(defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) +(flet ((latin1-code-p (x) + (not (or (< x 9) (< 10 x 32) (< #x7f x #xa0) (> x 255))))) + (defun string-encode (string) + (delete-if-not #'latin1-code-p (map 'vector #'char-code string))) + (defun exactly-encodable-as-string-p (string) + (every #'latin1-code-p (map 'vector #'char-code string)))) + +;;; TODO: INCR property? +;;; +;;; FIXME: per ICCCM we MUST support :MULTIPLE +(defmethod send-selection + ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) (when (null property) - (format *trace-output* "~&* Requestor property is null! *~%")) - (describe event *trace-output*) - (finish-output *trace-output*) + (format *trace-output* "~&* Requestor property is null! *~%")) + #+nil ; debugging output + (progn + (describe event *trace-output*) + (finish-output *trace-output*)) (flet ((send-event (&key target (property property)) + ;; debugging output, but the KDE Klipper client turns out + ;; to poll other clients for selection, which means it + ;; would be bad to print at every request. + #+nil (format *trace-output* "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A.~%" (selection-event-target event) target - property) + property) (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target target - :property property - :time time))) - (cond ((member target '(:UTF8_STRING :TEXT)) - (xlib:change-property requestor property - (utf-8-encode - (concatenate 'vector (map 'vector #'char-code string))) - :UTF8_STRING - 8) - (send-event :target :UTF8_STRING)) - ((member target '(:STRING :COMPOUND_TEXT)) - (xlib:change-property requestor property - (latin1-encode string) - :COMPOUND_TEXT - 8) - (send-event :target :COMPOUND_TEXT)) - (t - (format *trace-output* - "~&;; Warning, unhandled type \"~A\". Trying to send as UTF8_STRING.~%" - target) - (send-event :target :UTF8_STRING :property nil)))) ;; ... + :selection-notify nil + :window requestor + :event-window requestor + :selection :primary + :target target + :property property + :time time))) + (case target + ((:UTF8_STRING) + (xlib:change-property requestor property + (utf8-string-encode + (map 'vector #'char-code string)) + :UTF8_STRING 8) + (send-event :target :UTF8_STRING)) + ((:STRING :COMPOUND_TEXT) + (xlib:change-property requestor property + (string-encode string) + target 8) + (send-event :target target)) + ((:TEXT) + (cond + ((exactly-encodable-as-string-p string) + (xlib:change-property requestor property + (string-encode string) + :STRING 8) + (send-event :target :STRING)) + (t + (xlib:change-property requestor property + (utf8-string-encode + (map 'vector #'char-code string)) + :UTF8_STRING 8) + (send-event :target :UTF8_STRING)))) + ((:TARGETS) + (let* ((display (clx-port-display port)) + (targets (mapcar (lambda (x) (xlib:intern-atom display x)) + '(:TARGETS :STRING :TEXT :UTF8_STRING + :COMPOUND_TEXT :TIMESTAMP)))) + (xlib:change-property requestor property targets target 32)) + (send-event :target :TARGETS)) + ((:TIMESTAMP) + (when (null (selection-timestamp port)) + (format *trace-output* "~&;; selection-timestamp is null!~%")) + (xlib:change-property requestor property + (list (selection-timestamp port)) + target 32) + (send-event :target :TIMESTAMP)) + (t + (format *trace-output* + "~&;; Warning, unhandled type \"~A\". ~ + Sending property NIL to target.~%" target) + (send-event :target target :property nil)))) (xlib:display-force-output (xlib:window-display requestor))))