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

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

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv13084/Examples Modified Files: demodemo.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/Examples/demodemo.lisp 2005/02/01 05:35:30 1.7 +++ /project/mcclim/cvsroot/mcclim/Examples/demodemo.lisp 2006/03/29 10:43:43 1.8 @@ -211,4 +211,4 @@ -(format T "~&;; try (CLIM-DEMO::DEMODEMO)~%") +(format t "~&;; try (CLIM-DEMO::DEMODEMO)~%")

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle/windowing
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv13084/Backends/beagle/windowing Modified Files: mirror.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/Backends/beagle/windowing/mirror.lisp 2005/06/05 19:52:57 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2006/03/29 10:43:38 1.7 @@ -455,7 +455,7 @@ (send (send mirror 'window) :frame-rect-for-content-rect rect :style-mask (%beagle-style-mask-for-frame sheet)) - :display T)))) + :display t)))) (defun %beagle-style-mask-for-frame (sheet)

1 0

[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/Backends/PostScript
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv13084/Backends/PostScript Modified Files: afm.lisp class.lisp encoding.lisp font.lisp graphics.lisp package.lisp sheet.lisp standard-metrics.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/Backends/PostScript/afm.lisp 2005/08/13 14:28:23 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/afm.lisp 2006/03/29 10:43:38 1.5 @@ -25,7 +25,7 @@ ;;; - Kerning, ligatures. ;;; - Full AFM/AMFM/ACFM support. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defun space-char-p (char) (member char '(#\Space #\Tab))) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2006/02/06 16:47:47 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2006/03/29 10:43:38 1.9 @@ -32,7 +32,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;;; Medium --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/encoding.lisp 2004/12/03 11:42:43 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/encoding.lisp 2006/03/29 10:43:38 1.2 @@ -23,7 +23,7 @@ ;;; Boston, MA 02111-1307 USA. -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defvar *iso-latin-1-symbolic-names* '#(NIL NIL NIL NIL --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/10 10:56:01 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/font.lisp 2006/03/29 10:43:38 1.10 @@ -23,7 +23,7 @@ ;;; - Kerning, ligatures. ;;; - device fonts -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defclass font-info () ((name :type string :initarg :name :reader font-info-name) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/10 10:56:01 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2006/03/29 10:43:38 1.17 @@ -37,7 +37,7 @@ ;;; - structure this file ;;; - set miter limit? -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) ;;; Postscript output utilities (defun write-number (stream number) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/package.lisp 2002/07/19 06:42:49 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/package.lisp 2006/03/29 10:43:38 1.8 @@ -18,24 +18,23 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :COMMON-LISP-USER) +(in-package :cl-user) -(defpackage "CLIM-POSTSCRIPT" - (:use "CLIM" "CLIM-EXTENSIONS" "CLIM-LISP") - (:export "LOAD-AFM-FILE") - (:import-from "CLIM-INTERNALS" - "GET-ENVIRONMENT-VARIABLE" - "MAP-REPEATED-SEQUENCE" - "ATAN*" - - "ELLIPSE-NORMAL-RADII*" - - "GET-TRANSFORMATION" - "UNTRANSFORM-ANGLE" - "WITH-TRANSFORMED-POSITION" +(defpackage #:clim-postscript + (:use #:clim #:clim-extensions #:clim-lisp) + (:export #:load-afm-file) + (:import-from #:clim-internals + #:get-environment-variable + #:map-repeated-sequence + #:atan* - "MAXF" + #:ellipse-normal-radii* - "PORT-TEXT-STYLE-MAPPINGS" - )) + #:get-transformation + #:untransform-angle + #:with-transformed-position + + #:maxf + + #:port-text-style-mappings)) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/07 15:43:44 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/03/29 10:43:38 1.14 @@ -35,7 +35,7 @@ ;;; ;;;--GB -(in-package :CLIM-POSTSCRIPT) +(in-package :clim-postscript) (defmacro with-output-to-postscript-stream ((stream-var file-stream &rest options) --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/standard-metrics.lisp 2005/08/13 14:28:23 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/standard-metrics.lisp 2006/03/29 10:43:38 1.3 @@ -1,6 +1,6 @@ -(IN-PACKAGE :CLIM-POSTSCRIPT) -(DEFINE-FONT-METRICS '"Times-Roman" +(in-package :clim-postscript) +(define-font-metrics '"Times-Roman" '683 '217 '0 @@ -209,7 +209,7 @@ (-1 "Yacute" 722 890 0 -22 703) (-1 "brokenbar" 200 676 14 -67 133) (-1 "onehalf" 750 676 14 -31 746))) -(DEFINE-FONT-METRICS '"Times-Bold" +(define-font-metrics '"Times-Bold" '676 '205 '0 @@ -419,7 +419,7 @@ (-1 "Yacute" 722 928 0 -15 699) (-1 "brokenbar" 220 691 19 -66 154) (-1 "onehalf" 750 688 12 7 775))) -(DEFINE-FONT-METRICS '"Times-Italic" +(define-font-metrics '"Times-Italic" '683 '205 '-15.5 @@ -630,7 +630,7 @@ (-1 "Yacute" 556 876 0 -78 633) (-1 "brokenbar" 275 666 18 -105 171) (-1 "onehalf" 750 676 10 -34 749))) -(DEFINE-FONT-METRICS '"Times-BoldItalic" +(define-font-metrics '"Times-BoldItalic" '699 '205 '-15 @@ -836,7 +836,7 @@ (-1 "Yacute" 611 904 0 -73 659) (-1 "brokenbar" 220 685 18 -66 154) (-1 "onehalf" 750 683 14 9 723))) -(DEFINE-FONT-METRICS '"Courier" +(define-font-metrics '"Courier" '629 '157 '0 @@ -1077,7 +1077,7 @@ (-1 "aring" 600 627 15 -53 559) (-1 "yacute" 600 672 157 -7 592) (-1 "icircumflex" 600 654 0 -94 505))) -(DEFINE-FONT-METRICS '"Courier-Oblique" +(define-font-metrics '"Courier-Oblique" '629 '157 '-12 @@ -1319,7 +1319,7 @@ (-1 "aring" 600 627 15 -76 569) (-1 "yacute" 600 672 157 4 683) (-1 "icircumflex" 600 654 0 -95 551))) -(DEFINE-FONT-METRICS '"Courier-Bold" +(define-font-metrics '"Courier-Bold" '626 '142 '0 @@ -1558,7 +1558,7 @@ (-1 "aring" 600 678 15 -35 570) (-1 "yacute" 600 661 142 4 601) (-1 "icircumflex" 600 657 0 -63 523))) -(DEFINE-FONT-METRICS '"Courier-BoldOblique" +(define-font-metrics '"Courier-BoldOblique" '626 '142 '-12 @@ -1798,7 +1798,7 @@ (-1 "aring" 600 678 15 -62 592) (-1 "yacute" 600 661 142 20 694) (-1 "icircumflex" 600 657 0 -77 566))) -(DEFINE-FONT-METRICS '"Helvetica" +(define-font-metrics '"Helvetica" '718 '207 '0 @@ -2006,7 +2006,7 @@ (-1 "Yacute" 667 929 0 -14 653) (-1 "brokenbar" 260 737 19 -94 167) (-1 "onehalf" 834 703 19 -43 773))) -(DEFINE-FONT-METRICS '"Helvetica-Oblique" +(define-font-metrics '"Helvetica-Oblique" '718 '207 '-12 @@ -2215,7 +2215,7 @@ (-1 "Yacute" 667 929 0 -167 806) (-1 "brokenbar" 260 737 19 -90 324) (-1 "onehalf" 834 703 19 -114 839))) -(DEFINE-FONT-METRICS '"Helvetica-Bold" +(define-font-metrics '"Helvetica-Bold" '718 '207 '0 @@ -2423,7 +2423,7 @@ (-1 "Yacute" 667 936 0 -15 653) (-1 "brokenbar" 280 737 19 -84 196) (-1 "onehalf" 834 710 19 -26 794))) -(DEFINE-FONT-METRICS '"Helvetica-BoldOblique" +(define-font-metrics '"Helvetica-BoldOblique" '718 '207 '-12

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle/output
by tmoore 29 Mar '06

29 Mar '06

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv13084/Backends/beagle/output Modified Files: medium.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/Backends/beagle/output/medium.lisp 2005/05/28 19:56:07 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2006/03/29 10:43:38 1.5 @@ -93,7 +93,7 @@ (send (medium-bezier-path medium) :set-line-width width) (when dashes - (when (eq dashes T) + (when (eq dashes t) ;; Provide default dash pattern... no idea why, but when I use ;; #(5.0 5.0) as the dafault dash, it gets displayed as a solid ;; line (no dashing). So the default is larger than it needs to @@ -694,7 +694,7 @@ (defmethod medium-draw-point* ((medium beagle-medium) x y) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -709,7 +709,7 @@ (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) (do-sequence ((x y) coord-seq) - (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) T))))) + (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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