mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS update: mcclim/Doc/manual.tex
by rstrandh＠common-lisp.net 07 Apr '05

07 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Doc In directory common-lisp.net:/tmp/cvs-serv21370 Modified Files: manual.tex Log Message: Applied patch from R P Goldman. Thanks! Date: Thu Apr 7 09:54:59 2005 Author: rstrandh Index: mcclim/Doc/manual.tex diff -u mcclim/Doc/manual.tex:1.26 mcclim/Doc/manual.tex:1.27 --- mcclim/Doc/manual.tex:1.26 Fri Mar 11 23:34:59 2005 +++ mcclim/Doc/manual.tex Thu Apr 7 09:54:59 2005 @@ -7,6 +7,11 @@ \usepackage{alltt} \usepackage{moreverb} +\ifx\pdfoutput\undefined \csname newcount\endcsname\pdfoutput \fi +\ifcase\pdfoutput \else +\usepackage[pdftex]{hyperref} +\fi + \setlength{\parskip}{0.3cm} \setlength{\parindent}{0cm} @@ -372,7 +377,7 @@ \begin{figure} \begin{center} -\inputfig{ex2.pstex_t} +\includegraphics{ex2} \end{center} \caption{\label{figex2} View of the improved example} \end{figure} @@ -643,8 +648,9 @@ c. Mirrors are outlined with dotted rectangles. \begin{figure} -\begin{center} -\inputfig{native.pstex_t} + \begin{center} + \input native.pstex_t +%\inputfig{native.pstex_t} \end{center} \caption{\label{fignative} A sheet with a nontrivial transformation} \end{figure} @@ -1576,7 +1582,7 @@ The new cons cell diagram format looks like this: \begin{center} -\includegraphics{inspect-as-cells.eps} +\includegraphics{inspect-as-cells} \end{center} \section{Extending Clouseau} @@ -1718,7 +1724,7 @@ the right. This gives us some reasonably nice-looking output: \begin{center} -\includegraphics{inspect-object-1.eps} +\includegraphics{inspect-object-1} \end{center} But what we really want is something more closely adapted to our @@ -1754,7 +1760,7 @@ to \cl{x=y} and we're done. It looks like this: \begin{center} -\includegraphics{inspect-object-2.eps} +\includegraphics{inspect-object-2} \end{center} Finally, for our amusement and further practice, we'll try to get some @@ -1816,7 +1822,7 @@ Our final version looks like this: \begin{center} -\includegraphics{inspect-object-3.eps} +\includegraphics{inspect-object-3} \end{center} For more examples of how to extend the inspector, you can look at

1 0

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

05 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv23885/Backends/CLX Modified Files: port.lisp Log Message: Fix the new $DISPLAY parsing code after feedback from rpg. Date: Tue Apr 5 22:09:29 2005 Author: crhodes Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.110 mcclim/Backends/CLX/port.lisp:1.111 --- mcclim/Backends/CLX/port.lisp:1.110 Sun Apr 3 00:18:20 2005 +++ mcclim/Backends/CLX/port.lisp Tue Apr 5 22:09:29 2005 @@ -194,8 +194,8 @@ (t :internet)))) (list :clx :host (getf path :host host) - :display-id (getf path :display-id display) - :screen-id (getf path :screen-id screen) + :display-id (getf path :display-id (or display 0)) + :screen-id (getf path :screen-id (or screen 0)) :protocol protocol))) (setf (get :x11 :port-type) 'clx-port) @@ -268,7 +268,9 @@ (defmethod initialize-clx ((port clx-port)) (let ((options (cdr (port-server-path port)))) (setf (clx-port-display port) - (xlib:open-display (getf options :host "") :display (getf options :display-id 0) :protocol (getf options :protocol :local))) + (xlib:open-display (getf options :host) + :display (getf options :display-id) + :protocol (getf options :protocol))) (progn (setf (xlib:display-error-handler (clx-port-display port)) #'clx-error-handler) @@ -277,7 +279,7 @@ (setf (xlib:display-after-function (clx-port-display port)) #'xlib:display-force-output)) - (setf (clx-port-screen port) (nth (getf options :screen-id 0) + (setf (clx-port-screen port) (nth (getf options :screen-id) (xlib:display-roots (clx-port-display port)))) (setf (clx-port-window port) (xlib:screen-root (clx-port-screen port))) (make-cursor-table port)

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by crhodes＠common-lisp.net 02 Apr '05

02 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv9380/Backends/CLX Modified Files: port.lisp Log Message: Fix clim-over-ssh-x-fails, by parsing $DISPLAY more correctly. Date: Sun Apr 3 00:18:21 2005 Author: crhodes Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.109 mcclim/Backends/CLX/port.lisp:1.110 --- mcclim/Backends/CLX/port.lisp:1.109 Tue Mar 22 13:31:22 2005 +++ mcclim/Backends/CLX/port.lisp Sun Apr 3 00:18:20 2005 @@ -170,16 +170,33 @@ (defun parse-clx-server-path (path) (pop path) - (let* ((s (get-environment-variable "DISPLAY")) - (colon (position #\: s)) - (dot (position #\. s :start colon)) - (host-name (subseq s 0 colon)) - (display-number (parse-integer s :start (1+ colon) :end dot)) - (screen-number (if dot (parse-integer s :start (1+ dot)) 0))) + (let* ((name (get-environment-variable "DISPLAY")) + ;; this code courtesy telent-clx. + (slash-i (or (position #\/ name) -1)) + (colon-i (position #\: name :start (1+ slash-i))) + (decnet-colon-p (eql (elt name (1+ colon-i)) #\:)) + (host (subseq name (1+ slash-i) colon-i)) + (dot-i (and colon-i (position #\. name :start colon-i))) + (display (when colon-i + (parse-integer name + :start (if decnet-colon-p + (+ colon-i 2) + (1+ colon-i)) + :end dot-i))) + (screen (when dot-i + (parse-integer name :start (1+ dot-i)))) + (protocol + (cond ((or (string= host "") (string-equal host "unix")) :local) + (decnet-colon-p :decnet) + ((> slash-i -1) (intern + (string-upcase (subseq name 0 slash-i)) + :keyword)) + (t :internet)))) (list :clx - :host (getf path :host host-name) - :display-id (getf path :display-id display-number) - :screen-id (getf path :screen-id screen-number)))) + :host (getf path :host host) + :display-id (getf path :display-id display) + :screen-id (getf path :screen-id screen) + :protocol protocol))) (setf (get :x11 :port-type) 'clx-port) (setf (get :x11 :server-path-parser) 'parse-clx-server-path) @@ -251,7 +268,7 @@ (defmethod initialize-clx ((port clx-port)) (let ((options (cdr (port-server-path port)))) (setf (clx-port-display port) - (xlib:open-display (getf options :host "") :display (getf options :display-id 0))) + (xlib:open-display (getf options :host "") :display (getf options :display-id 0) :protocol (getf options :protocol :local))) (progn (setf (xlib:display-error-handler (clx-port-display port)) #'clx-error-handler)

1 0

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

02 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv27378 Modified Files: inspector.lisp Log Message: Fixed problems with PRINT-DOCUMENTATION, which turned out to be more complicated than I thought. It should work on ACL now. Date: Sat Apr 2 20:03:59 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.30 mcclim/Apps/Inspector/inspector.lisp:1.31 --- mcclim/Apps/Inspector/inspector.lisp:1.30 Fri Mar 18 21:51:29 2005 +++ mcclim/Apps/Inspector/inspector.lisp Sat Apr 2 20:03:59 2005 @@ -157,7 +157,11 @@ (formatting-cell (,evaluated-pane) (formatting-table (,evaluated-pane) ,@body)))) - (print-documentation ,evaluated-object ,evaluated-pane))))) + (print-documentation (if (eql (class-of ,evaluated-object) + (find-class 'standard-class)) + ,evaluated-object + (class-of ,evaluated-object)) + ,evaluated-pane))))) (defmacro inspector-table-row ((pane) left right) "Output a table row with two items, produced by evaluating LEFT and @@ -182,10 +186,15 @@ (princ ,label ,evaluated-pane) (inspect-object ,value ,evaluated-pane))))))) +;; The error handler shouldn't be necessary, but it works around an +;; ACL bug and shouldn't mess anything up on other lisps. The warning +;; handler is there in case DOCUMENTATION raises a warning, to tell +;; lisp that we don't care and it shouldn't go alarming the user. (defun print-documentation (object pane) "Print OBJECT's documentation, if any, to PANE" - (when (handler-bind ((warning #'muffle-warning)) - (documentation object t)) + (when (handler-case (documentation object t) + (error ()) + (warning ())) (with-heading-style (pane) (format pane "~&Documentation: ")) (princ (documentation object t) pane)))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by crhodes＠common-lisp.net 22 Mar '05

22 Mar '05

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

1 0

[mcclim-cvs] CVS update: mcclim/package.lisp mcclim/text-selection.lisp
by crhodes＠common-lisp.net 22 Mar '05

22 Mar '05

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)

1 0

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

18 Mar '05

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"

1 0

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

17 Mar '05

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) - ,@body)) + ,@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 "#<unbound slot>"))))) + (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 "#<unbound slot>")))))))) + (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)

1 0

[mcclim-cvs] CVS update: mcclim/panes.lisp mcclim/utils.lisp
by tmoore＠common-lisp.net 14 Mar '05

14 Mar '05

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) + ,@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 + ;; <pane> + ((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+ <pane>) + ((and (consp content) + (or (member (car content) '(+fill+ :fill)) + (eql (car content) +fill+))) + (make-instance 'box-client + :pane (cadr content) + :fillp t)) + ;; <n> + ;; + ;; what about something like (30 :mm) ? + ;; + ((and (realp content) (>= content 0)) + (make-instance 'box-client + :pane nil + :fixed-size content)) + + ;; (<n> 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) - ,@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 - ;; <pane> - ((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+ <pane>) - ((and (consp content) - (or (member (car content) '(+fill+ :fill)) - (eql (car content) +fill+))) - (make-instance 'box-client - :pane (cadr content) - :fillp t)) - ;; <n> - ;; - ;; what about something like (30 :mm) ? - ;; - ((and (realp content) (>= content 0)) - (make-instance 'box-client - :pane nil - :fixed-size content)) - - ;; (<n> 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))))

1 0

[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
by pscott＠common-lisp.net 11 Mar '05

11 Mar '05

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}.

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs