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)