March 2005 - mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd
by pscott＠common-lisp.net 09 Mar '05

09 Mar '05

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

1 0

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

09 Mar '05

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) ,@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) - ,@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) + ,@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 "#<unbound slot>")))))))) + (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 "#<unbound slot>")))))))) ;; Try to print the normal, textual representation of an object, but ;; if that's too long, make an abbreviated "instance of ~S" version. @@ -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"

1 0

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

08 Mar '05

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))

1 0

[mcclim-cvs] CVS update: mcclim/incremental-redisplay.lisp
by tmoore＠common-lisp.net 08 Mar '05

08 Mar '05

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,

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd
by pscott＠common-lisp.net 07 Mar '05

07 Mar '05

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

1 0

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

07 Mar '05

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 "#<unprintable ~S>" (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 "#<unprintable ~S>" (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

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/disassembly.lisp
by pscott＠common-lisp.net 07 Mar '05

07 Mar '05

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

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/mcclim-0.9.1.tar.gz.asc
by afuchs＠common-lisp.net 06 Mar '05

06 Mar '05

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

1 0

[mcclim-cvs] CVS update: mcclim/Webpage/downloads/mcclim-0.9.1.tar.gz
by afuchs＠common-lisp.net 06 Mar '05

06 Mar '05

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

1 0

[mcclim-cvs] CVS update: mcclim/ReleaseNotes/0-9-1-mothering-sunday
by afuchs＠common-lisp.net 06 Mar '05

06 Mar '05

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

1 0