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

[mcclim-cvs] CVS mcclim/Apps/Scigraph/dwim
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim In directory clnet:/tmp/cvs-serv13084/Apps/Scigraph/dwim Modified Files: tv.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2006/03/23 10:09:50 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/tv.lisp 2006/03/29 10:43:37 1.9 @@ -457,7 +457,7 @@ (clim:enable-frame frame) (clim:panes-need-redisplay frame) (clim:redisplay-frame-panes frame)) - (T (clim:start-frame frame wait-until-done))))) + (t (clim:start-frame frame wait-until-done))))) (:clim-1.0 (labels ((set-backing-store (window value) #+xlib

1 0

[mcclim-cvs] CVS mcclim
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13084 Modified Files: bordered-output.lisp events.lisp frames.lisp gadgets.lisp graphics.lisp mcclim.asd menu-choose.lisp panes.lisp protocol-classes.lisp recording.lisp stream-output.lisp text-formatting.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2005/01/02 05:24:49 1.13 +++ /project/mcclim/cvsroot/mcclim/bordered-output.lisp 2006/03/29 10:43:36 1.14 @@ -101,11 +101,11 @@ :filled nil) (draw-rectangle* stream right-edge (+ top-edge offset) - (+ right-edge offset) bottom-edge :filled T) + (+ right-edge offset) bottom-edge :filled t) (draw-rectangle* stream (+ left-edge offset) bottom-edge (+ right-edge offset) (+ bottom-edge offset) - :filled T))) + :filled t))) (define-border-type :underline (stream record) (labels ((fn (record) --- /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/10 21:58:12 1.28 +++ /project/mcclim/cvsroot/mcclim/events.lisp 2006/03/29 10:43:36 1.29 @@ -59,7 +59,11 @@ (defclass standard-event (event) ((timestamp :initarg :timestamp :initform nil - :reader event-timestamp))) + :reader event-timestamp) + ;; This slot is pretty much required in order to call handle-event. Some + ;; events have something other than a sheet in this slot, which is gross. + (sheet :initarg :sheet + :reader event-sheet))) (defmethod initialize-instance :after ((event standard-event) &rest initargs) (declare (ignore initargs)) @@ -79,11 +83,28 @@ ; (if (null position) ; :event ; (intern (subseq type 0 position) :keyword)))) +;;; Reintroduce something like that definition, with defmethod goodness. +;;; -- moore -(defclass device-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (modifier-state :initarg :modifier-state +(defmacro define-event-class (name supers slots &rest options) + (let* ((event-tag (string '#:-event)) + (name-string (string name)) + (pos (search event-tag name-string :from-end t))) + (when (or (null pos) + (not (eql (+ pos (length event-tag)) (length name-string)))) + (error "~S does not end in ~A and is not a valid event name for ~ + define-event-class." + name event-tag)) + (let ((type (intern (subseq name-string 0 pos) :keyword))) + `(progn + (defclass ,name ,supers + ,slots + ,@options) + (defmethod event-type ((event ,name)) + ',type))))) + +(define-event-class device-event (standard-event) + ((modifier-state :initarg :modifier-state :reader event-modifier-state) (x :initarg :x :reader device-event-native-x) @@ -94,21 +115,19 @@ (graft-y :initarg :graft-y :reader device-event-native-graft-y))) -(defclass keyboard-event (device-event) +(define-event-class keyboard-event (device-event) ((key-name :initarg :key-name :reader keyboard-event-key-name) (key-character :initarg :key-character :reader keyboard-event-character :initform nil))) -(defclass key-press-event (keyboard-event) - ( - )) - -(defclass key-release-event (keyboard-event) - ( - )) +(define-event-class key-press-event (keyboard-event) + ()) -(defclass pointer-event (device-event) +(define-event-class key-release-event (keyboard-event) + ()) + +(define-event-class pointer-event (device-event) ((pointer :initarg :pointer :reader pointer-event-pointer) (button :initarg :button @@ -149,33 +168,28 @@ (defmethod device-event-y ((event device-event)) (get-pointer-position ((event-sheet event) event) y)) -(defclass pointer-button-event (pointer-event) - ( - )) +(define-event-class pointer-button-event (pointer-event) + ()) -(defclass pointer-button-press-event (pointer-button-event) ()) +(define-event-class pointer-button-press-event (pointer-button-event) ()) -(defclass pointer-button-release-event (pointer-button-event) ()) +(define-event-class pointer-button-release-event (pointer-button-event) ()) -(defclass pointer-button-hold-event (pointer-button-event) ()) +(define-event-class pointer-button-hold-event (pointer-button-event) ()) -(defclass pointer-button-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-event (pointer-button-event) + ()) -(defclass pointer-button-double-click-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-double-click-event (pointer-button-event) + ()) -(defclass pointer-button-click-and-hold-event (pointer-button-event) - ( - )) +(define-event-class pointer-button-click-and-hold-event (pointer-button-event) + ()) -(defclass pointer-motion-event (pointer-event) - ( - )) +(define-event-class pointer-motion-event (pointer-event) + ()) (defclass motion-hint-mixin () () @@ -185,28 +199,22 @@ (defclass pointer-motion-hint-event (pointer-motion-event motion-hint-mixin) ()) -(defclass pointer-boundary-event (pointer-motion-event) - ( - )) +(define-event-class pointer-boundary-event (pointer-motion-event) + ()) -(defclass pointer-enter-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-enter-event (pointer-boundary-event) + ()) -(defclass pointer-exit-event (pointer-boundary-event) - ( - )) +(define-event-class pointer-exit-event (pointer-boundary-event) + ()) -(defclass pointer-ungrab-event (pointer-exit-event) +(define-event-class pointer-ungrab-event (pointer-exit-event) ()) -(defclass window-event (standard-event) - ((sheet :initarg :sheet - :reader event-sheet) - (region :initarg :region - :reader window-event-native-region) - )) +(define-event-class window-event (standard-event) + ((region :initarg :region + :reader window-event-native-region))) (defmethod window-event-region ((event window-event)) (untransform-region (sheet-native-transformation (event-sheet event)) @@ -215,7 +223,7 @@ (defmethod window-event-mirrored-sheet ((event window-event)) (sheet-mirror (event-sheet event))) -(defclass window-configuration-event (window-event) +(define-event-class window-configuration-event (window-event) ((x :initarg :x :reader window-configuration-event-native-x) (y :initarg :y :reader window-configuration-event-native-y) (width :initarg :width :reader window-configuration-event-width) @@ -235,64 +243,27 @@ (defmethod window-configuration-event-y ((event window-configuration-event)) (get-window-position ((event-sheet event) event) y)) -(defclass window-unmap-event (window-event) +(define-event-class window-unmap-event (window-event) ()) -(defclass window-destroy-event (window-event) +(define-event-class window-destroy-event (window-event) ()) -(defclass window-repaint-event (window-event) - ( - )) +(define-event-class window-repaint-event (window-event) + ()) -(defclass window-manager-event (standard-event) ()) +(define-event-class window-manager-event (standard-event) ()) -(defclass window-manager-delete-event (window-manager-event) - ((sheet :initarg :sheet ; not required by the spec but we need - :reader event-sheet) ; to know which window to delete - mikemac - )) +(define-event-class window-manager-delete-event (window-manager-event) + ;; sheet (inherited from standard-event) is not required by the spec but we + ;; need to know which window to delete - mikemac + ()) -(defclass timer-event (standard-event) - ((sheet - :initarg :sheet - :reader event-sheet) - (token +(define-event-class timer-event (standard-event) + ((token :initarg :token :reader event-token))) -(defmethod event-instance-slots ((self event)) - '(timestamp)) - -(defmethod event-instance-slots ((self device-event)) - '(timestamp modifier-state sheet)) - -(defmethod event-instance-slots ((self keyboard-event)) - '(timestamp modifier-state sheet key-name)) - -(defmethod event-instance-slots ((self pointer-event)) - '(timestamp modifier-state sheet pointer button x y root-x root-y)) - -(defmethod event-instance-slots ((self window-event)) - '(timestamp region)) - -;(defmethod print-object ((self event) sink) -; (print-object-with-slots self (event-instance-slots self) sink)) - -;(defmethod translate-event ((self pointer-event) dx dy) -; (apply #'make-instance (class-of self) -; :x (+ dx (pointer-event-x self)) -; :y (+ dy (pointer-event-y self)) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self window-event) dx dy) -; (apply #'make-instance (class-of self) -; :region (translate-region (window-event-region self) dx dy) -; (fetch-slots-as-kwlist self (event-instance-slots self)))) - -;(defmethod translate-event ((self event) dx dy) -; (declare (ignore dx dy)) -; self) - ;;; Constants dealing with events (defconstant +pointer-left-button+ #x01) @@ -339,32 +310,6 @@ (check-modifier (,m) (not (zerop (logand ,m ,modifier-state))))) (and ,@(do-substitutes clauses)))))) -(defmethod event-type ((event device-event)) :device) -(defmethod event-type ((event keyboard-event)) :keyboard) -(defmethod event-type ((event key-press-event)) :key-press) -(defmethod event-type ((event key-release-event)) :key-release) -(defmethod event-type ((event pointer-event)) :pointer) -(defmethod event-type ((event pointer-button-event)) :pointer-button) -(defmethod event-type ((event pointer-button-press-event)) :pointer-button-press) -(defmethod event-type ((event pointer-button-release-event)) :pointer-button-release) -(defmethod event-type ((event pointer-button-hold-event)) :pointer-button-hold) -(defmethod event-type ((event pointer-motion-event)) :pointer-motion) -(defmethod event-type ((event pointer-boundary-event)) :pointer-boundary) -(defmethod event-type ((event pointer-enter-event)) :pointer-enter) -(defmethod event-type ((event pointer-exit-event)) :pointer-exit) -(defmethod event-type ((event window-event)) :window) -(defmethod event-type ((event window-configuration-event)) :window-configuration) -(defmethod event-type ((event window-repaint-event)) :window-repaint) -(defmethod event-type ((event window-manager-event)) :window-manager) -(defmethod event-type ((event window-manager-delete-event)) :window-manager-delete) -(defmethod event-type ((event timer-event)) :timer) - -;; keyboard-event-character keyboard-event -;; pointer-event-native-x pointer-event -;; pointer-event-native-y pointer-event -;; window-event-native-region window-event -;; window-event-mirrored-sheet window-event - ;; Key names are a symbol whose value is port-specific. Key names ;; corresponding to the set of standard characters (such as the ;; alphanumerics) will be a symbol in the keyword package. --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/15 15:38:39 1.117 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2006/03/29 10:43:37 1.118 @@ -581,7 +581,7 @@ #+NIL (read-command (frame-command-table frame) :use-keystrokes nil :stream stream) (read-command (frame-command-table frame) :use-keystrokes t :stream stream)) -(defclass execute-command-event (window-manager-event) +(define-event-class execute-command-event (window-manager-event) ((sheet :initarg :sheet :reader event-sheet) (command :initarg :command :reader execute-command-event-command))) --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/27 10:46:11 1.97 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/29 10:43:37 1.98 @@ -115,11 +115,14 @@ ;; - make NIL a valid label, and take it into account when applying ;; spacing. -;;;; ------------------------------------------------------------------------------------------ +;;;; -------------------------------------------------------------------------- ;;;; ;;;; 30.3 Basic Gadget Classes ;;;; +;;; XXX I'm not sure that *application-frame* should be rebound like this. What +;;; about gadgets in accepting-values windows? An accepting-values window +;;; shouldn't be bound to *application-frame*. -- moore (defun invoke-callback (pane callback &rest more-arguments) (when callback (let ((*application-frame* (pane-frame pane))) @@ -1421,6 +1424,14 @@ (declare (ignore new-value invoke-callback)) (scroll-bar/update-display pane)) +(defmethod* (setf scroll-bar-values) + (min-value max-value thumb-size value (scroll-bar scroll-bar-pane)) + (setf (slot-value scroll-bar 'min-value) min-value + (slot-value scroll-bar 'max-value) max-value + (slot-value scroll-bar 'thumb-size) thumb-size + (slot-value scroll-bar 'value) value) + (scroll-bar/update-display scroll-bar)) + ;;;; geometry (defparameter +minimum-thumb-size-in-pixels+ 30) @@ -2818,3 +2829,31 @@ (defmethod note-sheet-grafted ((sheet clim-extensions:box-adjuster-gadget)) (setf (sheet-pointer-cursor sheet) :rotate)) + +;;; Support for definition of callbacks and associated callback events. A +;;; callback event is used by a backend when a high-level notification of a +;;; gadget state change is delivered in the CLIM event process -- by a native +;;; gadget, for example -- and must be delivered in the application process. + +(define-event-class callback-event (standard-event) + ((sheet :initarg :gadget :reader event-gadget + :documentation "An alias for sheet, for readability") + (callback-function :initarg :callback-function :reader callback-function) + (client :initarg :client :reader event-client) + (client-id :initarg :client-id :reader event-client-id) + (other-args :initarg :other-args :reader event-other-args :initform nil))) + +(defun queue-callback (fn gadget client client-id &rest other-args) + (queue-event gadget (make-instance 'callback-event + :callback-function fn + :gadget gadget + :client client + :client-id client-id + :other-args other-args))) + +(defmethod handle-event ((gadget basic-gadget) (event callback-event)) + (apply (callback-function event) + (event-client event) + (event-client-id event) + (event-other-args event))) + --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2005/09/10 11:53:15 1.51 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/03/29 10:43:37 1.52 @@ -111,7 +111,7 @@ (if (null line-style) (setf line-style old-line-style)) (when (or line-unit line-thickness dashes-p line-joint-shape line-cap-shape) - (setf changed-line-style T) + (setf changed-line-style t) (setf line-style (make-line-style :unit (or line-unit (line-style-unit line-style)) @@ -130,7 +130,7 @@ (medium-merged-text-style medium))) (setf text-style (medium-merged-text-style medium))) (when (or text-family-p text-face-p text-size-p) - (setf changed-text-style T) + (setf changed-text-style t) (setf text-style (merge-text-styles (make-text-style text-family text-face text-size) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/24 11:45:03 1.15 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/03/29 10:43:37 1.16 @@ -51,10 +51,11 @@ ;;; 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)) @@ -62,7 +63,6 @@ (defsystem :clx :class requireable-system)) - (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn (asdf:defsystem ,module --- /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/02/23 17:39:32 1.17 +++ /project/mcclim/cvsroot/mcclim/menu-choose.lisp 2006/03/29 10:43:37 1.18 @@ -43,7 +43,7 @@ ;;; + menu frame size ;;; + layout -(in-package :CLIM-INTERNALS) +(in-package :clim-internals) (defgeneric menu-choose (items --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/27 10:46:11 1.168 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/29 10:43:37 1.169 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.168 2006/03/27 10:46:11 crhodes Exp $ +;;; $Id: panes.lisp,v 1.169 2006/03/29 10:43:37 tmoore Exp $ (in-package :clim-internals) @@ -1515,7 +1515,7 @@ (space-requirement-major sr)))) srs))) #+nil - (format T "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" + (format t "~&;; ~S: allot=~S, wanted=~S, excess=~S, qs=~S~%" 'allot-space-xically allot wanted excess qs) (let ((sum (reduce #'+ qs))) (cond ((zerop sum) @@ -1592,11 +1592,11 @@ (- width xs)))) #+nil (progn - (format T "~&;; row space requirements = ~S." rsrs) - (format T "~&;; col space requirements = ~S." csrs) - (format T "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) - (format T "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) - (format T "~&;; align-x = ~S, align-y ~S~%" + (format t "~&;; row space requirements = ~S." rsrs) + (format t "~&;; col space requirements = ~S." csrs) + (format t "~&;; row allotment: needed = ~S result = ~S (sum ~S)." height rows (reduce #'+ rows)) + (format t "~&;; col allotment: needed = ~S result = ~S (sum ~S)." width cols (reduce #'+ cols)) + (format t "~&;; align-x = ~S, align-y ~S~%" (pane-align-x pane) (pane-align-y pane))) ;; now finally layout each child @@ -1882,7 +1882,7 @@ ;; ;; One might argue that in case of no scroll-bars the ;; application programmer can just skip the scroller - ;; pane altogether. But I think that the then needed + ;; pane altogether. Bu I think that the then needed ;; special casing on having a scroller pane or a bare ;; viewport at hand is an extra burden, that can be ;; avoided. @@ -1899,6 +1899,12 @@ :x-spacing 4 :y-spacing 4)) +(defgeneric scroll-bar-values (scroll-bar) + (:documentation "Returns the min value, max value, thumb size, and value of a + scroll bar. When Setf-ed, updates the scroll bar graphics")) + +(defgeneric* (setf scroll-bar-values) (min-value max-value thumb-size value scroll-bar)) + (defmacro scrolling ((&rest options) &body contents) `(let ((viewport (make-pane 'viewport-pane :contents (list ,@contents)))) (make-pane 'scroller-pane ,@options :contents (list viewport)))) @@ -1973,11 +1979,7 @@ 0 (* (/ (gadget-value vscrollbar) (gadget-max-value vscrollbar)) max)))) - (setf (gadget-min-value vscrollbar) min - (gadget-max-value vscrollbar) max - (scroll-bar-thumb-size vscrollbar) ts - (gadget-value vscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values vscrollbar) (values min max ts val)))) (when hscrollbar (let* ((scrollee (first (sheet-children viewport))) (min 0) @@ -1989,11 +1991,7 @@ 0 (* (/ (gadget-value hscrollbar) (gadget-max-value hscrollbar)) max)))) - (setf (gadget-min-value hscrollbar) min - (gadget-max-value hscrollbar) max - (scroll-bar-thumb-size hscrollbar) ts - (gadget-value hscrollbar :invoke-callback nil) val))) - + (setf (scroll-bar-values hscrollbar) (values min max ts val)))) (when viewport (setf (sheet-transformation viewport) (make-translation-transformation @@ -2009,17 +2007,24 @@ "Callback for the vertical scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - (if hscrollbar (gadget-value hscrollbar) 0) - new-value)))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (if hscrollbar + (- (gadget-value hscrollbar)) + 0)) + (round (- new-value))))))) (defmethod scroller-pane/horizontal-drag-callback ((pane scroller-pane) new-value) "Callback for the horizontal scroll-bar of a scroller-pane." (with-slots (viewport hscrollbar vscrollbar) pane (let ((scrollee (first (sheet-children viewport)))) - (scroll-extent scrollee - new-value - (if vscrollbar (gadget-value vscrollbar) 0))))) + (when (pane-viewport scrollee) + (move-sheet scrollee + (round (- new-value)) + (round (if vscrollbar + (- (gadget-value vscrollbar)) + 0))))))) + (defmethod scroller-pane/update-scroll-bars ((pane scroller-pane)) (with-slots (viewport hscrollbar vscrollbar) pane @@ -2028,24 +2033,27 @@ (viewport-sr (sheet-region viewport))) ;; (when hscrollbar - (setf (gadget-min-value hscrollbar) (bounding-rectangle-min-x scrollee-sr) - (gadget-max-value hscrollbar) (max (- (bounding-rectangle-max-x scrollee-sr) - (bounding-rectangle-width viewport-sr)) - (bounding-rectangle-min-x scrollee-sr)) - (scroll-bar-thumb-size hscrollbar) (bounding-rectangle-width viewport-sr) - (gadget-value hscrollbar :invoke-callback nil) - (- (nth-value 0 (transform-position (sheet-transformation scrollee) 0 0))) - )) + (setf (scroll-bar-values hscrollbar) + (values (bounding-rectangle-min-x scrollee-sr) + (max (- (bounding-rectangle-max-x scrollee-sr) + (bounding-rectangle-width viewport-sr)) + (bounding-rectangle-min-x scrollee-sr)) + (bounding-rectangle-width viewport-sr) + (- (nth-value 0 (transform-position + (sheet-transformation scrollee) 0 0)))))) ;; (when vscrollbar - (setf (gadget-min-value vscrollbar) (bounding-rectangle-min-y scrollee-sr) - (gadget-max-value vscrollbar) (max (- (bounding-rectangle-max-y scrollee-sr) - (bounding-rectangle-height viewport-sr)) - (bounding-rectangle-min-y scrollee-sr)) - (scroll-bar-thumb-size vscrollbar) (bounding-rectangle-height viewport-sr) - (gadget-value vscrollbar :invoke-callback nil) - (- (nth-value 1 (transform-position (sheet-transformation scrollee) 0 0))) - ))))) + (setf (scroll-bar-values vscrollbar) + (values (bounding-rectangle-min-y scrollee-sr) + (max (- (bounding-rectangle-max-y scrollee-sr) + (bounding-rectangle-height viewport-sr)) + (bounding-rectangle-min-y scrollee-sr)) + (bounding-rectangle-height viewport-sr) + (- (nth-value 1 (transform-position + (sheet-transformation scrollee) + 0 + 0))))))))) + (defmethod initialize-instance :after ((pane scroller-pane) &key contents &allow-other-keys) (sheet-adopt-child pane (first contents)) --- /project/mcclim/cvsroot/mcclim/protocol-classes.lisp 2006/03/10 21:58:13 1.1 +++ /project/mcclim/cvsroot/mcclim/protocol-classes.lisp 2006/03/29 10:43:37 1.2 @@ -22,10 +22,15 @@ (in-package :clim-internals) (defmacro define-protocol-class (name super-classes &optional slots &rest options) - (let ((protocol-predicate - (intern (concatenate 'string (symbol-name name) (if (find #\- (symbol-name name)) "-" "") "P"))) - (predicate-docstring - (concatenate 'string "Protocol predicate checking for class " (symbol-name name)))) + (let* ((sym-name (symbol-name name)) + (protocol-predicate + (intern (concatenate 'string + sym-name + (if (find #\- sym-name) "-" "") + (symbol-name '#:p)))) + (predicate-docstring + (concatenate 'string + "Protocol predicate checking for class " sym-name))) `(progn (defclass ,name ,super-classes ,slots ,@options) --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/10 21:58:13 1.124 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/03/29 10:43:37 1.125 @@ -844,7 +844,7 @@ (>= cx2 old-max-x) (>= cy2 old-max-y)) (values (min cx1 ox1) (min cy1 oy1) (max cx2 ox2) (max cy2 oy2))) - (T (%tree-recompute-extent* record))) + (t (%tree-recompute-extent* record))) ;; XXX banish x, y (with-slots (x y) record @@ -2337,7 +2337,7 @@ (bounding-rectangle region)))) (with-bounding-rectangle* (x1 y1 x2 y2) region (with-output-recording-options (stream :record nil) - (draw-rectangle* stream x1 y1 x2 y2 :filled T :ink +background-ink+))) + (draw-rectangle* stream x1 y1 x2 y2 :filled t :ink +background-ink+))) (stream-replay stream region))))) (defmethod handle-repaint ((stream output-recording-stream) region) --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/03/10 21:58:13 1.58 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/03/29 10:43:37 1.59 @@ -107,8 +107,8 @@ (defun decode-cursor-visibility (visibility) "Given :on, :off, or nil, returns the needed active and state attributes for the cursor." (ecase visibility - ((:on T) (values T T)) - (:off (values T nil)) + ((:on t) (values t t)) + (:off (values t nil)) ((nil) (values nil nil)))) (defmethod cursor-visibility ((cursor cursor-mixin)) @@ -116,7 +116,7 @@ (s (cursor-state cursor))) (cond ((and a s) :on) ((and a (not s)) :off) - (T nil)))) + (t nil)))) (defmethod (setf cursor-visibility) (nv (cursor cursor-mixin)) (multiple-value-bind (active state) --- /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2003/11/10 21:40:34 1.8 +++ /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2006/03/29 10:43:37 1.9 @@ -143,8 +143,8 @@ (setq seg-start (1+ i)))) (foo seg-start end))))) -(defmacro indenting-output ((stream indent &key (move-cursor T)) &body body) - (when (eq stream T) +(defmacro indenting-output ((stream indent &key (move-cursor t)) &body body) + (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (old-x old-y) `(multiple-value-bind (,old-x ,old-y)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13084/Apps/Listener Modified Files: dev-commands.lisp file-types.lisp icons.lisp listener.lisp util.lisp Log Message: Take out dependencies on case in symbol names. This makes McCLIM sort of work in ACL's so-called modern mode; there have been some CLX fixes recently that may get it all the way there. Clean up events.lisp. Add a callback-event, which will be used in ports that get high-level gadget notifications in the event process and need to deliver them to applications. Changed the implementation of scroll bars. When the drag callback is called, just move the sheet; assume that the gadget itself has updated the value and the graphic representation. add a scroll-bar-values interface that gets and sets all scroll bar values and only updates the bar once. This will break the Beagle back end momentarily. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/15 22:56:54 1.33 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/03/29 10:43:37 1.34 @@ -158,41 +158,41 @@ (define-presentation-translator class-name-to-class (class-name class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T) + :gesture t) (object) (find-class object)) (define-presentation-translator symbol-to-class (symbol class lisp-dev-commands :documentation ((object stream) (format stream "Class object ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) (find-class object)) (define-presentation-translator symbol-to-class-name (symbol class-name lisp-dev-commands :documentation ((object stream) (format stream "Class ~A" object)) - :gesture T + :gesture t :tester ((object) (not (not (find-class object nil)))) - :tester-definitive T) + :tester-definitive t) (object) object) (define-presentation-translator class-to-class-name (class class-name lisp-dev-commands :documentation ((object stream) (format stream "Class of ~A" object)) - :gesture T) + :gesture t) (object) (clim-mop:class-name object)) (define-presentation-translator symbol-to-function-name (symbol function-name lisp-dev-commands :documentation ((object stream) (format stream "Function ~A" object)) - :gesture T + :gesture t :tester ((object) (fboundp object)) - :tester-definitive T) + :tester-definitive t) (object) object) ;;; Application commands @@ -214,7 +214,7 @@ :provide-output-destination-keyword t) ((program 'string :prompt "command") (args '(sequence string) :default nil :prompt "args")) - (run-program program args :wait T :input nil)) + (run-program program args :wait t :input nil)) ;; I could replace this command with a keyword to COM-RUN.. (define-command (com-background-run :name "Background Run" @@ -327,10 +327,10 @@ (let ((symbols (remove-if-not (lambda (sym) (apropos-applicable-p domain sym)) (apropos-list string real-package)))) (dolist (sym symbols) - (apropos-present-symbol sym *standard-output* T) + (apropos-present-symbol sym *standard-output* t) (terpri)) (setf *apropos-list* symbols) - (note "Results have been saved to ~W~%" '*APROPOS-LIST*)))) + (note "Results have been saved to ~W~%" '*apropos-list*)))) (define-command (com-trace :name "Trace" :command-table lisp-commands @@ -340,8 +340,8 @@ (if (fboundp fsym) (progn (eval `(trace ,fsym)) - (format T "~&Tracing ~W.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&Tracing ~W.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-untrace :name "Untrace" :command-table lisp-commands @@ -351,8 +351,8 @@ (if (fboundp fsym) (progn (eval `(untrace ,fsym)) - (format T "~&~W will no longer be traced.~%" fsym)) - (format T "~&Function ~W is not defined.~%" fsym))) + (format t "~&~W will no longer be traced.~%" fsym)) + (format t "~&Function ~W is not defined.~%" fsym))) (define-command (com-load-file :name "Load File" @@ -453,7 +453,7 @@ (princ (clim-mop:class-name class) stream)))) ;) inferior-fun :stream stream - :merge-duplicates T + :merge-duplicates t :graph-type :tree :orientation orientation :arc-drawer @@ -528,30 +528,30 @@ (direct-slots (direct-slot-definitions class name)) (readers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-readers))) (writers (reduce #'append (filtermap direct-slots #'clim-mop:slot-definition-writers))) - (documentation (first (filtermap direct-slots (lambda (x) (documentation x T))))) + (documentation (first (filtermap direct-slots (lambda (x) (documentation x t))))) (*standard-output* stream)) (macrolet ((with-ink ((var) &body body) - `(with-drawing-options (T :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) + `(with-drawing-options (t :ink ,(intern (concatenate 'string "*SLOT-" (symbol-name var) "-INK*"))) ,@body)) (fcell ((var align-x &rest cell-opts) &body body) - `(formatting-cell (T :align-x ,align-x ,@cell-opts) + `(formatting-cell (t :align-x ,align-x ,@cell-opts) (with-ink (,var) ,@body) ))) (fcell (name :left) - (with-output-as-presentation (T slot 'slot-definition) + (with-output-as-presentation (t slot 'slot-definition) (princ name)) - (unless (eq type T) + (unless (eq type t) (fresh-line) (with-ink (type) (princ type)))) (fcell (initargs :right) (dolist (x initargs) - (format T "~W~%" x))) + (format t "~W~%" x))) (fcell (initform :left) (if initfunc - (format T "~W" initform) + (format t "~W" initform) (note "No initform"))) #+NIL ; argh, shouldn't this work? @@ -567,19 +567,19 @@ (dolist (writer writers) (format T "~A~%" writer)) (note "No writers")))))) - (formatting-cell (T :align-x :left) + (formatting-cell (t :align-x :left) (if (not (or readers writers)) (note "No accessors") (progn (with-ink (readers) - (if readers (dolist (reader readers) (format T "~A~%" reader)) + (if readers (dolist (reader readers) (format t "~A~%" reader)) (note "No readers~%"))) (with-ink (writers) - (if writers (dolist (writer writers) (format T "~A~%" writer)) + (if writers (dolist (writer writers) (format t "~A~%" writer)) (note "No writers")))))) (fcell (documentation :left) - (when documentation (with-text-family (T :serif) (princ documentation)))) + (when documentation (with-text-family (t :serif) (princ documentation)))) ))) @@ -601,18 +601,18 @@ (position (earliest-slot-definer b class) cpl)))))) (defun print-slot-table-heading () - (formatting-row (T) + (formatting-row (t) (dolist (name '("Slot name" "Initargs" "Initform" "Accessors")) - (formatting-cell (T :align-x :center) - (underlining (T) - (with-text-family (T :sans-serif) + (formatting-cell (t :align-x :center) + (underlining (t) + (with-text-family (t :sans-serif) (princ name))))))) (defun present-slot-list (slots class) - (formatting-table (T) + (formatting-table (t) (print-slot-table-heading) (dolist (slot slots) - (formatting-row (T) + (formatting-row (t) (present-slot slot class))))) (defun friendly-slot-allocation-type (allocation) @@ -626,11 +626,11 @@ (other-slots (set-difference slots instance-slots)) (allocation-types (remove-duplicates (mapcar #'clim-mop:slot-definition-allocation other-slots)))) (when other-slots - (underlining (T) (format T "~&Instance Slots~%"))) + (underlining (t) (format t "~&Instance Slots~%"))) (present-slot-list instance-slots class) (dolist (alloc allocation-types) - (underlining (T) - (format T "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) + (underlining (t) + (format t "~&Allocation: ~A~%" (friendly-slot-allocation-type alloc))) (present-slot-list (remove-if (lambda (x) (not (eq alloc (clim-mop:slot-definition-allocation x)))) other-slots) @@ -643,17 +643,17 @@ ((class-name 'clim:symbol :prompt "class name")) (let ((class (find-class class-name nil))) (if (null class) - (format T "~&~A is not a defined class.~%" class-name) + (format t "~&~A is not a defined class.~%" class-name) (let ((slots (clim-mop:class-slots class))) (if (null slots) (note "~%This class has no slots.~%~%") (progn ; oddly, looks much better in courier, because of all the capital letters. -; (with-text-family (T :sans-serif) +; (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "~&Slots for ") - (with-output-as-presentation (T (clim-mop:class-name class) 'class-name) + (format t "~&Slots for ") + (with-output-as-presentation (t (clim-mop:class-name class) 'class-name) (princ (clim-mop:class-name class))))) (present-the-slots class) )))))) @@ -697,7 +697,7 @@ (symbol-package b))) (string< (package-name (symbol-package a)) (package-name (symbol-package b)))) - (T (string< (symbol-name a) + (t (string< (symbol-name a) (symbol-name b)))) (string< (princ-to-string a) (princ-to-string b)))))) @@ -714,10 +714,10 @@ (let ((funcs (sort (class-funcs class) (lambda (a b) (slot-name-sortp (clim-mop:generic-function-name a) (clim-mop:generic-function-name b)))))) - (with-text-size (T :small) + (with-text-size (t :small) (format-items funcs :printer (lambda (item stream) (present item 'generic-function :stream stream)) - :move-cursor T)))))) + :move-cursor t)))))) (defun method-applicable-to-args-p (method args arg-types) (loop @@ -1026,7 +1026,7 @@ :type (pathname-type pathname) :version (pathname-version pathname)))))) -(defun pretty-pretty-pathname (pathname stream &key (long-name T)) +(defun pretty-pretty-pathname (pathname stream &key (long-name t)) (with-output-as-presentation (stream pathname 'clim:pathname) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) @@ -1077,10 +1077,10 @@ &key (sort-by '(member name size modify none) :default 'name) (show-hidden 'boolean :default nil :prompt "show hidden") - (hide-garbage 'boolean :default T :prompt "hide garbage") + (hide-garbage 'boolean :default t :prompt "hide garbage") (show-all 'boolean :default nil :prompt "show all") (style '(member items list) :default 'items :prompt "listing style") - (group-directories 'boolean :default T :prompt "group directories?") + (group-directories 'boolean :default t :prompt "group directories?") (full-names 'boolean :default nil :prompt "show full name?") (list-all-direct-subdirectories 'boolean :default nil :prompt "list all direct subdirectories?")) @@ -1092,18 +1092,18 @@ (list-directory-with-all-direct-subdirectories wild-pathname) (list-directory wild-pathname)))) - (with-text-family (T :sans-serif) + (with-text-family (t :sans-serif) (invoke-as-heading (lambda () - (format T "Directory contents of ") + (format t "Directory contents of ") (present (directory-namestring pathname) 'pathname) (when (pathname-type pathname) - (format T " (only files of type ~a)" (pathname-type pathname))))) + (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (T (strip-filespec (parent-directory pathname)) 'clim:pathname) - (draw-icon T (standard-icon "up-folder.xpm") :extra-spacing 3) - (format T "Parent Directory~%"))) + (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname) + (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) + (format t "Parent Directory~%"))) (dolist (group (split-sort-pathnames dir group-directories sort-by)) (unless show-all @@ -1120,7 +1120,7 @@ (declare (ignore stream)) (pretty-pretty-pathname x *standard-output* :long-name full-names))) (goatee::reposition-stream-cursor *standard-output*) - (vertical-gap T)) + (vertical-gap t)) (list (dolist (ent group) (let ((ent (merge-pathnames ent pathname))) ;; This is for CMUCL, see above. (fixme!) ;; And breaks some things for SBCL.. (mgr) @@ -1131,7 +1131,7 @@ (clim:pathname com-show-directory filesystem-commands :gesture :select :pointer-documentation ((object stream) (format stream "Show directory ~A" object)) - :tester-definitive T + :tester-definitive t :tester ((object) (directoryp object))) (object) @@ -1147,7 +1147,7 @@ (note "~A does not exist." pathname)) ((not (directoryp pathname)) (note "~A is not a directory." pathname)) - (T (change-directory (merge-pathnames pathname))) ))) + (t (change-directory (merge-pathnames pathname))) ))) (define-command (com-up-directory :name "Up Directory" :menu t @@ -1156,8 +1156,8 @@ (let ((parent (parent-directory *default-pathname-defaults*))) (when parent (change-directory parent) - (italic (T) - (format T "~&The current directory is now ") + (italic (t) + (format t "~&The current directory is now ") (present (truename parent)) (terpri))))) @@ -1283,18 +1283,18 @@ (directoryp pathname));; FIXME: Need smart conversion to directories, here and elsewhere. (progn (push *default-pathname-defaults* *directory-stack*) (com-change-directory pathname)) - (italic (T) + (italic (t) (fresh-line) (present (truename pathname)) - (format T " does not exist or is not a directory.~%")) )) + (format t " does not exist or is not a directory.~%")) )) (compute-dirstack-command-eligibility *application-frame*)) (defun comment-on-dir-stack () (if *directory-stack* (progn - (format T "~&The top of the directory stack is now ") + (format t "~&The top of the directory stack is now ") (present (truename (first *directory-stack*))) (terpri)) - (format T "~&The directory stack is now empty.~%"))) + (format t "~&The directory stack is now empty.~%"))) (define-command (com-pop-directory :name "Pop Directory" :menu t @@ -1304,16 +1304,16 @@ (note "The directory stack is empty!") (progn (com-change-directory (pop *directory-stack*)) - (italic (T) (comment-on-dir-stack)))) + (italic (t) (comment-on-dir-stack)))) (compute-dirstack-command-eligibility *application-frame*)) (define-command (com-drop-directory :name "Drop Directory" :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (setf *directory-stack* (rest *directory-stack*)) (comment-on-dir-stack)))) @@ -1323,9 +1323,9 @@ :menu t :command-table directory-stack-commands) () - (italic (T) + (italic (t) (if (null *directory-stack*) - (format T "~&The directory stack is empty!~%") + (format t "~&The directory stack is empty!~%") (progn (psetf (first *directory-stack*) *default-pathname-defaults* *default-pathname-defaults* (first *directory-stack*)) @@ -1412,21 +1412,21 @@ "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." (typecase object (sequence (present object 'expression)) - (T (present object)))) + (t (present object)))) (defun display-evalues (values) - (with-drawing-options (T :ink +olivedrab+) [29 lines skipped] --- /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/15 22:56:54 1.9 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/file-types.lisp 2006/03/29 10:43:37 1.10 @@ -136,7 +136,7 @@ (cond ((wild-pathname-p pathname) (standard-icon "wild.xpm")) ((not (probe-file pathname)) (standard-icon "invalid.xpm")) ((directoryp pathname) *folder-icon*) ;; FIXME: use inode mime types - (T (let ((mime-class (find-class (pathname-mime-type pathname) nil))) + (t (let ((mime-class (find-class (pathname-mime-type pathname) nil))) (if mime-class (or (gethash (class-name mime-class) *icon-mapping*) (icon-of (clim-mop:class-prototype (find-class (pathname-mime-type pathname) nil)))) @@ -201,15 +201,15 @@ (defun read-slashified-line (stream &optional (accumulation nil)) (let ((line (read-line stream nil))) (cond ((null line) (values nil nil)) - ((zerop (length line)) (values accumulation T)) + ((zerop (length line)) (values accumulation t)) ((and (null accumulation) ;; # Comment (char= (elt line 0) #\#)) - (values nil T)) - (T (if (char= #\\ (elt line (1- (length line)))) + (values nil t)) + (t (if (char= #\\ (elt line (1- (length line)))) (read-slashified-line stream (concatenate 'string accumulation (subseq line 0 (1- (length line))))) - (values (concatenate 'string accumulation line) T)))))) + (values (concatenate 'string accumulation line) t)))))) (defun read-the-lines (pathname) (let ((elements nil)) @@ -273,7 +273,7 @@ (when split-pos (let* ((foo (subseq string start split-pos)) (pos (skip-whitespace string (1+ split-pos)))) -; (format T "~%***** foo=~A~%" foo) +; (format t "~%***** foo=~A~%" foo) (when pos (let* ((end (or (if (eql (elt string pos) #\") (1+ (position-if (lambda (c) @@ -299,7 +299,7 @@ (when (eq keysym :type) (setf (gethash :subtype table) (nth-value 2 (read-mime-type bar))) (setf (gethash :media-type table) (read-mime-type bar))) -; (format T "~&~W => ~W~%" foo bar) +; (format t "~&~W => ~W~%" foo bar) (setf (gethash keysym table) value) (parse-netscrapings table string end) )))))) table) @@ -335,7 +335,7 @@ (exts (gethash :exts elt))) (eval `(define-mime-type (,media-type ,subtype) (:extensions ,@exts)))) - #+nil(format T "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) + #+nil(format t "Ignoring ~W, unknown media type.~%" (gethash :type elt))))) (defun parse-mime-types-file (pathname) (mapcar (lambda (x) (process-mime-type (parse-mt-elt x))) @@ -401,7 +401,7 @@ (when (< index (1- (length string))) (push (elt string (incf index)) chars))) ((eql c #\;) (return-from poop chars)) - (T (push c chars))) + (t (push c chars))) (incf index))) (values (string-trim *whitespace* (concatenate 'string (nreverse chars))) @@ -411,7 +411,7 @@ (let* ((sep-pos (position #\= string)) (field-name (subseq string 0 (or sep-pos (length string))))) (values (intern (string-upcase field-name) (find-package :keyword)) - (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) T))))) + (ignore-errors (or (when sep-pos (subseq string (1+ sep-pos))) t))))) (defun parse-mailcap-entry (line) "Parses a line of the mailcap file, returning either nil or the properties @@ -469,7 +469,7 @@ *mime.types-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mime types from ~A~%" path) + (format t "Loading mime types from ~A~%" path) (parse-mime-types-file path))))) (defun load-mailcaps () @@ -477,7 +477,7 @@ *mailcap-search-path*))) (dolist (path (reverse search-path)) (when (probe-file path) - (format T "Loading mailcap from ~A~%" path) + (format t "Loading mailcap from ~A~%" path) (parse-mailcap-file path))))) @@ -544,7 +544,7 @@ (cond ((eql d #\s) (princ (quote-shell-characters (namestring (truename pathname))) out)) ((eql d #\t) (princ (gethash :type spec) out)) ((eql d #\u) (princ (pathname-to-uri-string pathname) out)) - (T (debugf "Ignoring unknown % syntax." d)))) + (t (debugf "Ignoring unknown % syntax." d)))) (write-char c out)))))) (defun find-viewspec (pathname) @@ -571,13 +571,13 @@ (test (gethash :test def)) (needsterminal (gethash :needsterminal def))) (if needsterminal - (format T "Sorry, the viewer app needs a terminal (fixme!)~%") + (format t "Sorry, the viewer app needs a terminal (fixme!)~%") (progn (when test (debugf "Sorry, ignoring TEST option right now.. " test)) (if view-command (run-program "/bin/sh" `("-c" ,(gen-view-command-line def pathname) "&")) - (format T "~&No view-command!~%")))))))) + (format t "~&No view-command!~%")))))))) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2006/01/01 10:14:50 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2006/03/29 10:43:37 1.5 @@ -52,11 +52,11 @@ ;; Icon functions -(defmethod icon-of ((object T)) +(defmethod icon-of ((object t)) *object-icon*) (defun draw-icon (stream pattern &key (extra-spacing 0) ) - (let ((stream (if (eq stream T) *standard-output* stream))) + (let ((stream (if (eq stream t) *standard-output* stream))) (multiple-value-bind (x y) (stream-cursor-position stream) (draw-pattern* stream pattern x y) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/22 09:14:30 1.24 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/03/29 10:43:37 1.25 @@ -84,22 +84,22 @@ #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) #+clisp (values (sys::%room)) #-(or cmu scl sbcl lispworks openmcl clisp) 0)) - (with-text-family (T :serif) - (formatting-table (T :x-spacing '(3 :character)) - (formatting-row (T) + (with-text-family (t :serif) + (formatting-table (t :x-spacing '(3 :character)) + (formatting-row (t) (macrolet ((cell ((align-x) &body body) - `(formatting-cell (T :align-x ,align-x) ,@body))) - (cell (:left) (format T "~A@~A" username sitename)) + `(formatting-cell (t :align-x ,align-x) ,@body))) + (cell (:left) (format t "~A@~A" username sitename)) (cell (:center) - (format T "Package ") - (print-package-name T)) + (format t "Package ") + (print-package-name t)) (cell (:center) (when (probe-file *default-pathname-defaults*) - (with-output-as-presentation (T (truename *default-pathname-defaults*) 'pathname) - (format T "~A" (frob-pathname *default-pathname-defaults*)))) + (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) + (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* - (with-output-as-presentation (T *directory-stack* 'directory-stack) - (format T " (~D deep)" (length *directory-stack*))))) + (with-output-as-presentation (t *directory-stack* 'directory-stack) + (format t " (~D deep)" (length *directory-stack*))))) ;; Although the CLIM spec says the item formatter should try to fill ;; the available width, I can't get either the item or table formatters ;; to really do so such that the memory usage appears right justified. @@ -157,7 +157,7 @@ ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor :interactor :scroll-bars T + (:panes (interactor :interactor :scroll-bars t :display-function #'listener-initial-display-function :display-time t) (doc :pointer-documentation) @@ -218,7 +218,7 @@ (restart-case (call-next-method) (return-to-listener () :report "Return to listener." - (throw 'return-to-listener T))))))) + (throw 'return-to-listener t))))))) ;; Oops. As we've ditched our custom toplevel, we now have to duplicate all ;; this setup work to implement one little trick. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/15 22:56:54 1.20 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/util.lisp 2006/03/29 10:43:37 1.21 @@ -42,7 +42,7 @@ (mapcar #'(lambda (x) (cond ((stringp x) `((princ ,x *trace-output*))) - (T `((princ ',x *trace-output*) + (t `((princ ',x *trace-output*) (princ "=" *trace-output*) (write ,x :stream *trace-output*) (princ #\space *trace-output*))))) @@ -96,8 +96,8 @@ (defun sbcl-frob-to-pathname (pathname string) "This just keeps getting more disgusting." (let* ((parent (strip-filespec pathname)) - (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end T)) - :type (let ((x (position #\. string :start 1 :from-end T))) + (pn (merge-pathnames (make-pathname :name (subseq string 0 (position #\. string :start 1 :from-end t)) + :type (let ((x (position #\. string :start 1 :from-end t))) (if x (subseq string (1+ x)) nil))) parent)) (dir (ignore-errors (sb-posix:opendir (namestring pn))))) @@ -168,7 +168,7 @@ ;;; This ought to change the current directory to *default-pathname-defaults*.. ;;; (see above) -(defun run-program (program args &key (wait T) (output *standard-output*) (input *standard-input*)) +(defun run-program (program args &key (wait t) (output *standard-output*) (input *standard-input*)) #+(or CMU scl) (ext:run-program program args :input input :output output :wait wait) @@ -182,7 +182,7 @@ #+clisp (ext:run-program program :arguments args :wait wait) #-(or CMU scl SBCL lispworks clisp) - (format T "~&Sorry, don't know how to run programs in your CL.~%")) + (format t "~&Sorry, don't know how to run programs in your CL.~%")) ;;;; CLIM/UI utilities @@ -216,12 +216,12 @@ (truncate (/ (text-style-ascent (medium-text-style stream) stream) fraction)))) (defun invoke-as-heading (cont &optional ink) - (with-drawing-options (T :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) + (with-drawing-options (t :ink (or ink +royal-blue+) :text-style (make-text-style :sans-serif :bold nil)) (fresh-line) - (bordering (T :underline) + (bordering (t :underline) (funcall cont)) (fresh-line) - (vertical-gap T))) + (vertical-gap t))) (defun indent-to (stream x &optional (spacing 0) ) "Advances cursor horizontally to coordinate X. If the cursor is already past @@ -451,7 +451,7 @@ ;; Disgusting hacks to make input default to nil, as CMUCL's run-program seems ;; to hang randomly unless I do that. But sometimes I'll need to really change these.. ;; ** Goddamn CMUCL's run-program likes to hang randomly even with this dumb hack. Beware.. -(defparameter *run-output* T) +(defparameter *run-output* t) (defparameter *run-input* nil) ;; We attempt to translate keywords and a few types of lisp objects @@ -459,7 +459,7 @@ (defgeneric transform-program-arg (arg)) -(defmethod transform-program-arg ((arg T)) +(defmethod transform-program-arg ((arg t)) (values (prin1-to-string arg))) (defmethod transform-program-arg ((arg string))

1 0

[mcclim-cvs] CVS mcclim/Examples
by crhodes 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv4918 Modified Files: method-browser.lisp Log Message: Use a bit more of clim-mop in the method browser. May now work on scieneer. --- /project/mcclim/cvsroot/mcclim/Examples/method-browser.lisp 2005/03/06 20:35:40 1.2 +++ /project/mcclim/cvsroot/mcclim/Examples/method-browser.lisp 2006/03/29 09:36:30 1.3 @@ -46,11 +46,11 @@ ;;; * Portable MOP provided by CLIM-MOP package ;;; TODO: -;;; * EQL specializers on implementations other than SBCL/CMUCL -;;; * Nicer, more clever display of methods than simply listing them in a row. -;;; To do this right really involes some nonportable fun and a codewalker. -;;; You could probably write something that just understood the standard -;;; method combination and qualifiers with substantially less work. +;;; * Nicer, more clever display of methods than simply listing them +;;; in a row. To do this right really involes some nonportable +;;; fun and a codewalker. You could probably write something that +;;; just understood the standard method combination and qualifiers +;;; with substantially less work. ;;; * Change focus behavior of McCLIM text entry gadget ;;; * Implement focus-aware cursor shapes in McCLIM and/or Goatee ;;; (actually I did this ages ago, but let it rot away on my disk..) @@ -67,23 +67,19 @@ collect (remove-duplicates (mapcar (lambda (specs) (nth index specs)) specializers))))) +;;; FIXME: why is this necessary? I'm pretty sure the #+CMU clause +;;; here has been superseded by events for quite a while now. (Should +;;; clim-mop:class not cater for these implementation differences?) (defun classp (x) (or (typep x 'cl:class) - #+CMU (typep x 'pcl::class))) - -(defun eql-specializer-p (x) - #+SBCL (typep x 'sb-mop:eql-specializer) - #+CMU (typep x 'pcl:eql-specializer)) - -(defun eql-specializer-object (x) - #+SBCL (sb-mop:eql-specializer-object x) - #+CMU (pcl::eql-specializer-object x)) + #+CMU (typep x 'pcl::class) + #+scl (typep x 'clos::std-class))) (defun compute-applicable-methods-from-specializers (gf specializers) (clim-mop:compute-applicable-methods gf (mapcar (lambda (spec) - (cond ((eql-specializer-p spec) - (eql-specializer-object spec)) + (cond ((typep spec 'clim-mop:eql-specializer) + (clim-mop:eql-specializer-object spec)) ((classp spec) (clim-mop:class-prototype spec)) (t (error "Can't compute effective methods, specializer ~A is not understood." spec)))) @@ -104,17 +100,17 @@ (classp b)) (string< (class-name a) (class-name b))) - ((and (eql-specializer-p a) - (not (eql-specializer-p b))) + ((and (typep a 'clim-mop:eql-specializer) + (not (typep b 'clim-mop:eql-specializer))) nil) - ((and (not (eql-specializer-p a)) - (eql-specializer-p b)) + ((and (not (typep a 'clim-mop:eql-specializer)) + (typep b 'clim-mop:eql-specializer)) t) - ((and (eql-specializer-p a) - (eql-specializer-p b)) + ((and (typep a 'clim-mop:eql-specializer) + (typep b 'clim-mop:eql-specializer)) (string< - (princ-to-string (eql-specializer-object a)) - (princ-to-string (eql-specializer-object b)))) + (princ-to-string (clim-mop:eql-specializer-object a)) + (princ-to-string (clim-mop:eql-specializer-object b)))) (t (warn "Received specializer of unknown type") nil) )))) (compute-gf-specializers gf))) @@ -135,8 +131,8 @@ "Pretty print the name of a method specializer" (cond ((classp spec) (princ-to-string (class-name spec))) - ((eql-specializer-p spec) - (format nil "(EQL '~A)" (eql-specializer-object spec))) + ((typep spec 'clim-mop:eql-specializer) + (format nil "(EQL '~A)" (clim-mop:eql-specializer-object spec))) (t (princ-to-string spec)))) (defun maybe-find-gf (name) @@ -174,7 +170,7 @@ ;; commands within your application, a menu bar, etc. ;; The :panes option is typically used to define and name the important -;; elements of your interface. CLIM provides some syntactic sugare, for +;; elements of your interface. CLIM provides some syntactic sugar, for ;; example (arg-pane :vrack-pane) below is equivalent to ;; (arg-pane (make-pane 'vrack-pane)).

1 0

[mcclim-cvs] CVS mcclim
by crhodes 27 Mar '06

27 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26653 Modified Files: gadgets.lisp panes.lisp Log Message: Patch from Paul Werkowski for with-output-as-gadget. Still not good, but better, as I understand it. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/10 21:58:13 1.96 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2006/03/27 10:46:11 1.97 @@ -2656,17 +2656,15 @@ (defclass gadget-output-record (basic-output-record displayed-output-record) ((gadget :initarg :gadget :accessor gadget))) -(defmethod initialize-instance :after ((record gadget-output-record) &key child x y) - (let* ((sr (compose-space child)) - (width (space-requirement-width sr)) - (height (space-requirement-height sr))) - (allocate-space child width height) - (setf (gadget record) child - (rectangle-edges* record) (values x y (+ x width) (+ y height))))) +(defmethod initialize-instance :after ((record gadget-output-record) &key x y) + (setf (output-record-position record) (values x y))) (defmethod note-output-record-got-sheet ((record gadget-output-record) sheet) (multiple-value-bind (x y) (output-record-position record) (sheet-adopt-child sheet (gadget record)) + (allocate-space (gadget record) + (rectangle-width record) + (rectangle-height record)) (move-sheet (gadget record) x y))) (defmethod note-output-record-lost-sheet ((record gadget-output-record) sheet) @@ -2686,15 +2684,19 @@ (= oy gy)) (move-sheet (gadget record) ox oy))))) -(defun setup-gadget-record (sheet record x y) - ;; Here we modify the height of the current text line. This is necessary so - ;; that when the cursor advances to the next line, it does not start writing - ;; underneath the gadget. This is probably a less than optimal solution. - (with-slots (height) sheet - (setf height (max height (bounding-rectangle-height record)))) - (setf (stream-cursor-position sheet) - (values (+ x (bounding-rectangle-width record)) - y))) +(defun setup-gadget-record (sheet record) + (let* ((child (gadget record)) + (sr (compose-space child)) + (width (space-requirement-width sr)) + (height (space-requirement-height sr))) + (multiple-value-bind (x y)(output-record-position record) + (setf (rectangle-edges* record) (values x y (+ x width) (+ y height))) + (when t ; :move-cursor t + ;; Almost like LWW, except baseline of text should align with bottom + ;; of gadget? FIXME + (setf (stream-cursor-position sheet) + (values (+ x (bounding-rectangle-width record)) + (+ y (bounding-rectangle-height record)))))))) ;; The CLIM 2.0 spec does not really say what this macro should return. ;; Existing code written for "Real CLIM" assumes it returns the gadget pane @@ -2702,22 +2704,36 @@ ;; For compatibility I'm having it return (values GADGET GADGET-OUTPUT-RECORD) (defmacro with-output-as-gadget ((stream &rest options) &body body) - (declare (type symbol stream) - (ignorable options)) - (when (eq stream t) - (setq stream '*standard-output*)) - (let ((gadget (gensym)) - (gadget-output-record (gensym)) - (x (gensym)) - (y (gensym))) - `(multiple-value-bind (,x ,y) (stream-cursor-position ,stream) - (let* ((,gadget (progn ,@body)) - (,gadget-output-record (make-instance 'gadget-output-record - :child ,gadget :x (round ,x) :y (round ,y)))) - (stream-add-output-record ,stream ,gadget-output-record) - (setup-gadget-record ,stream ,gadget-output-record (round ,x) (round ,y)) - (values ,gadget ,gadget-output-record))))) - + ;; NOTE - incremental-redisplay 12/28/05 will call this on redisplay + ;; unless wrapped in (updating-output (stream :cache-value t) ...) + ;; Otherwise, new gadget-output-records are generated but only the first + ;; gadget is ever adopted, and an erase-output-record called on a newer + ;; gadget-output-record will face a sheet-not-child error when trying + ;; to disown the never adopted gadget. + (let ((gadget-output-record (gensym)) + (x (gensym)) + (y (gensym))) + `(multiple-value-bind (,x ,y)(stream-cursor-position ,stream) + (flet ((with-output-as-gadget-continuation (,stream record) + (flet ((with-output-as-gadget-body (,stream) + (declare (ignorable ,stream)) + (progn ,@body))) + (setf (gadget record) + (with-output-as-gadget-body ,stream)))) + (gadget-output-record-constructor () + (make-instance 'gadget-output-record + ,@options :x ,x :y ,y))) + (declare (dynamic-extent with-output-as-gadget-continuation + gadget-output-record-constructor)) + (let ((,gadget-output-record + (invoke-with-output-to-output-record + ,stream + #'with-output-as-gadget-continuation + nil + #'gadget-output-record-constructor))) + (setup-gadget-record ,stream ,gadget-output-record) + (stream-add-output-record ,stream ,gadget-output-record) + (values (gadget ,gadget-output-record) ,gadget-output-record)))))) ;;; (defclass orientation-from-parent-mixin () ()) --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/10 21:58:13 1.167 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/03/27 10:46:11 1.168 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.167 2006/03/10 21:58:13 tmoore Exp $ +;;; $Id: panes.lisp,v 1.168 2006/03/27 10:46:11 crhodes Exp $ (in-package :clim-internals) @@ -2654,7 +2654,8 @@ (let ((frame (pane-frame stream))) (when frame (disown-frame (frame-manager frame) frame))) - (call-next-method)) + (when (next-method-p) + (call-next-method))) (define-application-frame a-window-stream (standard-encapsulating-stream standard-extended-input-stream

1 0

[mcclim-cvs] CVS mcclim
by crhodes 27 Mar '06

27 Mar '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25146 Modified Files: ports.lisp Log Message: Whoops. A missing piece of the Null backend. Put :null at the end of *server-path-search-order*. --- /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/10 21:58:13 1.50 +++ /project/mcclim/cvsroot/mcclim/ports.lisp 2006/03/27 10:44:34 1.51 @@ -25,7 +25,7 @@ (defvar *default-server-path* nil) -(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle)) +(defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl :beagle :null)) (defun find-default-server-path () (loop for port in *server-path-search-order*

1 0

[mcclim-cvs] CVS mcclim/Webpage/downloads
by afuchs 26 Mar '06

26 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv29247/downloads Modified Files: index.html Log Message: Change link to 0.9.2 tarball --- /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2005/07/30 17:11:36 1.12 +++ /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/03/26 20:19:53 1.13 @@ -46,13 +46,13 @@ A compressed tar file of the <a href="http://common-lisp.net/cvs_tarballs/mcclim.tar.gz">sources</a> is made nightly. </p> <h2>Releases</h2> - The most recent release of McCLIM is 0.9.1, in March 2005, available here: <a href="mcclim-0.9.1.tar.gz">mcclim-0.9.1.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. + The most recent release of McCLIM is 0.9.2, in March 2006, available here: <a href="mcclim-0.9.2.tar.gz">mcclim-0.9.2.tar.gz</a>. It is also available via <a href="http://cliki.net/asdf-install">ASDF-INSTALL</a>. </td> </tr> </table> <br> <hr> -$Date: 2005/07/30 17:11:36 $ +$Date: 2006/03/26 20:19:53 $

1 0

[mcclim-cvs] CVS mcclim/ReleaseNotes
by afuchs 26 Mar '06

26 Mar '06

Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv26981a Modified Files: 0-9-2-laetare-sunday Log Message: Added note about INSTALL files. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 1.1 +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 20:06:01 1.2 @@ -6,6 +6,16 @@ This release works on CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL, using the CLX X Window bindings. +Changes to the Install Process +============================== + +Implementation-specific INSTALL.* files were removed. Generic and +implementation-specific Installation instructions were improved and +merged into the file INSTALL. + +This release requires the "spatial-trees" library by Christophe +Rhodes. Get it via asdf-install or at http://cliki.net/spatial-trees. + Changes to Backends ===================

1 0

[mcclim-cvs] CVS mcclim/ReleaseNotes
by afuchs 26 Mar '06

26 Mar '06

Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv25413/ReleaseNotes Added Files: 0-9-2-laetare-sunday Log Message: Erm. Actually add the release notes. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 NONE +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-2-laetare-sunday 2006/03/26 19:58:36 1.1 RELEASE NOTES FOR McCLIM 0.9.2, "Laetare Sunday": Compatibility ============= This release works on CMUCL, SBCL, CLISP, OpenMCL, Allegro CL, LispWorks, and the Scieneer CL, using the CLX X Window bindings. Changes to Backends =================== Copy & Paste code in the CLX backend was improved and should now adhere more strictly to ICCCM. Support for connecting to a ssh-forwarded display was restored. Several unused parts (marked with #+unicode) of the CLX backend were removed, thus restoring buildability on installations of clisp that have the unicode feature turned on. Double buffering for panes was implemented. To use it, create panes with the :double-buffering t initarg. There is now rudimentary support for entering non-Ascii characters from X11 ports using SBCL CLX (a.k.a. telent CLX). McCLIM ships experimental support for TrueType font rendering using the FreeType libraries and the free Bitstream Vera fonts. To use it, link Experimental/freetype/mcclim-freetype.asd to one of your asdf:*central-registry* directories and load the "MCCLIM-FREETYPE" system. An experimental "Null" backend was added that should allow testing of CLIM functionality without requiring a GUI environment to run. Changes to the Documentation ============================ A new chapter on contributed applications was added. Several new figures and examples were added to the manual Clemens Fruhwirth added a CLIM tutorial paper called "A Guided Tour to CLIM". It is available in Doc/Guided-Tour/. Changes to Contributed Applications and Examples ================================================ New application: A CLIM Debugger (by Peter Mechlenborg). It resides in Apps/Debugger/. New application: Functional-Geometry by Frank Buss and Rainer Joswig. It resides in Apps/Functional-Geometry/. The Inspector now is now able to disassemble functions and inspect pathnames. The Listener can now produce vertically-aligned graphs. The Scigraph application now builds on SBCL again. A demo for drag-and-drop-translators was added. Further additions to McCLIM =========================== There is now a test suite, located in Tests/. It contains tests for regions, bounding rectangles, transformations, commands, and the PostScript backend. With the addition of the Null backend, we hope to add several more tests for more chapters of the CLIM spec. New Extension "conditional-commands": allows activation/deactivation of commands when other commands are invoked. It resides in Extensions/conditional-commands/. Status of the CLIM 2 Spec Implementation ======================================== Here is a list of what we think works, organized by chapters and sections of the CLIM 2 specification. Chapter 3 Regions Mostly finished. There are some troublesome parts of the specification that may not be implemented for all possible regions, for instance region-contains-region-p. There may not be an efficient way of implementing this function for all kinds of regions. Chapter 4, Bounding rectangles Finished Chapter 5, Affine transformations Finished Chapter 6, Overview of window facilities Finished Chapter 7, Properties of sheets Finished, though the correct behavior of sheet transformations may not have been tested. Chapter 8, Sheet protocols Finished Chapter 9, Ports, Grafts, and Mirrored sheets Finished Chapter 10, Sheet and medium output facilities Finished Chapter 11, Text styles Mostly complete. There is now experimental support for device font text styles (via make-device-font-text-style) for the CLX, PostScript, and CLX+FreeType backends. Chapter 12, Graphics Finished Chapter 13, Drawing in Color I am note sure about the state of this. I thought we were doing only full opacity and full transparency, but I see traces of more general designs. Chapter 14, General Designs The composition of designs is not supported. We do support regions as designs. Chapter 15, Extended Stream Output Extended output streams are fully supported. Chapter 16, Output Recording Output recording is mostly implemented. This release ships with a standard-tree-output-record type for the first time. The tree output record type speeds up point- and region-based queries, but slows down insertion of output records by a bit. make-design-from-output-record is not implemented. *Note*: the coordinates in output records are relative to the stream. This is in conformance with the Spec, but not necessarily compatible with other CLIM implementations. Chapter 17, Table Formatting Table formatting is completely implemented. Chapter 18, Graph Formatting Graph formatting is fully implemented. The :hash-table argument to format-graph-from-roots is ignored. Support for a :dag graph type was added, as was support for vertically oriented graphs and support for the :arc-drawer argument to format-graph-from-roots. Chapter 19, Bordered Output Bordered output is fully supported. Chapter 20, Text Formatting With the exception of the :after-line-break-initially argument to filling-output, this chapter is fully implemented. Chapter 21 Incremental Redisplay The updating-output interface to incremental redisplay is implemented. McCLIM makes no effort to move i.e., bitblit, output records; they are always erased and redrawn if their position changes. This is much more compatible with support for partial transparency. The :x, :y, :parent-x and :parent-y arguments to redisplay-output-record are ignored. McCLIM follows the spirit of 21.3 "Incremental Redisplay Protocol", but we have not tried very hard to implement the vague description in the Spec. augment-draw-set, note-output-record-child-changed and propagate-output-record-changes-p are not implemented. Incremental redisplay in McCLIM may still suffer from performance problems, despite the presence of spatially-organized compound output record types. Chapter 22, Extended Stream Input The implementation of extended input streams is quite complete. (setf* pointer-position) is not implemented. There is no stream numeric argument, so that slot of the accelerator-gesture condition is always 1. Chapter 23 Presentation Types Most of the literal specification of this chapter is implemented. Specific accept and present presentation methods for some types are not implemented, so the default method may be surprising. The output record bounding rectangle is always used or highlighting and pointer testing. presentation-default-processor is not implemented. The presentation method mechanism supports all method combinations. The body of a presentation method is surrounded with a block of the same name as the presentation method, not just the magic internal name. The method by which presentation type parameters and options are decoded for the method bodies is a bit different from real CLIM. In particular, you cannot refer to the type parameters and options in the lambda list of the method. The NIL value of presentation-single-box is now supported. Presentation type histories are now partially implemented. The gesture C-M-y should recall the last entered presentation. define-drag-and-drop-translator is now implemented. Chapter 24 Input Editing and Completion Facilities with-input-editor-typeout is not implemented. The noise strings produced by input-editor-format and the strings produced by presentation-replace-input are not read-only. This could lead to interesting "issues" if the user edits them. Only a few of the suggested editing commands are implemented. An additional command that is implemented is control-meta-B, which drops into the debugger. add-input-editor-command is not implemented. with-accept-help is not implemented. Chapter 25 Menu Facilities The protocol is implemented, but McCLIM doesn't use it to draw command table menus. Chapter 26 Dialog Facilities McCLIM contains a basic, somewhat buggy implementation of accepting-values. There is little user feedback as to what has been accepted in a dialog. The user has to press the "OK" button to exit the dialog; there are no short cuts. There are no special accept-present-default methods for member or subset presentation types. Command-buttons are not implemented. There is no gadget-based implementation of accepting-values. The internal structure of accepting-values should be "culturally compatible" with real CLIM; if you have some spiffy hack, check the source. :own-window is now supported in accepting-values. Chapter 27 Command Processing command-line-complete-input is not implemented (the functionality does exist in the accept method for command-name). display-command-table-menu and menu-choose-command-from-table are not implemented. Menu-command-parser is not implemented, though the functionality obviously is. Nothing is done about partial menu commands. There is no support for numeric arguments. The command-or-form presentation type is not implemented. Chapter 28 Application Frames raise-frame, bury-frame and notify-user are not implemented. :accept-values panes are not implemented. frame-maintain-presentation-histories is not implemented. frame-drag-and-drop-feedback and frame-drag-and-drop-highlighting are now implemented. execute-frame-command ignores the possibility that frame and the current frame might be different. display-command-menu isn't implemented. Chapter 29 Panes Due to the way the space-allocation protocol is implemented, it is not easy to create application-specific layout-panes. Client code needs to know about :AROUND methods to compose-space, but they are not mentioned in the spec. restraining-pane is partially implemented. Chapter 30 Gadgets This chapter is implemented. with-output-as-gadget is not quite working yet, but it was improved since the last release.

1 0

[mcclim-cvs] CVS mcclim/Webpage/downloads
by afuchs 26 Mar '06

26 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv25264/Webpage/downloads Removed Files: mcclim-0.9.1.tar.gz mcclim-0.9.1.tar.gz.asc Log Message: Add release notes for 0.9.2. Fix README. Remove .tar.gz files. * README now mentions mcclim-devel and the correct release. * release notes: self-explanatory. * Removed the .tar.gz files, so no more uselessly gigantic checkouts.

1 0