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

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

04 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv26011 Modified Files: inspector.lisp clouseau.asd Log Message: Exported DEFINE-INSPECTOR-COMMAND and changed the presentation type for vectors to 'VECTOR. This makes it easier to extend the inspector in application-specific ways. Date: Fri Feb 4 23:37:21 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.12 mcclim/Apps/Inspector/inspector.lisp:1.13 --- mcclim/Apps/Inspector/inspector.lisp:1.12 Fri Feb 4 21:17:42 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 4 23:37:21 2005 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: INSPECTOR -*- +;;; -*- Mode: Lisp; Package: CLOUSEAU -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh(a)labri.fr) @@ -348,8 +348,10 @@ (inspect-object uses pane))))) (defmethod inspect-object ((object vector) pane) + ;; Using 'vector as the presentation type may be nonstandard, but it + ;; is more useful than the default. (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'vector) (formatting-table (pane) (formatting-row (pane) (formatting-cell (pane) Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.2 mcclim/Apps/Inspector/clouseau.asd:1.3 --- mcclim/Apps/Inspector/clouseau.asd:1.2 Fri Feb 4 21:17:42 2005 +++ mcclim/Apps/Inspector/clouseau.asd Fri Feb 4 23:37:21 2005 @@ -24,7 +24,8 @@ (:use :clim-lisp :clim) (:export #:inspector #:inspect-object - #:inspect-object-briefly)) + #:inspect-object-briefly + #:define-inspector-command)) (asdf::defsystem clouseau :serial t

1 0

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

04 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv18302 Modified Files: inspector.lisp clouseau.asd Log Message: Added :new-process argument to INSPECTOR, and changed this to do it properly as suggested by Paolo Amoroso. Exported INSPECT-OBJECT and INSPECT-OBJECT-BRIEFLY to make extending the inspector easier for users. Made EQL specializers show up informatively. Date: Fri Feb 4 21:17:43 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.11 mcclim/Apps/Inspector/inspector.lisp:1.12 --- mcclim/Apps/Inspector/inspector.lisp:1.11 Thu Feb 3 23:15:21 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Feb 4 21:17:42 2005 @@ -52,11 +52,17 @@ pane :height (bounding-rectangle-height (stream-output-history pane)))) -(defun inspector (obj) - (let ((*print-length* 10) - (*print-level* 10)) - (run-frame-top-level - (make-application-frame 'inspector :obj obj)))) +(defun inspector (obj &key (new-process nil)) + (flet ((run () + (let ((*print-length* 10) + (*print-level* 10)) + (run-frame-top-level + (make-application-frame 'inspector :obj obj))))) + (if new-process + (clim-sys:make-process #'run + :name (format nil "Inspector Clouseau: ~S" + obj)) + (run)))) (defparameter *inspected-objects* '() "A list of objects which are currently being inspected with @@ -286,7 +292,9 @@ (format pane "~a " (if (typep specializer 'clim-mop:eql-specializer) - "EQL specializer" ; FIXME: says nothing + (format nil "(EQL ~S)" + (clim-mop:eql-specializer-object + specializer)) (class-name specializer)))))))))) (defun pretty-print-function (fun) @@ -446,8 +454,7 @@ (define-inspector-command (com-inspect :name t) () (let ((obj (accept t :prompt "Select an object"))) - (clim-sys:make-process #'(lambda () (inspector obj)) - :name "Inspector Clouseau"))) + (inspector obj :new-process t))) (define-inspector-command (com-toggle-show-list-cells :name t) ((obj 'cons :gesture :select :prompt "Select a cons or list")) Index: mcclim/Apps/Inspector/clouseau.asd diff -u mcclim/Apps/Inspector/clouseau.asd:1.1 mcclim/Apps/Inspector/clouseau.asd:1.2 --- mcclim/Apps/Inspector/clouseau.asd:1.1 Wed Feb 2 10:33:49 2005 +++ mcclim/Apps/Inspector/clouseau.asd Fri Feb 4 21:17:42 2005 @@ -22,7 +22,9 @@ (defpackage :clouseau (:use :clim-lisp :clim) - (:export #:inspector)) + (:export #:inspector + #:inspect-object + #:inspect-object-briefly)) (asdf::defsystem clouseau :serial t

1 0

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

03 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv12283 Modified Files: inspector.lisp Log Message: Applied quick and dirty fix to bug with generic function inspection's display of EQL specializers. Added display of superclasses and subclasses to objects. Some miscellaneous bug fixes. Improved printing of object instances. Date: Thu Feb 3 23:15:21 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.10 mcclim/Apps/Inspector/inspector.lisp:1.11 --- mcclim/Apps/Inspector/inspector.lisp:1.10 Thu Feb 3 21:14:57 2005 +++ mcclim/Apps/Inspector/inspector.lisp Thu Feb 3 23:15:21 2005 @@ -145,6 +145,18 @@ (let ((class (class-of object))) (inspector-table (print (class-name class) pane) + (when (clim-mop:class-direct-superclasses class) + (inspector-table-row + (format pane "Superclasses") + (dolist (superclass (clim-mop:class-direct-superclasses class)) + (inspect-object superclass pane) + (terpri pane)))) + (when (clim-mop:class-direct-subclasses class) + (inspector-table-row + (format pane "Subclasses") + (dolist (subclass (clim-mop:class-direct-subclasses class)) + (inspect-object subclass pane) + (terpri pane)))) (loop for slot in (reverse (clim-mop:class-slots class)) do (let ((slot-name (clim-mop:slot-definition-name slot))) (inspector-table-row @@ -153,10 +165,21 @@ (format pane "~a:" slot-name)) (inspect-object (slot-value object slot-name) pane))))))) +(defparameter *object-representation-max-length* 60 + "Maximum number of characters of an object's textual representation +that are allowed before abbreviation kicks in") + +;; Try to print the normal, textual representation of an object, but +;; if that's too long, make an abbreviated "instance of ~S" version. (defmethod inspect-object-briefly ((object standard-object) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (format pane "instance of ~S" (class-name (class-of object))))) + (let ((representation (with-output-to-string (string) + (prin1 object string)))) + (if (< (length representation) *object-representation-max-length*) + (princ representation pane) + (format pane "instance of ~S" (class-name (class-of object))))))) + (defmethod inspect-object ((object standard-object) pane) (inspect-structure-or-object object pane)) @@ -172,7 +195,7 @@ (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) @@ -186,7 +209,7 @@ (formatting-column (pane) (formatting-cell (pane) (with-output-as-presentation - (pane object (presentation-type-of object)) + (pane object 'cons) (draw-rectangle* pane 0 0 20 10 :filled nil)) (draw-line* pane 10 0 10 10) (draw-arrow* pane 5 5 5 30) @@ -260,7 +283,11 @@ (print (method-qualifiers method))) (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) - (format pane "~s " (class-name specializer))))))))) + (format pane "~a " + (if (typep specializer + 'clim-mop:eql-specializer) + "EQL specializer" ; FIXME: says nothing + (class-name specializer)))))))))) (defun pretty-print-function (fun) "Print a function in a readable way, returning a string. On most @@ -401,7 +428,7 @@ (princ "propery list:") (dolist (property (symbol-plist object)) (inspect-object property pane))))) -(make-instance 'packrat) + ;; Characters are so short that displaying them as "..." takes almost ;; as much space as just showing them, and this way is more ;; informative. @@ -437,8 +464,11 @@ (define-inspector-command (com-set-slot :name t) ((slot 'settable-slot :gesture :select :prompt "Set slot")) - (setf (slot-value (car slot) (cdr slot)) - (accept t :prompt "New slot value"))) + (handler-case (setf (slot-value (car slot) (cdr slot)) + (accept t :prompt "New slot value")) + (simple-parse-error () + (format (get-frame-pane *application-frame* 'int) + "~&Command canceled; slot value not set~%")))) (defun slot-documentation (class slot) "Returns the documentation of a slot of a class, or nil. There is, @@ -462,7 +492,8 @@ (destructuring-bind (object . slot-name) slot (let* ((stream (get-frame-pane *application-frame* 'int)) (class (class-of object)) - (documentation (slot-documentation class slot-name)) + (documentation (handler-bind ((warning #'muffle-warning)) + (slot-documentation class slot-name))) (slot-object (find slot-name (clim-mop:class-slots class) :key #'clim-mop:slot-definition-name))) (when documentation

1 0

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

03 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv5675 Modified Files: inspector.lisp Log Message: Added class-like inspection of structures, characters are inspected non-annoyingly, documentation strings are displayed where possible, the source code has been commented and documented more, and some other features and bug fixes have been added. Date: Thu Feb 3 21:14:57 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.9 mcclim/Apps/Inspector/inspector.lisp:1.10 --- mcclim/Apps/Inspector/inspector.lisp:1.9 Wed Feb 2 11:16:59 2005 +++ mcclim/Apps/Inspector/inspector.lisp Thu Feb 3 21:14:57 2005 @@ -24,8 +24,11 @@ (in-package :clouseau) +(define-modify-macro togglef () not) + (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico) + (cons-cell-dico :initform (make-hash-table) :reader cons-cell-dico) (obj :initarg :obj :reader obj)) (:pointer-documentation t) (:panes @@ -55,16 +58,23 @@ (run-frame-top-level (make-application-frame 'inspector :obj obj)))) -(defparameter *inspected-objects* '()) +(defparameter *inspected-objects* '() + "A list of objects which are currently being inspected with +INSPECT-OBJECT") + +(defgeneric inspect-object-briefly (object pane) + (:documentation "Inspect an object in a short form, displaying this +on PANE. For example, rather than displaying all the slots of a class, +only the class name would be shown.")) -(defgeneric inspect-object-briefly (object pane)) -(defgeneric inspect-object (object pane)) +(defgeneric inspect-object (object pane) + (:documentation "Inspect an object, displaying it on PANE")) (defmethod inspect-object :around (object pane) (cond ((member object *inspected-objects*) (with-output-as-presentation (pane object (presentation-type-of object)) - (princ "==="))) + (princ "==="))) ; Prevent infinite loops ((not (gethash object (dico *application-frame*))) (inspect-object-briefly object pane)) (t @@ -84,6 +94,8 @@ (define-presentation-type settable-slot () :inherit-from t) +(define-presentation-type cons () + :inherit-from t) (define-presentation-method present (object (type settable-slot) stream @@ -93,6 +105,11 @@ (format stream "~s" (cdr object))) (defmacro inspector-table (header &body body) + "Present OBJECT (captured from environment) in tabular form, with +HEADER printed in a box at the top. BODY should output the rows of the +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) @@ -102,32 +119,54 @@ ,header)) (formatting-cell (pane) (formatting-table (pane) - ,@body)))))) + ,@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) ,left) (formatting-cell (pane) ,right))) +(defun print-documentation (object pane) + "Print OBJECT's documentation, if any, to PANE" + (when (handler-bind ((warning #'muffle-warning)) + (documentation object t)) + (format pane "~&Documentation: ~A" (documentation object t)))) + +(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 +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) + (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)) + (inspect-object (slot-value object slot-name) pane))))))) + (defmethod inspect-object-briefly ((object standard-object) pane) (with-output-as-presentation (pane object (presentation-type-of object)) (format pane "instance of ~S" (class-name (class-of object))))) (defmethod inspect-object ((object standard-object) pane) - (let ((class (class-of object))) - (inspector-table - (print (class-name 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)) - (inspect-object (slot-value object slot-name) pane))))))) + (inspect-structure-or-object object pane)) -(defmethod inspect-object ((object cons) pane) +(defmethod inspect-object ((object structure-object) pane) + (inspect-structure-or-object object pane)) + +(defun inspect-cons-as-cells (object pane) + "Inspect a cons cell in a fancy graphical way. The inconvenient part +is that this necessarily involves quite a bit of clicking to show a +moderately-sized list." (if (null (cdr object)) (formatting-table (pane) (formatting-column (pane) @@ -157,6 +196,44 @@ (formatting-cell (pane) (inspect-object (cdr object) 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) + (formatting-table (pane) + (formatting-row (pane) + (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) + ((>= length *print-length*) + (formatting-cell (pane) (inspect-object car pane)) + (formatting-cell (pane) (princ "..." pane)) + t) + (t nil))) + (formatting-cell (pane) (inspect-object car pane))))))) + +(defmethod inspect-object ((object cons) pane) + (if (gethash object (cons-cell-dico *application-frame*)) + (inspect-cons-as-cells object pane) + (inspect-cons-as-list object pane))) + + (defmethod inspect-object-briefly ((object hash-table) pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -185,6 +262,33 @@ do (formatting-cell (pane) (format pane "~s " (class-name specializer))))))))) +(defun pretty-print-function (fun) + "Print a function in a readable way, returning a string. On most +implementations this just uses the standard Lisp printer, but it can +use implementation-specific functions to be more informative." + (flet ((generic-print (fun) + (with-output-to-string (string) + (prin1 fun string)))) + ;; If we have SBCL, try to do fancy formatting. If anything goes + ;; wrong with that, fall back on ugly standard PRIN1. + #+sbcl (handler-case (format nil "~A ~S" + (sb-impl::%simple-fun-name fun) + (sb-impl::%simple-fun-arglist fun)) + (error () (generic-print fun))) + ;; FIXME: Other Lisp implementations have ways of getting this + ;; information. If you want a better inspector on a non-SBCL Lisp, + ;; please add code for it and send patches. + #-sbcl (generic-print fun))) + +(defmethod inspect-object ((object function) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (format pane "Function: ~A" + (pretty-print-function object)) + #+sbcl (format pane "~&Type: ~A" + (sb-impl::%simple-fun-type object)) + (print-documentation object pane))) + (defmethod inspect-object-briefly ((object package) pane) (with-output-as-presentation (pane object (presentation-type-of object)) @@ -231,7 +335,10 @@ (pane object (presentation-type-of object)) (print object))) -(defmethod inspect-object ((object complex) pane) +(defun inspect-complex (object pane) + "Inspect a complex number. Since complex numbers should be inspected +the same way briefly and fully, this function can be called by both of +them." (with-output-as-presentation (pane object (presentation-type-of object)) (formatting-table (pane) @@ -245,6 +352,12 @@ (formatting-cell (pane) (princ ")" pane)))))) +(defmethod inspect-object-briefly ((object complex) pane) + (inspect-complex object pane)) + +(defmethod inspect-object ((object complex) pane) + (inspect-complex object pane)) + (defmethod inspect-object ((object float) pane) (inspector-table (format pane "float ~S" object) @@ -267,6 +380,7 @@ (with-output-as-presentation (pane object (presentation-type-of object)) (print object))) + (defmethod inspect-object ((object symbol) pane) (inspector-table (format pane "Symbol ~S" (symbol-name object)) @@ -287,8 +401,17 @@ (princ "propery list:") (dolist (property (symbol-plist object)) (inspect-object property pane))))) +(make-instance 'packrat) +;; Characters are so short that displaying them as "..." takes almost +;; as much space as just showing them, and this way is more +;; informative. +(defmethod inspect-object-briefly ((object character) pane) + (with-output-as-presentation + (pane object (presentation-type-of object)) + (print object pane))) (defun display-app (frame pane) + "Display the APP frame of the inspector" (inspect-object (obj frame) pane)) (define-inspector-command (com-quit :name t) () @@ -297,13 +420,16 @@ (define-inspector-command (com-inspect :name t) () (let ((obj (accept t :prompt "Select an object"))) (clim-sys:make-process #'(lambda () (inspector obj)) - :name "inspector"))) + :name "Inspector Clouseau"))) + +(define-inspector-command (com-toggle-show-list-cells :name t) + ((obj 'cons :gesture :select :prompt "Select a cons or list")) + (togglef (gethash obj (cons-cell-dico *application-frame*)))) (define-inspector-command (com-toggle-inspect :name t) ((obj t :gesture :select :prompt "Select an object")) (unless (eq obj (obj *application-frame*)) - (setf (gethash obj (dico *application-frame*)) - (not (gethash obj (dico *application-frame*)))))) + (togglef (gethash obj (dico *application-frame*))))) (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) @@ -313,3 +439,33 @@ ((slot 'settable-slot :gesture :select :prompt "Set slot")) (setf (slot-value (car slot) (cdr slot)) (accept t :prompt "New slot value"))) + +(defun slot-documentation (class slot) + "Returns the documentation of a slot of a class, or nil. There is, +unfortunately, no portable way to do this, but the MOP is +semi-portable and we can use it. To complicate things even more, some +implementations have unpleasant oddities in the way they store slot +documentation. For example, in SBCL slot documentation is only +available in direct slots." + (let ((slot-object (find slot (clim-mop:class-direct-slots class) + :key #'clim-mop:slot-definition-name))) + (if slot-object + (documentation slot-object t) + (when (clim-mop:class-direct-superclasses class) + (find-if #'identity + (mapcar #'(lambda (class) + (slot-documentation class slot)) + (clim-mop:class-direct-superclasses class))))))) + +(define-inspector-command (com-describe-slot :name t) + ((slot 'settable-slot :gesture :describe :prompt "Describe slot")) + (destructuring-bind (object . slot-name) slot + (let* ((stream (get-frame-pane *application-frame* 'int)) + (class (class-of object)) + (documentation (slot-documentation class slot-name)) + (slot-object (find slot-name (clim-mop:class-slots class) + :key #'clim-mop:slot-definition-name))) + (when documentation + (format stream "~&Documentation: ~A~%" documentation)) + (format stream "~&Type: ~S~%" + (clim-mop:slot-definition-type slot-object))))) \ No newline at end of file

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/INSTALL
by varkesteijn＠common-lisp.net 03 Feb '05

03 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv1400 Modified Files: INSTALL Log Message: Updated INSTALL file to reflect the change of system and package name. (thanks Paolo Amoroso) Date: Thu Feb 3 19:47:18 2005 Author: varkesteijn Index: mcclim/Apps/Inspector/INSTALL diff -u mcclim/Apps/Inspector/INSTALL:1.1 mcclim/Apps/Inspector/INSTALL:1.2 --- mcclim/Apps/Inspector/INSTALL:1.1 Sat Jan 29 13:10:54 2005 +++ mcclim/Apps/Inspector/INSTALL Thu Feb 3 19:47:18 2005 @@ -1,11 +1,11 @@ 1. Start your Lisp system and make sure you have ASDF and McCLIM in your core file. -2. (asdf:operate 'asdf:load-op :inspector) +2. (asdf:operate 'asdf:load-op :clouseau) 3. Try something like: - (inspector::inspector (clim:make-application-frame 'inspector::inspector :obj 20)) + (clouseau::inspector (clim:make-application-frame 'clouseau::inspector :obj 20)) in order to inspect the inspector pane.

1 0

[mcclim-cvs] CVS update: mcclim/Experimental/menu-choose.lisp
by tmoore＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Experimental In directory common-lisp.net:/tmp/cvs-serv31595/Experimental Modified Files: menu-choose.lisp Log Message: Hammered on with-room-for-graphics. It should now leave the cursor in the right place and do the right thing with respect to recording options. Changed with-drawing-options to not rebind its medium argument at all. Added :label and :scroll-bars arguments to with-menu which are currently ignored. Date: Wed Feb 2 12:34:02 2005 Author: tmoore Index: mcclim/Experimental/menu-choose.lisp diff -u mcclim/Experimental/menu-choose.lisp:1.16 mcclim/Experimental/menu-choose.lisp:1.17 --- mcclim/Experimental/menu-choose.lisp:1.16 Wed Jan 26 05:29:06 2005 +++ mcclim/Experimental/menu-choose.lisp Wed Feb 2 12:34:02 2005 @@ -137,7 +137,7 @@ (defmacro with-menu ((menu &optional associated-window - &key (deexpose t)) + &key (deexpose t) label scroll-bars) &body body) (check-type menu symbol) (with-gensyms (with-menu-cont) @@ -146,10 +146,13 @@ (declare (dynamic-extent #',with-menu-cont)) (invoke-with-menu #',with-menu-cont ,associated-window ; XXX - ',deexpose)))) ; XXX!!! + ',deexpose ; XXX!!! + ,label + ,scroll-bars)))) -(defun invoke-with-menu (continuation associated-window deexpose) - (declare (ignore deexpose)) ; FIXME!!! +(defun invoke-with-menu (continuation associated-window deexpose + label scroll-bars) + (declare (ignore deexpose label scroll-bars)) ; FIXME!!! (let* ((associated-frame (if associated-window (pane-frame associated-window) *application-frame*))

1 0

[mcclim-cvs] CVS update: mcclim/decls.lisp mcclim/frames.lisp mcclim/graphics.lisp mcclim/recording.lisp mcclim/stream-output.lisp mcclim/utils.lisp
by tmoore＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31595 Modified Files: decls.lisp frames.lisp graphics.lisp recording.lisp stream-output.lisp utils.lisp Log Message: Hammered on with-room-for-graphics. It should now leave the cursor in the right place and do the right thing with respect to recording options. Changed with-drawing-options to not rebind its medium argument at all. Added :label and :scroll-bars arguments to with-menu which are currently ignored. Date: Wed Feb 2 12:33:59 2005 Author: tmoore Index: mcclim/decls.lisp diff -u mcclim/decls.lisp:1.30 mcclim/decls.lisp:1.31 --- mcclim/decls.lisp:1.30 Thu Dec 30 11:09:40 2004 +++ mcclim/decls.lisp Wed Feb 2 12:33:58 2005 @@ -111,6 +111,13 @@ (defgeneric invoke-with-drawing-options (medium continuation &rest drawing-options &key &allow-other-keys)) +;;;; 10.2.1 +(defgeneric invoke-with-identity-transformation (medium continuation)) + +;;;; 10.2.2 +(defgeneric invoke-with-local-coordinates (medium continuation x y)) + +(defgeneric invoke-with-first-quadrant-coordinates (medium continuation x y)) ;;;; 14.5 (defgeneric draw-design Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.104 mcclim/frames.lisp:1.105 --- mcclim/frames.lisp:1.104 Tue Jan 11 14:14:18 2005 +++ mcclim/frames.lisp Wed Feb 2 12:33:58 2005 @@ -1394,6 +1394,37 @@ (frob pointer-button-press-event presentation-button-press-handler) (frob pointer-button-release-event presentation-button-release-handler)) +(defun make-drag-bounding (old-highlighting new-highlighting + old-presentation new-presentation) + (let (x1 y1 x2 y2) + (flet ((union-with-bounds (rect) + (cond ((null rect) + nil) + ((null x1) + (setf (values x1 y1 x2 y2) (bounding-rectangle* rect))) + (t (with-bounding-rectangle* (r-x1 r-y1 r-x2 r-y2) + rect + (setf (values x1 y1 x2 y2) + (bound-rectangles x1 y1 x2 y2 + r-x1 r-y1 r-x2 r-y2))))))) + (union-with-bounds old-highlighting) + (union-with-bounds new-highlighting) + (union-with-bounds old-presentation) + (union-with-bounds new-presentation) + (values x1 y1 x2 y2)))) + +(defun make-drag-and-drop-feedback-function (from-presentation) + (multiple-value-bind (record-x record-y) + (output-record-position from-presentation) + (let ((current-to-presentation nil) + (current-from-higlighting nil)) + (lambda (frame from-presentation to-presentation initial-x initial-y + x y event) + (let ((dx (- record-x initial-x)) + (dy (- record-y initial-y))) + (typecase event + (null + ()))))))) (defun frame-drag (translator-name command-table object presentation context-type frame event window x y) @@ -1416,5 +1447,5 @@ (tracking-pointer (window :context-type drag-c-type :highlight nil) (:pointer-motion (&key event x y) (multiple-value-bind (presentation translator) - (find-innermost-presentation-context drag-context window - x y :event event))))))) + (find-innermost-presentation-match drag-context window + x y :event event))))))) Index: mcclim/graphics.lisp diff -u mcclim/graphics.lisp:1.49 mcclim/graphics.lisp:1.50 --- mcclim/graphics.lisp:1.49 Tue Jan 11 14:35:18 2005 +++ mcclim/graphics.lisp Wed Feb 2 12:33:58 2005 @@ -20,6 +20,38 @@ (in-package :clim-internals) +;;; Work in progress that reduces consing of rest arguments and keyword +;;; processing. +(defmacro with-medium-and-options ((sheet + &key ink clipping-region transformation + line-unit line-thickness + line-style line-style-p + line-dashes dashes-p + line-joint-shape line-cap-shape + text-style text-style-p + text-family text-family-p + text-face text-face-p + text-size text-size-p) + (medium) + &body body) + (with-gensyms (continuation sheet-medium) + `(flet ((,continuation (,medium) + ,@body)) + (declare (dynamic-extent #',continuation)) + (with-sheet-medium (,sheet-medium ,sheet) + (do-graphics-with-options-internal-1 + ,sheet-medium #'continuation + ,ink ,clipping-region ,transformation + ,line-unit ,line-thickness + ,line-style ,line-style-p + ,line-dashes ,dashes-p + ,line-joint-shape ,line-cap-shape + ,text-style ,text-style-p + ,text-family ,text-family-p + ,text-face ,text-face-p + ,text-size ,text-size-p)))) + ) + (defmethod do-graphics-with-options ((sheet sheet) func &rest options) (with-sheet-medium (medium sheet) (apply #'do-graphics-with-options-internal medium sheet func options))) @@ -130,15 +162,15 @@ (apply #'do-graphics-with-options ,sheet #'graphics-op ,args))) (defmacro with-drawing-options ((medium &rest drawing-options) &body body) - (when (eq medium t) - (setq medium '*standard-output*)) - (check-type medium symbol) - (let ((gcontinuation (gensym))) - `(flet ((,gcontinuation (,medium) - ,@body)) - #-clisp (declare (dynamic-extent #',gcontinuation)) - (apply #'invoke-with-drawing-options - ,medium #',gcontinuation (list ,@drawing-options))))) + (setq medium (stream-designator-symbol medium '*standard-output*)) + (with-gensyms (gcontinuation cont-arg) + `(flet ((,gcontinuation (,cont-arg) + (declare (ignore ,cont-arg)) + ,@body)) + #-clisp (declare (dynamic-extent #',gcontinuation)) + (apply #'invoke-with-drawing-options + ,medium #',gcontinuation (list ,@drawing-options))))) + (defmethod invoke-with-drawing-options ((medium medium) continuation &rest drawing-options @@ -151,8 +183,8 @@ (defmethod invoke-with-drawing-options ((sheet sheet) continuation &rest drawing-options) (with-sheet-medium (medium sheet) - (with-medium-options (medium drawing-options) - (funcall continuation sheet)))) + (with-medium-options (medium drawing-options) + (funcall continuation medium)))) ;;; Compatibility with real CLIM (defmethod invoke-with-drawing-options ((sheet t) continuation @@ -160,11 +192,23 @@ (declare (ignore drawing-options)) (funcall continuation sheet)) -(defmethod invoke-with-identity-transformation (medium cont) - (with-drawing-options (medium - :transformation (invert-transformation - (medium-transformation medium))) - (funcall cont medium))) +(defmethod invoke-with-identity-transformation + ((sheet sheet) continuation) + (with-sheet-medium (medium sheet) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation sheet)))) + + +(defmethod invoke-with-identity-transformation + ((destination pixmap) continuation) + (with-pixmap-medium (medium destination) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation destination)))) + +(defmethod invoke-with-identity-transformation + ((medium medium) continuation) + (letf (((medium-transformation medium) +identity-transformation+)) + (funcall continuation medium))) (defmethod invoke-with-local-coordinates (medium cont x y) ;; For now we do as real CLIM does. @@ -653,6 +697,13 @@ (copy-area (sheet-medium stream) from-x from-y width height to-x to-y) (error "COPY-AREA on a stream is not implemented"))) +;;; XXX The modification of the sheet argument to hold the pixmap medium seems +;;; completely incorrect here; the description of the macro in the spec says +;;; nothing about that. On the other hand, the spec talks about "medium-var" +;;; when that is clearly meant to be a stream (and an output-recording stream +;;; at that, if the example in the Franz user guide is to be believed). What a +;;; mess. I think we need a pixmap output recording stream in order to do this +;;; right. -- moore (defmacro with-output-to-pixmap ((medium-var sheet &key width height) &body body) `(let* ((pixmap (allocate-pixmap ,sheet ,width ,height)) ; XXX size might be unspecified -- APD (,medium-var (make-medium (port ,sheet) pixmap)) Index: mcclim/recording.lisp diff -u mcclim/recording.lisp:1.115 mcclim/recording.lisp:1.116 --- mcclim/recording.lisp:1.115 Thu Oct 14 08:30:11 2004 +++ mcclim/recording.lisp Wed Feb 2 12:33:58 2005 @@ -2190,43 +2190,62 @@ (call-next-method))) ;;; ---------------------------------------------------------------------------- - +;;; Complicated, underspecified... +;;; +;;; From examining old Genera documentation, I believe that +;;; with-room-for-graphics is supposed to set the medium transformation to +;;; give the desired coordinate system; i.e., it doesn't preserve any +;;; rotation, scaling or translation in the current medium transformation. (defmethod invoke-with-room-for-graphics (cont stream - &key (first-quadrant t) - height - (move-cursor t) - (record-type 'standard-sequence-output-record)) + &key (first-quadrant t) + height + (move-cursor t) + (record-type + 'standard-sequence-output-record)) ;; I am not sure what exactly :height should do. ;; --GB 2003-05-25 ;; The current behavior is consistent with 'classic' CLIM ;; --Hefner 2004-06-19 + ;; Don't know if it still is :) + ;; -- Moore 2005-01-26 (multiple-value-bind (cx cy) (stream-cursor-position stream) - (let ((record - (with-output-recording-options (stream :draw nil :record t) - (with-new-output-record (stream record-type) - (with-drawing-options - (stream :transformation - (if first-quadrant - (make-scaling-transformation 1 -1) - +identity-transformation+)) - (funcall cont stream)))))) - (cond ((null height) - (setf (output-record-position record) - (values cx cy))) - (t - (setf (output-record-position record) - (values cx - (- cy (- (bounding-rectangle-height record) height)))))) - (with-output-recording-options (stream :draw t :record nil) - (replay-output-record record stream)) - (cond (move-cursor - (setf (stream-cursor-position stream) - (values (bounding-rectangle-max-x record) - (bounding-rectangle-max-y record)))) - (t - (setf (stream-cursor-position stream) - (values cx cy))))))) + (with-sheet-medium (medium stream) + (letf (((medium-transformation medium) + (if first-quadrant + (make-scaling-transformation 1 -1) + +identity-transformation+))) + (let ((record (with-output-to-output-record (stream record-type) + (funcall cont stream)))) + ;; Bounding rectangle is in sheet coordinates! + (with-bounding-rectangle* (x1 y1 x2 y2) + record + (declare (ignore x2)) + (if first-quadrant + (setf (output-record-position record) + (values (max cx (+ cx x1)) + (if height + (max cy (+ cy (- height (- y2 y1)))) + cy))) + (setf (output-record-position record) + (values (max cx (+ cx x1)) (max cy (+ cy y1))))) + (when (stream-recording-p stream) + (stream-add-output-record stream record)) + (when (stream-drawing-p stream) + (replay record stream)) + (if move-cursor + (let ((record-height (- y2 y1))) + (setf (stream-cursor-position stream) + (values cx + (if first-quadrant + (+ cy (max (- y1) + (or height 0) + record-height)) + (+ cy (max (or height 0) + record-height)))))) + (setf (stream-cursor-position stream) (values cx cy))) + record)))))) + (defmethod repaint-sheet ((sheet output-recording-stream) region) Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.52 mcclim/stream-output.lisp:1.53 --- mcclim/stream-output.lisp:1.52 Sun Oct 31 02:46:31 2004 +++ mcclim/stream-output.lisp Wed Feb 2 12:33:59 2005 @@ -426,6 +426,7 @@ non-nil, that is used as the width where needed; otherwise STREAM-STRING-WIDTH will be called.")) +;;; The cursor is in stream coordinates. (defmethod stream-write-output (stream line string-width &optional (start 0) end) (declare (ignore string-width)) @@ -433,6 +434,7 @@ (multiple-value-bind (cx cy) (stream-cursor-position stream) (draw-text* (sheet-medium stream) line cx (+ cy baseline) + :transformation +identity-transformation+ :start start :end end)))) (defmethod stream-write-char ((stream standard-extended-output-stream) char) Index: mcclim/utils.lisp diff -u mcclim/utils.lisp:1.39 mcclim/utils.lisp:1.40 --- mcclim/utils.lisp:1.39 Mon Dec 20 16:50:22 2004 +++ mcclim/utils.lisp Wed Feb 2 12:33:59 2005 @@ -452,7 +452,7 @@ (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) (defun stream-designator-symbol (symbol default) - "Maps T to *standard-output*, barfs if argument does not look good. + "Maps T to DEFAULT, barfs if argument does not look good. To be used in the various WITH-... macros." (cond ((eq symbol 't) default)

1 0

[mcclim-cvs] CVS update: mcclim/transforms.lisp
by tmoore＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv27090 Modified Files: transforms.lisp Log Message: comments from the peanut gallery Date: Wed Feb 2 11:18:59 2005 Author: tmoore Index: mcclim/transforms.lisp diff -u mcclim/transforms.lisp:1.28 mcclim/transforms.lisp:1.29 --- mcclim/transforms.lisp:1.28 Wed Oct 6 14:03:56 2004 +++ mcclim/transforms.lisp Wed Feb 2 11:18:58 2005 @@ -4,7 +4,7 @@ ;;; Created: 1998-09-29 ;;; Author: Gilbert Baumann <unk6(a)rz.uni-karlsruhe.de> ;;; License: LGPL (See file COPYING for details). -;;; $Id: transforms.lisp,v 1.28 2004/10/06 12:03:56 moore Exp $ +;;; $Id: transforms.lisp,v 1.29 2005/02/02 10:18:58 tmoore Exp $ ;;; -------------------------------------------------------------------------------------- ;;; (c) copyright 1998,1999,2003 by Gilbert Baumann ;;; (c) copyright 2000 by @@ -434,8 +434,13 @@ ;; transformation. To use WITH-DRAWING-OPTIONS which concatenates the the ;; transformation given to the existing one we just pass the inverse. ;; - ;; Further we don't use LETF since it is a pretty much broken idea in case - ;; of multithreading. + ;; "Further we don't use LETF since it is a pretty much broken idea in case + ;; of multithreading." -- gilbert + ;; + ;; "That may be, but all of the transformation functions/macros are + ;; going to set the medium state at some point (see + ;; with-drawing-options), and that's not thread-safe either. So I + ;; say, 'just use LETF.'" -- moore ;; ;; Q: Do we want a invoke-with-identity-transformation? ;;

1 0

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

02 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv27047 Modified Files: inspector.lisp Log Message: Peter Scott's patch to use clim-mop in the inspector Date: Wed Feb 2 11:16:59 2005 Author: tmoore Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.8 mcclim/Apps/Inspector/inspector.lisp:1.9 --- mcclim/Apps/Inspector/inspector.lisp:1.8 Wed Feb 2 10:33:49 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 2 11:16:59 2005 @@ -81,35 +81,6 @@ (pane object (presentation-type-of object)) (print object pane))) -(defun class-slots (class) - #+sbcl (sb-mop:class-slots class) - #+openmcl (ccl:class-slots class) - #-(or sbcl openmcl) (error "no MOP")) - -(defun slot-definition-name (slot) - #+sbcl (sb-mop:slot-definition-name slot) - #+openmcl (ccl:slot-definition-name slot) - #-(or sbcl openmcl) (error "no MOP")) - -(defun generic-function-name (generic-function) - #+sbcl (sb-mop:generic-function-name generic-function) - #+openmcl (ccl:generic-function-name generic-function) - #-(or sbcl openmcl) (error "no MOP")) - -(defun generic-function-methods (generic-function) - #+sbcl (sb-mop:generic-function-methods generic-function) - #+openmcl (ccl:generic-function-methods generic-function) - #-(or sbcl openmcl) (error "no MOP")) - -(defun method-specializers (method) - #+sbcl (sb-mop:method-specializers method) - #+openmcl (ccl:method-specializers method) - #-(or sbcl openmcl) (error "no MOP")) - -(defun method-generic-function (method) - #+sbcl (sb-mop:method-generic-function method) - #+openmcl (ccl:method-generic-function method) - #-(or sbcl openmcl) (error "no MOP")) (define-presentation-type settable-slot () :inherit-from t) @@ -148,8 +119,8 @@ (let ((class (class-of object))) (inspector-table (print (class-name class) pane) - (loop for slot in (reverse (class-slots class)) - do (let ((slot-name (slot-definition-name slot))) + (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) @@ -202,14 +173,15 @@ (defmethod inspect-object ((object generic-function) pane) (inspector-table - (format pane "Generic Function: ~s" (generic-function-name object)) - (loop for method in (generic-function-methods object) + (format pane "Generic Function: ~s" + (clim-mop:generic-function-name object)) + (loop for method in (clim-mop:generic-function-methods object) do (with-output-as-presentation (pane method (presentation-type-of method)) (formatting-row (pane) (formatting-cell (pane) (print (method-qualifiers method))) - (loop for specializer in (method-specializers method) + (loop for specializer in (clim-mop:method-specializers method) do (formatting-cell (pane) (format pane "~s " (class-name specializer))))))))) @@ -335,7 +307,7 @@ (define-inspector-command (com-remove-method :name t) ((obj 'method :gesture :delete :prompt "Remove method")) - (remove-method (method-generic-function obj) obj)) + (remove-method (clim-mop:method-generic-function obj) obj)) (define-inspector-command (com-set-slot :name t) ((slot 'settable-slot :gesture :select :prompt "Set slot"))

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/clouseau.asd mcclim/Apps/Inspector/inspector.lisp mcclim/Apps/Inspector/inspector.asd
by tmoore＠common-lisp.net 02 Feb '05

02 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv24562 Modified Files: inspector.lisp Added Files: clouseau.asd Removed Files: inspector.asd Log Message: Changed name of inspector system and package to clouseau in order to avoid conflicts with system inspectors. Date: Wed Feb 2 10:33:49 2005 Author: tmoore Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.7 mcclim/Apps/Inspector/inspector.lisp:1.8 --- mcclim/Apps/Inspector/inspector.lisp:1.7 Sun Jan 30 07:02:56 2005 +++ mcclim/Apps/Inspector/inspector.lisp Wed Feb 2 10:33:49 2005 @@ -22,7 +22,7 @@ ;;; CLIM inspector application -(in-package :inspector) +(in-package :clouseau) (define-application-frame inspector () ((dico :initform (make-hash-table) :reader dico)

1 0