mcclim-cvs April 2005

mcclim-cvs@common-lisp.net

5 participants
16 discussions

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

26 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv26618 Modified Files: inspector.lisp Log Message: When inspecting packages, Clouseau now lists exported symbols. Date: Tue Apr 26 23:35:24 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.31 mcclim/Apps/Inspector/inspector.lisp:1.32 --- mcclim/Apps/Inspector/inspector.lisp:1.31 Sat Apr 2 20:03:59 2005 +++ mcclim/Apps/Inspector/inspector.lisp Tue Apr 26 23:35:24 2005 @@ -512,6 +512,12 @@ (with-text-family (pane :fix) (princ (package-name object) pane)))) +(defun package-exported-symbols (package) + "Return a list of all symbols exported by PACKAGE" + (let (symbols) + (do-external-symbols (symbol package symbols) + (push symbol symbols)))) + (defmethod inspect-object ((object package) pane) (inspector-table (object pane) (format pane "Package: ~S" (package-name object)) @@ -526,7 +532,10 @@ (inspect-vertical-list (package-used-by-list object) pane)) (inspector-table-row (pane) (princ "Uses:") - (inspect-vertical-list (package-use-list object) pane)))) + (inspect-vertical-list (package-use-list object) pane)) + (inspector-table-row (pane) + (princ "Exports:") + (inspect-vertical-list (package-exported-symbols object) pane)))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Debugger/clim-debugger.lisp
by ahefner＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Debugger In directory common-lisp.net:/tmp/cvs-serv26063/Debugger Added Files: clim-debugger.lisp Log Message: Checking in Peter Mechlenborg's CLIM debugger. Date: Tue Apr 26 05:19:35 2005 Author: ahefner

1 0

[mcclim-cvs] CVS update: Directory change: mcclim/Apps/Debugger
by ahefner＠common-lisp.net 26 Apr '05

26 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Debugger In directory common-lisp.net:/tmp/cvs-serv26023/Debugger Log Message: Directory /project/mcclim/cvsroot/mcclim/Apps/Debugger added to the repository Date: Tue Apr 26 05:16:16 2005 Author: ahefner New directory mcclim/Apps/Debugger added

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 23 Apr '05

23 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29580 Modified Files: graph-formatting.lisp Log Message: Check type of root-objects argument. Date: Sat Apr 23 22:02:02 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.13 mcclim/graph-formatting.lisp:1.14 --- mcclim/graph-formatting.lisp:1.13 Thu Apr 21 05:34:58 2005 +++ mcclim/graph-formatting.lisp Sat Apr 23 22:02:01 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.13 2005/04/21 03:34:58 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.14 2005/04/23 20:02:01 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -133,6 +133,7 @@ (declare (ignore orientation generation-separation within-generation-separation center-nodes)) ;; Mungle some arguments (check-type cutoff-depth (or null integer)) + (check-type root-objects sequence) (setf stream (or stream *standard-output*) graph-type (or graph-type (if merge-duplicates :digraph :tree)) duplicate-key (or duplicate-key #'identity)

1 0

[mcclim-cvs] CVS update: mcclim/Apps/Listener/dev-commands.lisp
by ahefner＠common-lisp.net 21 Apr '05

21 Apr '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory common-lisp.net:/tmp/cvs-serv28867 Modified Files: dev-commands.lisp Log Message: Applied patched from Paolo adding vertical grapher orientation to listener commands. Date: Thu Apr 21 05:41:24 2005 Author: ahefner Index: mcclim/Apps/Listener/dev-commands.lisp diff -u mcclim/Apps/Listener/dev-commands.lisp:1.28 mcclim/Apps/Listener/dev-commands.lisp:1.29 --- mcclim/Apps/Listener/dev-commands.lisp:1.28 Sun Jan 2 06:14:28 2005 +++ mcclim/Apps/Listener/dev-commands.lisp Thu Apr 21 05:41:24 2005 @@ -434,7 +434,7 @@ (defparameter *graph-edge-ink* (make-rgb-color 0.72 0.72 0.72)) (defparameter *graph-text-style* (make-text-style :fix :roman :normal)) -(defun class-grapher (stream class inferior-fun) +(defun class-grapher (stream class inferior-fun &key (orientation :horizontal)) "Does the graphing for Show Class Superclasses and Subclasses commands" (let ((normal-ink +foreground-ink+) (arrow-ink *graph-edge-ink*) @@ -453,7 +453,7 @@ :stream stream :merge-duplicates T :graph-type :tree - :orientation :horizontal + :orientation orientation :arc-drawer #'(lambda (stream foo bar x1 y1 x2 y2) (declare (ignore foo bar)) @@ -468,20 +468,26 @@ :command-table show-commands :menu "Class Superclasses" :provide-output-destination-keyword t) - ((class-spec 'class-name :prompt "class")) + ((class-spec 'class-name :prompt "class") + &key + (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (null class) (note "~A is not a defined class." class-spec) - (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses)))) + (class-grapher *standard-output* class #'clim-mop:class-direct-superclasses + :orientation orientation)))) (define-command (com-show-class-subclasses :name "Show Class Subclasses" :command-table show-commands :menu "Class Subclasses" :provide-output-destination-keyword t) - ((class-spec 'class-name :prompt "class")) + ((class-spec 'class-name :prompt "class") + &key + (orientation 'keyword :prompt "orientation" :default :horizontal)) (let ((class (frob-to-class class-spec))) (if (not (null class)) - (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses) + (class-grapher *standard-output* class #'clim-mop:class-direct-subclasses + :orientation orientation) (note "~A is not a defined class." class-spec))))

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 21 Apr '05

21 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28776 Modified Files: graph-formatting.lisp Log Message: Fix bug causing misalignment of graph nodes and edges when using a non-identity medium transformation. (Tranform node positions by medium transformation before inserting into output history, then draw edges in stream coordinates with no medium transformation, so that medium transformation is not applied twice.) Date: Thu Apr 21 05:34:58 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.12 mcclim/graph-formatting.lisp:1.13 --- mcclim/graph-formatting.lisp:1.12 Tue Apr 12 22:43:26 2005 +++ mcclim/graph-formatting.lisp Thu Apr 21 05:34:58 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.12 2005/04/12 20:43:26 ahefner Exp $ +;;; $Id: graph-formatting.lisp,v 1.13 2005/04/21 03:34:58 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -338,8 +338,8 @@ (let ((v (+ v0 (/ (min 0 d) -2)))) (setf (output-record-position node) (if (eq orientation :vertical) - (values v u0) - (values u0 v))) + (transform-position (medium-transformation stream) v u0) + (transform-position (medium-transformation stream) u0 v))) (add-output-record node graph-output-record)) ;; (let ((u (+ u0 (car majors))) @@ -401,6 +401,11 @@ (defmethod layout-graph-edges ((graph standard-graph-output-record) stream arc-drawer arc-drawing-options) (with-slots (orientation) graph + ;; We tranformed the position of the nodes when we inserted them into + ;; output history, so the bounding rectangles queried below will be + ;; transformed. Therefore, disable the transformation now, otherwise + ;; the transformation is effectively applied twice to the edges. + (with-identity-transformation (stream) (traverse-graph-nodes graph (lambda (node children continuation) (unless (eq node graph) @@ -424,7 +429,7 @@ (/ (+ x1 x2) 2) from (/ (+ u1 u2) 2) to arc-drawing-options)))))))) - (map nil continuation children))))) + (map nil continuation children)))))) (defmethod layout-graph-edges :around ((graph-output-record tree-graph-output-record) stream arc-drawer arc-drawing-options)

1 0

[mcclim-cvs] CVS update: mcclim/stream-output.lisp
by ahefner＠common-lisp.net 21 Apr '05

21 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv25453 Modified Files: stream-output.lisp Log Message: Fix assumption in BEEP function that standard output must be a CLIM stream. Date: Thu Apr 21 04:43:20 2005 Author: ahefner Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.54 mcclim/stream-output.lisp:1.55 --- mcclim/stream-output.lisp:1.54 Sun Apr 17 18:42:47 2005 +++ mcclim/stream-output.lisp Thu Apr 21 04:43:19 2005 @@ -540,9 +540,10 @@ ,@body)) (defmethod beep (&optional medium) - (when (null medium) - (setq medium (sheet-medium *standard-output*))) - (medium-beep medium)) - + (if medium + (medium-beep medium) + (when (sheetp *standard-output*) + (medium-beep (sheet-medium *standard-output*))))) + (defmethod scroll-quantum ((sheet standard-extended-output-stream)) (stream-line-height sheet))

1 0

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

19 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv24657 Modified Files: mcclim.asd Log Message: Make Allegro CL a McCLIM/asdf-supported lisp. Thanks for the patch go to rpgoldman. Date: Wed Apr 20 00:35:42 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.4 mcclim/mcclim.asd:1.5 --- mcclim/mcclim.asd:1.4 Tue Mar 1 16:46:13 2005 +++ mcclim/mcclim.asd Wed Apr 20 00:35:42 2005 @@ -48,6 +48,21 @@ #+mp (when (eq mp::*initial-process* mp::*current-process*) (format t "~%~%You need to run (mp::startup-idle-and-top-level-loops) to start up the multiprocessing support.~%~%"))) +;;; Make CLX asdf-loadable on Allegro 6.2 +;;; possibly this should be further refined to funciton properly for +;;; Allegro on Windows platforms. [2005/04/18:rpg] +#+allegro +(progn + (defclass requireable-system (asdf:system) + ()) + (defmethod asdf:perform ((op asdf:load-op) (system requireable-system)) + (require (intern (slot-value system 'asdf::name) "KEYWORD"))) + (defmethod asdf::traverse ((op asdf:load-op) (system requireable-system)) + (list (cons op system))) + (defsystem :clx + :class requireable-system)) + + (pushnew :clim *features*) (pushnew :mcclim *features*) @@ -216,7 +231,7 @@ )) (defsystem :clim-clx - :depends-on (:clim #+(or sbcl openmcl ecl) :clx) + :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) :components ((:module "Backends/CLX" :pathname #.(make-pathname :directory '(:relative "Backends" "CLX")) @@ -276,7 +291,7 @@ :depends-on (:clim ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl openmcl ecl clx) :clim-clx + #+(or sbcl openmcl ecl clx allegro) :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X).

1 0

[mcclim-cvs] CVS update: mcclim/frames.lisp
by ahefner＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv1008 Modified Files: frames.lisp Log Message: Check in nyef's partial fix for changing frame layouts. Added comment protesting default of :use-keystrokes t in the spec. Corrected a spelling error. Date: Sun Apr 17 20:46:27 2005 Author: ahefner Index: mcclim/frames.lisp diff -u mcclim/frames.lisp:1.106 mcclim/frames.lisp:1.107 --- mcclim/frames.lisp:1.106 Tue Feb 22 04:14:17 2005 +++ mcclim/frames.lisp Sun Apr 17 20:46:26 2005 @@ -272,8 +272,11 @@ (defmethod (setf frame-current-layout) :after (name (frame application-frame)) (declare (ignore name)) - (generate-panes (frame-manager frame) frame) - (signal 'frame-layout-changed :frame frame)) + (when (frame-manager frame) + (generate-panes (frame-manager frame) frame) + (multiple-value-bind (w h) (frame-geometry* frame) + (layout-frame frame w h)) + (signal 'frame-layout-changed :frame frame))) (defmethod generate-panes :before (fm (frame application-frame)) (declare (ignore fm)) @@ -578,6 +581,12 @@ (defmethod read-frame-command ((frame application-frame) &key (stream *standard-input*)) + ;; The following is the correct interpretation according to the spec. + ;; I think it is terribly counterintuitive and want to look into + ;; what existing CLIMs do before giving in to it. + ;; If we do things as the spec says, command accelerators will + ;; appear to not work, confusing new users. + #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) (defmethod execute-frame-command ((frame application-frame) command) @@ -876,11 +885,11 @@ ,@(if command-table `((define-command-table ,@command-table))) ,@(if command-definer - `((defmacro ,command-definer (name-and-options arguements &rest body) + `((defmacro ,command-definer (name-and-options arguments &rest body) (let ((name (if (listp name-and-options) (first name-and-options) name-and-options)) (options (if (listp name-and-options) (cdr name-and-options) nil)) (command-table ',(first command-table))) - `(define-command (,name :command-table ,command-table ,@options) ,arguements ,@body)))))))) + `(define-command (,name :command-table ,command-table ,@options) ,arguments ,@body)))))))) (defun get-application-frame-class-geometry (name indicator) (getf (get name 'application-frame-geometry) indicator nil))

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv29185 Modified Files: gadgets.lisp Log Message: Answer anonymous wish for an :active-p initarg, but call it :active instead, as classic CLIM appeared to. Added documentation to the list-pane and option-pane listing what is left to be done, some performance considerations, user behavior, and extensions beyond the CLIM spec. Various fixes and cleanups to the list and option panes. Made it capable of handling an unbound gadget-value. Cleaned up the (still) scary event loop that manages the popup menu for option-pane. Fixed some bugs whose details I've forgotten. Also fixed bogus slot type declaration reported by David Christiansen last month. Date: Sun Apr 17 19:30:26 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.88 mcclim/gadgets.lisp:1.89 --- mcclim/gadgets.lisp:1.88 Fri Feb 25 07:03:02 2005 +++ mcclim/gadgets.lisp Sun Apr 17 19:30:26 2005 @@ -85,8 +85,6 @@ ;; - Should RADIO-BOX-PANE and CHECK-BOX-PANE use rack or box layout? -;; - I would like to have a :ACTIVE-P initarg - ;; - :CHOICES initarg to RADIO-BOX and CHECK-BOX is from Franz' user ;; guide. @@ -144,7 +142,8 @@ ;; ACTIVATE-GADGET after creating a gadget? ;; ;; I think, T is correct here --GB - (active-p :initform t + + (active-p :initform t :initarg :active :reader gadget-active-p) ;; ;; I am not so lucky with the armed slot in GADGET --GB @@ -1954,7 +1953,33 @@ ;; things in their list pane. Instead of :exclusive and :nonexclusive modes, ;; they call them :one-of and :some-of. I've supported these aliases for ;; compatibility. They also state the default mode is :some-of, which -;; contradicts the CLIM 2.0 Spec. Our default does not. +;; contradicts the CLIM 2.0 Spec and doesn't make a lot of sense. +;; McCLIM defaults to :one-of. + +;; TODO: Improve performance in order to scale to extremely large lists. +;; * Computing text-size for a 100k list items is expensive +;; * Need to share text size and cache of computed name-key/value-key +;; results with LIST-PANE when instantiated in the popup for +;; the OPTION-PANE. +;; * Improve repaint logic when items are selected to reduce flicker. +;; Currently the list and option panes are usable up to several thousand +;; items on a reasonably fast P4. + +;; TODO: Consider appearance of nonexclusive option-pane when multiple items are +;; selected. + +;; TODO: I think the list/option gadgets currently ignore enabled/disabled status. + +;; Notes +;; A some-of/nonexclusive list pane (or option-pane popup window) supports +;; the following behaviors: +;; single-click: toggle selected item +;; shift-click: select/deselect multiple items. Selection or deselection +;; is chosen according to the result of your previous click. +;; McCLIM adds an initarg :prefer-single-selection. If true, a nonexclusive pane +;; will deselect other items selected when a new selection is made. Multiple +;; items can be selected using control-click, or shift-click as before. This +;; imitates the behvior of certain GUIs and may be useful in applications. (define-abstract-pane-mapping 'list-pane 'generic-list-pane) @@ -1962,7 +1987,7 @@ ((mode :initarg :mode :initform :exclusive :reader list-pane-mode - :type (member :one-of :some-of)) + :type (member :one-of :some-of :exclusive :nonexclusive)) (items :initarg :items :initform nil :reader list-pane-items @@ -2009,6 +2034,14 @@ (defmethod initialize-instance :after ((gadget meta-list-pane) &rest rest) (declare (ignorable rest)) + ;; Initialize slot value if not specified + #+NIL ;; XXX + (when (slot-boundp gadget 'value) + (setf (slot-value gadget 'value) + (if (list-pane-exclusive-p gadget) + (funcall (list-pane-value-key gadget) (first (list-pane-items gadget))) + (mapcar #'list-pane-value-key (list (first (list-pane-items gadget))))))) + (when (and (not (list-pane-exclusive-p gadget)) (not (listp (gadget-value gadget)))) (error "A :nonexclusive list-pane cannot be initialized with a value which is not a list.")) @@ -2094,7 +2127,8 @@ (with-bounding-rectangle* (rx0 ry0 rx1 ry1) (if (bounding-rectangle-p region) region - (sheet-region pane)) ; workaround for non-rectangular regions (such as +everywhere+) + (or (pane-viewport-region pane) ; workaround for +everywhere+ + (sheet-region pane))) (let ((item-height (generic-list-pane-item-height pane)) (highlight-ink (list-pane-highlight-ink pane))) (do ((index (floor (- ry0 sy0) item-height) (1+ index))) @@ -2103,14 +2137,16 @@ (let ((y0 (+ sy0 (* index item-height))) (y1 (+ sy0 (* (1+ index) item-height)))) (multiple-value-bind (background foreground) - (if (if (list-pane-exclusive-p pane) + (cond ((not (slot-boundp pane 'value)) + (values (pane-background pane) (pane-foreground pane))) + ((if (list-pane-exclusive-p pane) (funcall (list-pane-test pane) (elt (generic-list-pane-item-values pane) index) (gadget-value pane)) (member (elt (generic-list-pane-item-values pane) index) (gadget-value pane) :test (list-pane-test pane))) - (values highlight-ink (pane-background pane)) - (values (pane-background pane) (pane-foreground pane))) + (values highlight-ink (pane-background pane))) + (t (values (pane-background pane) (pane-foreground pane)))) (draw-rectangle* pane rx0 y0 rx1 y1 :filled t :ink background) (draw-text* pane (elt (generic-list-pane-item-strings pane) index) sx0 @@ -2261,9 +2297,11 @@ (defun generic-option-pane-compute-label (pane) (generic-option-pane-compute-label-from-value pane (gadget-value pane))) -(defmethod initialize-instance :after ((object generic-option-pane) &rest rest) +(defmethod initialize-instance :after ((object generic-option-pane) &rest rest) (setf (slot-value object 'current-label) - (generic-option-pane-compute-label object))) + (if (slot-boundp object 'value) + (generic-option-pane-compute-label object) + ""))) (defmethod (setf gadget-value) :after (new-value (gadget generic-option-pane) &key &allow-other-keys) (setf (slot-value gadget 'current-label) @@ -2391,13 +2429,14 @@ (t (values nil :above height))))))) (defun popup-init (parent manager frame) - (let ((list-pane (make-pane-1 manager frame 'generic-list-pane + (let ((list-pane (apply #'make-pane-1 manager frame 'generic-list-pane :items (list-pane-items parent) :mode (list-pane-mode parent) - :value (gadget-value parent) :name-key (list-pane-name-key parent) :value-key (list-pane-value-key parent) - :test (list-pane-test parent)))) + :test (list-pane-test parent) + (and (slot-boundp parent 'value) + (list :value (gadget-value parent)))))) (multiple-value-bind (scroll-p position height) (popup-compute-height parent list-pane) (with-bounding-rectangle* (cx0 cy0 cx1 cy1) parent @@ -2429,11 +2468,11 @@ (let* ((frame *application-frame*) (manager (frame-manager frame)) ;; Popup state - (ready-to-exit nil) - (inner-grab nil) ;; Gadget 'grabbing' the pointer, used to simulate the - ;; implicit pointer grabbing of X for the scrollbar + (final-change nil) ;; Menu should exit after next value change + (inner-grab nil) ;; Gadget is grabbing the pointer, used to simulate + ;; X implicit pointer grabbing (for the scrollbar) (retain-value nil) - (all-done nil) + (consume-and-exit nil) ;; If true, wait until a button release then exit (last-click-time nil) (last-item-index nil)) (with-look-and-feel-realization (manager *application-frame*) @@ -2458,16 +2497,16 @@ (< (/ (- now last-click-time) internal-time-units-per-second) *double-click-delay*)) (setf last-click-time now)))) (end-it () - (unless all-done - (setf all-done t) - (throw 'popup-list-box-done nil)))) + (throw 'popup-list-box-done nil))) (catch 'popup-list-box-done (setf (slot-value list-pane 'value-changed-callback) (lambda (pane value) (declare (ignore pane value)) - (when ready-to-exit (end-it)))) - + (when (and final-change + (not consume-and-exit)) + (end-it)))) + (tracking-pointer (list-pane :multiple-window t :highlight nil) (:pointer-motion (&key event window x y) (cond (inner-grab (handle-event inner-grab (rewrite-event-for-grab inner-grab event))) @@ -2484,30 +2523,33 @@ (multiple-value-bind (item current-index) (generic-list-pane-item-from-x-y list-pane x y) (declare (ignore item)) - (setf retain-value t) (let ((double-clicked (and (compute-double-clicked) (= (or last-item-index -1) (or current-index -2)))) (exclusive (list-pane-exclusive-p parent))) - (setf ready-to-exit (or exclusive double-clicked) - last-item-index current-index) - (if (and (not exclusive) - double-clicked) - (end-it) + (setf retain-value t + final-change (or exclusive double-clicked) + last-item-index current-index + consume-and-exit (or exclusive + (and (not exclusive) + double-clicked))) + (unless (and (not exclusive) + double-clicked) (handle-event list-pane event))))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event) (setf inner-grab (event-sheet event))) - (t (end-it))))) - + (t (setf consume-and-exit t))))) + (:pointer-button-release (&key event x y) + (when consume-and-exit (end-it)) (cond (inner-grab (handle-event inner-grab event) (setf inner-grab nil)) ((in-list (event-sheet event) x y) (when (list-pane-exclusive-p parent) - (setf ready-to-exit t - retain-value t) + (setf retain-value t + final-change t) (handle-event list-pane event))) ((in-menu (event-sheet event) x y) (handle-event (event-sheet event) event)))))))

1 0

[mcclim-cvs] CVS update: mcclim/stream-output.lisp
by ahefner＠common-lisp.net 17 Apr '05

17 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv26576 Modified Files: stream-output.lisp Log Message: Squashed a "magic fudge factor". Date: Sun Apr 17 18:42:48 2005 Author: ahefner Index: mcclim/stream-output.lisp diff -u mcclim/stream-output.lisp:1.53 mcclim/stream-output.lisp:1.54 --- mcclim/stream-output.lisp:1.53 Wed Feb 2 12:33:59 2005 +++ mcclim/stream-output.lisp Sun Apr 17 18:42:47 2005 @@ -487,15 +487,15 @@ (declare (ignore total-height final-y baseline)) (values final-x total-width)))) -;;; XXX where does "6" come from? Magic fudge factor? -- moore (defmethod stream-text-margin ((stream standard-extended-output-stream)) (with-slots (margin) stream (or margin (- (bounding-rectangle-width (or (pane-viewport stream) stream)) - 6)))) + (text-size stream "O"))))) -(defmethod stream-line-height ((stream standard-extended-output-stream) &key (text-style nil)) +(defmethod stream-line-height ((stream standard-extended-output-stream) + &key (text-style nil)) (+ (text-style-height (or text-style (medium-text-style (sheet-medium stream))) (sheet-medium stream)) (stream-vertical-spacing stream)))

1 0

[mcclim-cvs] CVS update: mcclim/graph-formatting.lisp
by ahefner＠common-lisp.net 12 Apr '05

12 Apr '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv510 Modified Files: graph-formatting.lisp Log Message: Fixed arc-drawer keyword default, as reported by rpgoldman(a)real-time.com Date: Tue Apr 12 22:43:26 2005 Author: ahefner Index: mcclim/graph-formatting.lisp diff -u mcclim/graph-formatting.lisp:1.11 mcclim/graph-formatting.lisp:1.12 --- mcclim/graph-formatting.lisp:1.11 Sun Dec 5 20:37:52 2004 +++ mcclim/graph-formatting.lisp Tue Apr 12 22:43:26 2005 @@ -3,7 +3,7 @@ ;;; Title: Graph Formatting ;;; Created: 2002-08-13 ;;; License: LGPL (See file COPYING for details). -;;; $Id: graph-formatting.lisp,v 1.11 2004/12/05 19:37:52 hefner1 Exp $ +;;; $Id: graph-formatting.lisp,v 1.12 2005/04/12 20:43:26 ahefner Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -125,7 +125,9 @@ merge-duplicates duplicate-key duplicate-test generation-separation within-generation-separation - center-nodes arc-drawer arc-drawing-options + center-nodes + (arc-drawer #'clim-internals::standard-arc-drawer) + arc-drawing-options graph-type (move-cursor t) &allow-other-keys) (declare (ignore orientation generation-separation within-generation-separation center-nodes))

1 0

[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

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs April 2005