mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Backends/beagle/native-panes
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native-panes Modified Files: beagle-fundamental-button-pane.lisp beagle-scroll-bar-pane.lisp beagle-slider-pane.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-fundamental-button-pane.lisp 2005/06/12 16:53:26 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-fundamental-button-pane.lisp 2008/05/16 14:05:15 1.2 @@ -77,10 +77,11 @@ (defun %beagle-get-label-size (label sheet) - (let ((retsize 0.0) + (let ((retsize (cg-floatify 0.0)) (dictionary (reuse-attribute-dictionary (sheet-medium sheet) (send (@class ns-font) - :system-font-of-size 0.0)))) + :system-font-of-size + (cg-floatify 0.0))))) (slet ((label-size (send (ccl::%make-nsstring label) :size-with-attributes dictionary))) (setf retsize label-size) @@ -100,12 +101,13 @@ (defmethod compose-space ((pb beagle-push-button-pane) &key width height) (declare (ignore width height)) ;; - magic numbers are from the HIG - (let ((column-spacing 12.0) - (row-spacing 12.0) - (standard-width-sans-ends 41.0) - (standard-end-size 28.0) - (standard-width 69.0) ; width of OK, Cancel buttons - (standard-height 20.0) + (let ((column-spacing #.(cg-floatify 12.0)) + (row-spacing #.(cg-floatify 12.0)) + (standard-width-sans-ends #.(cg-floatify 41.0)) + (standard-end-size #.(cg-floatify 28.0)) + ; width of OK, Cancel buttons + (standard-width #.(cg-floatify 69.0)) + (standard-height #.(cg-floatify 20.0)) (label-size (%beagle-get-label-size (gadget-label pb) pb))) (let ((width (if (< (pref label-size :<NSS>ize.width) standard-width-sans-ends) standard-width-sans-ends @@ -125,10 +127,10 @@ (sheet beagle-push-button-pane)) (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-button :with-frame rect))) (send mirror 'retain) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/04/25 18:50:31 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2008/05/16 14:05:17 1.10 @@ -21,10 +21,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (space-requirement-width q) - (space-requirement-height q))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-scroller :with-frame rect))) (send mirror 'retain) @@ -33,7 +33,7 @@ (send mirror :set-enabled #$YES) ;; Make knob fill pane initially. - (send mirror :set-float-value 0.0 :knob-proportion 1.0) + (send mirror :set-float-value 0.0 :knob-proportion #.(cg-floatify 1.0)) (setf (toolkit-object sheet) mirror) (setf (view-lisp-scroller mirror) sheet) @@ -99,7 +99,7 @@ (/ ts (+ range ts))))) (send (toolkit-object scroll-bar) :set-float-value (coerce (clamp value 0.0 1.0) 'short-float) - :knob-proportion (coerce (clamp loz-size 0.0 1.0) 'short-float)))) + :knob-proportion (cg-floatify (clamp loz-size 0.0 1.0))))) (defmethod (setf gadget-min-value) :after (new-value (pane beagle-scroll-bar-pane)) @@ -153,7 +153,7 @@ (/ size range)))) (send (toolkit-object gadget) :set-float-value (coerce position 'short-float) - :knob-proportion (coerce loz-size 'short-float))))) + :knob-proportion (cg-floatify loz-size))))) ;;; Called in the Cocoa App thread. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2005/06/12 13:27:42 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2008/05/16 14:05:18 1.2 @@ -26,10 +26,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-slider :with-frame rect))) (send mirror 'retain)

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle/native
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native Modified Files: lisp-bezier-path.lisp lisp-image.lisp lisp-view.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-bezier-path.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-bezier-path.lisp 2008/05/16 14:05:11 1.2 @@ -28,7 +28,7 @@ (defclass lisp-bezier-path (ns:ns-bezier-path) ((colour :foreign-type :id :accessor path-colour) - (fill :foreign-type :bool + (fill :foreign-type :<bool> :initform #$NO :accessor path-fill)) (:metaclass ns:+ns-object)) @@ -36,7 +36,7 @@ (define-objc-method ((:void :set-colour colour) lisp-bezier-path) (setf (path-colour self) colour)) -(define-objc-method ((:void :set-fill (:bool fill)) lisp-bezier-path) +(define-objc-method ((:void :set-fill (:<bool> fill)) lisp-bezier-path) (setf (path-fill self) fill)) (define-objc-method ((:void draw) lisp-bezier-path) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2008/05/16 14:05:11 1.2 @@ -129,7 +129,7 @@ (progn (send self 'lock-focus) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)))) ;;; (format *debug-io* "(paste-bitmap...) - FAILED TO LOCK FOCUS ON VIEW (NOT VALID) ~S!!!~%" self))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2006/03/24 11:18:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2008/05/16 14:05:11 1.3 @@ -119,7 +119,7 @@ (when (send self 'lock-focus-if-can-draw) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)) ;;; (send (send self 'window) 'flush-window)) @@ -127,7 +127,7 @@ (define-objc-method ((:void :draw-image image :at-point (:<NSP>oint point)) lisp-view) (when (send self 'lock-focus-if-can-draw) - (send image :dissolve-to-point point :fraction 1.0) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0)) (send self 'unlock-focus))) ;;; ----------------------------------------------------------------------------

1 0

[mcclim-cvs] CVS mcclim/Backends/beagle
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv3307/Backends/beagle Modified Files: cocoa-util.lisp package.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/cocoa-util.lisp 2005/06/05 19:52:54 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/cocoa-util.lisp 2008/05/16 14:05:09 1.5 @@ -23,30 +23,33 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :ccl) +(in-package :beagle) + +(declaim (inline cg-floatify)) +(defun cg-floatify (cg-float-value) + (float cg-float-value ns:+cgfloat-zero+)) -;; Make an NSRect structure with the origin at (x, y) and with the width and height -;; specified. (defun make-ns-rect (x y width height) "Make a Cocoa NSRect structure with the origin at (x, y) and with the width and height specified. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :<NSR>ect :origin.x x - :origin.y y - :size.width width - :size.height height)) + (ccl:make-record :<NSR>ect + :origin.x (cg-floatify x) + :origin.y (cg-floatify y) + :size.width (cg-floatify width) + :size.height (cg-floatify height))) (defun make-ns-point (x y) "Make a Cocoa NSPoint structure populated with x and y provided. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :<NSP>oint :x x :y y)) + (ccl:make-record :<NSP>oint :x (cg-floatify x) :y (cg-floatify y))) ;; Stolen from Bosco "main.lisp". (defun description (c) - (with-autorelease-pool - (lisp-string-from-nsstring - (send c 'description)))) + (ccl::with-autorelease-pool + (ccl::lisp-string-from-nsstring + (ccl::send c 'description)))) (defun nslog (c) (let* ((rep (format nil "~a" c))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2007/12/18 10:54:21 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2008/05/16 14:05:09 1.7 @@ -1,18 +1,5 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :cocoa)) - -;;; START - Cribbed from framework/cocoa-support.lisp -(in-package "CCL") -(defun nslog (c) - "Writes a string message to the OSX console log." - (let* ((rep (format nil "~a" c))) - (with-cstrs ((str rep)) - (with-nsstr (nsstr str (length rep)) - (#_NSLog #@"Logging: %@" :address nsstr))))) -;;; END - (in-package :common-lisp-user) (defpackage :beagle @@ -84,11 +71,9 @@ (:import-from :ccl #:@class #:define-objc-method - #:description #:get-selector-for #:make-cstring #:%make-nsstring - #:nslog #:ns-make-point #:%null-ptr #:pref

1 0

[mcclim-cvs] CVS mcclim
by rschlatte 16 May '08

16 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3307 Modified Files: mcclim.asd Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/01 21:45:23 1.83 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/16 14:05:07 1.84 @@ -82,11 +82,9 @@ (defsystem :clx :class requireable-system)) -;;; Required for the beagle backend (not activated by default) +;;; Clozure CL native GUI stuff #+clim-beagle -(progn - (require :cocoa) - (require :objc-support)) +(require :cocoa) (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn @@ -405,6 +403,7 @@ :serial t :components ((:file "package") + (:file "cocoa-util") (:module "native" :components ((:file "lisp-bezier-path") (:file "lisp-window") @@ -417,7 +416,6 @@ (:file "lisp-slider") (:file "lisp-button") (:file "lisp-image"))) - (:file "cocoa-util") (:module "windowing" :depends-on ("native") :components ((:file "port")

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 May '08

15 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7688 Modified Files: text-formatting.lisp Log Message: FILLING-OUTPUT fixes: * Very naive and inefficient implementation of STREAM-WRITE-STRING. * Silenced compiler warning. --- /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2006/03/29 10:43:37 1.9 +++ /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2008/05/15 16:07:59 1.10 @@ -80,13 +80,17 @@ (encapsulating-stream-stream stream)))) (call-next-method)))) +(defmethod stream-write-string :around ((stream filling-stream) string + &optional (start 0) (end (length string))) + (dotimes (i (- end start)) + (stream-write-char stream (aref string (+ i start))))) + ;;; All the monkey business with the lambda form has to do with capturing the ;;; keyword arguments of the macro while preserving the user's evaluation order. (defmacro filling-output ((stream &rest args &key fill-width break-characters after-line-break after-line-break-initially) &body body) - (declare (ignore after-line-break-initially)) (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (fill-var break-var after-var initially-var) @@ -94,7 +98,7 @@ ((:break-characters ,break-var)) ((:after-line-break ,after-var)) ((:after-line-break-initially ,initially-var))) - (declare (ignorable ,fill-var ,break-var ,after-var)) + (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var)) (let ((,stream (make-instance 'filling-stream :stream ,stream @@ -103,8 +107,9 @@ `(:break-characters ,break-var)) ,@(and after-line-break `(:after-line-break ,after-var))))) - (when ,initially-var - (write-string ,after-var ,stream)) + ,(unless (null after-line-break-initially) + `(when ,initially-var + (write-string ,after-var ,stream))) ,@body)) ,@args)))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 15 May '08

15 May '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21582/Drei Modified Files: views.lisp Log Message: Delete the line cache when changing the buffer of a Drei buffer view. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/03 07:47:17 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/15 13:51:40 1.46 @@ -645,7 +645,7 @@ (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) - (with-accessors ((top top) (bot bot) + (with-accessors ((top top) (bot bot) (lines lines) (lines-prefix lines-prefix-size) (lines-suffix lines-suffix-size) (buffer-size last-seen-buffer-size)) view @@ -654,6 +654,7 @@ lines-prefix 0 lines-suffix 0 buffer-size 0) + (delete-elements* lines 0 (nb-elements lines)) (update-line-data view))) (defmethod cache-string :around ((view drei-buffer-view))

1 0

[mcclim-cvs] CVS mcclim
by ahefner 13 May '08

13 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15466 Modified Files: sheets.lisp Log Message: clim:graft should return nil for degrafted sheets. Also, strengthen conditions necessary to process configure-notify for toplevel sheets. This should reduce or eliminate 'No applicable method for generic funciton clim:graft with arguments NIL' errors when closing the listener, due to a race condition between disown-frame and the CLX event thread. --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/01/21 01:26:42 1.55 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/05/13 03:04:37 1.56 @@ -448,7 +448,7 @@ (bury-mirror (port sheet) sheet))) (defmethod graft ((sheet sheet-parent-mixin)) - (graft (sheet-parent sheet))) + (and (sheet-parent sheet) (graft (sheet-parent sheet)))) (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin)) (declare (ignore newvalue))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by ahefner 13 May '08

13 May '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv15466/Backends/CLX Modified Files: port.lisp Log Message: clim:graft should return nil for degrafted sheets. Also, strengthen conditions necessary to process configure-notify for toplevel sheets. This should reduce or eliminate 'No applicable method for generic funciton clim:graft with arguments NIL' errors when closing the listener, due to a race condition between disown-frame and the CLX event thread. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/21 01:07:49 1.133 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/05/13 03:04:39 1.134 @@ -743,8 +743,8 @@ :timestamp time)) ;; (:configure-notify - ;; Resizes are consolidated later.. --Hefner (cond ((and (eq (sheet-parent sheet) (graft sheet)) + (graft sheet) (not override-redirect-p) (not send-event-p)) ;; this is genuine event for a top-level sheet (with

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 09 May '08

09 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10826 Modified Files: gadgets.lisp Log Message: The default value of a list-pane should be NIL. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 21:24:28 1.110 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 22:16:11 1.111 @@ -628,7 +628,8 @@ (:documentation "The instantiable class that implements an abstract list pane, that is, a gadget whose semantics are similar to a radio box or check box, but whose visual - appearance is a list of buttons.")) + appearance is a list of buttons.") + (:default-initargs :value nil)) (defclass option-pane (value-gadget) ()

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 09 May '08

09 May '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31790 Modified Files: gadgets.lisp Log Message: Fix list panes with multi-element-selection. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 19:12:14 1.109 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 21:24:28 1.110 @@ -1976,15 +1976,18 @@ (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected."))) -(defmethod value-changed-callback - :before +(defmethod value-changed-callback :before ((gadget generic-list-pane) client gadget-id value) (declare (ignore client gadget-id)) - (let* ((i (position value (generic-list-pane-item-values gadget))) - (item (elt (list-pane-items gadget) i)) - (ptype (funcall (list-pane-presentation-type-key gadget) item))) - (when ptype - (throw-object-ptype value ptype)))) + ;; Maybe act as if a presentation was clicked on, but only if the + ;; list pane only allows single-selection. + (when (or (eq (list-pane-mode gadget) :one-of) + (eq (list-pane-mode gadget) :exclusive)) + (let* ((i (position value (generic-list-pane-item-values gadget))) + (item (elt (list-pane-items gadget) i)) + (ptype (funcall (list-pane-presentation-type-key gadget) item))) + (when ptype + (throw-object-ptype value ptype))))) (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive)

1 0

← Newer
1
...
9
10
11
12
13
14
15
...
170
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs