Author: junrue Date: Tue Sep 26 16:54:18 2006 New Revision: 269
Modified: trunk/src/uitoolkit/system/datastructs.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp Log: added foreign type translators for the RECT and POINT foreign types
Modified: trunk/src/uitoolkit/system/datastructs.lisp ============================================================================== --- trunk/src/uitoolkit/system/datastructs.lisp (original) +++ trunk/src/uitoolkit/system/datastructs.lisp Tue Sep 26 16:54:18 2006 @@ -58,15 +58,38 @@ (declare (ignore param)) (cffi:foreign-free ptr))
+(defmethod cffi:free-translated-object (ptr (name (eql 'rect-pointer)) param) + (declare (ignore param)) + (cffi:foreign-free ptr)) + (defmethod cffi:translate-from-foreign (ptr (name (eql 'point-pointer))) - (if (null-pointer-p ptr) + (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))) + (if (cffi:null-pointer-p ptr) + (make-rectangle) + (cffi:with-foreign-slots ((left top right bottom) ptr rect) + (let ((pnt (make-point :x left :y top)) + (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))) (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))) + (let ((ptr (cffi:foreign-alloc 'rect)) + (pnt (location lisp-rect)) + (size (size lisp-rect))) + (cffi:with-foreign-slots ((left top right bottom) ptr rect) + (setf left (gfs:point-x pnt) + top (gfs:point-y pnt) + right (+ (gfs:point-x pnt) (gfs:size-width size)) + bottom (+ (gfs:point-y pnt) (gfs:size-height size)))) + ptr))
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 26 16:54:18 2006 @@ -1277,6 +1277,15 @@ (defconstant +ws-ex-composited+ #x02000000) (defconstant +ws-ex-noactivate+ #x08000000)
+(defconstant +wvr-aligntop+ #x0010) +(defconstant +wvr-alignleft+ #x0020) +(defconstant +wvr-alignbottom+ #x0040) +(defconstant +wvr-alignright+ #x0080) +(defconstant +wvr-hredraw+ #x0100) +(defconstant +wvr-vredraw+ #x0200) +(defconstant +wvr-redraw+ #x0300) +(defconstant +wvr-validrects+ #x0400) + (defconstant +white-brush+ 0) (defconstant +ltgray-brush+ 1) (defconstant +gray-brush+ 2)
Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 26 16:54:18 2006 @@ -287,6 +287,8 @@ (incupdate BOOL) (reserved BYTE :count 32))
+(defctype rect-pointer :pointer) + (defcstruct rect (left LONG) (top LONG) @@ -300,6 +302,12 @@ (flags DWORD) (device TCHAR :count 32)) ; CCHDEVICENAME
+(defcstruct nccalcsize_params + (clientnewrect rect) + (destvalidrect rect) + (srcvalidrect rect) + (lppos LPTR)) + (defcstruct openfilename (ofnsize DWORD) (ofnhwnd HANDLE) @@ -383,6 +391,15 @@ (cywinborders UINT) (wintype ATOM) (version WORD)) + +(defcstruct windowpos + (hwnd HANDLE) + (hwndafter HANDLE) + (x INT) + (y INT) + (cx INT) + (cy INT) + (flags UINT))
(defcstruct wndclassex (cbsize UINT)