From junrue at common-lisp.net Sun Mar 11 17:45:21 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 11 Mar 2007 12:45:21 -0500 (EST) Subject: [graphic-forms-cvs] r431 - trunk/src/uitoolkit/system Message-ID: <20070311174521.182377433D@common-lisp.net> Author: junrue Date: Sun Mar 11 12:45:20 2007 New Revision: 431 Modified: trunk/src/uitoolkit/system/metrics.lisp Log: fix for CFFI API change: foreign-funcall cannot be used on pointers any more Modified: trunk/src/uitoolkit/system/metrics.lisp ============================================================================== --- trunk/src/uitoolkit/system/metrics.lisp (original) +++ trunk/src/uitoolkit/system/metrics.lisp Sun Mar 11 12:45:20 2007 @@ -44,7 +44,7 @@ (cffi:with-foreign-slots ((gfs::size gfs::vermajor gfs::verminor gfs::buildnum) info-ptr gfs::dllversioninfo) (setf gfs::size (cffi:foreign-type-size 'gfs::dllversioninfo)) - (cffi:foreign-funcall func-ptr gfs::dllversioninfo info-ptr gfs::hresult) + (cffi:foreign-funcall-pointer func-ptr (:cconv :stdcall) :pointer info-ptr gfs::hresult) (setf version (list gfs::vermajor gfs::verminor gfs::buildnum)))))) (gfs::free-library hmodule))) version)) From junrue at common-lisp.net Fri Mar 16 03:02:57 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 15 Mar 2007 22:02:57 -0500 (EST) Subject: [graphic-forms-cvs] r432 - branches/graphic-forms-newtypes Message-ID: <20070316030257.6A2FD3C050@common-lisp.net> 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 From junrue at common-lisp.net Fri Mar 16 03:50:50 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 15 Mar 2007 22:50:50 -0500 (EST) Subject: [graphic-forms-cvs] r433 - in branches/graphic-forms-newtypes/src/uitoolkit: graphics/plugins/default graphics/plugins/imagemagick system widgets Message-ID: <20070316035050.D32352F04F@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) From junrue at common-lisp.net Sat Mar 17 16:24:03 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 11:24:03 -0500 (EST) Subject: [graphic-forms-cvs] r434 - branches/graphic-forms-newtypes/src/uitoolkit/system Message-ID: <20070317162403.7B12F1B000@common-lisp.net> 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) From junrue at common-lisp.net Sat Mar 17 16:24:51 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 11:24:51 -0500 (EST) Subject: [graphic-forms-cvs] r435 - trunk/src/uitoolkit/system Message-ID: <20070317162451.EB36334020@common-lisp.net> 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) From junrue at common-lisp.net Sat Mar 17 17:12:50 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 12:12:50 -0500 (EST) Subject: [graphic-forms-cvs] r436 - in trunk: . src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20070317171250.66D4B6D029@common-lisp.net> 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)) From junrue at common-lisp.net Sat Mar 17 17:13:56 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 12:13:56 -0500 (EST) Subject: [graphic-forms-cvs] r437 - in branches/graphic-forms-newtypes: . src/uitoolkit/graphics src/uitoolkit/widgets Message-ID: <20070317171356.8E0816D029@common-lisp.net> 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)) From junrue at common-lisp.net Sat Mar 17 22:53:17 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 17:53:17 -0500 (EST) Subject: [graphic-forms-cvs] r438 - in branches/graphic-forms-newtypes: . src/uitoolkit/widgets Message-ID: <20070317225317.9D11145001@common-lisp.net> 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 From junrue at common-lisp.net Sat Mar 17 22:53:31 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sat, 17 Mar 2007 17:53:31 -0500 (EST) Subject: [graphic-forms-cvs] r439 - in trunk: . src/uitoolkit/widgets Message-ID: <20070317225331.375C745000@common-lisp.net> 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 From junrue at common-lisp.net Sun Mar 18 23:22:40 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 18 Mar 2007 18:22:40 -0500 (EST) Subject: [graphic-forms-cvs] r440 - trunk/src/uitoolkit/widgets Message-ID: <20070318232240.425BFB2A1@common-lisp.net> 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)) From junrue at common-lisp.net Sun Mar 18 23:23:03 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 18 Mar 2007 18:23:03 -0500 (EST) Subject: [graphic-forms-cvs] r441 - branches/graphic-forms-newtypes/src/uitoolkit/widgets Message-ID: <20070318232303.C23D8B1E3@common-lisp.net> 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)) From junrue at common-lisp.net Mon Mar 19 04:25:32 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 18 Mar 2007 23:25:32 -0500 (EST) Subject: [graphic-forms-cvs] r442 - in branches/graphic-forms-newtypes: . src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20070319042532.50DA6B1E3@common-lisp.net> Author: junrue Date: Sun Mar 18 23:25:30 2007 New Revision: 442 Modified: branches/graphic-forms-newtypes/NEWS.txt branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: revised stdcall callback declarations to take advantage of built-in CFFI support Modified: branches/graphic-forms-newtypes/NEWS.txt ============================================================================== --- branches/graphic-forms-newtypes/NEWS.txt (original) +++ branches/graphic-forms-newtypes/NEWS.txt Sun Mar 18 23:25:30 2007 @@ -1,5 +1,5 @@ -. Latest CFFI is required to take advantage of newly-added support for the +. Latest CFFI is required to take advantage of built-in support for the stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). @@ -8,12 +8,27 @@ . Ported the library to Allegro CL 8.0. +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) + . 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. +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.8.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +xx xxxxxxx 2007 + ============================================================================== Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp Sun Mar 18 23:25:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; user32.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 @@ -206,39 +206,13 @@ (hwnd HANDLE) (ps LPTR)) -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumChildWindows" enum-child-windows) - BOOL + ("EnumChildWindows" enum-child-windows :cconv :stdcall) + INT (hwnd HANDLE) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-child-windows "EnumChildWindows") - ((hwnd :foreign-address) - (func :foreign-address) - (lparam :long))) - -#+clisp -(ffi:def-call-out enum-child-windows - (:name "EnumChildWindows") - (:library "user32.dll") - (:language :stdc) - (:arguments (hwnd ffi:c-pointer) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (lparam ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (lparam ffi:long)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -248,50 +222,14 @@ (lparam :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int - (hwnd sb-alien:system-area-pointer) - (func enumchildproc) - (lparam sb-alien:long)) - -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumDisplayMonitors" enum-display-monitors) - BOOL + ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) + INT (hdc HANDLE) (cliprect LPTR) (enumproc LPTR) (data LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors") - ((hdc :foreign-address) - (cliprect :foreign-address) - (func :foreign-address) - (data :foreign-address))) - -#+clisp -(ffi:def-call-out enum-display-monitors - (:name "EnumDisplayMonitors") - (:library "user32.dll") - (:language :stdc) - (:arguments (hdc ffi:c-pointer) - (cliprect ffi:c-pointer) - (func (ffi:c-function - (:arguments - (hmonitor ffi:c-pointer) - (hdc ffi:c-pointer) - (monitorrect ffi:c-pointer) - (data ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (data ffi:c-pointer)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -302,46 +240,13 @@ (data :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int - (hdc sb-alien:system-area-pointer) - (rect sb-alien:system-area-pointer) - (func monitorsenumproc) - (lparam sb-alien:long)) - -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumThreadWindows" enum-thread-windows) - BOOL + ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) + INT (threadid DWORD) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-thread-windows "EnumThreadWindows") - ((thread-id :unsigned-long) - (func :foreign-address) - (lparam :long))) - -#+clisp -(ffi:def-call-out enum-thread-windows - (:name "EnumThreadWindows") - (:library "user32.dll") - (:language :stdc) - (:arguments (threadid ffi:ulong) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (lparam ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (lparam ffi:long)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -351,12 +256,6 @@ (lparam :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int - (id sb-alien:unsigned-long) - (func enumthreadwndproc) - (lparam sb-alien:unsigned-long)) - (defcfun ("GetAncestor" get-ancestor) HANDLE 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 Sun Mar 18 23:25:30 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; display.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 @@ -37,23 +37,13 @@ ;;; helper functions ;;; -(defun display-visitor (hmonitor hdc monitorrect data) +#-cffi-features:no-stdcall +(cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL + ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address) - (hdc :foreign-address) - (monitorrect :foreign-address) - (data :long)) - (declare (:convention :stdcall)) - (call-display-visitor-func (thread-context) hmonitor data)) - - (defvar *monitors-enum-proc* - (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("display_visitor" :result-type :integer :calling-convention :stdcall) @@ -65,17 +55,6 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+sbcl -(defvar *monitors-enum-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int - sb-alien:system-area-pointer - sb-alien:system-area-pointer - sb-alien:system-area-pointer - sb-alien:long) - #'display-visitor - :stdcall)) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) @@ -109,17 +88,13 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+allegro - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (cffi:pointer-address *monitors-enum-proc*) 0)) -#+clisp - (gfs::enum-display-monitors nil nil #'display-visitor nil) +#-cffi-features:no-stdcall + (gfs::enum-display-monitors (cffi:null-pointer) + (cffi:null-pointer) + (cffi:callback display-visitor) 0) #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+sbcl - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -134,7 +109,9 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -(defun top-level-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) @@ -142,16 +119,6 @@ (call-top-level-visitor-func tc win))) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall)) - (top-level-window-visitor hwnd lparam)) - - (defvar *enum-thread-wnd-proc* - (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -160,15 +127,6 @@ (top-level-window-visitor hwnd lparam) 1) -#+sbcl -(defvar *enum-thread-wnd-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int - sb-alien:system-area-pointer - sb-alien:long) - #'top-level-window-visitor - :stdcall)) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -177,22 +135,14 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+allegro - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (cffi:pointer-address *enum-thread-wnd-proc*) - 0) -#+clisp - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top-level-window-visitor - 0) +#-cffi-features:no-stdcall + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (cffi:callback top-level-window-visitor) + 0) #+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (fli:make-pointer :symbol-name "top_level_window_visitor") 0) -#+sbcl - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (sb-alien:alien-sap *enum-thread-wnd-proc*) - 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Sun Mar 18 23:25:30 2007 @@ -70,7 +70,9 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -(defun child-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) @@ -81,16 +83,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall)) - (child-window-visitor hwnd lparam)) - - (defvar *enum-child-proc* - (ff:register-foreign-callable 'enum-child-windows-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -99,13 +91,6 @@ (child-window-visitor hwnd lparam) 1) -#+sbcl -(defvar *enum-child-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long) - #'child-window-visitor - :stdcall)) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -341,22 +326,14 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#+allegro +#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd - (cffi:pointer-address *enum-child-proc*) - (cffi:pointer-address hwnd)) -#+clisp - (gfs::enum-child-windows hwnd - #'child-window-visitor + (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) #+lispworks (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address hwnd)) -#+sbcl - (gfs::enum-child-windows hwnd - (sb-alien:alien-sap *enum-child-proc*) - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil) From junrue at common-lisp.net Mon Mar 19 04:25:53 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Sun, 18 Mar 2007 23:25:53 -0500 (EST) Subject: [graphic-forms-cvs] r443 - in trunk: . src/uitoolkit/system src/uitoolkit/widgets Message-ID: <20070319042553.BAE81B1E3@common-lisp.net> Author: junrue Date: Sun Mar 18 23:25:52 2007 New Revision: 443 Modified: trunk/NEWS.txt trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: revised stdcall callback declarations to take advantage of built-in CFFI support Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Sun Mar 18 23:25:52 2007 @@ -1,5 +1,5 @@ -. Latest CFFI is required to take advantage of newly-added support for the +. Latest CFFI is required to take advantage of built-in support for the stdcall calling convention (FIXME: change checked in this past Feb., need to narrow down which snapshot actually has it). @@ -8,12 +8,27 @@ . Ported the library to Allegro CL 8.0. +. Upgraded to LispWorks 5.0.1 (note: 4.4.6 is no longer supported) + . 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. +The README.txt file in the release zip file also has additional important +information about this release. + +Download the release zip file here: +http://prdownloads.sourceforge.net/graphic-forms/graphic-forms-0.8.0.zip?download + +The project website is: +http://common-lisp.net/project/graphic-forms/ + +Jack Unrue +jdunrue (at) gmail (dot) com +xx xxxxxxx 2007 + ============================================================================== Release 0.7.0 of Graphic-Forms, a Common Lisp library for Windows GUI Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun Mar 18 23:25:52 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; user32.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 @@ -206,39 +206,13 @@ (hwnd HANDLE) (ps LPTR)) -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumChildWindows" enum-child-windows) - BOOL + ("EnumChildWindows" enum-child-windows :cconv :stdcall) + INT (hwnd HANDLE) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-child-windows "EnumChildWindows") - ((hwnd :foreign-address) - (func :foreign-address) - (lparam :long))) - -#+clisp -(ffi:def-call-out enum-child-windows - (:name "EnumChildWindows") - (:library "user32.dll") - (:language :stdc) - (:arguments (hwnd ffi:c-pointer) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (lparam ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (lparam ffi:long)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -248,50 +222,14 @@ (lparam :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumChildWindows" enum-child-windows) sb-alien:int - (hwnd sb-alien:system-area-pointer) - (func enumchildproc) - (lparam sb-alien:long)) - -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumDisplayMonitors" enum-display-monitors) - BOOL + ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) + INT (hdc HANDLE) (cliprect LPTR) (enumproc LPTR) (data LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-display-monitors "EnumDisplayMonitors") - ((hdc :foreign-address) - (cliprect :foreign-address) - (func :foreign-address) - (data :foreign-address))) - -#+clisp -(ffi:def-call-out enum-display-monitors - (:name "EnumDisplayMonitors") - (:library "user32.dll") - (:language :stdc) - (:arguments (hdc ffi:c-pointer) - (cliprect ffi:c-pointer) - (func (ffi:c-function - (:arguments - (hmonitor ffi:c-pointer) - (hdc ffi:c-pointer) - (monitorrect ffi:c-pointer) - (data ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (data ffi:c-pointer)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -302,46 +240,13 @@ (data :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumDisplayMonitors" enum-display-monitors) sb-alien:int - (hdc sb-alien:system-area-pointer) - (rect sb-alien:system-area-pointer) - (func monitorsenumproc) - (lparam sb-alien:long)) - -;;; FIXME: uncomment this when CFFI callbacks can -;;; be tagged as stdcall or cdecl (only the latter -;;; is supported as of 0.9.0) -;;; -#| +#-cffi-features:no-stdcall (defcfun - ("EnumThreadWindows" enum-thread-windows) - BOOL + ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) + INT (threadid DWORD) (func :pointer) (lparam LPARAM)) -|# - -#+allegro -(ff:def-foreign-call (enum-thread-windows "EnumThreadWindows") - ((thread-id :unsigned-long) - (func :foreign-address) - (lparam :long))) - -#+clisp -(ffi:def-call-out enum-thread-windows - (:name "EnumThreadWindows") - (:library "user32.dll") - (:language :stdc) - (:arguments (threadid ffi:ulong) - (func (ffi:c-function - (:arguments - (hwnd ffi:c-pointer) - (lparam ffi:long)) - (:return-type ffi:int) - (:language :stdc-stdcall))) - (lparam ffi:long)) - (:return-type ffi:int)) #+lispworks (fli:define-foreign-function @@ -351,12 +256,6 @@ (lparam :long)) :result-type :int) -#+sbcl -(sb-alien:define-alien-routine ("EnumThreadWindows" enum-thread-windows) sb-alien:int - (id sb-alien:unsigned-long) - (func enumthreadwndproc) - (lparam sb-alien:unsigned-long)) - (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Sun Mar 18 23:25:52 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; display.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 @@ -37,23 +37,13 @@ ;;; helper functions ;;; -(defun display-visitor (hmonitor hdc monitorrect data) +#-cffi-features:no-stdcall +(cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL + ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-display-monitors-callback ((hmonitor :foreign-address) - (hdc :foreign-address) - (monitorrect :foreign-address) - (data :long)) - (declare (:convention :stdcall)) - (call-display-visitor-func (thread-context) hmonitor data)) - - (defvar *monitors-enum-proc* - (ff:register-foreign-callable 'enum-display-monitors-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("display_visitor" :result-type :integer :calling-convention :stdcall) @@ -65,17 +55,6 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+sbcl -(defvar *monitors-enum-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int - sb-alien:system-area-pointer - sb-alien:system-area-pointer - sb-alien:system-area-pointer - sb-alien:long) - #'display-visitor - :stdcall)) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) @@ -109,17 +88,13 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+allegro - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (cffi:pointer-address *monitors-enum-proc*) 0)) -#+clisp - (gfs::enum-display-monitors nil nil #'display-visitor nil) +#-cffi-features:no-stdcall + (gfs::enum-display-monitors (cffi:null-pointer) + (cffi:null-pointer) + (cffi:callback display-visitor) 0) #+lispworks (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+sbcl - (let ((ptr (cffi:null-pointer))) - (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -134,7 +109,9 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -(defun top-level-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) @@ -142,16 +119,6 @@ (call-top-level-visitor-func tc win))) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-thread-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall)) - (top-level-window-visitor hwnd lparam)) - - (defvar *enum-thread-wnd-proc* - (ff:register-foreign-callable 'enum-thread-windows-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -160,15 +127,6 @@ (top-level-window-visitor hwnd lparam) 1) -#+sbcl -(defvar *enum-thread-wnd-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int - sb-alien:system-area-pointer - sb-alien:long) - #'top-level-window-visitor - :stdcall)) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -177,22 +135,14 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+allegro - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (cffi:pointer-address *enum-thread-wnd-proc*) - 0) -#+clisp - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'top-level-window-visitor +#-cffi-features:no-stdcall + (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + (cffi:callback top-level-window-visitor) 0) #+lispworks (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (fli:make-pointer :symbol-name "top_level_window_visitor") 0) -#+sbcl - (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (sb-alien:alien-sap *enum-thread-wnd-proc*) - 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Mar 18 23:25:52 2007 @@ -70,7 +70,9 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -(defun child-window-visitor (hwnd lparam) +#-cffi-features:no-stdcall +(cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL + ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) (child (get-widget tc hwnd)) (parent (get-widget tc (cffi:make-pointer lparam)))) @@ -81,16 +83,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (ff:defun-foreign-callable enum-child-windows-callback ((hwnd :foreign-address) - (lparam :long)) - (declare (:convention :stdcall)) - (child-window-visitor hwnd lparam)) - - (defvar *enum-child-proc* - (ff:register-foreign-callable 'enum-child-windows-callback :reuse t))) - #+lispworks (fli:define-foreign-callable ("child_window_visitor" :result-type :integer :calling-convention :stdcall) @@ -99,13 +91,6 @@ (child-window-visitor hwnd lparam) 1) -#+sbcl -(defvar *enum-child-proc* - (sb-alien::alien-callback - (sb-alien:function sb-alien:int sb-alien:system-area-pointer sb-alien:long) - #'child-window-visitor - :stdcall)) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -341,22 +326,14 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#+allegro +#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd - (cffi:pointer-address *enum-child-proc*) - (cffi:pointer-address hwnd)) -#+clisp - (gfs::enum-child-windows hwnd - #'child-window-visitor + (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) #+lispworks (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") (cffi:pointer-address hwnd)) -#+sbcl - (gfs::enum-child-windows hwnd - (sb-alien:alien-sap *enum-child-proc*) - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil) From junrue at common-lisp.net Wed Mar 28 05:24:47 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Mar 2007 00:24:47 -0500 (EST) Subject: [graphic-forms-cvs] r444 - branches/graphic-forms-newtypes/docs/website Message-ID: <20070328052447.84C6634068@common-lisp.net> Author: junrue Date: Wed Mar 28 00:24:46 2007 New Revision: 444 Modified: branches/graphic-forms-newtypes/docs/website/index.html Log: updated LispWorks version Modified: branches/graphic-forms-newtypes/docs/website/index.html ============================================================================== --- branches/graphic-forms-newtypes/docs/website/index.html (original) +++ branches/graphic-forms-newtypes/docs/website/index.html Wed Mar 28 00:24:46 2007 @@ -49,8 +49,8 @@

Mailing Lists

From junrue at common-lisp.net Wed Mar 28 05:25:10 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Mar 2007 00:25:10 -0500 (EST) Subject: [graphic-forms-cvs] r445 - trunk/docs/website Message-ID: <20070328052510.6D65A34068@common-lisp.net> Author: junrue Date: Wed Mar 28 00:25:10 2007 New Revision: 445 Modified: trunk/docs/website/index.html Log: updated LispWorks version Modified: trunk/docs/website/index.html ============================================================================== --- trunk/docs/website/index.html (original) +++ trunk/docs/website/index.html Wed Mar 28 00:25:10 2007 @@ -49,8 +49,8 @@

Mailing Lists

From junrue at common-lisp.net Wed Mar 28 05:26:03 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Mar 2007 00:26:03 -0500 (EST) Subject: [graphic-forms-cvs] r446 - branches/graphic-forms-newtypes/src/uitoolkit/widgets Message-ID: <20070328052603.B0ACB34068@common-lisp.net> Author: junrue Date: Wed Mar 28 00:26:03 2007 New Revision: 446 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-utils.lisp Log: revised thread context and startup implementation to use Allegro MT support Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp Wed Mar 28 00:26:03 2007 @@ -65,12 +65,10 @@ ;; ;; TODO: change this once we understand SBCL MT support ;; -;; TODO: support Allegro MT -;; -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defvar *the-thread-context* nil) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun thread-context () (when (null *the-thread-context*) (setf *the-thread-context* (make-instance 'thread-context)) @@ -81,13 +79,39 @@ (format *error-output* "~a~%" e)))) *the-thread-context*) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun dispose-thread-context () (let ((hwnd (utility-hwnd *the-thread-context*))) (unless (gfs:null-handle-p hwnd) (gfs::destroy-window hwnd))) (setf *the-thread-context* nil)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) tc) + (handler-case + (init-utility-hwnd tc) + (gfs:win32-error (e) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil) + (format *error-output* "~a~%" e)))) + tc)) + +#+allegro +(defun dispose-thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil)) + + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-utils.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 28 00:26:03 2007 @@ -87,12 +87,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun startup (thread-name start-fn) (declare (ignore thread-name)) (funcall start-fn) (message-loop #'default-message-filter)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun startup (thread-name start-fn) + (mp:process-run-function thread-name + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) + #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) From junrue at common-lisp.net Wed Mar 28 05:26:10 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Wed, 28 Mar 2007 00:26:10 -0500 (EST) Subject: [graphic-forms-cvs] r447 - trunk/src/uitoolkit/widgets Message-ID: <20070328052610.D06D134068@common-lisp.net> Author: junrue Date: Wed Mar 28 00:26:10 2007 New Revision: 447 Modified: trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: revised thread context and startup implementation to use Allegro MT support Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Wed Mar 28 00:26:10 2007 @@ -65,12 +65,10 @@ ;; ;; TODO: change this once we understand SBCL MT support ;; -;; TODO: support Allegro MT -;; -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defvar *the-thread-context* nil) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun thread-context () (when (null *the-thread-context*) (setf *the-thread-context* (make-instance 'thread-context)) @@ -81,13 +79,39 @@ (format *error-output* "~a~%" e)))) *the-thread-context*) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun dispose-thread-context () (let ((hwnd (utility-hwnd *the-thread-context*))) (unless (gfs:null-handle-p hwnd) (gfs::destroy-window hwnd))) (setf *the-thread-context* nil)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) tc) + (handler-case + (init-utility-hwnd tc) + (gfs:win32-error (e) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil) + (format *error-output* "~a~%" e)))) + tc)) + +#+allegro +(defun dispose-thread-context () + (let ((tc (getf (mp:process-property-list mp:*current-process*) 'thread-context))) + (if tc + (let ((hwnd (utility-hwnd tc))) + (unless (gfs:null-handle-p hwnd) + (gfs::destroy-window hwnd))))) + (setf (getf (mp:process-property-list mp:*current-process*) 'thread-context) nil)) + + #+lispworks (defun thread-context () (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Wed Mar 28 00:26:10 2007 @@ -87,12 +87,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+(or allegro clisp sbcl) +#+(or clisp sbcl) (defun startup (thread-name start-fn) (declare (ignore thread-name)) (funcall start-fn) (message-loop #'default-message-filter)) +#+allegro +(eval-when (:compile-top-level :load-top-level :execute) (require :process)) + +#+allegro +(defun startup (thread-name start-fn) + (mp:process-run-function thread-name + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) + #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) From junrue at common-lisp.net Fri Mar 30 01:05:45 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 29 Mar 2007 20:05:45 -0500 (EST) Subject: [graphic-forms-cvs] r448 - in branches/graphic-forms-newtypes/src/uitoolkit: system widgets Message-ID: <20070330010545.2F67E19008@common-lisp.net> Author: junrue Date: Thu Mar 29 20:05:44 2007 New Revision: 448 Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/display.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Log: completed change-over to stdcall support offered by CFFI Modified: branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/system/user32.lisp Thu Mar 29 20:05:44 2007 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.system) (eval-when (:compile-toplevel :load-toplevel :execute) - (use-package :cffi)) + (use-package :cffi) +#+cffi-features:no-stdcall + (error "Graphic-Forms requires stdcall support enabled in CFFI.")) (load-foreign-library "user32.dll") @@ -206,7 +208,6 @@ (hwnd HANDLE) (ps LPTR)) -#-cffi-features:no-stdcall (defcfun ("EnumChildWindows" enum-child-windows :cconv :stdcall) INT @@ -214,15 +215,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-child-windows "EnumChildWindows") - ((hwnd :pointer) - (func :pointer) - (lparam :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) INT @@ -231,16 +223,6 @@ (enumproc LPTR) (data LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-display-monitors "EnumDisplayMonitors") - ((hdc :pointer) - (cliprect :pointer) - (enumproc :pointer) - (data :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) INT @@ -248,14 +230,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-thread-windows "EnumThreadWindows") - ((threadid (:unsigned :long)) - (func :pointer) - (lparam :long)) - :result-type :int) - (defcfun ("GetAncestor" get-ancestor) HANDLE 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 29 20:05:44 2007 @@ -37,30 +37,16 @@ ;;; helper functions ;;; -#-cffi-features:no-stdcall (cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+lispworks -(fli:define-foreign-callable - ("display_visitor" :result-type :integer :calling-convention :stdcall) - ((hmonitor :pointer) - (hdc :pointer) - (monitorrect :pointer) - (data :long)) - (declare (ignore hdc monitorrect)) - (call-display-visitor-func (thread-context) hmonitor data) - 1) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work - gfs::flags gfs::device) - mi-ptr gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::flags) mi-ptr gfs::monitorinfoex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) (error 'gfs:win32-warning :detail "get-monitor-info failed")) @@ -88,13 +74,9 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-display-monitors (cffi:null-pointer) (cffi:null-pointer) (cffi:callback display-visitor) 0) -#+lispworks - (let ((ptr (fli:make-pointer :address 0))) - (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -109,7 +91,6 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#-cffi-features:no-stdcall (cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) @@ -119,14 +100,6 @@ (call-top-level-visitor-func tc win))) 1) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (top-level-window-visitor hwnd lparam) - 1) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -135,14 +108,9 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (cffi:callback top-level-window-visitor) 0) -#+lispworks - (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") - 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) (setf (top-level-visitor-results tc) nil) Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/thread-context.lisp Thu Mar 29 20:05:44 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; thread-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 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp ============================================================================== --- branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp (original) +++ branches/graphic-forms-newtypes/src/uitoolkit/widgets/window.lisp Thu Mar 29 20:05:44 2007 @@ -70,7 +70,6 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -#-cffi-features:no-stdcall (cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) @@ -83,14 +82,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+lispworks -(fli:define-foreign-callable - ("child_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (child-window-visitor hwnd lparam) - 1) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -326,14 +317,9 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) -#+lispworks - (gfs::enum-child-windows hwnd - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil) From junrue at common-lisp.net Fri Mar 30 01:05:58 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 29 Mar 2007 20:05:58 -0500 (EST) Subject: [graphic-forms-cvs] r449 - in trunk/src/uitoolkit: system widgets Message-ID: <20070330010558.C890919008@common-lisp.net> Author: junrue Date: Thu Mar 29 20:05:58 2007 New Revision: 449 Modified: trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/window.lisp Log: completed change-over to stdcall support offered by CFFI Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Mar 29 20:05:58 2007 @@ -34,7 +34,9 @@ (in-package :graphic-forms.uitoolkit.system) (eval-when (:compile-toplevel :load-toplevel :execute) - (use-package :cffi)) + (use-package :cffi) +#+cffi-features:no-stdcall + (error "Graphic-Forms requires stdcall support enabled in CFFI.")) (load-foreign-library "user32.dll") @@ -206,7 +208,6 @@ (hwnd HANDLE) (ps LPTR)) -#-cffi-features:no-stdcall (defcfun ("EnumChildWindows" enum-child-windows :cconv :stdcall) INT @@ -214,15 +215,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-child-windows "EnumChildWindows") - ((hwnd :pointer) - (func :pointer) - (lparam :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumDisplayMonitors" enum-display-monitors :cconv :stdcall) INT @@ -231,16 +223,6 @@ (enumproc LPTR) (data LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-display-monitors "EnumDisplayMonitors") - ((hdc :pointer) - (cliprect :pointer) - (enumproc :pointer) - (data :long)) - :result-type :int) - -#-cffi-features:no-stdcall (defcfun ("EnumThreadWindows" enum-thread-windows :cconv :stdcall) INT @@ -248,14 +230,6 @@ (func :pointer) (lparam LPARAM)) -#+lispworks -(fli:define-foreign-function - (enum-thread-windows "EnumThreadWindows") - ((threadid (:unsigned :long)) - (func :pointer) - (lparam :long)) - :result-type :int) - (defcfun ("GetAncestor" get-ancestor) HANDLE Modified: trunk/src/uitoolkit/widgets/display.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/display.lisp (original) +++ trunk/src/uitoolkit/widgets/display.lisp Thu Mar 29 20:05:58 2007 @@ -37,30 +37,16 @@ ;;; helper functions ;;; -#-cffi-features:no-stdcall (cffi:defcallback (display-visitor :cconv :stdcall) gfs::BOOL ((hmonitor :pointer) (hdc :pointer) (monitorrect :pointer) (data gfs::LPARAM)) (declare (ignore hdc monitorrect)) (call-display-visitor-func (thread-context) hmonitor data) 1) -#+lispworks -(fli:define-foreign-callable - ("display_visitor" :result-type :integer :calling-convention :stdcall) - ((hmonitor :pointer) - (hdc :pointer) - (monitorrect :pointer) - (data :long)) - (declare (ignore hdc monitorrect)) - (call-display-visitor-func (thread-context) hmonitor data) - 1) - (defun query-display-info (hmonitor) (let ((info nil)) (cffi:with-foreign-object (mi-ptr 'gfs::monitorinfoex) - (cffi:with-foreign-slots ((gfs::cbsize gfs::monitor gfs::work - gfs::flags gfs::device) - mi-ptr gfs::monitorinfoex) + (cffi:with-foreign-slots ((gfs::cbsize gfs::flags) mi-ptr gfs::monitorinfoex) (setf gfs::cbsize (cffi:foreign-type-size 'gfs::monitorinfoex)) (if (zerop (gfs::get-monitor-info hmonitor mi-ptr)) (error 'gfs:win32-warning :detail "get-monitor-info failed")) @@ -88,13 +74,9 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-display-monitors (cffi:null-pointer) (cffi:null-pointer) (cffi:callback display-visitor) 0) -#+lispworks - (let ((ptr (fli:make-pointer :address 0))) - (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -109,7 +91,6 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#-cffi-features:no-stdcall (cffi:defcallback (top-level-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (declare (ignore lparam)) @@ -119,14 +100,6 @@ (call-top-level-visitor-func tc win))) 1) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (top-level-window-visitor hwnd lparam) - 1) - (defun maptoplevels (func) ;; ;; func should expect one parameter: @@ -135,13 +108,8 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) (cffi:callback top-level-window-visitor) - 0) -#+lispworks - (gfs::enum-thread-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - (fli:make-pointer :symbol-name "top_level_window_visitor") 0) (setf (top-level-visitor-func tc) nil)) (let ((tmp (reverse (top-level-visitor-results tc)))) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Mar 29 20:05:58 2007 @@ -1,7 +1,7 @@ ;;;; ;;;; thread-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 Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Mar 29 20:05:58 2007 @@ -70,7 +70,6 @@ (if (and parent (layout-of parent)) (append-layout-item (layout-of parent) win))))) -#-cffi-features:no-stdcall (cffi:defcallback (child-window-visitor :cconv :stdcall) gfs::BOOL ((hwnd :pointer) (lparam gfs::LPARAM)) (let* ((tc (thread-context)) @@ -83,14 +82,6 @@ (setf (child-visitor-results tc) (push (call-child-visitor-func tc parent child) tmp-list)))))) 1) -#+lispworks -(fli:define-foreign-callable - ("child_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) - (child-window-visitor hwnd lparam) - 1) - (defun window-class-registered-p (class-name) (cffi:with-foreign-string (str-ptr class-name) (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex) @@ -326,14 +317,9 @@ (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect -#-cffi-features:no-stdcall (gfs::enum-child-windows hwnd (cffi:callback child-window-visitor) (cffi:pointer-address hwnd)) -#+lispworks - (gfs::enum-child-windows hwnd - (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc)))) (setf (child-visitor-results tc) nil) From junrue at common-lisp.net Fri Mar 30 03:26:27 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 29 Mar 2007 22:26:27 -0500 (EST) Subject: [graphic-forms-cvs] r450 - branches/graphic-forms-newtypes/src/uitoolkit/widgets Message-ID: <20070330032627.0241812089@common-lisp.net> Author: junrue Date: Thu Mar 29 22:26:27 2007 New Revision: 450 Modified: branches/graphic-forms-newtypes/src/uitoolkit/widgets/event.lisp Log: when processing WM_CTLCOLOR* messages, call the default wndproc rather than returning 0 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 Thu Mar 29 22:26:27 2007 @@ -145,18 +145,17 @@ 0)))) (defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) - (hdc (cffi:make-pointer wparam)) - (bkgdcolor (brush-color-of widget)) - (textcolor (text-color-of widget)) - (ret-val 0)) - (when widget - (if bkgdcolor - (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) - (if textcolor - (gfs::set-text-color hdc (gfg:color->rgb textcolor))) - (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) - ret-val)) + (let ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) + (hdc (cffi:make-pointer wparam))) + (if widget + (let ((bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget))) + (if bkgdcolor + (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) + (if textcolor + (gfs::set-text-color hdc (gfg:color->rgb textcolor))) + (cffi:pointer-address (brush-handle-of widget))) + 0))) (defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget)) @@ -425,20 +424,28 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) (let* ((widget (get-widget (thread-context) hwnd)) From junrue at common-lisp.net Fri Mar 30 03:26:46 2007 From: junrue at common-lisp.net (junrue at common-lisp.net) Date: Thu, 29 Mar 2007 22:26:46 -0500 (EST) Subject: [graphic-forms-cvs] r451 - trunk/src/uitoolkit/widgets Message-ID: <20070330032646.9228519007@common-lisp.net> Author: junrue Date: Thu Mar 29 22:26:46 2007 New Revision: 451 Modified: trunk/src/uitoolkit/widgets/event.lisp Log: when processing WM_CTLCOLOR* messages, call the default wndproc rather than returning 0 Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Mar 29 22:26:46 2007 @@ -145,18 +145,17 @@ 0)))) (defun process-ctlcolor-message (wparam lparam) - (let* ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) - (hdc (cffi:make-pointer wparam)) - (bkgdcolor (brush-color-of widget)) - (textcolor (text-color-of widget)) - (ret-val 0)) - (when widget + (let ((widget (get-widget (thread-context) (cffi:make-pointer (logand #xFFFFFFFF lparam)))) + (hdc (cffi:make-pointer wparam))) + (if widget + (let ((bkgdcolor (brush-color-of widget)) + (textcolor (text-color-of widget))) (if bkgdcolor (gfs::set-bk-color hdc (gfg:color->rgb bkgdcolor))) (if textcolor (gfs::set-text-color hdc (gfg:color->rgb textcolor))) - (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) - ret-val)) + (cffi:pointer-address (brush-handle-of widget))) + 0))) (defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget)) @@ -425,20 +424,28 @@ 0) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorbtn+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcoloredit+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorlistbox+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-ctlcolorstatic+)) wparam lparam) - (declare (ignore hwnd)) - (process-ctlcolor-message wparam lparam)) + (let ((retval (process-ctlcolor-message wparam lparam))) + (if (zerop retval) + (gfs::def-window-proc hwnd msg wparam lparam) + retval))) (defmethod process-message (hwnd (msg (eql gfs::+wm-setcursor+)) wparam lparam) (let* ((widget (get-widget (thread-context) hwnd))