[mcclim-cvs] CVS mcclim/Backends/beagle/output
rschlatte
rschlatte at common-lisp.net
Fri May 16 14:05:27 UTC 2008
Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output
In directory clnet:/tmp/cvs-serv3307/Backends/beagle/output
Modified Files:
fonts.lisp medium.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/output/fonts.lisp 2007/12/18 10:54:22 1.4
+++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2008/05/16 14:05:23 1.5
@@ -37,13 +37,13 @@
:serif "Times New Roman"
:sans-serif "Verdana"))
-(defparameter *beagle-text-sizes* '(:normal 12.0
- :tiny 9.0
- :very-small 10.0
- :small 11.0
- :large 14.0
- :very-large 18.0
- :huge 24.0))
+(defparameter *beagle-text-sizes* '(:normal #.(cg-floatify 12.0)
+ :tiny #.(cg-floatify 9.0)
+ :very-small #.(cg-floatify 10.0)
+ :small #.(cg-floatify 11.0)
+ :large #.(cg-floatify 14.0)
+ :very-large #.(cg-floatify 18.0)
+ :huge #.(cg-floatify 24.0)))
(defparameter *beagle-native-fonts* (make-hash-table :test #'equal))
(defparameter *beagle-font-metrics* (make-hash-table :test #'equal))
--- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2006/03/29 10:43:38 1.5
+++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2008/05/16 14:05:23 1.6
@@ -84,7 +84,7 @@
(defmethod (setf medium-line-style) :before (line-style (medium beagle-medium))
(unless (equal (medium-line-style medium) line-style)
- (let ((width (coerce (line-style-thickness line-style) 'short-float))
+ (let ((width (cg-floatify (line-style-thickness line-style)))
(cap (%translate-cap-shape (line-style-cap-shape line-style)))
(dashes (line-style-dashes line-style))
(join (%translate-joint-shape (line-style-joint-shape line-style))))
@@ -344,7 +344,7 @@
(defmethod %clim-opacity-from-design ((medium beagle-medium) design)
(declare (ignore medium design))
;; Just a stub for now. ::FIXME:: Need to ask on the list about this...
- 1.0)
+ #.(cg-floatify 1.0))
(defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::indirect-ink))
@@ -477,12 +477,8 @@
(defun medium-copy-area-aux (from from-x from-y width height to to-x to-y)
"Helper method for copying areas. 'from' and 'to' must both be 'mirror'
objects. From and To coordinates must already be transformed as appropriate."
- (let* ((source-region (ccl::make-ns-rect (coerce from-x 'short-float)
- (coerce from-y 'short-float)
- (coerce width 'short-float)
- (coerce height 'short-float)))
- (target-point (ccl::make-ns-point (coerce to-x 'short-float)
- (coerce to-y 'short-float)))
+ (let* ((source-region (make-ns-rect from-x from-y width height))
+ (target-point (make-ns-point to-x to-y))
(bitmap-image (send from :copy-bitmap-from-region source-region)))
(when (eql bitmap-image (%null-ptr))
(warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%")
@@ -581,10 +577,10 @@
(do-sequence ((left top right bottom) coord-seq)
(when (< right left) (rotatef left right))
(when (< top bottom) (rotatef top bottom))
- (let ((rect (ccl::make-ns-rect (pixel-center left)
- (pixel-center bottom)
- (pixel-count (- right left))
- (pixel-count (- top bottom)))))
+ (let ((rect (make-ns-rect (pixel-center left)
+ (pixel-center bottom)
+ (pixel-count (- right left))
+ (pixel-count (- top bottom)))))
(send path :append-bezier-path-with-rect rect)
(#_free rect)))
(if filled
@@ -594,16 +590,15 @@
;; ::FIXME:: Move these from here!
(defun pixel-center (pt)
"Ensure any ordinate provided sits on the center of a pixel. This
-prevents Cocoa from 'antialiasing' lines, making them thicker and
-a shade of grey. Ensures the return value is a short-float, as
-required by the Cocoa methods."
- (coerce (+ (round-coordinate pt) 0.5) 'short-float))
+prevents Cocoa from 'antialiasing' lines, making them thicker and a
+shade of grey. Ensures the return value is an appropriate float type."
+ (cg-floatify (+ (round-coordinate pt) 0.5)))
(defun pixel-count (sz)
"Ensures any value provided is rounded to the nearest unit, and
-returned as a short-float as required by the Cocoa methods."
- (coerce (round-coordinate sz) 'short-float))
+returned as an appropriate float type."
+ (cg-floatify (round-coordinate sz)))
;;; Nabbed from CLX backend medium.lisp
@@ -657,10 +652,10 @@
(origin-y (- center-y radius-dy))
(width (* 2 radius-dx))
(height (* 2 radius-dy))
- (rect (ccl::make-ns-rect (pixel-center origin-x)
- (pixel-center origin-y)
- (pixel-count width)
- (pixel-count height))))
+ (rect (make-ns-rect (pixel-center origin-x)
+ (pixel-center origin-y)
+ (pixel-count width)
+ (pixel-count height))))
(send path :append-bezier-path-with-oval-in-rect rect)
(#_free rect)
(if filled
@@ -677,8 +672,8 @@
(pixel-center center-y))))
(send path :append-bezier-path-with-arc-with-center point
:radius (pixel-count radius)
- :start-angle (coerce (/ start-angle (/ pi 180)) 'short-float)
- :end-angle (coerce (/ end-angle (/ pi 180)) 'short-float)
+ :start-angle (cg-floatify (/ start-angle (/ pi 180)))
+ :end-angle (cg-floatify (/ end-angle (/ pi 180)))
:clockwise NIL)))
(if filled
(send mirror :fill-path path :in-colour colour)
@@ -692,8 +687,7 @@
;;; Draws a point on the medium 'medium'.
(defmethod medium-draw-point* ((medium beagle-medium) x y)
- (let ((width (coerce (line-style-thickness (medium-line-style medium))
- 'short-float)))
+ (let ((width (cg-floatify (line-style-thickness (medium-line-style medium)))))
(medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t)))
@@ -707,7 +701,7 @@
(defmethod medium-draw-points* ((medium beagle-medium) coord-seq)
(with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq)
- (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float)))
+ (let ((width (cg-floatify (line-style-thickness (medium-line-style medium)))))
(do-sequence ((x y) coord-seq)
(medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t)))))
@@ -775,10 +769,10 @@
(send mirror :draw-image colour :at-point (ns-make-point (pixel-center left)
(pixel-center top)))
(return-from medium-draw-rectangle* (values)))
- (let ((rect (ccl::make-ns-rect (pixel-center left)
- (pixel-center bottom)
- (pixel-count (- right left))
- (pixel-count (- top bottom)))))
+ (let ((rect (make-ns-rect (pixel-center left)
+ (pixel-center bottom)
+ (pixel-count (- right left))
+ (pixel-count (- top bottom)))))
(send path :append-bezier-path-with-rect rect)
(#_free rect)
(if filled
@@ -853,8 +847,7 @@
(:baseline (- y baseline))
;;; (:bottom y)))
(:bottom (- y text-height))))
- (slet ((point (ns-make-point (coerce x 'short-float)
- (coerce y 'short-float))))
+ (slet ((point (ns-make-point (cg-floatify x) (cg-floatify y))))
(let ((objc-string (%make-nsstring (subseq string start end))))
;; NB: draw-string-at-point uses upper-left as origin in a flipped
;; view.
More information about the Mcclim-cvs
mailing list