March 2007 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r441 - branches/graphic-forms-newtypes/src/uitoolkit/widgets
by junrue＠common-lisp.net 18 Mar '07

18 Mar '07

Author: junrue Date: Sun Mar 18 18:23:03 2007 New Revision: 441 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Log: a call to gfs::show-window immediately following init-window gets us around the get-message hang when running under slime/sbcl Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/top-level.lisp Sun Mar 18 18:23:03 2007 @@ -166,7 +166,8 @@ (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window self classname register-func owner text))) + (init-window self classname register-func owner text) + (show self nil))) (defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self))

1 0

[graphic-forms-cvs] r440 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 18 Mar '07

18 Mar '07

Author: junrue Date: Sun Mar 18 18:22:39 2007 New Revision: 440 Modified: trunk/src/uitoolkit/widgets/top-level.lisp Log: a call to gfs::show-window immediately following init-window gets us past the get-message hang when running under slime/sbcl Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Sun Mar 18 18:22:39 2007 @@ -166,7 +166,8 @@ (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window self classname register-func owner text))) + (init-window self classname register-func owner text) + (show self nil))) (defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self))

1 0

[graphic-forms-cvs] r439 - in trunk: . src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 17:53:30 2007 New Revision: 439 Modified: trunk/NEWS.txt trunk/src/uitoolkit/widgets/panel.lisp Log: set WS_CLIPCHILDREN and WS_CLIPSIBLINGS style bits for panels Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Mar 17 17:53:30 2007 @@ -6,7 +6,10 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Graphic-Forms has been ported to Allegro CL 8.0. +. Ported the library to Allegro CL 8.0. + +. Implemented a new graphics context function GFG:CLEAR that is a convenient + way to fill a window or image with a background color. . GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll and shell32.dll. Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Sat Mar 17 17:53:30 2007 @@ -55,7 +55,7 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-child+ gfs::+ws-visible+))) (loop for sym in (style-of self) do (ecase sym ;; styles that can be combined

1 0

[graphic-forms-cvs] r438 - in branches/graphic-forms-newtypes: . src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 17:53:16 2007 New Revision: 438 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/uitoolkit/widgets/panel.lisp Log: set WS_CLIPCHILDREN and WS_CLIPSIBLINGS style bits for panels Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Sat Mar 17 17:53:16 2007 @@ -6,7 +6,10 @@ . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. -. Graphic-Forms has been ported to Allegro CL 8.0. +. Ported the library to Allegro CL 8.0. + +. Implemented a new graphics context function GFG:CLEAR that is a convenient + way to fill a window or image with a background color. . GFS:OBTAIN-SYSTEM-METRICS now includes version information for comctl32.dll and shell32.dll. Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/panel.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/panel.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/panel.lisp Sat Mar 17 17:53:16 2007 @@ -55,7 +55,7 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) - (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))) + (let ((std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-child+ gfs::+ws-visible+))) (loop for sym in (style-of self) do (ecase sym ;; styles that can be combined

1 0

[graphic-forms-cvs] r437 - in branches/graphic-forms-newtypes: . src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 12:13:55 2007 New Revision: 437 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Log: graphics-context clear now works for widgets and images, added surface-size slot Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Sat Mar 17 12:13:55 2007 @@ -1,4 +1,8 @@ +. Latest CFFI is required to take advantage of newly-added support for the + stdcall calling convention (FIXME: change checked in this past Feb., need + to narrow down which snapshot actually has it). + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-classes.lisp Sat Mar 17 12:13:55 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-classes.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -113,6 +113,10 @@ (widget-handle :accessor widget-handle-of :initform nil) + (surface-size + :accessor surface-size-of + :initarg :surface-size + :initform nil) (logbrush-style :accessor logbrush-style-of :initform gfs::+bs-solid+) Modified: branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/graphics/graphics-context.lisp Sat Mar 17 12:13:55 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-context.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -224,22 +224,16 @@ (error 'gfs:disposed-error)) (setf (background-color self) color (foreground-color self) color) - (let* ((hdc (gfs:handle self)) - (hwnd (gfs::window-from-dc hdc))) - (if (gfs:null-handle-p hwnd) - (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC") - (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom) - wi-ptr gfs::windowinfo) - (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (if (zerop (gfs::get-window-info hwnd wi-ptr)) - (warn 'gfs:win32-warning :detail "get-window-info failed") + (let ((hdc (gfs:handle self)) + (size (surface-size-of self))) + (if size (gfs::with-rect (rect-ptr) (setf gfs::top 0 gfs::left 0 - gfs::bottom gfs::clientbottom - gfs::right gfs::clientright) - (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))))))))) + gfs::right (gfs:size-width size) + gfs::bottom (gfs:size-height size)) + (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))) + (warn 'gfs:toolkit-warning :detail "null surface size")))) (defmethod gfs:dispose ((self graphics-context)) (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) @@ -250,6 +244,7 @@ (if (null (widget-handle-of self)) (funcall fn (gfs:handle self)) (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (surface-size-of self) nil) (setf (widget-handle-of self) nil) (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) @@ -483,9 +478,11 @@ (progn (setf hdc (gfs::get-dc (gfs:handle widget))) (setf (dc-destructor-of self) #'gfs::release-dc) - (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (widget-handle-of self) (gfs:handle widget)) + (setf (surface-size-of self) (gfw:client-size widget)))) (setf (slot-value self 'gfs:handle) hdc) (unless (null image) + (setf (surface-size-of self) (gfg:size image)) (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Sat Mar 17 12:13:55 2007 @@ -410,6 +410,7 @@ (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (disp (dispatcher widget))) + (setf (gfg::surface-size-of gc) (client-size widget)) (unwind-protect (let ((parent (gfw:parent widget))) (when (and parent (typep (dispatcher parent) 'scrolling-helper))

1 0

[graphic-forms-cvs] r436 - in trunk: . src/uitoolkit/graphics src/uitoolkit/widgets
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 12:12:49 2007 New Revision: 436 Modified: trunk/NEWS.txt trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-context.lisp trunk/src/uitoolkit/widgets/event.lisp Log: graphics-context clear now works for widgets and images, added surface-size slot Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sat Mar 17 12:12:49 2007 @@ -1,4 +1,8 @@ +. Latest CFFI is required to take advantage of newly-added support for the + stdcall calling convention (FIXME: change checked in this past Feb., need + to narrow down which snapshot actually has it). + . Greatly expanded the symbols for accessing predefined colors, and now provide access to system color settings in a similar manner. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Sat Mar 17 12:12:49 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-classes.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -113,6 +113,10 @@ (widget-handle :accessor widget-handle-of :initform nil) + (surface-size + :accessor surface-size-of + :initarg :surface-size + :initform nil) (logbrush-style :accessor logbrush-style-of :initform gfs::+bs-solid+) Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-context.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-context.lisp Sat Mar 17 12:12:49 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; graphics-context.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -224,22 +224,16 @@ (error 'gfs:disposed-error)) (setf (background-color self) color (foreground-color self) color) - (let* ((hdc (gfs:handle self)) - (hwnd (gfs::window-from-dc hdc))) - (if (gfs:null-handle-p hwnd) - (warn 'gfs:toolkit-warning :detail "could not retrieve window handle for DC") - (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) - (cffi:with-foreign-slots ((gfs::cbsize gfs::clientright gfs::clientbottom) - wi-ptr gfs::windowinfo) - (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo)) - (if (zerop (gfs::get-window-info hwnd wi-ptr)) - (warn 'gfs:win32-warning :detail "get-window-info failed") - (gfs::with-rect (rect-ptr) - (setf gfs::top 0 - gfs::left 0 - gfs::bottom gfs::clientbottom - gfs::right gfs::clientright) - (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))))))))) + (let ((hdc (gfs:handle self)) + (size (surface-size-of self))) + (if size + (gfs::with-rect (rect-ptr) + (setf gfs::top 0 + gfs::left 0 + gfs::right (gfs:size-width size) + gfs::bottom (gfs:size-height size)) + (gfs::ext-text-out hdc 0 0 gfs::+eto-opaque+ rect-ptr "" 0 (cffi:null-pointer))) + (warn 'gfs:toolkit-warning :detail "null surface size")))) (defmethod gfs:dispose ((self graphics-context)) (gfs::select-object (gfs:handle self) (gfs::get-stock-object gfs::+null-pen+)) @@ -250,6 +244,7 @@ (if (null (widget-handle-of self)) (funcall fn (gfs:handle self)) (funcall fn (widget-handle-of self) (gfs:handle self))))) + (setf (surface-size-of self) nil) (setf (widget-handle-of self) nil) (setf (slot-value self 'gfs:handle) (cffi:null-pointer))) @@ -483,9 +478,11 @@ (progn (setf hdc (gfs::get-dc (gfs:handle widget))) (setf (dc-destructor-of self) #'gfs::release-dc) - (setf (widget-handle-of self) (gfs:handle widget)))) + (setf (widget-handle-of self) (gfs:handle widget)) + (setf (surface-size-of self) (gfw:client-size widget)))) (setf (slot-value self 'gfs:handle) hdc) (unless (null image) + (setf (surface-size-of self) (gfg:size image)) (gfs::select-object hdc (gfs:handle image))))) ;; ensure world-to-device transformation conformance (gfs::set-graphics-mode (gfs:handle self) gfs::+gm-advanced+) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sat Mar 17 12:12:49 2007 @@ -410,6 +410,7 @@ (pnt (gfs:make-point :x gfs::rcpaint-x :y gfs::rcpaint-y)) (size (gfs:make-size :width gfs::rcpaint-width :height gfs::rcpaint-height)) (disp (dispatcher widget))) + (setf (gfg::surface-size-of gc) (client-size widget)) (unwind-protect (let ((parent (gfw:parent widget))) (when (and parent (typep (dispatcher parent) 'scrolling-helper))

1 0

[graphic-forms-cvs] r435 - trunk/src/uitoolkit/system
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 11:24:50 2007 New Revision: 435 Modified: trunk/src/uitoolkit/system/system-types.lisp Log: got rid of BYTE alias for :unsigned-char to avoid CFFI warning Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Sat Mar 17 11:24:50 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-types.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -48,7 +48,6 @@ (defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) (defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) @@ -121,18 +120,18 @@ (bcbitcount WORD)) (defcstruct bitmapinfo - (bisize DWORD) - (biwidth LONG) - (biheight LONG) - (biplanes WORD) - (bibitcount WORD) + (bisize DWORD) + (biwidth LONG) + (biheight LONG) + (biplanes WORD) + (bibitcount WORD) (bicompression DWORD) - (bisizeimage DWORD) - (bixpels LONG) - (biypels LONG) - (biclrused DWORD) - (biclrimp DWORD) - (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) + (bisizeimage DWORD) + (bixpels LONG) + (biypels LONG) + (biclrused DWORD) + (biclrimp DWORD) + (bmicolors :unsigned-char :count 1024)) ; allocate space for max palette (256 RGBQUADs) (defctype bitmapinfo-pointer :pointer) (defctype bitmap-pixels-pointer :pointer) @@ -240,20 +239,20 @@ (hatch LONG)) (defcstruct logfont - (lfheight LONG) - (lfwidth LONG) - (lfescapement LONG) - (lforientation LONG) - (lfweight LONG) - (lfitalic BYTE) - (lfunderline BYTE) - (lfstrikeout BYTE) - (lfcharset BYTE) - (lfoutprec BYTE) - (lfclipprec BYTE) - (lfquality BYTE) - (lfpitchandfamily BYTE) - (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic :unsigned-char) + (lfunderline :unsigned-char) + (lfstrikeout :unsigned-char) + (lfcharset :unsigned-char) + (lfoutprec :unsigned-char) + (lfclipprec :unsigned-char) + (lfquality :unsigned-char) + (lfpitchandfamily :unsigned-char) + (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo (cbsize DWORD) @@ -300,15 +299,15 @@ (pnt point)) (defcstruct paintstruct - (hdc HANDLE) - (erase BOOL) - (rcpaint-x LONG) - (rcpaint-y LONG) - (rcpaint-width LONG) + (hdc HANDLE) + (erase BOOL) + (rcpaint-x LONG) + (rcpaint-y LONG) + (rcpaint-width LONG) (rcpaint-height LONG) - (restore BOOL) - (incupdate BOOL) - (reserved BYTE :count 32)) + (restore BOOL) + (incupdate BOOL) + (reserved :unsigned-char :count 32)) (defctype rect-pointer :pointer) @@ -366,10 +365,10 @@ (ofnexflags DWORD)) (defcstruct rgbquad - (rgbblue BYTE) - (rgbgreen BYTE) - (rgbred BYTE) - (rgbreserved BYTE)) + (rgbblue :unsigned-char) + (rgbgreen :unsigned-char) + (rgbred :unsigned-char) + (rgbreserved :unsigned-char)) (defcstruct scrollinfo (cbsize UINT) @@ -385,26 +384,26 @@ (cy LONG)) (defcstruct textmetrics - (tmheight LONG) - (tmascent LONG) - (tmdescent LONG) + (tmheight LONG) + (tmascent LONG) + (tmdescent LONG) (tminternalleading LONG) (tmexternalleading LONG) - (tmavgcharwidth LONG) - (tmmaxcharwidth LONG) - (tmweight LONG) - (tmoverhang LONG) - (tmdigaspectx LONG) - (tmdigaspecty LONG) - (tmfirstchar :char) - (tmlastchar :char) - (tmdefaultchar :char) - (tmbreakchar :char) - (tmitalic BYTE) - (tmunderlined BYTE) - (tmstruckout BYTE) - (tmpitchfam BYTE) - (tmcharset BYTE)) + (tmavgcharwidth LONG) + (tmmaxcharwidth LONG) + (tmweight LONG) + (tmoverhang LONG) + (tmdigaspectx LONG) + (tmdigaspecty LONG) + (tmfirstchar :char) + (tmlastchar :char) + (tmdefaultchar :char) + (tmbreakchar :char) + (tmitalic :unsigned-char) + (tmunderlined :unsigned-char) + (tmstruckout :unsigned-char) + (tmpitchfam :unsigned-char) + (tmcharset :unsigned-char)) (defcstruct windowinfo (cbsize DWORD)

1 0

[graphic-forms-cvs] r434 - branches/graphic-forms-newtypes/src/uitoolkit/system
by junrue＠common-lisp.net 17 Mar '07

17 Mar '07

Author: junrue Date: Sat Mar 17 11:24:02 2007 New Revision: 434 Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/system-types.lisp Log: got rid of BYTE alias for :unsigned-char to avoid CFFI warning 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 Sat Mar 17 11:24:02 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; system-types.lisp ;;;; -;;;; Copyright (C) 2006, Jack D. Unrue +;;;; Copyright (C) 2006-2007, Jack D. Unrue ;;;; All rights reserved. ;;;; ;;;; Redistribution and use in source and binary forms, with or without @@ -48,7 +48,6 @@ (defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) (defctype BOOLEAN :char) ; shadowed in gfs: package -(defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) (defctype HANDLE :pointer) @@ -121,18 +120,18 @@ (bcbitcount WORD)) (defcstruct bitmapinfo - (bisize DWORD) - (biwidth LONG) - (biheight LONG) - (biplanes WORD) - (bibitcount WORD) + (bisize DWORD) + (biwidth LONG) + (biheight LONG) + (biplanes WORD) + (bibitcount WORD) (bicompression DWORD) - (bisizeimage DWORD) - (bixpels LONG) - (biypels LONG) - (biclrused DWORD) - (biclrimp DWORD) - (bmicolors BYTE :count 1024)) ; allocate space for max palette (256 RGBQUADs) + (bisizeimage DWORD) + (bixpels LONG) + (biypels LONG) + (biclrused DWORD) + (biclrimp DWORD) + (bmicolors :unsigned-char :count 1024)) ; allocate space for max palette (256 RGBQUADs) (define-foreign-type bitmapinfo-pointer-type () () (:actual-type :pointer) @@ -249,19 +248,19 @@ (hatch LONG)) (defcstruct logfont - (lfheight LONG) - (lfwidth LONG) - (lfescapement LONG) - (lforientation LONG) - (lfweight LONG) - (lfitalic BYTE) - (lfunderline BYTE) - (lfstrikeout BYTE) - (lfcharset BYTE) - (lfoutprec BYTE) - (lfclipprec BYTE) - (lfquality BYTE) - (lfpitchandfamily BYTE) + (lfheight LONG) + (lfwidth LONG) + (lfescapement LONG) + (lforientation LONG) + (lfweight LONG) + (lfitalic :unsigned-char) + (lfunderline :unsigned-char) + (lfstrikeout :unsigned-char) + (lfcharset :unsigned-char) + (lfoutprec :unsigned-char) + (lfclipprec :unsigned-char) + (lfquality :unsigned-char) + (lfpitchandfamily :unsigned-char) (lffacename TCHAR :count 32)) ; LF_FACESIZE is 32 (defcstruct menuinfo @@ -311,15 +310,15 @@ (pnt point)) (defcstruct paintstruct - (hdc HANDLE) - (erase BOOL) - (rcpaint-x LONG) - (rcpaint-y LONG) - (rcpaint-width LONG) + (hdc HANDLE) + (erase BOOL) + (rcpaint-x LONG) + (rcpaint-y LONG) + (rcpaint-width LONG) (rcpaint-height LONG) - (restore BOOL) - (incupdate BOOL) - (reserved BYTE :count 32)) + (restore BOOL) + (incupdate BOOL) + (reserved :unsigned-char :count 32)) (define-foreign-type rect-pointer-type () () (:actual-type :pointer) @@ -379,10 +378,10 @@ (ofnexflags DWORD)) (defcstruct rgbquad - (rgbblue BYTE) - (rgbgreen BYTE) - (rgbred BYTE) - (rgbreserved BYTE)) + (rgbblue :unsigned-char) + (rgbgreen :unsigned-char) + (rgbred :unsigned-char) + (rgbreserved :unsigned-char)) (defcstruct scrollinfo (cbsize UINT) @@ -398,26 +397,26 @@ (cy LONG)) (defcstruct textmetrics - (tmheight LONG) - (tmascent LONG) - (tmdescent LONG) + (tmheight LONG) + (tmascent LONG) + (tmdescent LONG) (tminternalleading LONG) (tmexternalleading LONG) - (tmavgcharwidth LONG) - (tmmaxcharwidth LONG) - (tmweight LONG) - (tmoverhang LONG) - (tmdigaspectx LONG) - (tmdigaspecty LONG) - (tmfirstchar :char) - (tmlastchar :char) - (tmdefaultchar :char) - (tmbreakchar :char) - (tmitalic BYTE) - (tmunderlined BYTE) - (tmstruckout BYTE) - (tmpitchfam BYTE) - (tmcharset BYTE)) + (tmavgcharwidth LONG) + (tmmaxcharwidth LONG) + (tmweight LONG) + (tmoverhang LONG) + (tmdigaspectx LONG) + (tmdigaspecty LONG) + (tmfirstchar :char) + (tmlastchar :char) + (tmdefaultchar :char) + (tmbreakchar :char) + (tmitalic :unsigned-char) + (tmunderlined :unsigned-char) + (tmstruckout :unsigned-char) + (tmpitchfam :unsigned-char) + (tmcharset :unsigned-char)) (defcstruct windowinfo (cbsize DWORD)

1 0

[graphic-forms-cvs] r433 - in branches/graphic-forms-newtypes/src/uitoolkit: graphics/plugins/default graphics/plugins/imagemagick system widgets
by junrue＠common-lisp.net 16 Mar '07

16 Mar '07

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)

1 0

[graphic-forms-cvs] r432 - branches/graphic-forms-newtypes
by junrue＠common-lisp.net 16 Mar '07

16 Mar '07

Author: junrue Date: Thu Mar 15 22:02:57 2007 New Revision: 432 Added: branches/graphic-forms-newtypes/ - copied from r431, trunk/ Log: creating a branch for development with cffi-newtypes

1 0