[mcclim-cvs] CVS mcclim
tmoore
tmoore at common-lisp.net
Wed Mar 29 10:43:37 UTC 2006
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
+ , at 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 , at contents))))
(make-pane 'scroller-pane , at 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 , at 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)
More information about the Mcclim-cvs
mailing list