[graphic-forms-cvs] r433 - in branches/graphic-forms-newtypes/src/uitoolkit: graphics/plugins/default graphics/plugins/imagemagick system widgets

[junrue at common-lisp.net]

Author: junrue
Date: Thu Mar 15 22:50:49 2007
New Revision: 433

Modified:
   branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp
   branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
   branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp
   branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp
   branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp
Log:
initial fixes for cffi-newtypes

Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/default/default-data-plugin.lisp	Thu Mar 15 22:50:49 2007
@@ -149,7 +149,7 @@
   size)
 
 (defmethod cffi:translate-to-foreign ((lisp-obj default-data-plugin)
-                                      (name (eql 'gfs::bitmapinfo-pointer)))
+                                      (type gfs::bitmapinfo-pointer-type))
   (let ((bi-ptr (gfg::make-initial-bitmapinfo lisp-obj))
         (colors (gfg:color-table (palette-of lisp-obj))))
     (let ((ptr (cffi:foreign-slot-pointer bi-ptr 'gfs::bitmapinfo 'gfs::bmicolors)))

Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/plugins/imagemagick/magick-data-plugin.lisp	Thu Mar 15 22:50:49 2007
@@ -122,7 +122,7 @@
   size)
 
 (defmethod cffi:translate-to-foreign ((lisp-obj magick-data-plugin)
-                                      (name (eql 'gfs::bitmapinfo-pointer)))
+                                      (type gfs::bitmapinfo-pointer-type))
   ;; FIXME: assume true-color for now
   ;;
   (gfg::make-initial-bitmapinfo lisp-obj))

Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/system/datastructs.lisp	Thu Mar 15 22:50:49 2007
@@ -68,21 +68,21 @@
   (and (= (size-width size1) (size-width size2))
        (= (size-height size1) (size-height size2))))
 
-(defmethod cffi:free-translated-object (ptr (name (eql 'point-pointer)) param)
+(defmethod cffi:free-translated-object (ptr (type point-pointer-type) param)
   (declare (ignore param))
   (cffi:foreign-free ptr))
 
-(defmethod cffi:free-translated-object (ptr (name (eql 'rect-pointer)) param)
+(defmethod cffi:free-translated-object (ptr (type rect-pointer-type) param)
   (declare (ignore param))
   (cffi:foreign-free ptr))
 
-(defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer)))
+(defmethod cffi:translate-from-foreign (ptr (type point-pointer-type))
   (if (cffi:null-pointer-p ptr)
     (make-point)
     (cffi:with-foreign-slots ((x y) ptr point)
       (make-point :x x :y y))))
 
-(defmethod cffi:translate-from-foreign (ptr (name (eql 'rect-pointer)))
+(defmethod cffi:translate-from-foreign (ptr (type rect-pointer-type))
   (if (cffi:null-pointer-p ptr)
     (make-rectangle)
     (cffi:with-foreign-slots ((left top right bottom) ptr rect)
@@ -90,14 +90,14 @@
             (size (make-size :width (- right left) :height (- bottom top))))
         (make-rectangle :location pnt :size size)))))
 
-(defmethod cffi:translate-to-foreign ((lisp-pnt point) (name (eql 'point-pointer)))
+(defmethod cffi:translate-to-foreign ((lisp-pnt point) (type point-pointer-type))
   (let ((ptr (cffi:foreign-alloc 'point)))
     (cffi:with-foreign-slots ((x y) ptr point)
       (setf x (point-x lisp-pnt)
             y (point-y lisp-pnt)))
     ptr))
 
-(defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (name (eql 'rect-pointer)))
+(defmethod cffi:translate-to-foreign ((lisp-rect rectangle) (type rect-pointer-type))
   (let ((ptr (cffi:foreign-alloc 'rect))
         (pnt (location lisp-rect))
         (size (size lisp-rect)))

Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp	Thu Mar 15 22:50:49 2007
@@ -134,8 +134,13 @@
   (biclrimp DWORD)
   (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs)
 
-(defctype bitmapinfo-pointer    :pointer)
-(defctype bitmap-pixels-pointer :pointer)
+(define-foreign-type bitmapinfo-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser bitmapinfo-pointer))
+
+(define-foreign-type bitmap-pixels-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser bitmap-pixels-pointer))
 
 (defcstruct bitmapinfoheader
   (bisize DWORD)
@@ -185,7 +190,9 @@
   (buildnum DWORD)
   (platform DWORD))
 
-(defctype dllversioninfo-pointer :pointer)
+(define-foreign-type dllversioninfo-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser dllversioninfo-pointer))
 
 (defcstruct drawitemstruct
   (ctltype    UINT)
@@ -228,7 +235,9 @@
   (hmask      HANDLE)
   (hcolor     HANDLE))
 
-(defctype iconinfo-pointer :pointer)
+(define-foreign-type iconinfo-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser iconinfo-pointer))
 
 (defcstruct initcommoncontrolsex
   (size DWORD)
@@ -278,7 +287,9 @@
   (cch UINT)
   (hbmpitem HANDLE))
 
-(defctype point-pointer :pointer)
+(define-foreign-type point-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser point-pointer))
 
 (defcstruct point
   (x LONG)
@@ -310,7 +321,9 @@
   (incupdate BOOL)
   (reserved BYTE :count 32))
 
-(defctype rect-pointer :pointer)
+(define-foreign-type rect-pointer-type () ()
+  (:actual-type :pointer)
+  (:simple-parser rect-pointer))
 
 (defcstruct rect
   (left LONG)

Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp
==============================================================================
--- branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp	(original)
+++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp	Thu Mar 15 22:50:49 2007
@@ -87,7 +87,7 @@
           (error 'gfs:win32-warning :detail "get-monitor-info failed"))
         (push (= (logand gfs::flags gfs::+monitorinfoof-primary+) gfs::+monitorinfoof-primary+) info)
         (let ((str-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::device)))
-          (push (cffi:foreign-string-to-lisp str-ptr (1- gfs::+cchdevicename+)) info))
+          (push (cffi:foreign-string-to-lisp str-ptr :count (1- gfs::+cchdevicename+)) info))
         (let ((rect-ptr (cffi:foreign-slot-pointer mi-ptr 'gfs::monitorinfoex 'gfs::monitor)))
           (cffi:with-foreign-slots ((gfs::left gfs::top gfs::right gfs::bottom)
                                     rect-ptr gfs::rect)