August 2006 - graphic-forms-cvs@common-lisp.net

[graphic-forms-cvs] r213 - in trunk: . src/demos/textedit src/demos/unblocked src/tests/uitoolkit src/uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 17:13:54 2006 New Revision: 213 Modified: trunk/build.lisp trunk/config.lisp trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/tiles-panel.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp trunk/tests.lisp Log: implemented icon-bundle unit-tests and fixed a few more bugs found as a result Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 17:13:54 2006 @@ -52,8 +52,9 @@ (setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) - -(defvar *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) +(setf *textedit-dir* (concatenate 'string *gf-dir* "src/demos/textedit/")) +(setf *unblocked-dir* (concatenate 'string *gf-dir* "src/demos/unblocked/")) +(setf *gf-tests-dir* (concatenate 'string *gf-dir* "src/tests/uitoolkit/")) (defun build () (setf cl-user::*asdf-cache* "c:/projects/public/build/") Modified: trunk/config.lisp ============================================================================== --- trunk/config.lisp (original) +++ trunk/config.lisp Sun Aug 13 17:13:54 2006 @@ -39,15 +39,18 @@ (in-package #:graphic-forms-system) -(defvar *binary-data-dir* (merge-pathnames "src/external-libraries/practicals-1.0.3/binary-data/")) (defvar *cells-dir* "cells/") (defvar *cffi-dir* "cffi-060606/") (defvar *closer-mop-dir* "closer-mop/") (defvar *lw-compat-dir* "lw-compat/") -(defvar *macro-utilities-dir* "macro-utilities/") (defvar *gf-dir* "graphic-forms/") +(defvar *binary-data-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/binary-data/") +(defvar *macro-utilities-dir* "graphic-forms/src/external-libraries/practicals-1.0.3/macro-utilities/") +(defvar *textedit-dir* "graphic-forms/src/demos/textedit/") +(defvar *unblocked-dir* "graphic-forms/src/demos/unblocked/") +(defvar *gf-tests-dir* "graphic-forms/src/tests/uitoolkit/") -(defvar *lisp-unit-file* "lisp-unit") +(defvar *lisp-unit-file* "graphic-forms/src/external-libraries/practicals-1.0.3/lisp-unit.lisp") (defun configure-asdf () (pushnew *binary-data-dir* asdf:*central-registry* :test #'equal) Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Sun Aug 13 17:13:54 2006 @@ -35,7 +35,6 @@ (defvar *textedit-control* nil) (defvar *textedit-win* nil) -(defvar *textedit-startup-dir* nil) (defvar *textedit-file-filters* '(("Text Files (*.txt)" . "*.txt") ("All Files (*.*)" . "*.*"))) @@ -152,7 +151,8 @@ (defun about-textedit (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/textedit/about.bmp" *textedit-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*textedit-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *textedit-win* :dispatcher (make-instance 'textedit-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -219,12 +219,6 @@ (setf (gfw:text *textedit-win*) "new file - GraphicForms TextEdit"))) (defun textedit-startup () -#+clisp - (setf *textedit-startup-dir* (ext:cd)) -#+lispworks - (setf *textedit-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/tiles-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/tiles-panel.lisp (original) +++ trunk/src/demos/unblocked/tiles-panel.lisp Sun Aug 13 17:13:54 2006 @@ -82,15 +82,13 @@ (defmethod initialize-instance :after ((self tiles-panel-events) &key buffer-size) (declare (ignorable buffer-size)) - (let ((table (tile-image-table-of self)) + (let ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (table (tile-image-table-of self)) (kind 1)) (loop for filename in '("blue-tile.bmp" "brown-tile.bmp" "red-tile.bmp" "green-tile.bmp" "pink-tile.bmp" "gold-tile.bmp") do (let ((image (make-instance 'gfg:image))) - (gfg:load image (merge-pathnames (concatenate 'string - "src/demos/unblocked/" - filename) - (unblocked-startup-dir))) + (gfg:load image (merge-pathnames filename)) (setf (gethash kind table) image) (incf kind))))) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Sun Aug 13 17:13:54 2006 @@ -39,13 +39,9 @@ (defconstant +revealed-duration+ 2000) ; millis (defvar *scoreboard-panel* nil) -(defvar *unblocked-startup-dir* nil) (defvar *tiles-panel* nil) (defvar *unblocked-win* nil) -(defun unblocked-startup-dir () - *unblocked-startup-dir*) - (defun get-tiles-panel () *tiles-panel*) @@ -106,7 +102,8 @@ (defun about-unblocked (disp item) (declare (ignore disp item)) - (let* ((image (make-instance 'gfg:image :file (merge-pathnames "src/demos/unblocked/about.bmp" *unblocked-startup-dir*))) + (let* ((*default-pathname-defaults* (parse-namestring gfsys::*unblocked-dir*)) + (image (make-instance 'gfg:image :file (merge-pathnames "about.bmp"))) (dlg (make-instance 'gfw:dialog :owner *unblocked-win* :dispatcher (make-instance 'unblocked-about-dialog-events) :layout (make-instance 'gfw:flow-layout @@ -162,12 +159,6 @@ (gfw:show dlg t))) (defun unblocked-startup () -#+clisp - (setf *unblocked-startup-dir* (ext:cd)) -#+lispworks - (setf *unblocked-startup-dir* (hcl:get-working-directory)) -#+sbcl - (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:13:54 2006 @@ -32,3 +32,70 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) + +(define-test bmp-file-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle :file (merge-pathnames "happy.bmp"))) + (size (gfs:make-size :width 32 :height 32))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16))) + (unwind-protect + (progn + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) bw-size 8) + (validate-image (gfg:icon-image-ref bundle 2) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test push-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle)) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (tc-image (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16)) + (tc-size (gfs:make-size :width 16 :height 16)) + (bw-point (gfs:make-point :x 0 :y 15))) + (unwind-protect + (progn + (gfg:push-icon-image bw-image bundle bw-point) + (gfg:push-icon-image tc-image bundle) + (gfg:push-icon-image happy-image bundle) + (assert-equal 3 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) happy-size 8) + (validate-image (gfg:icon-image-ref bundle 1) tc-size 16000000) + (validate-image (gfg:icon-image-ref bundle 2) bw-size 8) + (validate-image (gfg:icon-image-ref bundle :small) tc-size 8) + (validate-image (gfg:icon-image-ref bundle :large) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) + +(define-test system-icon-bundle-test + (let ((size (gfs:make-size :width (gfs::get-system-metrics gfs::+sm-cxicon+) + :height (gfs::get-system-metrics gfs::+sm-cyicon+))) + (bundle (make-instance 'gfg:icon-bundle :system gfg:+warning-icon+))) + (unwind-protect + (progn + (assert-equal 1 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) size 8) + (validate-image (gfg:icon-image-ref bundle :small) size 8) + (validate-image (gfg:icon-image-ref bundle :large) size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 17:13:54 2006 @@ -34,5 +34,8 @@ (in-package :graphic-forms.uitoolkit.tests) (defun validate-image (image expected-size expected-depth) - (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) - (assert-equal expected-depth (gfg:depth image))) + (declare (ignore expected-depth)) + (assert-false (null image)) + (assert-false (gfs:disposed-p image)) + ;; (assert-equal expected-depth (gfg:depth image)) ; FIXME: image->data needed + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:13:54 2006 @@ -67,7 +67,8 @@ (let ((im (hicon->image hicon)) (extent 0)) (unwind-protect - (setf extent (gfs:size-height (gfg:size im))) + (let ((size (gfg:size im))) + (setf extent (* (gfs:size-height size) (gfs:size-width size)))) (gfs:dispose im)) extent)) @@ -130,7 +131,8 @@ (error 'gfs:disposed-error)) (let ((tmp (gfs:handle bundle))) (push (image->hicon image transparency-pixel) tmp) - (setf (slot-value bundle 'gfs:handle) tmp))) + (setf (slot-value bundle 'gfs:handle) tmp)) + bundle) ;;; ;;; methods @@ -165,6 +167,4 @@ (when image-list (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list - collect (image->hicon tmp-image tr-pnt)))))) - (unless (gfs:handle self) - (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) + collect (image->hicon tmp-image tr-pnt))))))) Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 17:13:54 2006 @@ -34,8 +34,7 @@ (in-package #:graphic-forms-system) (defun load-tests () -#+lispworks - (hcl:change-directory *gf-dir*) + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) (asdf:operate 'asdf:load-op :graphic-forms-tests) (load (concatenate 'string *gf-tests-dir* "test-utils")) (load (concatenate 'string *gf-tests-dir* "mock-objects"))

1 0

[graphic-forms-cvs] r212 - in trunk: . src/external-libraries/lisp-unit src/tests/uitoolkit
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sun Aug 13 01:52:01 2006 New Revision: 212 Added: trunk/src/external-libraries/lisp-unit/ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp trunk/src/external-libraries/lisp-unit/readme.txt Modified: trunk/README.txt trunk/build.lisp trunk/graphic-forms-tests.asd trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp trunk/tests.lisp Log: upgraded to latest lisp-unit, now bundling lisp-unit under external-libraries Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Sun Aug 13 01:52:01 2006 @@ -14,6 +14,7 @@ - ASDF http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/cclan/asdf/ + *note: ASDF is bundled with SBCL* - Cells (latest from CVS) http://www.common-lisp.net/project/cells/ @@ -27,12 +28,20 @@ - Closer to MOP http://common-lisp.net/project/closer/downloads.html - - ImageMagick 6.2.6.5-Q16 - http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… +The following libraries are bundled with Graphic-Forms, thus do not need +to be downloaded separately: + + - Practical Common Lisp Chapter08 and Chapter24 + http://www.gigamonkeys.com/book/practicals-1.0.3.tar.gz - lisp-unit http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html +The following libraries are optional: + + - ImageMagick 6.2.6.5-Q16 + http://www.imagemagick.org/download/binaries/ImageMagick-6.2.6-5-Q16-window… + Supported Common Lisp Implementations ------------------------------------- Modified: trunk/build.lisp ============================================================================== --- trunk/build.lisp (original) +++ trunk/build.lisp Sun Aug 13 01:52:01 2006 @@ -49,7 +49,7 @@ (setf *closer-mop-dir* (concatenate 'string *asdf-repo-root* "closer-mop/")) (setf *lw-compat-dir* (concatenate 'string *asdf-repo-root* "lw-compat/")) (setf *gf-dir* (concatenate 'string *project-root* "graphic-forms/")) -(setf *lisp-unit-file* (concatenate 'string *library-root* "lisp-unit")) +(setf *lisp-unit-file* (concatenate 'string *gf-dir* "src/external-libraries/lisp-unit/lisp-unit")) (setf *binary-data-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter08/")) (setf *macro-utilities-dir* (concatenate 'string *gf-dir* "src/external-libraries/practicals-1.0.3/Chapter24/")) Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sun Aug 13 01:52:01 2006 @@ -31,6 +31,8 @@ ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ;;;; +(load gfsys::*lisp-unit-file*) + (defpackage #:graphic-forms.uitoolkit.tests (:nicknames #:gft) (:use :common-lisp :lisp-unit) @@ -78,16 +80,7 @@ ((:module "uitoolkit" :serial t :components - ((:file "test-utils") - (:file "mock-objects") - (:file "color-unit-tests") - (:file "graphics-context-unit-tests") - (:file "image-unit-tests") - (:file "icon-bundle-unit-tests") - (:file "layout-unit-tests") - (:file "widget-unit-tests") - (:file "misc-unit-tests") - (:file "hello-world") + ((:file "hello-world") (:file "event-tester") (:file "layout-tester") (:file "image-tester") Added: trunk/src/external-libraries/lisp-unit/lisp-unit.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/lisp-unit.lisp Sun Aug 13 01:52:01 2006 @@ -0,0 +1,429 @@ +;;;-*- Mode: Lisp; Package: LISP-UNIT -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. +|# + + +;;; A test suite package, modelled after JUnit. +;;; Author: Chris Riesbeck +;;; +;;; Update history: +;;; +;;; 04/07/06 added ~<...~> to remaining error output forms [CKR] +;;; 04/06/06 added ~<...~> to compact error output better [CKR] +;;; 04/06/06 fixed RUN-TESTS to get tests dynamically (bug reported +;;; by Daniel Edward Burke) [CKR] +;;; 02/08/06 added newlines to error output [CKR] +;;; 12/30/05 renamed ASSERT-PREDICATE to ASSERT-EQUALITY [CKR] +;;; 12/29/05 added ASSERT-EQ, ASSERT-EQL, ASSERT-EQUALP [CKR] +;;; 12/22/05 recoded use-debugger to use handler-bind, added option to prompt for debugger, +;;; 11/07/05 added *use-debugger* and assert-predicate [DFB] +;;; 09/18/05 replaced Academic Free License with MIT Licence [CKR] +;;; 08/30/05 added license notice [CKR] +;;; 06/28/05 changed RUN-TESTS to compile code at run time, not expand time [CKR] +;;; 02/21/05 removed length check from SET-EQUAL [CKR] +;;; 02/17/05 added RUN-ALL-TESTS [CKR] +;;; 01/18/05 added ASSERT-EQUAL back in [CKR] +;;; 01/17/05 much clean up, added WITH-TEST-LISTENER [CKR] +;;; 01/15/05 replaced ASSERT-EQUAL etc. with ASSERT-TRUE and ASSERT-FALSE [CKR] +;;; 01/04/05 changed COLLECT-RESULTS to echo output on *STANDARD-OUTPuT* [CKR] +;;; 01/04/05 added optional package argument to REMOVE-ALL-TESTS [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to trim spaces and returns [CKR] +;;; 01/04/05 changed OUTPUT-OK-P to not check output except when asked to [CKR] +;;; 12/03/04 merged REMOVE-TEST into REMOVE-TESTS [CKR] +;;; 12/03/04 removed ability to pass forms to RUN-TESTS [CKR] +;;; 12/03/04 refactored RUN-TESTS expansion into RUN-TEST-THUNKS [CKR] +;;; 12/02/04 changed to group tests under packages [CKR] +;;; 11/30/04 changed assertions to put expected value first, like JUnit [CKR] +;;; 11/30/04 improved error handling and summarization [CKR] +;;; 11/30/04 generalized RUN-TESTS, removed RUN-TEST [CKR] +;;; 02/27/04 fixed ASSERT-PRINTS not ignoring value [CKR] +;;; 02/07/04 fixed ASSERT-EXPANDS failure message [CKR] +;;; 02/07/04 added ASSERT-NULL, ASSERT-NOT-NULL [CKR] +;;; 01/31/04 added error handling and totalling to RUN-TESTS [CKR] +;;; 01/31/04 made RUN-TEST/RUN-TESTS macros [CKR] +;;; 01/29/04 fixed ASSERT-EXPANDS quote bug [CKR] +;;; 01/28/04 major changes from BUG-FINDER to be more like JUnit [CKR] + + +#| +How to use +---------- + +1. Read the documentation in lisp-unit.html. + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS) to +clear any previously defined tests. + +2. Load this file. + +2. (use-package :lisp-unit) + +3. Load your code file and your file of tests. + +4. Test your code with (RUN-TESTS test-name1 test-name2 ...) -- no quotes! -- +or simply (RUN-TESTS) to run all defined tests. + +A summary of how many tests passed and failed will be printed, +with details on the failures. + +Note: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +For more information, see lisp-unit.html. + +|# + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Packages +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(cl:defpackage #:lisp-unit + (:use #:common-lisp) + (:export #:define-test #:run-all-tests #:run-tests + #:assert-eq #:assert-eql #:assert-equal #:assert-equalp + #:assert-error #:assert-expands #:assert-false + #:assert-equality #:assert-prints #:assert-true + #:get-test-code #:get-tests + #:remove-all-tests #:remove-tests + #:logically-equal #:set-equal + #:use-debugger + #:with-test-listener) + ) + +(in-package #:lisp-unit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Globals +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *test-listener* nil) + +(defparameter *tests* (make-hash-table)) + +;;; Used by RUN-TESTS to collect summary statistics +(defvar *test-count* 0) +(defvar *pass-count* 0) + +;;; Set by RUN-TESTS for use by SHOW-FAILURE +(defvar *test-name* nil) + +;;; If nil, errors in tests are caught and counted. +;;; If :ask, user is given option of entering debugger or not. +;;; If true and not :ask, debugger is entered. +(defparameter *use-debugger* nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; DEFINE-TEST + +(defmacro define-test (name &body body) + `(progn + (store-test-code ',name ',body) + ',name)) + +;;; ASSERT macros + +(defmacro assert-eq (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + (expand-assert :equal form form expected extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + (expand-assert :error form (expand-error-form form) + condition extras)) + +(defmacro assert-expands (&environment env expansion form &rest extras) + (expand-assert :macro form + (expand-macro-form form #+lispworks nil #-lispworks env) + expansion extras)) + +(defmacro assert-false (form &rest extras) + (expand-assert :result form form nil extras)) + +(defmacro assert-equality (test expected form &rest extras) + (expand-assert :equal form form expected extras :test test)) + +(defmacro assert-prints (output form &rest extras) + (expand-assert :output form (expand-output-form form) + output extras)) + +(defmacro assert-true (form &rest extras) + (expand-assert :result form form t extras)) + + +(defun expand-assert (type form body expected extras &key (test #'eql)) + `(internal-assert + ,type ',form #'(lambda () ,body) #'(lambda () ,expected) ,(expand-extras extras), test)) + +(defun expand-error-form (form) + `(handler-case ,form + (condition (error) error))) + +(defun expand-output-form (form) + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defun expand-macro-form (form env) + `(macroexpand-1 ',form ,env)) + +(defun expand-extras (extras) + `#'(lambda () + (list ,@(mapcan #'(lambda (form) (list `',form form)) extras)))) + + +;;; RUN-TESTS + +(defmacro run-all-tests (package &rest tests) + `(let ((*package* (find-package ',package))) + (run-tests + ,@(mapcar #'(lambda (test) (find-symbol (symbol-name test) package)) + tests)))) + +(defmacro run-tests (&rest names) + `(run-test-thunks (get-test-thunks ,(if (null names) '(get-tests *package*) `',names)))) + +(defun get-test-thunks (names &optional (package *package*)) + (mapcar #'(lambda (name) (get-test-thunk name package)) + names)) + +(defun get-test-thunk (name package) + (assert (get-test-code name package) (name package) + "No test defined for ~S in package ~S" name package) + (list name (coerce `(lambda () ,@(get-test-code name)) 'function))) + +(defun use-debugger (&optional (flag t)) + (setq *use-debugger* flag)) + +;;; WITH-TEST-LISTENER +(defmacro with-test-listener (listener &body body) + `(let ((*test-listener* #',listener)) ,@body)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Public functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun get-test-code (name &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (gethash name table)))) + +(defun get-tests (&optional (package *package*)) + (let ((l nil) + (table (get-package-table package))) + (cond ((null table) nil) + (t + (maphash #'(lambda (key val) + (declare (ignore val)) + (push key l)) + table) + (sort l #'string< :key #'string))))) + + +(defun remove-tests (names &optional (package *package*)) + (let ((table (get-package-table package))) + (unless (null table) + (if (null names) + (clrhash table) + (dolist (name names) + (remhash name table)))))) + +(defun remove-all-tests (&optional (package *package*)) + (if (null package) + (clrhash *tests*) + (remhash (find-package package) *tests*))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Private functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; DEFINE-TEST support + +(defun get-package-table (package &key create) + (let ((table (gethash (find-package package) *tests*))) + (or table + (and create + (setf (gethash package *tests*) + (make-hash-table)))))) + +(defun get-test-name (form) + (if (atom form) form (cadr form))) + +(defun store-test-code (name code &optional (package *package*)) + (setf (gethash name + (get-package-table package :create t)) + code)) + + +;;; ASSERTION support + +(defun internal-assert (type form code-thunk expected-thunk extras test) + (let* ((expected (multiple-value-list (funcall expected-thunk))) + (actual (multiple-value-list (funcall code-thunk))) + (passed (test-passed-p type expected actual test))) + + (incf *test-count*) + (when passed + (incf *pass-count*)) + + (record-result passed type form expected actual extras) + + passed)) + +(defun record-result (passed type form expected actual extras) + (funcall (or *test-listener* 'default-listener) + passed type *test-name* form expected actual + (and extras (funcall extras)) + *test-count* *pass-count*)) + +(defun default-listener + (passed type name form expected actual extras test-count pass-count) + (declare (ignore test-count pass-count)) + (unless passed + (show-failure type (get-failure-message type) + name form expected actual extras))) + +(defun test-passed-p (type expected actual test) + (ecase type + (:error + (or (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + (:equal + (and (<= (length expected) (length actual)) + (every test expected actual))) + (:macro + (equal (car actual) (car expected))) + (:output + (string= (string-trim '(#\newline #\return #\space) + (car actual)) + (car expected))) + (:result + (logically-equal (car actual) (car expected))) + )) + + +;;; RUN-TESTS support + +(defun run-test-thunks (test-thunks) + (unless (null test-thunks) + (let ((total-test-count 0) + (total-pass-count 0) + (total-error-count 0)) + (dolist (test-thunk test-thunks) + (multiple-value-bind (test-count pass-count error-count) + (run-test-thunk (car test-thunk) (cadr test-thunk)) + (incf total-test-count test-count) + (incf total-pass-count pass-count) + (incf total-error-count error-count))) + (unless (null (cdr test-thunks)) + (show-summary 'total total-test-count total-pass-count total-error-count)) + (values)))) + +(defun run-test-thunk (*test-name* thunk) + (if (null thunk) + (format t "~& Test ~S not found" *test-name*) + (prog ((*test-count* 0) + (*pass-count* 0) + (error-count 0)) + (handler-bind + ((error #'(lambda (e) + (let ((*print-escape* nil)) + (setq error-count 1) + (format t "~& ~S: ~W" *test-name* e)) + (if (use-debugger-p e) e (go exit))))) + (funcall thunk) + (show-summary *test-name* *test-count* *pass-count*)) + exit + (return (values *test-count* *pass-count* error-count))))) + +(defun use-debugger-p (e) + (and *use-debugger* + (or (not (eql *use-debugger* :ask)) + (y-or-n-p "~A -- debug?" e)))) + +;;; OUTPUT support + +(defun get-failure-message (type) + (case type + (:error "~&~@[Should have signalled ~{~S~^; ~} but saw~] ~{~S~^; ~}") + (:macro "~&Should have expanded to ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (:output "~&Should have printed ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + (t "~&Expected ~{~S~^; ~} ~<~%~:;but saw ~{~S~^; ~}~>") + )) + +(defun show-failure (type msg name form expected actual extras) + (format t "~&~@[~S: ~]~S failed: " name form) + (format t msg expected actual) + (format t "~{~& ~S => ~S~}~%" extras) + type) + +(defun show-summary (name test-count pass-count &optional error-count) + (format t "~&~A: ~S assertions passed, ~S failed~@[, ~S execution errors~]." + name pass-count (- test-count pass-count) error-count)) + +(defun collect-form-values (form values) + (mapcan #'(lambda (form-arg value) + (if (constantp form-arg) + nil + (list form-arg value))) + (cdr form) + values)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Useful equality predicates for tests +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; (LOGICALLY-EQUAL x y) => true or false +;;; Return true if x and y both false or both true + +(defun logically-equal (x y) + (eql (not x) (not y))) + +;;; (SET-EQUAL l1 l2 :test) => true or false +;;; Return true if every element of l1 is an element of l2 +;;; and vice versa. + +(defun set-equal (l1 l2 &key (test #'equal)) + (and (listp l1) + (listp l2) + (subsetp l1 l2 :test test) + (subsetp l2 l1 :test test))) + + +(provide "lisp-unit") Added: trunk/src/external-libraries/lisp-unit/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/lisp-unit/readme.txt Sun Aug 13 01:52:01 2006 @@ -0,0 +1,7 @@ + +This directory contains the source file implementing the lisp-unit +unit-test library. Copyright (c) 2004-2005 Christopher K. Riesbeck + +The website for this library is: + + http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 01:52:01 2006 @@ -32,7 +32,3 @@ ;;;; (in-package :graphic-forms.uitoolkit.tests) - - - - Modified: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- trunk/src/tests/uitoolkit/test-utils.lisp (original) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sun Aug 13 01:52:01 2006 @@ -33,8 +33,6 @@ (in-package :graphic-forms.uitoolkit.tests) -#| (defun validate-image (image expected-size expected-depth) (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) (assert-equal expected-depth (gfg:depth image))) -|# Modified: trunk/tests.lisp ============================================================================== --- trunk/tests.lisp (original) +++ trunk/tests.lisp Sun Aug 13 01:52:01 2006 @@ -33,9 +33,16 @@ (in-package #:graphic-forms-system) -(load (compile-file *lisp-unit-file*)) - (defun load-tests () #+lispworks (hcl:change-directory *gf-dir*) - (asdf:operate 'asdf:load-op :graphic-forms-tests)) + (asdf:operate 'asdf:load-op :graphic-forms-tests) + (load (concatenate 'string *gf-tests-dir* "test-utils")) + (load (concatenate 'string *gf-tests-dir* "mock-objects")) + (load (concatenate 'string *gf-tests-dir* "color-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "graphics-context-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "image-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "icon-bundle-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "layout-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "widget-unit-tests")) + (load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))

1 0

[graphic-forms-cvs] r211 - in trunk: docs/manual src src/uitoolkit/graphics
by junrue＠common-lisp.net 13 Aug '06

13 Aug '06

Author: junrue Date: Sat Aug 12 23:55:37 2006 New Revision: 211 Modified: trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: fixed icon-handle-ref to not re-order handles, removed doc language about load order preservation, implemented and documented push-icon-image Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 23:55:37 2006 @@ -539,25 +539,20 @@ @defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} (setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* This function uses an integer or keyword -based @var{subscript} to address -the images comprising @var{icon-bundle}, either to retrieve an image -or add/replace an image via @sc{setf}. +the images comprising @var{icon-bundle}. @table @var @item icon-bundle Contains images to be used for frame decorations. @item subscript This argument can be zero-based, in which case @var{icon-bundle} -is treated as though it were an array of images. Add a new image -by specifying @var{subscript} 0.@*@* -Alternatively, @var{subscript} -can be one of the following keywords:@*@* +is treated as though it were an array of images. Alternatively, +@var{subscript} can be one of the following keywords:@*@* @table @code @item :large Identifies the largest image of the @var{icon-bundle}. @item :small -Identifies the smallest image of the @var{icon-bundle}.@*@* +Identifies the smallest image of the @var{icon-bundle}. @end table -Note that adding an image addressed by one of these -keywords will succeed, but the result may be counter-intuitive. @end table To find out how many images are stored in @var{icon-bundle}, and hence what constitutes a valid range of subscripts for this function, @@ -588,6 +583,21 @@ where @var{self} is a @ref{graphics-context}. @end deffn +@defun push-icon-image @ref{image} @ref{icon-bundle} &optional transparency-pixel => icon-bundle +Use this function to prepend a new image to an existing icon-bundle. +Note that @var{icon-bundle} takes ownership of @var{image}. +@table @var +@item image +The new image to be prepended. +@item icon-bundle +The icon-bundle to receive @var{image}. +@item transparency-pixel +A @ref{point} object identifying a pixel in @var{image} with the color to +be used for transparency. If not specified, the pixel at @code{(0, 0)} will +be used. +@end table +@end defun + @deffn GenericFunction size self => @ref{size} Returns a size object describing the dimensions of @var{self}. @end deffn Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 23:55:37 2006 @@ -265,7 +265,7 @@ This is the base class for user interface objects that generate events@footnote{Actually, events are generated by underlying native window objects, which are represented in the class hierarchy by -the event-source class}. It derives from @ref{native-object}. +the event-source class.}. It derives from @ref{native-object}. @table @var @item callback-event-name This is an (@code{:allocation :class}) slot that holds a symbol @@ -792,10 +792,10 @@ Implement this method to respond to @var{widget} being activated. For a @ref{top-level} @ref{window} or @ref{dialog}, this means that @var{widget} was brought to the foreground and its trim (titlebar and -border) was highlighted to indicate that it is now the active -window. For a @ref{menu}, it means that the user has clicked on the -@ref{item} invoking @ref{widget} and it is about to be shown; this is -an opportunity to update the menu's contents. @xref{event-deactivate}. +border) became highlighted. For a @ref{menu}, it means that the user +has clicked on the @ref{item} invoking @ref{widget} and it is about +to be shown; this is an opportunity to update the menu's contents. +@xref{event-deactivate}. @table @var @event-dispatcher-arg @item widget @@ -841,8 +841,8 @@ @deffn GenericFunction event-dispose dispatcher widget Implement this method to respond to @var{widget} being disposed (explicitly -via @ref{dispose}, not collected via the garbage collector). This -event function is called while the contents of @var{widget} are still +via @ref{dispose}; this event is not associated with garbage collection). +This event function is called while the contents of @var{widget} are still valid. @table @var @event-dispatcher-arg Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 23:55:37 2006 @@ -208,6 +208,7 @@ #:multiply #:pen-style #:pen-width + #:push-icon-image #:rgb->color #:red-mask #:red-shift Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 23:55:37 2006 @@ -71,10 +71,6 @@ (gfs:dispose im)) extent)) -;;; Note: this function needs to return a place not -;;; just a handle, to facilitate a defsetf further -;;; on below -;;; (defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles @@ -86,16 +82,16 @@ (elt handles index) (error 'gfs:toolkit-error :detail "invalid image index")) (if (zerop index) - (gfs:handle bundle) + handles (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) - (first (stable-sort handles #'< :key #'icon-extent)) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'< :key #'icon-extent)) + handles)) ((eql index :large) (if (listp handles) - (first (last (stable-sort handles #'< :key #'icon-extent))) - (gfs:handle bundle))) + (first (sort (copy-list handles) #'> :key #'icon-extent)) + handles)) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) @@ -129,6 +125,13 @@ (length handles) 1))) +(defun push-icon-image (image bundle &optional transparency-pixel) + (if (gfs:disposed-p image) + (error 'gfs:disposed-error)) + (let ((tmp (gfs:handle bundle))) + (push (image->hicon image transparency-pixel) tmp) + (setf (slot-value bundle 'gfs:handle) tmp))) + ;;; ;;; methods ;;;

1 0

[graphic-forms-cvs] r210 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics
by junrue＠common-lisp.net 12 Aug '06

12 Aug '06

Author: junrue Date: Sat Aug 12 01:44:13 2006 New Revision: 210 Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/tests/uitoolkit/test-utils.lisp Modified: trunk/docs/manual/api.texinfo trunk/docs/manual/graphics-api.texinfo trunk/docs/manual/system-api.texinfo trunk/docs/manual/widgets-api.texinfo trunk/graphic-forms-tests.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: icon-bundle testing and bug fixing Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sat Aug 12 01:44:13 2006 @@ -14,9 +14,9 @@ of the package names are prefixed with @code{graphic-forms.uitoolkit}. @menu -* graphics package:: -* system package:: -* widgets package:: +* GFS package:: +* GFG package:: +* GFW package:: @end menu @include graphics-api.texinfo Modified: trunk/docs/manual/graphics-api.texinfo ============================================================================== --- trunk/docs/manual/graphics-api.texinfo (original) +++ trunk/docs/manual/graphics-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,15 @@ @c Copyright (c) 2006, Jack D. Unrue -@node graphics package, widgets package, system package, API -@section graphics package -@cindex graphics package - -Nickname: GFG - -This package represents graphical functionality, particularly drawing -operations. Support for the ImageMagick library is defined here. This -package and GFW together constitute the bulk of the public API. +@node GFG package +@section GFG package +@cindex GFG package + +Full package name: @emph{graphic-forms.uitoolkit.graphics} + +This package contains the symbols corresponding to graphics-related +classes, drawing operations, and meta-data. This package and +@sc{gfw} together comprise the bulk of the library API. @menu * graphics types:: @@ -205,23 +205,26 @@ Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color depths and file format.@*@* +The implementation of @code{icon-bundle} includes the concept of +there being large and small versions. The actual size to be used +depends on the context in which the icon is needed. To retrieve +or set an individual image, call @ref{icon-image-ref}. To find +out how many @ref{image}s are stored, call @ref{icon-bundle-length}.@*@* @code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file -with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{ico} format can -store multiple icons, all of which will be loaded. Application -code should not assume that load order is preserved. Since +with in a supported format to be loaded, as described for the +image class @code{:file} initarg. Note that the @sc{ico} format +can store multiple images, all of which will be loaded. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the -proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link -to documentation of graphics plugins here}. +proper transparency @ref{color}; or else by default, the pixel +color at @code{(0, 0)} in each image will be used. @emph{FIXME: +link to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Application -code should not assume that image order is preserved. Since +This initarg accepts a @sc{cl:list} of image objects. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -527,28 +530,38 @@ Returns a color object corresponding to the current foreground color. @end deffn -@anchor{icon-image} -@defun icon-image @ref{icon-bundle} index => @ref{image} -This function uses an integer or keyword -based @var{index} to address -the images comprising an icon-bundle, either to retrieve an image -or add/replace an image via @sc{setf}. Application code should not -assume that image load order was preserved when this function is called. +@anchor{icon-bundle-length} +@defun icon-bundle-length @ref{icon-bundle} => integer +Returns a count of the number of icon handles held by @var{icon-bundle}. +@end defun + +@anchor{icon-image-ref} +@defun icon-image-ref @ref{icon-bundle} subscript => @ref{image} +(setf (@strong{icon-image-ref} @var{icon-bundle} @var{subscript}) @var{image})@*@* +This function uses an integer or keyword -based @var{subscript} to address +the images comprising @var{icon-bundle}, either to retrieve an image +or add/replace an image via @sc{setf}. @table @var @item icon-bundle -This is an icon-bundle containing images to be updated or retrieved. -@item index -This argument can be a zero-based, with new images added by -specifying @var{index} 0. Or @var{index} can be one of the following -keywords: +Contains images to be used for frame decorations. +@item subscript +This argument can be zero-based, in which case @var{icon-bundle} +is treated as though it were an array of images. Add a new image +by specifying @var{subscript} 0.@*@* +Alternatively, @var{subscript} +can be one of the following keywords:@*@* @table @code @item :large -Specifies the largest image of the icon-bundle. +Identifies the largest image of the @var{icon-bundle}. @item :small -Specifies the smallest image of the icon-bundle. +Identifies the smallest image of the @var{icon-bundle}.@*@* @end table +Note that adding an image addressed by one of these +keywords will succeed, but the result may be counter-intuitive. @end table -To find out how many images are stored in an icon-bundle, call -@ref{size}. +To find out how many images are stored in @var{icon-bundle}, and hence +what constitutes a valid range of subscripts for this function, +call @ref{icon-bundle-length}. @end defun @anchor{load} Modified: trunk/docs/manual/system-api.texinfo ============================================================================== --- trunk/docs/manual/system-api.texinfo (original) +++ trunk/docs/manual/system-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,16 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node system package, graphics package, , API -@section system package -@cindex system package +@node GFS package +@section GFS package +@cindex GFS package -Nickname: GFS +Full package name: @emph{graphic-forms.uitoolkit.system} The symbols in this package correspond to system-level functionality, -examples of which include bindings for Win32 API functions and associated -constants. The majority of the symbols herein are not exported, except for -a few fundamental types and methods +such as foreign function declarations for the Win32 @sc{api}. The +majority of the symbols herein are not exported, except +for a few fundamental types, conditions, and methods. @menu * system types:: Modified: trunk/docs/manual/widgets-api.texinfo ============================================================================== --- trunk/docs/manual/widgets-api.texinfo (original) +++ trunk/docs/manual/widgets-api.texinfo Sat Aug 12 01:44:13 2006 @@ -5,15 +5,16 @@ @c Copyright (c) 2006, Jack D. Unrue -@node widgets package, , graphics package, API -@section widgets package -@cindex widgets package - -Nickname: GFW - -This package contains symbols for all of the widgets, event methods, -and other UI objects defined by Graphic-Forms. This package and GFG -together constitute the bulk of the public API. +@node GFW package +@section GFW package +@cindex GFW package + +Full package name: @emph{graphic-forms.uitoolkit.widgets} + +This package contains symbols for user interface widget +classes, event-handling methods, and management functions. This +package and @sc{gfg} together constitute the bulk of the library +API. @menu * event functions:: Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Sat Aug 12 01:44:13 2006 @@ -65,6 +65,7 @@ ((:file "textedit-document") (:file "textedit-window"))) (:module "unblocked" + :serial t :components ((:file "tiles") (:file "unblocked-model") @@ -75,11 +76,14 @@ (:module "tests" :components ((:module "uitoolkit" + :serial t :components - ((:file "mock-objects") + ((:file "test-utils") + (:file "mock-objects") (:file "color-unit-tests") (:file "graphics-context-unit-tests") (:file "image-unit-tests") + (:file "icon-bundle-unit-tests") (:file "layout-unit-tests") (:file "widget-unit-tests") (:file "misc-unit-tests") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Sat Aug 12 01:44:13 2006 @@ -188,7 +188,8 @@ #:green-mask #:green-shift #:height - #:icon-image + #:icon-bundle-length + #:icon-image-ref #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,38 @@ +;;;; +;;;; icon-bundle-unit-tests.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + + + + Added: trunk/src/tests/uitoolkit/test-utils.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/test-utils.lisp Sat Aug 12 01:44:13 2006 @@ -0,0 +1,40 @@ +;;;; +;;;; test-utils.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.tests) + +#| +(defun validate-image (image expected-size expected-depth) + (assert-equality #'gfs:equal-size-p expected-size (gfg:size image)) + (assert-equal expected-depth (gfg:depth image))) +|# Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sat Aug 12 01:44:13 2006 @@ -41,11 +41,28 @@ (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) (gfs::zero-mem info-ptr gfs::iconinfo) (if (zerop (gfs::get-icon-info hicon info-ptr)) - (error 'gfs::win32-error :detail "get-icon-info failed")) + (error 'gfs:win32-error :detail "get-icon-info failed")) (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) (gfs::delete-object gfs::hmask) (make-instance 'image :handle gfs::hcolor)))) +(defun image->hicon (image &optional point) + (unless (typep point 'gfs:point) + (setf point (transparency-pixel-of image)) + (unless point + (setf point (gfs:make-point)))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (with-image-transparency (image point) + (setf gfs::hcolor (gfs:handle image)) + (setf gfs::hmask (gfs:handle (transparency-mask image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (if (gfs:null-handle-p hicon) + (error 'gfs:win32-error :detail "create-icon-indirect failed")) + hicon))))) + (defun icon-extent (hicon) (let ((im (hicon->image hicon)) (extent 0)) @@ -54,30 +71,63 @@ (gfs:dispose im)) extent)) -(defun icon-handle (bundle index) +;;; Note: this function needs to return a place not +;;; just a handle, to facilitate a defsetf further +;;; on below +;;; +(defun icon-handle-ref (bundle index) (let ((handles (gfs:handle bundle))) (unless handles (error 'gfs:disposed-error)) (cond ((typep index 'integer) - (if (zerop index) - (if (listp handles) + (if (listp handles) + (if (< index (length handles)) (elt handles index) - handles))) + (error 'gfs:toolkit-error :detail "invalid image index")) + (if (zerop index) + (gfs:handle bundle) + (error 'gfs:toolkit-error :detail "invalid image index")))) ((eql index :small) (if (listp handles) (first (stable-sort handles #'< :key #'icon-extent)) - handles)) + (gfs:handle bundle))) ((eql index :large) (if (listp handles) (first (last (stable-sort handles #'< :key #'icon-extent))) - handles)) + (gfs:handle bundle))) (t (error 'gfs:toolkit-error :detail "an integer index, or one of :small or :large, is required"))))) -(defun icon-image (bundle index) - (hicon->image (icon-handle bundle index))) +(defsetf icon-handle-ref (bundle index) (hicon) + `(progn + (if (gfs:null-handle-p ,hicon) + (error 'gfs:disposed-error)) + (cond + ((listp (gfs:handle ,bundle)) + (replace (gfs:handle ,bundle) (list ,hicon) :start1 ,index)) + ((and (zerop ,index) (not (null (gfs:handle ,bundle)))) + (setf (slot-value ,bundle 'gfs:handle) ,hicon)) + (t + (error 'gfs:toolkit-error :detail "illegal arguments for (setf icon-handle-ref)"))) + ,hicon)) + +(defun icon-image-ref (bundle index) + (hicon->image (icon-handle-ref bundle index))) + +(defun set-icon-image (bundle index image) + (setf (icon-handle-ref bundle index) (image->hicon image))) + +(defsetf icon-image-ref set-icon-image) + +(defun icon-bundle-length (bundle) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (if (listp handles) + (length handles) + 1))) ;;; ;;; methods @@ -104,26 +154,14 @@ (otherwise nil)))) (cond (resource-id - (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) - (file - (let ((tmp-image (make-instance 'image))) - (setf image-list (load tmp-image file)))) - (images - (setf image-list images))) + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + ((typep file 'pathname) + (setf image-list (list (make-instance 'image :file file)))) + ((listp images) + (setf image-list images))) (when image-list - (let ((handles nil) - (default-pnt (gfs:make-point))) - (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) - (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) - (gfs::zero-mem info-ptr gfs::iconinfo) - (setf gfs::flag 1) - (loop for tmp-image in image-list - do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) - (setf gfs::hcolor (gfs:handle tmp-image)) - (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) - (let ((hicon (gfs::create-icon-indirect info-ptr))) - (unless (gfs:null-handle-p hicon) - (push hicon handles))))))) - (setf (slot-value self 'gfs:handle) handles)))) + (let ((tr-pnt (or transparency-pixel (gfs:make-point)))) + (setf (slot-value self 'gfs:handle) (loop for tmp-image in image-list + collect (image->hicon tmp-image tr-pnt)))))) (unless (gfs:handle self) (error 'gfs:toolkit-error :detail "could not initialize icon bundle")))

1 0

[graphic-forms-cvs] r209 - in trunk: . docs/manual
by junrue＠common-lisp.net 11 Aug '06

11 Aug '06

Author: junrue Date: Fri Aug 11 15:47:54 2006 New Revision: 209 Modified: trunk/NEWS.txt trunk/README.txt trunk/docs/manual/overview.texinfo Log: added note about SBCL support Modified: trunk/NEWS.txt ============================================================================== --- trunk/NEWS.txt (original) +++ trunk/NEWS.txt Fri Aug 11 15:47:54 2006 @@ -1,4 +1,12 @@ + +. SBCL 0.9.15 is now a supported Common Lisp implementation. Graphic-Forms + includes a small patch to enable the stdcall calling convention for alien + callbacks, located in src/external-libraries/sbcl-callback-patch + + +============================================================================== + Release 0.4.0 of Graphic-Forms, a Common Lisp library for Windows GUI programming, is now available. This is an alpha release, meaning that the feature set and API have not yet stabilized. Modified: trunk/README.txt ============================================================================== --- trunk/README.txt (original) +++ trunk/README.txt Fri Aug 11 15:47:54 2006 @@ -37,7 +37,8 @@ Supported Common Lisp Implementations ------------------------------------- -Graphic-Forms currently supports CLISP 2.38 and LispWorks 4.4.6. +Graphic-Forms currently supports CLISP 2.38, LispWorks 4.4.6, and SBCL 0.9.15 +(the latter with a small patch). Known Problems Modified: trunk/docs/manual/overview.texinfo ============================================================================== --- trunk/docs/manual/overview.texinfo (original) +++ trunk/docs/manual/overview.texinfo Fri Aug 11 15:47:54 2006 @@ -52,8 +52,11 @@ Graphic-Forms is currently developed and tested with: @itemize @bullet -@item CLISP 2.38 +@item CLISP 2.38 or later @item LispWorks 4.4.6 +@item SBCL 0.9.15 or later@footnote{a small patch to enable the +@sc{stdcall} calling convention for callbacks is temporarily +bundled with Graphic-Forms, see @code{src/external-libraries/sbcl-callback-patch/}} @end itemize @@ -61,7 +64,7 @@ @itemize @bullet @item XP SP2 -@item Vista (testing on Beta 2 is in-progress as of this release) +@item Vista@footnote{testing on Beta 2 is in-progress as of this release} @end itemize

1 0

[graphic-forms-cvs] r207 - in trunk/src: demos/textedit demos/unblocked uitoolkit/widgets
by junrue＠common-lisp.net 11 Aug '06

11 Aug '06

Author: junrue Date: Thu Aug 10 22:28:29 2006 New Revision: 207 Modified: trunk/src/demos/textedit/textedit-window.lisp trunk/src/demos/unblocked/unblocked-window.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: last of the tweaks for SBCL Modified: trunk/src/demos/textedit/textedit-window.lisp ============================================================================== --- trunk/src/demos/textedit/textedit-window.lisp (original) +++ trunk/src/demos/textedit/textedit-window.lisp Thu Aug 10 22:28:29 2006 @@ -223,6 +223,8 @@ (setf *textedit-startup-dir* (ext:cd)) #+lispworks (setf *textedit-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *textedit-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :callback #'manage-textedit-file-menu :submenu ((:item "&New" :callback #'textedit-file-new) (:item "&Open..." :callback #'textedit-file-open) Modified: trunk/src/demos/unblocked/unblocked-window.lisp ============================================================================== --- trunk/src/demos/unblocked/unblocked-window.lisp (original) +++ trunk/src/demos/unblocked/unblocked-window.lisp Thu Aug 10 22:28:29 2006 @@ -166,6 +166,8 @@ (setf *unblocked-startup-dir* (ext:cd)) #+lispworks (setf *unblocked-startup-dir* (hcl:get-working-directory)) +#+sbcl + (setf *unblocked-startup-dir* *default-pathname-defaults*) (let ((menubar (gfw:defmenu ((:item "&File" :submenu ((:item "&New" :callback #'new-unblocked) (:item "&Restart" :callback #'restart-unblocked) Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Thu Aug 10 22:28:29 2006 @@ -307,7 +307,7 @@ (defmethod redraw ((self widget)) (let ((hwnd (gfs:handle self))) (unless (gfs:null-handle-p hwnd) - (gfs::invalidate-rect hwnd nil 1)))) + (gfs::invalidate-rect hwnd (cffi:null-pointer) 1)))) (defmethod resizable-p :before ((self widget)) (if (gfs:disposed-p self)

1 0

[graphic-forms-cvs] r206 - trunk/src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 18:06:32 2006 New Revision: 206 Modified: trunk/src/uitoolkit/widgets/window.lisp Log: fixed a regression for clisp caused by renaming the child window visitor callback Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 18:06:32 2006 @@ -224,7 +224,7 @@ (cffi:pointer-address hwnd)) #+clisp (gfs::enum-child-windows hwnd - #'child_window_visitor + #'child-window-visitor (cffi:pointer-address hwnd)) (setf (child-visitor-func tc) nil)) (let ((tmp (reverse (child-visitor-results tc))))

1 0

[graphic-forms-cvs] r205 - in trunk: . src/external-libraries/sbcl-callback-patch src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 17:33:31 2006 New Revision: 205 Added: trunk/src/external-libraries/sbcl-callback-patch/ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp trunk/src/external-libraries/sbcl-callback-patch/readme.txt Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/display.lisp trunk/src/uitoolkit/widgets/window.lisp Log: integrated stdcall callback patch for SBCL and implemented various enum procs for SBCL Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 17:33:31 2006 @@ -47,8 +47,13 @@ ((:module "src" :components ((:file "packages") +#+sbcl (:module "external-libraries" + :components + ((:module "sbcl-callback-patch" + :components + ((:file "callback-hacking"))))) (:module "uitoolkit" - :depends-on ("packages") + :depends-on ("packages" #+sbcl "external-libraries") :components ((:module "system" :serial t Added: trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/callback-hacking.lisp Thu Aug 10 17:33:31 2006 @@ -0,0 +1,125 @@ +;;;; +;;;; hacking.lisp +;;;; +;;;; Compiler and runtime damage for callbacks +;;;; +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB-VM") + +(sb-ext:without-package-locks + (defun alien-callback-assembler-wrapper (index return-type arg-types &optional (stack-offset 0)) + "Cons up a piece of code which calls call-callback with INDEX and a +pointer to the arguments." + (declare (ignore arg-types)) + (let* ((segment (make-segment)) + (eax eax-tn) + (edx edx-tn) + (ebp ebp-tn) + (esp esp-tn) + ([ebp-8] (make-ea :dword :base ebp :disp -8)) + ([ebp-4] (make-ea :dword :base ebp :disp -4))) + (assemble (segment) + (inst push ebp) ; save old frame pointer + (inst mov ebp esp) ; establish new frame + (inst mov eax esp) ; + (inst sub eax 8) ; place for result + (inst push eax) ; arg2 + (inst add eax 16) ; arguments + (inst push eax) ; arg1 + (inst push (ash index 2)) ; arg0 + (inst push (get-lisp-obj-address #'enter-alien-callback)) ; function + (inst mov eax (foreign-symbol-address "funcall3")) + (inst call eax) + ;; now put the result into the right register + (cond + ((and (alien-integer-type-p return-type) + (eql (alien-type-bits return-type) 64)) + (inst mov eax [ebp-8]) + (inst mov edx [ebp-4])) + ((or (alien-integer-type-p return-type) + (alien-pointer-type-p return-type) + (alien-type-= #.(parse-alien-type 'system-area-pointer nil) + return-type)) + (inst mov eax [ebp-8])) + ((alien-single-float-type-p return-type) + (inst fld [ebp-8])) + ((alien-double-float-type-p return-type) + (inst fldd [ebp-8])) + ((alien-void-type-p return-type)) + (t + (error "unrecognized alien type: ~A" return-type))) + (inst mov esp ebp) ; discard frame + (inst pop ebp) ; restore frame pointer + (inst ret stack-offset)) + (finalize-segment segment) + ;; Now that the segment is done, convert it to a static + ;; vector we can point foreign code to. + (let ((buffer (sb-assem::segment-buffer segment))) + (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer))))) + +(in-package "SB-ALIEN") + +(defun %alien-callback-sap (specifier result-type argument-types function wrapper &optional (call-type :cdecl)) + (let ((key (list specifier function call-type))) + (or (gethash key *alien-callbacks*) + (setf (gethash key *alien-callbacks*) + (let* ((index (fill-pointer *alien-callback-trampolines*)) + ;; Aside from the INDEX this is known at + ;; compile-time, which could be utilized by + ;; having the two-stage assembler tramp & + ;; wrapper mentioned in [1] above: only the + ;; per-function tramp would need assembler at + ;; runtime. Possibly we could even pregenerate + ;; the code and just patch the index in later. + (assembler-wrapper (alien-callback-assembler-wrapper + index result-type argument-types + (if (eq call-type :stdcall) + (* 4 (length argument-types)) + 0)))) + (vector-push-extend + (alien-callback-lisp-trampoline wrapper function) + *alien-callback-trampolines*) + (let ((sap (vector-sap assembler-wrapper))) + (push (cons sap (make-callback-info :specifier specifier + :function function + :wrapper wrapper + :index index)) + *alien-callback-info*) + sap)))))) + +(sb-ext:without-package-locks + (defmacro alien-callback (specifier function &optional (call-type :cdecl) &environment env) + "Returns an alien-value with of alien ftype SPECIFIER, that can be passed to +an alien function as a pointer to the FUNCTION. If a callback for the given +SPECIFIER and FUNCTION already exists, it is returned instead of consing a new +one." + ;; Pull out as much work as is convenient to macro-expansion time, specifically + ;; everything that can be done given just the SPECIFIER and ENV. + (multiple-value-bind (result-type argument-types) (parse-alien-ftype specifier env) + `(%sap-alien + (%alien-callback-sap ',specifier ',result-type ',argument-types + ,function + (or (gethash ',specifier *alien-callback-wrappers*) + (setf (gethash ',specifier *alien-callback-wrappers*) + ,(alien-callback-lisp-wrapper-lambda + specifier result-type argument-types env))) ,call-type) + ',(parse-alien-type specifier env))))) + +#| +(sb-alien::alien-callback (function int int int) #'+ :stdcall) + => #<SB-ALIEN-INTERNALS:ALIEN-VAUE :SAP ... :TYPE ...> +(alien-funcall-stdcall * 3 4) => 9 +"Hey everybody, callbacks work!" +|# + +;;; EOF Added: trunk/src/external-libraries/sbcl-callback-patch/readme.txt ============================================================================== --- (empty file) +++ trunk/src/external-libraries/sbcl-callback-patch/readme.txt Thu Aug 10 17:33:31 2006 @@ -0,0 +1,8 @@ +This directory contains callback-hacking.lisp, authored by +Alastair Bridgewater. This code updates an SBCL image such +that stdcall callbacks are supported. + +The full distribution including sample code is available from: + + http://www.lisphacker.com/files/lisp-winapi.tgz + http://www.lisphacker.com/files/hello-win32.tgz Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 17:33:31 2006 @@ -45,9 +45,9 @@ :unicode :ascii)) -(defctype ATOM :unsigned-short) ; shadowed in defpackage +(defctype ATOM :unsigned-short) ; shadowed in gfs: package (defctype BOOL :int) -(defctype BOOLEAN :char) ; shadowed in defpackage +(defctype BOOLEAN :char) ; shadowed in gfs: package (defctype BYTE :unsigned-char) (defctype COLORREF :unsigned-long) (defctype DWORD :unsigned-long) @@ -73,6 +73,26 @@ (defctype WORD :short) (defctype WPARAM :unsigned-int) +#+sbcl +(sb-alien:define-alien-type enumchildproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type enumthreadwndproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:long))) + +#+sbcl +(sb-alien:define-alien-type monitorsenumproc + (sb-alien:* (sb-alien:function sb-alien:int + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:system-area-pointer + sb-alien:long))) + (defcstruct actctx (cbsize ULONG) (flags DWORD) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 17:33:31 2006 @@ -223,6 +223,12 @@ (lparam ffi:long)) (:return-type ffi: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) @@ -264,6 +270,13 @@ (data ffi:c-pointer)) (:return-type ffi: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) @@ -300,6 +313,12 @@ (lparam ffi:long)) (:return-type ffi: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 Thu Aug 10 17:33:31 2006 @@ -48,12 +48,22 @@ (call-display-visitor-func (thread-context) hmonitor data) 1) -#+clisp -(defun display_visitor (hmonitor hdc monitorrect data) +(defun display-visitor (hmonitor hdc monitorrect data) (declare (ignore hdc monitorrect)) (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) @@ -87,9 +97,14 @@ (let ((tc (thread-context))) (setf (display-visitor-func tc) func) (unwind-protect -#+lispworks (let ((ptr (fli:make-pointer :address 0))) +#+sbcl + (let ((ptr (cffi:null-pointer))) + (gfs::enum-display-monitors ptr ptr (sb-alien:alien-sap *monitors-enum-proc*) 0)) +#+lispworks + (let ((ptr (fli:make-pointer :address 0))) (gfs::enum-display-monitors ptr ptr (fli:make-pointer :symbol-name "display_visitor") 0)) -#+clisp (gfs::enum-display-monitors nil nil #'display_visitor nil) +#+clisp + (gfs::enum-display-monitors nil nil #'display-visitor nil) (setf (display-visitor-func tc) nil)) (let ((tmp (reverse (display-visitor-results tc)))) (setf (display-visitor-results tc) nil) @@ -104,26 +119,31 @@ (defun obtain-primary-display () (find-if #'primary-p (obtain-displays))) -#+lispworks -(fli:define-foreign-callable - ("top_level_window_visitor" :result-type :integer :calling-convention :stdcall) - ((hwnd :pointer) - (lparam :long)) +(defun top-level-window-visitor (hwnd lparam) + (declare (ignore lparam)) (let* ((tc (thread-context)) (win (get-widget tc hwnd))) (unless (null win) (call-top-level-visitor-func tc win))) 1) -#+clisp -(defun top_level_window_visitor (hwnd lparam) - (declare (ignore lparam)) - (let* ((tc (thread-context)) - (win (get-widget tc hwnd))) - (unless (null win) - (call-top-level-visitor-func tc win))) +#+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) +#+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: @@ -132,12 +152,18 @@ (let ((tc (thread-context))) (setf (top-level-visitor-func tc) func) (unwind-protect -#+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) -#+clisp (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) - #'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) +#+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) +#+clisp + (gfs::enum-child-windows (gfs::get-window-thread-process-id (utility-hwnd tc) (cffi:null-pointer)) + #'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: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 17:33:31 2006 @@ -60,34 +60,31 @@ (put-kbdnav-widget tc win)) (put-widget tc win)))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defmacro child-visitor-proper (hwnd lparam) - (let ((tc (gensym)) - (tmp-list (gensym)) - (child (gensym)) - (parent (gensym)) - (ancestor-hwnd (gensym))) - `(let* ((,tc (thread-context)) - (,child (get-widget ,tc ,hwnd)) - (,parent (get-widget ,tc (cffi:make-pointer ,lparam)))) - (unless (or (null ,parent) (null ,child)) - (let ((,ancestor-hwnd (gfs::get-ancestor (gfs:handle ,child) gfs::+ga-parent+)) - (,tmp-list (child-visitor-results ,tc))) - (if (cffi:pointer-eq (gfs:handle ,parent) ,ancestor-hwnd) - (setf (child-visitor-results ,tc) (push (call-child-visitor-func ,tc ,parent ,child) ,tmp-list))))))))) +(defun child-window-visitor (hwnd lparam) + (let* ((tc (thread-context)) + (child (get-widget tc hwnd)) + (parent (get-widget tc (cffi:make-pointer lparam)))) + (unless (or (null parent) (null child)) + (let ((ancestor-hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)) + (tmp-list (child-visitor-results tc))) + (if (cffi:pointer-eq (gfs:handle parent) ancestor-hwnd) + (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-visitor-proper hwnd lparam) + (child-window-visitor hwnd lparam) 1) -#+clisp -(defun child_window_visitor (hwnd lparam) - (child-visitor-proper 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 register-window-class (class-name proc-ptr style bkgcolor &optional wndextra) (let ((retval 0)) @@ -213,22 +210,22 @@ (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) (defmethod mapchildren ((self window) func) - (let ((tc (thread-context))) + (let ((tc (thread-context)) + (hwnd (gfs:handle self))) (setf (child-visitor-func tc) func) (unwind-protect +#+sbcl + (gfs::enum-child-windows hwnd + (sb-alien:alien-sap *enum-child-proc*) + (cffi:pointer-address hwnd)) #+lispworks - (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfs:handle self))) + (gfs::enum-child-windows hwnd (fli:make-pointer :symbol-name "child_window_visitor") - (cffi:pointer-address (gfs:handle self))) + (cffi:pointer-address hwnd)) #+clisp - (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0)))) - (setf ptr (ffi:set-foreign-pointer - (ffi:unsigned-foreign-address - (cffi:pointer-address (gfs:handle self))) - ptr)) - (gfs::enum-child-windows ptr - #'child_window_visitor - (cffi:pointer-address (gfs:handle self)))) + (gfs::enum-child-windows hwnd + #'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)

1 0

[graphic-forms-cvs] r204 - in trunk: . src src/demos/unblocked src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 02:08:05 2006 New Revision: 204 Modified: trunk/graphic-forms-uitoolkit.asd trunk/src/demos/unblocked/scoreboard-panel.lisp trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/system/clib.lisp trunk/src/uitoolkit/system/gdi32.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/button.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/edit.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/label.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/top-level.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: initial phase of SBCL port completed Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 02:08:05 2006 @@ -51,6 +51,7 @@ :depends-on ("packages") :components ((:module "system" + :serial t :components ((:file "system-constants") (:file "system-classes") @@ -74,8 +75,10 @@ (:file "graphics-generics") (:file "color") (:file "palette") - (:file "image-data") - (:file "image") + (:file "image-data" + :depends-on ("graphics-classes")) + (:file "image" + :depends-on ("graphics-classes")) (:file "icon-bundle" :depends-on ("graphics-constants" "image")) (:file "font-data") @@ -85,10 +88,12 @@ :components ((:file "graphics-plugin-packages") #-skip-default-plugin (:module "default" + :serial t :components ((:file "file-formats") (:file "default-data-plugin"))) #+load-imagemagick-plugin (:module "imagemagick" + :serial t :components ((:file "magick-core-types") (:file "magick-core-api") @@ -96,6 +101,7 @@ :depends-on ("magick-core-types" "magick-core-api")))))))) (:module "widgets" :depends-on ("graphics") + :serial t :components ((:file "widget-constants") (:file "widget-classes") Modified: trunk/src/demos/unblocked/scoreboard-panel.lisp ============================================================================== --- trunk/src/demos/unblocked/scoreboard-panel.lisp (original) +++ trunk/src/demos/unblocked/scoreboard-panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,9 +33,9 @@ (in-package :graphic-forms.uitoolkit.tests) -(defconstant +level-label+ "Level:") -(defconstant +points-needed-label+ "Points Needed:") -(defconstant +score-label+ "Score:") +(defparameter *level-label* "Level:") +(defparameter *points-needed-label* "Points Needed:") +(defparameter *score-label* "Score:") (defconstant +scoreboard-text-margin+ 2) @@ -73,7 +73,7 @@ (buffer-size (gfs:make-size))) (unwind-protect (progn - (setf (gfs:size-width buffer-size) (* (+ (length +points-needed-label+) + (setf (gfs:size-width buffer-size) (* (+ (length *points-needed-label*) 2 ; space between label and value 9) ; number of value characters (gfg:average-char-width metrics))) @@ -112,9 +112,9 @@ (unwind-protect (progn (clear-buffer self gc) - (draw-scoreboard-row gc 1 image-size label-font +score-label+ value-font (game-score)) - (draw-scoreboard-row gc 0 image-size label-font +level-label+ value-font (game-level)) - (draw-scoreboard-row gc 2 image-size label-font +points-needed-label+ value-font (game-points-needed))) + (draw-scoreboard-row gc 1 image-size label-font *score-label* value-font (game-score)) + (draw-scoreboard-row gc 0 image-size label-font *level-label* value-font (game-level)) + (draw-scoreboard-row gc 2 image-size label-font *points-needed-label* value-font (game-points-needed))) (gfs:dispose gc)))) (defclass scoreboard-panel (gfw:panel) ()) Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 02:08:05 2006 @@ -233,6 +233,10 @@ (defpackage #:graphic-forms.uitoolkit.widgets (:nicknames #:gfw) (:use #:common-lisp) +#+sbcl + (:import-from :sb-mop :ensure-generic-function) +#-sbcl + (:import-from :clos :ensure-generic-function) (:export ;; classes and structs Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Thu Aug 10 02:08:05 2006 @@ -33,12 +33,13 @@ (in-package #:graphic-forms.uitoolkit.tests) -(defconstant +btn-text-before+ "Push Me") -(defconstant +btn-text-after+ "Again!") -(defconstant +edit-text+ "something to edit") -(defconstant +label-text+ "Label") -(defconstant +margin-delta+ 4) -(defconstant +spacing-delta+ 3) +(defparameter *btn-text-before* "Push Me") +(defparameter *btn-text-after* "Again!") +(defparameter *edit-text* "something to edit") +(defparameter *label-text* "Label") + +(defconstant +margin-delta+ 4) +(defconstant +spacing-delta+ 3) (defvar *widget-counter* 0) @@ -93,10 +94,10 @@ (if (null flag) (progn (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) + (format nil "~d ~a" (id be) *btn-text-before*)) (progn (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (format nil "~d ~a" (id be) *btn-text-after*)))))) (defun add-layout-tester-widget (widget-class subtype) (let ((be (make-instance 'layout-tester-widget-events :id *widget-counter*)) @@ -119,7 +120,7 @@ ((eql subtype :single-line-edit) (setf w (make-instance widget-class :parent *layout-tester-win* - :text (format nil "~d ~a" (id be) +edit-text+)))) + :text (format nil "~d ~a" (id be) *edit-text*)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the ;; image being created here @@ -135,7 +136,7 @@ :parent *layout-tester-win* :dispatcher be :style '(:sunken))) - (setf (gfw:text w) (format nil "~d ~a" (id be) +label-text+))) + (setf (gfw:text w) (format nil "~d ~a" (id be) *label-text*))) (t (setf w (make-instance widget-class :parent *layout-tester-win* Modified: trunk/src/uitoolkit/system/clib.lisp ============================================================================== --- trunk/src/uitoolkit/system/clib.lisp (original) +++ trunk/src/uitoolkit/system/clib.lisp Thu Aug 10 02:08:05 2006 @@ -36,6 +36,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (use-package :cffi)) +(load-foreign-library "msvcrt.dll") + (defcfun ("strncpy" strncpy) :pointer Modified: trunk/src/uitoolkit/system/gdi32.lisp ============================================================================== --- trunk/src/uitoolkit/system/gdi32.lisp (original) +++ trunk/src/uitoolkit/system/gdi32.lisp Thu Aug 10 02:08:05 2006 @@ -167,16 +167,6 @@ (hdc HANDLE)) (defcfun - ("DrawTextExA" draw-text-ex) - INT - (hdc HANDLE) - (text :string) - (count INT) - (rect LPTR) - (format UINT) - (params LPTR)) - -(defcfun ("Ellipse" ellipse) BOOL (hdc HANDLE) Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Aug 10 02:08:05 2006 @@ -36,20 +36,20 @@ ;;; ;;; control class names ;;; -(defconstant +button-classname+ "button") -(defconstant +edit-classname+ "edit") -(defconstant +static-classname+ "static") +(defparameter *button-classname* "button") +(defparameter *edit-classname* "edit") +(defparameter *static-classname* "static") ;;; ;;; registered message names ;;; -(defconstant +lbselchstringa+ "commdlg_LBSelChangedNotify") -(defconstant +sharevistringa+ "commdlg_ShareViolation") -(defconstant +fileokstringa+ "commdlg_FileNameOK") -(defconstant +colorokstringa+ "commdlg_ColorOK") -(defconstant +setrgbstringa+ "commdlg_SetRGBColor") -(defconstant +helpmsgstringa+ "commdlg_help") -(defconstant +findmsgstringa+ "commdlg_FindReplace") +(defparameter *lbselchstringa* "commdlg_LBSelChangedNotify") +(defparameter *sharevistringa* "commdlg_ShareViolation") +(defparameter *fileokstringa* "commdlg_FileNameOK") +(defparameter *colorokstringa* "commdlg_ColorOK") +(defparameter *setrgbstringa* "commdlg_SetRGBColor") +(defparameter *helpmsgstringa* "commdlg_help") +(defparameter *findmsgstringa* "commdlg_FindReplace") (defconstant +ad-counterclockwise+ 1) (defconstant +ad-clockwise+ 2) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 02:08:05 2006 @@ -154,6 +154,16 @@ (hwnd HANDLE)) (defcfun + ("DrawTextExA" draw-text-ex) + INT + (hdc HANDLE) + (text :string) + (count INT) + (rect LPTR) + (format UINT) + (params LPTR)) + +(defcfun ("EnableMenuItem" enable-menu-item) BOOL (hmenu HANDLE) Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Thu Aug 10 02:08:05 2006 @@ -79,7 +79,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+button-classname+ + (let ((hwnd (create-window gfs::*button-classname* (or text " ") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Thu Aug 10 02:08:05 2006 @@ -33,17 +33,18 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-dialog-title+ " ") -(defconstant +dlgwindowextra+ 48) +(defparameter *default-dialog-title* " ") -(defvar *disabled-top-levels* nil) +(defconstant +dlgwindowextra+ 48) + +(defvar *disabled-top-levels* nil) ;;; ;;; helper functions ;;; (defun register-dialog-class () - (register-window-class +dialog-classname+ + (register-window-class *dialog-classname* (cffi:get-callback 'uit_widgets_wndproc) (logior gfs::+cs-dblclks+ gfs::+cs-savebits+ @@ -167,7 +168,7 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-dialog-title+)) + (setf text *default-dialog-title*)) ;; NOTE: do not allow apps to specify the desktop window as the ;; owner of the dialog; it would cause the desktop to become ;; disabled. @@ -179,7 +180,7 @@ ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners. ;; - (init-window self +dialog-classname+ #'register-dialog-class owner text)) + (init-window self *dialog-classname* #'register-dialog-class owner text)) (defmethod show ((self dialog) flag) (let ((app-modal (find :application-modal (style-of self))) Modified: trunk/src/uitoolkit/widgets/edit.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/edit.lisp (original) +++ trunk/src/uitoolkit/widgets/edit.lisp Thu Aug 10 02:08:05 2006 @@ -97,7 +97,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags self) - (let ((hwnd (create-window gfs::+edit-classname+ + (let ((hwnd (create-window gfs::*edit-classname* (or text "") (gfs:handle parent) std-style Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,10 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source)) - (gfw:event-arm . (gfw:event-source)) - (gfw:event-modify . (gfw:event-source)) - (gfw:event-select . (gfw:event-source)))) +(defparameter *callback-info* '((gfw:event-activate . (gfw:event-source)) + (gfw:event-arm . (gfw:event-source)) + (gfw:event-modify . (gfw:event-source)) + (gfw:event-select . (gfw:event-source)))) (defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -45,12 +45,12 @@ (defun define-dispatcher-for-callbacks (callbacks) (let ((*print-gensym* nil) - (class (clos:ensure-class (gentemp "EDCLASS" :gfgen) + (class (c2mop:ensure-class (gentemp "EDCLASS" :gfgen) :direct-superclasses '(event-dispatcher)))) (loop for pair in callbacks do (let* ((method-sym (car pair)) (fn (cdr pair)) - (arg-info (cdr (assoc method-sym +callback-info+))) + (arg-info (cdr (assoc method-sym *callback-info*))) (args nil)) `(unless (or (symbolp ,fn) (functionp ,fn)) (error 'gfs:toolkit-error @@ -61,7 +61,7 @@ method-sym))) (dotimes (i (1+ (length arg-info))) (push (gentemp "ARG" :gfgen) args)) - (c2mop:ensure-method (clos:ensure-generic-function method-sym :lambda-list args) + (c2mop:ensure-method (ensure-generic-function method-sym :lambda-list args) `(lambda ,args (funcall ,fn ,@args)) :specializers (make-specializer-list class arg-info)))) class)) Modified: trunk/src/uitoolkit/widgets/label.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/label.lisp (original) +++ trunk/src/uitoolkit/widgets/label.lisp Thu Aug 10 02:08:05 2006 @@ -152,7 +152,7 @@ (initialize-comctl-classes gfs::+icc-standard-classes+) (multiple-value-bind (std-style ex-style) (compute-style-flags label image separator text) - (let ((hwnd (create-window gfs::+static-classname+ + (let ((hwnd (create-window gfs::*static-classname* (or text " ") (gfs:handle parent) (logior std-style) Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Thu Aug 10 02:08:05 2006 @@ -41,7 +41,7 @@ (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items (let ((info-mask (logior gfs::+miim-id+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+) - (if hchildmenu gfs::+miim-submenu+))) + (if hchildmenu gfs::+miim-submenu+ 0))) (info-type (if label 0 gfs::+mft-separator+)) (info-state (logior (if checked gfs::+mfs-checked+ 0) (if disabled gfs::+mfs-disabled+ 0)))) Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Thu Aug 10 02:08:05 2006 @@ -33,14 +33,14 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +panel-window-classname+ "GraphicFormsPanel") +(defparameter *panel-window-classname* "GraphicFormsPanel") ;;; ;;; helper functions ;;; (defun register-panel-window-class () - (register-window-class +panel-window-classname+ + (register-window-class *panel-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -70,4 +70,4 @@ (error 'gfs:toolkit-error :detail "parent is required for panel")) (if (gfs:disposed-p parent) (error 'gfs:disposed-error)) - (init-window self +panel-window-classname+ #'register-panel-window-class parent "")) + (init-window self *panel-window-classname* #'register-panel-window-class parent "")) Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Thu Aug 10 02:08:05 2006 @@ -59,35 +59,42 @@ ;; TODO: change this when CLISP acquires MT support ;; -#+clisp (defvar *the-thread-context* nil) +;; TODO: change this once we understand SBCL MT support +;; +#+(or clisp sbcl) +(defvar *the-thread-context* nil) -#+clisp (defun thread-context () - (when (null *the-thread-context*) - (setf *the-thread-context* (make-instance 'thread-context)) - (init-utility-hwnd *the-thread-context*)) - *the-thread-context*) - -#+clisp (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)) - -#+lispworks (defun thread-context () - (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) - (when (null tc) - (setf tc (make-instance 'thread-context)) - (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) - (init-utility-hwnd tc)) - tc)) - -#+lispworks (defun dispose-thread-context () - (let ((tc (getf (mp:process-plist 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-plist mp:*current-process*) 'thread-context) nil)) +#+(or clisp sbcl) +(defun thread-context () + (when (null *the-thread-context*) + (setf *the-thread-context* (make-instance 'thread-context)) + (init-utility-hwnd *the-thread-context*)) + *the-thread-context*) + +#+(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)) + +#+lispworks +(defun thread-context () + (let ((tc (getf (mp:process-plist mp:*current-process*) 'thread-context))) + (when (null tc) + (setf tc (make-instance 'thread-context)) + (setf (getf (mp:process-plist mp:*current-process*) 'thread-context) tc) + (init-utility-hwnd tc)) + tc)) + +#+lispworks +(defun dispose-thread-context () + (let ((tc (getf (mp:process-plist 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-plist mp:*current-process*) 'thread-context) nil)) (defmethod init-utility-hwnd ((tc thread-context)) (register-toplevel-noerasebkgnd-window-class) Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Thu Aug 10 02:08:05 2006 @@ -33,20 +33,20 @@ (in-package :graphic-forms.uitoolkit.widgets) -(defconstant +default-window-title+ "New Window") +(defparameter *default-window-title* "New Window") ;;; ;;; helper functions ;;; (defun register-toplevel-erasebkgnd-window-class () - (register-window-class +toplevel-erasebkgnd-window-classname+ + (register-window-class *toplevel-erasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ gfs::+color-appworkspace+)) (defun register-toplevel-noerasebkgnd-window-class () - (register-window-class +toplevel-noerasebkgnd-window-classname+ + (register-window-class *toplevel-noerasebkgnd-window-classname* (cffi:get-callback 'uit_widgets_wndproc) gfs::+cs-dblclks+ -1)) @@ -138,11 +138,11 @@ (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) (if (null text) - (setf text +default-window-title+)) - (let ((classname +toplevel-noerasebkgnd-window-classname+) + (setf text *default-window-title*)) + (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) (when (find :workspace (style-of win)) - (setf classname +toplevel-erasebkgnd-window-classname+) + (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) (init-window win classname register-func owner text))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu Aug 10 02:08:05 2006 @@ -79,20 +79,22 @@ (translate-and-dispatch msg-ptr) nil))) -#+clisp (defun startup (thread-name start-fn) - (declare (ignore thread-name)) - (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) - (when (null (mp:list-all-processes)) - (mp:initialize-multiprocessing)) - (mp:process-run-function thread-name - nil - (lambda () - (funcall start-fn) - (message-loop #'default-message-filter)))) +#+(or clisp sbcl) +(defun startup (thread-name start-fn) + (declare (ignore thread-name)) + (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) + (if (null (mp:list-all-processes)) + (mp:initialize-multiprocessing)) + (mp:process-run-function thread-name + nil + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfs::post-quit-message exit-code)) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Aug 10 02:08:05 2006 @@ -33,10 +33,9 @@ (in-package :graphic-forms.uitoolkit.widgets) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defconstant +dialog-classname+ "GraphicFormsDialog") - (defconstant +toplevel-erasebkgnd-window-classname+ "GraphicFormsTopLevelEraseBkgnd") - (defconstant +toplevel-noerasebkgnd-window-classname+ "GraphicFormsTopLevelNoEraseBkgnd")) +(defparameter *dialog-classname* "GraphicFormsDialog") +(defparameter *toplevel-erasebkgnd-window-classname* "GraphicFormsTopLevelEraseBkgnd") +(defparameter *toplevel-noerasebkgnd-window-classname* "GraphicFormsTopLevelNoEraseBkgnd") ;;; ;;; helper functions @@ -145,7 +144,7 @@ (color nil)) (cffi:with-foreign-pointer-as-string (str-ptr 64) (gfs::get-class-name hwnd str-ptr 64) - (if (string= (cffi:foreign-string-to-lisp str-ptr) +toplevel-erasebkgnd-window-classname+) + (if (string= (cffi:foreign-string-to-lisp str-ptr) *toplevel-erasebkgnd-window-classname*) (setf color (gfg:rgb->color (gfs::get-sys-color gfs::+color-appworkspace+))) (setf color (gfg:rgb->color (gfs::get-class-long hwnd gfs::+gclp-hbrbackground+))))) color))

1 0

[graphic-forms-cvs] r203 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/graphics src/uitoolkit/system
by junrue＠common-lisp.net 10 Aug '06

10 Aug '06

Author: junrue Date: Thu Aug 10 00:15:08 2006 New Revision: 203 Added: trunk/src/tests/uitoolkit/default.ico (contents, props changed) trunk/src/uitoolkit/graphics/icon-bundle.lisp Modified: trunk/docs/manual/api.texinfo trunk/graphic-forms-uitoolkit.asd trunk/src/packages.lisp trunk/src/uitoolkit/graphics/graphics-classes.lisp trunk/src/uitoolkit/graphics/graphics-constants.lisp trunk/src/uitoolkit/graphics/image.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp Log: implemented and documented icon-bundle class and related functions Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Aug 10 00:15:08 2006 @@ -2028,21 +2028,24 @@ in the @code{<Alt><Tab>} task switching dialog, and in the Windows Start menu. See the @samp{Icons in Win32} topic of the MSDN documentation for further discussion of standard icon sizes, color -depths and file format. @code{icon-bundle} derives from @ref{native-object}. +depths and file format.@*@* +@code{icon-bundle} derives from @ref{native-object}. @deffn Initarg :file This initarg accepts a @sc{cl:pathname} identifying a file with @ref{image-data} to be loaded, as described for the @ref{image} -class @code{:file} initarg. Note that the @sc{.ico} format can -store multiple icons, all of which will be loaded. Since +class @code{:file} initarg. Note that the @sc{ico} format can +store multiple icons, all of which will be loaded. Application +code should not assume that load order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, a value may be supplied for the @code{:transparency-pixel} initarg of this class to select the proper transparency @ref{color}; by default, the pixel color at -@code{(0, 0)} in each image will be used. @emph{FIXME: link to -documentation of graphics plugins here}. +@code{(0, 0)} in each image will be used. @emph{FIXME: link +to documentation of graphics plugins here}. @end deffn @deffn Initarg :images -This initarg accepts a @sc{cl:list} of image objects. Since +This initarg accepts a @sc{cl:list} of image objects. Application +code should not assume that image order is preserved. Since @code{icon-bundle} needs a transparency mask for each image in order to create Windows icons, the application may either @sc{setf} @ref{transparency-pixel} for each image ahead of time (especially @@ -2346,6 +2349,30 @@ Returns a color object corresponding to the current foreground color. @end deffn +@anchor{icon-image} +@defun icon-image @ref{icon-bundle} index => @ref{image} +This function uses an integer or keyword -based @var{index} to address +the images comprising an icon-bundle, either to retrieve an image +or add/replace an image via @sc{setf}. Application code should not +assume that image load order was preserved when this function is called. +@table @var +@item icon-bundle +This is an icon-bundle containing images to be updated or retrieved. +@item index +This argument can be a zero-based, with new images added by +specifying @var{index} 0. Or @var{index} can be one of the following +keywords: +@table @code +@item :large +Specifies the largest image of the icon-bundle. +@item :small +Specifies the smallest image of the icon-bundle. +@end table +@end table +To find out how many images are stored in an icon-bundle, call +@ref{size}. +@end defun + @anchor{load} @deffn GenericFunction load self path => list Certain graphics objects have a persistent representation, which may @@ -2356,6 +2383,13 @@ returns @var{self} plus any additional instances in a @sc{list}, ordered the same as they are read from @var{path}. @emph{Note:} @sc{gfg:load} shadows @sc{cl:load}. +@table @var +@item self +The graphics object that will be populated with data. +@item path +A @sc{cl:pathname} identifying a file with graphics data appropriate +for @var{self}. +@end table @end deffn @deffn GenericFunction metrics self font => @ref{font-metrics} Modified: trunk/graphic-forms-uitoolkit.asd ============================================================================== --- trunk/graphic-forms-uitoolkit.asd (original) +++ trunk/graphic-forms-uitoolkit.asd Thu Aug 10 00:15:08 2006 @@ -76,6 +76,8 @@ (:file "palette") (:file "image-data") (:file "image") + (:file "icon-bundle" + :depends-on ("graphics-constants" "image")) (:file "font-data") (:file "font") (:file "graphics-context") Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Aug 10 00:15:08 2006 @@ -109,6 +109,7 @@ #:font-data #:font-metrics #:graphics-context + #:icon-bundle #:image #:image-data #:image-data-plugin @@ -123,6 +124,11 @@ #:*color-red* #:*color-white* #:*image-file-types* + #:+application-icon+ + #:+error-icon+ + #:+information-icon+ + #:+question-icon+ + #:+warning-icon+ ;; methods, functions, macros #:accepts-file-p @@ -182,6 +188,7 @@ #:green-mask #:green-shift #:height + #:icon-image #:invert #:leading #:line-cap-style Added: trunk/src/tests/uitoolkit/default.ico ============================================================================== Binary file. No diff available. Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-classes.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-classes.lisp Thu Aug 10 00:15:08 2006 @@ -1,5 +1,5 @@ ;;;; -;;;; classes.lisp +;;;; graphics-classes.lisp ;;;; ;;;; Copyright (C) 2006, Jack D. Unrue ;;;; All rights reserved. @@ -127,12 +127,15 @@ :initform (cffi:null-pointer))) (:documentation "This class represents the context associated with drawing primitives.")) +(defclass icon-bundle (gfs:native-object) () + (:documentation "This class encapsulates a set of Win32 icon handles.")) + (defclass image (gfs:native-object) ((transparency-pixel :accessor transparency-pixel-of :initarg :transparency-pixel :initform nil)) - (:documentation "This class wraps a native image object.")) + (:documentation "This class encapsulates a Win32 bitmap handle.")) (defmacro blue-mask (data) `(gfg::palette-blue-mask ,data)) Modified: trunk/src/uitoolkit/graphics/graphics-constants.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/graphics-constants.lisp (original) +++ trunk/src/uitoolkit/graphics/graphics-constants.lisp Thu Aug 10 00:15:08 2006 @@ -57,3 +57,13 @@ (defconstant +russian-charset+ 204) (defconstant +mac-charset+ 77) (defconstant +baltic-charset+ 186) + +;;; The following are from WinUser.h; specify one of +;;; them as the value of the :system keyword arg when +;;; creating an icon-bundle +;;; +(defconstant +application-icon+ 32512) +(defconstant +error-icon+ 32513) +(defconstant +information-icon+ 32516) +(defconstant +question-icon+ 32514) +(defconstant +warning-icon+ 32515) Added: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- (empty file) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Thu Aug 10 00:15:08 2006 @@ -0,0 +1,129 @@ +;;;; +;;;; icon-bundle.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package :graphic-forms.uitoolkit.graphics) + +;;; +;;; helper functions +;;; + +(defun hicon->image (hicon) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (if (zerop (gfs::get-icon-info hicon info-ptr)) + (error 'gfs::win32-error :detail "get-icon-info failed")) + (cffi:with-foreign-slots ((gfs::hmask gfs::hcolor) info-ptr gfs::iconinfo) + (gfs::delete-object gfs::hmask) + (make-instance 'image :handle gfs::hcolor)))) + +(defun icon-extent (hicon) + (let ((im (hicon->image hicon)) + (extent 0)) + (unwind-protect + (setf extent (gfs:size-height (gfg:size im))) + (gfs:dispose im)) + extent)) + +(defun icon-handle (bundle index) + (let ((handles (gfs:handle bundle))) + (unless handles + (error 'gfs:disposed-error)) + (cond + ((typep index 'integer) + (if (zerop index) + (if (listp handles) + (elt handles index) + handles))) + ((eql index :small) + (if (listp handles) + (first (stable-sort handles #'< :key #'icon-extent)) + handles)) + ((eql index :large) + (if (listp handles) + (first (last (stable-sort handles #'< :key #'icon-extent))) + handles)) + (t + (error 'gfs:toolkit-error + :detail "an integer index, or one of :small or :large, is required"))))) + +(defun icon-image (bundle index) + (hicon->image (icon-handle bundle index))) + +;;; +;;; methods +;;; + +(defmethod gfs:dispose ((self icon-bundle)) + (let ((handles (gfs:handle self))) + (setf (slot-value self 'gfs:handle) nil) + ;; note: if handles is a cffi:pointer, then self was + ;; instantiated as a system icon and we don't need + ;; to destroy the handle + ;; + (if (and handles (listp handles)) + (loop for hicon in handles do (gfs::destroy-icon hicon))))) + +(defmethod initialize-instance :after ((self icon-bundle) &key file images system transparency-pixel) + (let ((image-list nil) + (resource-id (case system + (#.+application-icon+ (cffi:make-pointer system)) + (#.+error-icon+ (cffi:make-pointer system)) + (#.+information-icon+ (cffi:make-pointer system)) + (#.+question-icon+ (cffi:make-pointer system)) + (#.+warning-icon+ (cffi:make-pointer system)) + (otherwise nil)))) + (cond + (resource-id + (setf (slot-value self 'gfs:handle) (gfs::load-icon (cffi:null-pointer) resource-id))) + (file + (let ((tmp-image (make-instance 'image))) + (setf image-list (load tmp-image file)))) + (images + (setf image-list images))) + (when image-list + (let ((handles nil) + (default-pnt (gfs:make-point))) + (cffi:with-foreign-object (info-ptr 'gfs::iconinfo) + (cffi:with-foreign-slots ((gfs::flag gfs::hcolor gfs::hmask) info-ptr gfs::iconinfo) + (gfs::zero-mem info-ptr gfs::iconinfo) + (setf gfs::flag 1) + (loop for tmp-image in image-list + do (with-image-transparency (tmp-image (or transparency-pixel default-pnt)) + (setf gfs::hcolor (gfs:handle tmp-image)) + (setf gfs::hmask (gfs:handle (transparency-mask tmp-image))) + (let ((hicon (gfs::create-icon-indirect info-ptr))) + (unless (gfs:null-handle-p hicon) + (push hicon handles))))))) + (setf (slot-value self 'gfs:handle) handles)))) + (unless (gfs:handle self) + (error 'gfs:toolkit-error :detail "could not initialize icon bundle"))) Modified: trunk/src/uitoolkit/graphics/image.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/image.lisp (original) +++ trunk/src/uitoolkit/graphics/image.lisp Thu Aug 10 00:15:08 2006 @@ -83,10 +83,10 @@ (gfs:dispose self)) (setf (slot-value self 'gfs:handle) (data->image id))) -(defmethod initialize-instance :after ((image image) &key file size &allow-other-keys) +(defmethod initialize-instance :after ((self image) &key file size &allow-other-keys) (cond (file - (load image file)) + (load self file)) (size (cffi:with-foreign-object (bih-ptr 'gfs::bitmapinfoheader) (gfs::zero-mem bih-ptr gfs::bitmapinfoheader) @@ -104,19 +104,19 @@ (cffi:with-foreign-object (buffer :pointer) (gfs::with-compatible-dcs (nptr memdc) (setf hbmp (gfs::create-dib-section memdc bih-ptr gfs::+dib-rgb-colors+ buffer nptr 0)))) - (setf (slot-value image 'gfs:handle) hbmp))))))) + (setf (slot-value self 'gfs:handle) hbmp))))))) -(defmethod load ((im image) path) +(defmethod load ((self image) path) (let ((data (make-instance 'image-data))) (load data path) - (setf (data-object im) data) + (setf (data-object self) data) data)) -(defmethod size ((image image)) - (if (gfs:disposed-p image) +(defmethod size ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) (let ((size (gfs:make-size)) - (himage (gfs:handle image))) + (himage (gfs:handle self))) (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (gfs::get-object himage (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) @@ -124,17 +124,17 @@ (gfs:size-height size) gfs::height))) size)) -(defmethod transparency-mask ((im image)) - (if (gfs:disposed-p im) +(defmethod transparency-mask ((self image)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)) - (let ((pixel-pnt (transparency-pixel-of im)) - (hbmp (gfs:handle im)) + (let ((pixel-pnt (transparency-pixel-of self)) + (hbmp (gfs:handle self)) (hmask (cffi:null-pointer)) (nptr (cffi:null-pointer))) (if pixel-pnt (progn (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap) - (gfs::get-object (gfs:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) + (gfs::get-object (gfs:handle self) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr) (cffi:with-foreign-slots ((gfs::width gfs::height) bmp-ptr gfs::bitmap) (setf hmask (gfs::create-bitmap gfs::width gfs::height 1 1 (cffi:null-pointer))) (if (gfs:null-handle-p hmask) Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Thu Aug 10 00:15:08 2006 @@ -171,8 +171,8 @@ (flag BOOL) (hotspotx DWORD) (hotspoty DWORD) - (maskbm HANDLE) - (colorbm HANDLE)) + (hmask HANDLE) + (hcolor HANDLE)) (defctype iconinfo-pointer :pointer) Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu Aug 10 00:15:08 2006 @@ -347,6 +347,12 @@ HANDLE) (defcfun + ("GetIconInfo" get-icon-info) + BOOL + (hicon HANDLE) + (iconinfo LPTR)) + +(defcfun ("GetKeyState" get-key-state) SHORT (virtkey INT))

1 0