From junrue at common-lisp.net  Tue Feb  7 17:42:36 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue,  7 Feb 2006 11:42:36 -0600 (CST)
Subject: [graphic-forms-cvs] r2 - in trunk: . src src/tests/uitoolkit
	src/uitoolkit/widgets
Message-ID: <20060207174236.B63545100E@common-lisp.net>

Author: junrue
Date: Tue Feb  7 11:42:35 2006
New Revision: 2

Added:
   trunk/graphic-forms-tests.asd
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/tests.lisp
Modified:
   trunk/build.lisp
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
upgraded to CFFI 0.9.0; started pulling in test code

Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp	(original)
+++ trunk/build.lisp	Tue Feb  7 11:42:35 2006
@@ -1,10 +1,38 @@
 ;;;;
 ;;;; build.lisp
 ;;;;
-;;;; Copyright (c) 2006 by Jack D. Unrue
+;;;; 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.
 ;;;;
 
 (defpackage #:graphic-forms-system
+  (:nicknames #:gfs)
   (:use :common-lisp :asdf))
 
 (in-package #:graphic-forms-system)
@@ -16,7 +44,7 @@
 
 (defvar *asdf-root*    (concatenate 'string *library-root* "asdf-repo/"))
 
-(defvar *cffi-dir*     (concatenate 'string *asdf-root* "cffi-060114/"))
+(defvar *cffi-dir*     (concatenate 'string *asdf-root* "cffi-0.9.0/"))
 (defvar *pcl-ch08-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter08/"))
 (defvar *pcl-ch24-dir* (concatenate 'string *asdf-root* "practicals-1.0.3/Chapter24/"))
 (defvar *cldoc-dir*    (concatenate 'string *asdf-root* "cldoc/"))
@@ -25,7 +53,11 @@
 (defvar *gf-build-dir* "c:/projects/public/build/graphic-forms/")
 (defvar *gf-doc-dir*   (concatenate 'string *gf-build-dir* "docs/"))
 
-(defvar *asdf-dirs* (list *cffi-dir* *pcl-ch08-dir* *pcl-ch24-dir* *cldoc-dir* *gf-dir*))
+(defvar *asdf-dirs* (list *cffi-dir*
+                          *pcl-ch08-dir*
+                          *pcl-ch24-dir*
+                          *cldoc-dir*
+                          *gf-dir*))
 
 (defvar *library-build-root* (concatenate 'string *library-root* "build/"))
 (defvar *cffi-build-dir*     (concatenate 'string *library-build-root* "cffi/"))
@@ -33,9 +65,11 @@
 (defvar *pcl-ch24-build-dir* (concatenate 'string *library-build-root* "pcl-binary-data/"))
 (defvar *cldoc-build-dir*    (concatenate 'string *library-build-root* "cldoc/"))
 
-(defvar *build-dirs* (list *cffi-build-dir* *pcl-ch08-build-dir* *pcl-ch24-build-dir* *cldoc-build-dir* *gf-build-dir*))
-
-(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp"))
+(defvar *build-dirs* (list *cffi-build-dir*
+                           *pcl-ch08-build-dir*
+                           *pcl-ch24-build-dir*
+                           *cldoc-build-dir*
+                           *gf-build-dir*))
 
 #+lispworks (defmacro chdir (path)
               `(hcl:change-directory ,path))
@@ -43,7 +77,6 @@
               `(ext:cd ,path))
 
 (defun build ()
-
   (mapc #'(lambda (dir-str) (pushnew dir-str asdf:*central-registry* :test #'equal)) *asdf-dirs*)
   (when *external-build-dirs*
     (mapc #'(lambda (dir-str) (ensure-directories-exist (parse-namestring dir-str))) *build-dirs*))
@@ -65,11 +98,6 @@
     (chdir *gf-build-dir*))
   (asdf:operate 'asdf:load-op :graphic-forms-uitoolkit))
 
-;;; FIXME: define test package (and must :use #:lisp-unit)
-;;;
-(defun run-tests ()
-  (load (compile-file *lisp-unit-srcfile*)))
-
 ;;; FIXME: reference to :cldoc below can't be satisfied yet when
 ;;; this file is loaded
 #|

Added: trunk/graphic-forms-tests.asd
==============================================================================
--- (empty file)
+++ trunk/graphic-forms-tests.asd	Tue Feb  7 11:42:35 2006
@@ -0,0 +1,53 @@
+;;;;
+;;;; graphic-forms-tests.asd
+;;;;
+;;;; 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-system)
+
+(print "Graphic-Forms UI Toolkit Tests")
+(print "Copyright (c) 2006 by Jack D. Unrue")
+(print " ")
+
+(defsystem graphic-forms-tests
+  :description "Graphic-Forms UI Toolkit Tests"
+  :version "0.2.0"
+  :author "Jack D. Unrue"
+  :licence "BSD"
+  :components
+    ((:module "src"
+        :components
+          ((:module "tests"
+              :components
+                ((:module "uitoolkit"
+                  :components
+                    ((:file "hello-world")
+                     (:file "event-tester")))))))))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Tue Feb  7 11:42:35 2006
@@ -451,6 +451,7 @@
     #:show-selection
     #:shutdown
     #:size
+    #:startup
     #:step-increment
     #:style
     #:text

Added: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Tue Feb  7 11:42:35 2006
@@ -0,0 +1,195 @@
+;;;;
+;;;; event-tester.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)
+
+(defparameter *event-tester-window* nil)
+(defparameter *text* "Hello!")
+(defvar *event-counter* 0)
+(defvar *mouse-down-flag* nil)
+
+(defun exit-event-tester ()
+  (let ((w *event-tester-window*))
+    (setf *event-tester-window* nil)
+    (gfis:dispose w))
+  (gfuw:shutdown 0))
+
+(defclass event-tester-window-events (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-paint ((d event-tester-window-events) time (gc gfug:graphics-context) rect)
+  (declare (ignore time) (ignore rect))
+  (setf (gfug:background-color gc) gfug:+color-white+)
+  (setf (gfug:foreground-color gc) gfug:+color-blue+)
+  (gfug:draw-text gc *text* (gfid:make-point)))
+
+(defmethod gfuw:event-close ((d event-tester-window-events) time)
+  (declare (ignore time))
+  (exit-event-tester))
+
+(defun text-for-modifiers ()
+  (format nil
+          "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]"
+          (not (gfuw:key-down-p gfuw:+vk-shift+))
+          (not (gfuw:key-down-p gfuw:+vk-control+))
+          (not (gfuw:key-down-p gfuw:+vk-alt+))
+          (not (gfuw:key-down-p gfuw:+vk-left-win+))
+          (not (gfuw:key-down-p gfuw:+vk-right-win+))
+          (not (gfuw:key-toggled-p gfuw:+vk-escape+))
+          (not (gfuw:key-toggled-p gfuw:+vk-caps-lock+))
+          (not (gfuw:key-toggled-p gfuw:+vk-num-lock+))
+          (not (gfuw:key-toggled-p gfuw:+vk-scroll-lock+))))
+
+(defun text-for-mouse (action time button pnt)
+  (format nil
+          "~a mouse action: ~s  button: ~a  point: (~d,~d)  time: 0x~x  ~s"
+          (incf *event-counter*)
+          action
+          button
+          (gfid:point-x pnt)
+          (gfid:point-y pnt)
+          time
+          (text-for-modifiers)))
+
+(defun text-for-key (action time key-code char)
+  (format nil
+          "~a key action: ~s  char: ~s  code: 0x~x  time: 0x~x  ~s"
+          (incf *event-counter*)
+          action
+          char
+          key-code
+          time
+          (text-for-modifiers)))
+
+(defun text-for-menu (text time)
+  (format nil
+          "~a menu: ~s  time: 0x~x  ~s"
+          (incf *event-counter*)
+          text
+          time
+          (text-for-modifiers)))
+
+(defun text-for-size (type time size)
+  (format nil
+          "~a resize action: ~s  size: (~d,~d)  time: 0x~x  ~s"
+          (incf *event-counter*)
+          (symbol-name type)
+          (gfid:size-width size)
+          (gfid:size-height size)
+          time
+          (text-for-modifiers)))
+
+(defun text-for-move (time pnt)
+  (format nil
+          "~a move  point: (~d,~d)  time: 0x~x  ~s"
+          (incf *event-counter*)
+          (gfid:point-x pnt)
+          (gfid:point-y pnt)
+          time
+          (text-for-modifiers)))
+          
+(defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char)
+  (setf *text* (text-for-key "down" time key-code char))
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char)
+  (setf *text* (text-for-key "up" time key-code char))
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button)
+  (setf *text* (text-for-mouse "double" time button pnt))
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button)
+  (setf *text* (text-for-mouse "down" time button pnt))
+  (setf *mouse-down-flag* t)
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button)
+  (when *mouse-down-flag*
+    (setf *text* (text-for-mouse "move" time button pnt))
+    (gfuw:redraw *event-tester-window*)))
+
+(defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button)
+  (setf *text* (text-for-mouse "up" time button pnt))
+  (setf *mouse-down-flag* nil)
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-move ((d event-tester-window-events) time pnt)
+  (setf *text* (text-for-move time pnt))
+  (gfuw:redraw *event-tester-window*)
+  0)
+
+(defmethod gfuw:event-resize ((d event-tester-window-events) time size type)
+  (setf *text* (text-for-size type time size))
+  (gfuw:redraw *event-tester-window*)
+  0)
+
+(defclass event-tester-exit-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d event-tester-exit-dispatcher) time item rect)
+  (declare (ignorable time item rect))
+  (exit-event-tester))
+
+(defclass echo-menu-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d echo-menu-dispatcher) time item rect)
+  (declare (ignore rect))
+  (setf *text* (text-for-menu (gfuw:text item) time))
+  (gfuw:redraw *event-tester-window*))
+
+(defun run-event-tester-internal ()
+  (setf *text* "Hello!")
+  (setf *event-counter* 0)
+  (let ((echo-md (make-instance 'echo-menu-dispatcher))
+        (exit-md (make-instance 'event-tester-exit-dispatcher))
+        (menubar nil))
+    (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events)))
+    (gfuw:realize *event-tester-window* nil :style-workspace)
+    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
+                                         (:menuitem "&Open..." :dispatcher ,echo-md)
+                                         (:menuitem "&Save..." :disabled :dispatcher ,echo-md)
+                                         (:menuitem :separator)
+                                         (:menuitem "E&xit" :dispatcher ,exit-md))
+                                        ((:menu "&Options")
+                                         (:menuitem "&Enabled" :checked :dispatcher ,echo-md)
+                                         (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md)
+                                                              (:menuitem "&Fonts" :dispatcher ,echo-md :disabled)
+                                                              (:menuitem "&Colors" :dispatcher ,echo-md))))
+                                        ((:menu "&Help")
+                                         (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
+    (setf (gfuw:menu-bar *event-tester-window*) menubar)
+    (gfuw:show *event-tester-window*)
+    (gfuw:run-default-message-loop)))
+
+(defun run-event-tester ()
+  (gfuw:startup "Event Tester" #'run-event-tester-internal))

Added: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Tue Feb  7 11:42:35 2006
@@ -0,0 +1,75 @@
+;;;;
+;;;; hello-world.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)
+
+(defparameter *hellowin* nil)
+
+(defun exit-hello-world ()
+  (let ((w *hellowin*))
+    (setf *hellowin* nil)
+    (gfis:dispose w))
+  (gfuw:shutdown 0))
+
+(defclass hellowin-events (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-close ((d hellowin-events) time)
+  (declare (ignore time))
+  (format t "hellowin-events event-close~%")
+  (exit-hello-world))
+
+(defmethod gfuw:event-paint ((d hellowin-events) time (gc gfug:graphics-context) rect)
+  (declare (ignore time) (ignore rect))
+  (setf (gfug:background-color gc) gfug:+color-red+)
+  (setf (gfug:foreground-color gc) gfug:+color-green+)
+  (gfug:draw-text gc "Hello World!" (gfid:make-point)))
+
+(defclass hellowin-exit-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d hellowin-exit-dispatcher) time item rect)
+  (declare (ignorable time item rect))
+  (exit-hello-world))
+
+(defun run-hello-world-internal ()
+  (let ((menubar nil)
+        (md (make-instance 'hellowin-exit-dispatcher)))
+    (setf *hellowin* (make-instance 'gfuw:window :dispatcher (make-instance 'hellowin-events)))
+    (gfuw:realize *hellowin* nil :style-workspace)
+    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
+                                         (:menuitem "E&xit" :dispatcher ,md)))))
+    (setf (gfuw:menu-bar *hellowin*) menubar)
+    (gfuw:show *hellowin*)
+    (gfuw:run-default-message-loop)))
+
+(defun run-hello-world ()
+  (gfuw:startup "Hello World" #'run-hello-world-internal))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Tue Feb  7 11:42:35 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; utils.lisp
+;;;; widget-utils.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.
@@ -31,7 +31,19 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.uitoolkit.widgets)
+(in-package #:graphic-forms.uitoolkit.widgets)
+
+#+clisp (defun startup (thread-name start-fn)
+          (declare (ignore thread-name))
+          (funcall start-fn))
+
+#+lispworks (defun startup (thread-name start-fn)
+              (when (null (mp:list-all-processes))
+                (mp:initialize-multiprocessing))
+              (mp:process-run-function thread-name nil start-fn))
+
+(defun shutdown (exit-code)
+  (gfus::post-quit-message exit-code))
 
 (defun create-window (class-name title parent-hwnd std-style ex-style)
   (cffi:with-foreign-string (cname-ptr class-name)

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Tue Feb  7 11:42:35 2006
@@ -145,10 +145,3 @@
 (defun remove-widget (hwnd)
   (when (not *widget-in-progress*)
     (remhash (cffi:pointer-address hwnd) *widgets-by-hwnd*)))
-
-;;;
-;;; miscellaneous
-;;;
-
-(defun shutdown (exit-code)
-  (gfus::post-quit-message exit-code))

Added: trunk/tests.lisp
==============================================================================
--- (empty file)
+++ trunk/tests.lisp	Tue Feb  7 11:42:35 2006
@@ -0,0 +1,47 @@
+;;;;
+;;;; 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-system)
+
+(defvar *lisp-unit-srcfile* (concatenate 'string *library-root* "lisp-unit.lisp"))
+
+(load (compile-file *lisp-unit-srcfile*))
+
+(defpackage #:graphic-forms.uitoolkit.tests
+  (:nicknames #:gft)
+  (:use :common-lisp :lisp-unit))
+
+(defun load-adhoc-tests ()
+  (if *external-build-dirs*
+    (chdir *gf-build-dir*))
+  (asdf:operate 'asdf:load-op :graphic-forms-tests))


From junrue at common-lisp.net  Wed Feb  8 04:50:34 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue,  7 Feb 2006 22:50:34 -0600 (CST)
Subject: [graphic-forms-cvs] r3 - in trunk: . src src/tests/uitoolkit
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060208045034.44F864900D@common-lisp.net>

Author: junrue
Date: Tue Feb  7 22:50:33 2006
New Revision: 3

Added:
   trunk/src/tests/uitoolkit/layout-tester.lisp
Modified:
   trunk/graphic-forms-tests.asd
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/uitoolkit/system/system-conditions.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/system-types.lisp
   trunk/src/uitoolkit/system/system-utils.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
Log:
first implementation of menu activation and arming

Modified: trunk/graphic-forms-tests.asd
==============================================================================
--- trunk/graphic-forms-tests.asd	(original)
+++ trunk/graphic-forms-tests.asd	Tue Feb  7 22:50:33 2006
@@ -49,5 +49,6 @@
               :components
                 ((:module "uitoolkit"
                   :components
-                    ((:file "hello-world")
-                     (:file "event-tester")))))))))
+                    ((:file "event-tester")
+                     (:file "hello-world")
+                     (:file "layout-tester")))))))))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Tue Feb  7 22:50:33 2006
@@ -338,6 +338,7 @@
     #:disable-layout
     #:disable-redraw
     #:disabled-image
+    #:dispatcher
     #:display-to-object
     #:echo-char
     #:enable

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Tue Feb  7 22:50:33 2006
@@ -34,7 +34,7 @@
 (in-package #:graphic-forms.uitoolkit.tests)
 
 (defparameter *event-tester-window* nil)
-(defparameter *text* "Hello!")
+(defparameter *event-tester-text* "Hello!")
 (defvar *event-counter* 0)
 (defvar *mouse-down-flag* nil)
 
@@ -46,11 +46,13 @@
 
 (defclass event-tester-window-events (gfuw:event-dispatcher) ())
 
-(defmethod gfuw:event-paint ((d event-tester-window-events) time (gc gfug:graphics-context) rect)
-  (declare (ignore time) (ignore rect))
+(defmethod gfuw:event-paint ((d event-tester-window-events) time gc rect)
+  (declare (ignorable time rect))
   (setf (gfug:background-color gc) gfug:+color-white+)
   (setf (gfug:foreground-color gc) gfug:+color-blue+)
-  (gfug:draw-text gc *text* (gfid:make-point)))
+  (let* ((sz (gfuw:client-size *event-tester-window*))
+         (pnt (gfid:make-point :x 0 :y (floor (/ (gfid:size-height sz) 2)))))
+    (gfug:draw-text gc *event-tester-text* pnt)))
 
 (defmethod gfuw:event-close ((d event-tester-window-events) time)
   (declare (ignore time))
@@ -90,10 +92,11 @@
           time
           (text-for-modifiers)))
 
-(defun text-for-menu (text time)
+(defun text-for-item (text time desc)
   (format nil
-          "~a menu: ~s  time: 0x~x  ~s"
+          "~a ~s: ~s  time: 0x~x  ~s"
           (incf *event-counter*)
+          desc
           text
           time
           (text-for-modifiers)))
@@ -118,39 +121,39 @@
           (text-for-modifiers)))
           
 (defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char)
-  (setf *text* (text-for-key "down" time key-code char))
+  (setf *event-tester-text* (text-for-key "down" time key-code char))
   (gfuw:redraw *event-tester-window*))
 
 (defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char)
-  (setf *text* (text-for-key "up" time key-code char))
+  (setf *event-tester-text* (text-for-key "up" time key-code char))
   (gfuw:redraw *event-tester-window*))
 
 (defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button)
-  (setf *text* (text-for-mouse "double" time button pnt))
+  (setf *event-tester-text* (text-for-mouse "double" time button pnt))
   (gfuw:redraw *event-tester-window*))
 
 (defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button)
-  (setf *text* (text-for-mouse "down" time button pnt))
+  (setf *event-tester-text* (text-for-mouse "down" time button pnt))
   (setf *mouse-down-flag* t)
   (gfuw:redraw *event-tester-window*))
 
 (defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button)
   (when *mouse-down-flag*
-    (setf *text* (text-for-mouse "move" time button pnt))
+    (setf *event-tester-text* (text-for-mouse "move" time button pnt))
     (gfuw:redraw *event-tester-window*)))
 
 (defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button)
-  (setf *text* (text-for-mouse "up" time button pnt))
+  (setf *event-tester-text* (text-for-mouse "up" time button pnt))
   (setf *mouse-down-flag* nil)
   (gfuw:redraw *event-tester-window*))
 
 (defmethod gfuw:event-move ((d event-tester-window-events) time pnt)
-  (setf *text* (text-for-move time pnt))
+  (setf *event-tester-text* (text-for-move time pnt))
   (gfuw:redraw *event-tester-window*)
   0)
 
 (defmethod gfuw:event-resize ((d event-tester-window-events) time size type)
-  (setf *text* (text-for-size type time size))
+  (setf *event-tester-text* (text-for-size type time size))
   (gfuw:redraw *event-tester-window*)
   0)
 
@@ -160,32 +163,46 @@
   (declare (ignorable time item rect))
   (exit-event-tester))
 
-(defclass echo-menu-dispatcher (gfuw:event-dispatcher) ())
+(defmethod gfuw:event-arm ((d event-tester-exit-dispatcher) time item)
+  (declare (ignore rect))
+  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed"))
+  (gfuw:redraw *event-tester-window*))
+
+(defclass event-tester-echo-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d event-tester-echo-dispatcher) time item rect)
+  (declare (ignore rect))
+  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item selected"))
+  (gfuw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-select ((d echo-menu-dispatcher) time item rect)
+(defmethod gfuw:event-arm ((d event-tester-echo-dispatcher) time item)
   (declare (ignore rect))
-  (setf *text* (text-for-menu (gfuw:text item) time))
+  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed"))
+  (gfuw:redraw *event-tester-window*))
+
+(defmethod gfuw:event-activate ((d event-tester-echo-dispatcher) time)
+  (setf *event-tester-text* (text-for-item "" time "menu activated"))
   (gfuw:redraw *event-tester-window*))
 
 (defun run-event-tester-internal ()
-  (setf *text* "Hello!")
+  (setf *event-tester-text* "Hello!")
   (setf *event-counter* 0)
-  (let ((echo-md (make-instance 'echo-menu-dispatcher))
+  (let ((echo-md (make-instance 'event-tester-echo-dispatcher))
         (exit-md (make-instance 'event-tester-exit-dispatcher))
         (menubar nil))
     (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events)))
     (gfuw:realize *event-tester-window* nil :style-workspace)
-    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
+    (setf menubar (gfuw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md)
                                          (:menuitem "&Open..." :dispatcher ,echo-md)
                                          (:menuitem "&Save..." :disabled :dispatcher ,echo-md)
                                          (:menuitem :separator)
                                          (:menuitem "E&xit" :dispatcher ,exit-md))
-                                        ((:menu "&Options")
+                                        ((:menu "&Options" :dispatcher ,echo-md)
                                          (:menuitem "&Enabled" :checked :dispatcher ,echo-md)
                                          (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md)
                                                               (:menuitem "&Fonts" :dispatcher ,echo-md :disabled)
                                                               (:menuitem "&Colors" :dispatcher ,echo-md))))
-                                        ((:menu "&Help")
+                                        ((:menu "&Help" :dispatcher ,echo-md)
                                          (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
     (setf (gfuw:menu-bar *event-tester-window*) menubar)
     (gfuw:show *event-tester-window*)

Added: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Tue Feb  7 22:50:33 2006
@@ -0,0 +1,103 @@
+;;;;
+;;;; layout-tester.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)
+
+(defconstant +btn-text-1+ "Push Me")
+(defconstant +btn-text-2+ "Again!")
+
+(defparameter *layout-win* nil)
+
+(defun exit-layout-tester ()
+  (let ((w *layout-win*))
+    (setf *layout-win* nil)
+    (gfis:dispose w))
+  (gfuw:shutdown 0))
+
+(defclass fill-events (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-close ((d fill-events) time)
+  (declare (ignore time))
+  (exit-layout-tester))
+
+(defclass fill-btn-events (gfuw:event-dispatcher)
+  ((button
+    :accessor button
+    :initarg :button
+    :initform nil)
+   (toggle-fn
+    :accessor toggle-fn
+    :initform nil)))
+
+(defmethod gfuw:event-select ((d fill-btn-events) time item rect)
+  (declare (ignorable time rect))
+  (let ((btn (button d)))
+    (setf (gfuw:text btn) (funcall (toggle-fn d)))))
+
+(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect)
+  (declare (ignorable time item rect))
+  (exit-layout-tester))
+
+(defun run-layout-tester-internal ()
+  (let* ((menubar nil)
+         (md (make-instance 'fill-exit-dispatcher))
+         (bd (make-instance 'fill-btn-events))
+         (btn (make-instance 'gfuw:button :dispatcher bd)))
+    (setf (button bd) btn)
+    (setf (toggle-fn bd) (let ((flag nil))
+                           #'(lambda ()
+                               (if (null flag)
+                                 (progn
+                                   (setf flag t)
+                                   +btn-text-1+)
+                                 (progn
+                                   (setf flag nil)
+                                   +btn-text-2+)))))
+    (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events)))
+    (gfuw:realize *layout-win* nil :style-workspace)
+    (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150))
+    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
+                                           (:menuitem "E&xit" :dispatcher ,md))
+                                        ((:menu "&Children")))))
+    (setf (gfuw:menu-bar *layout-win*) menubar)
+    (gfuw:realize btn *layout-win* :push-button)
+    (setf (gfuw:text btn) (funcall (toggle-fn bd)))
+    (setf (gfuw:location btn) (gfid:make-point))
+    (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1))
+    (gfuw:show *layout-win*)
+    (gfuw:run-default-message-loop)))
+
+(defun run-layout-tester ()
+  (gfuw:startup "Layout Tester" #'run-layout-tester-internal))

Modified: trunk/src/uitoolkit/system/system-conditions.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-conditions.lisp	(original)
+++ trunk/src/uitoolkit/system/system-conditions.lisp	Tue Feb  7 22:50:33 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; conditions.lisp
+;;;; system-conditions.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Tue Feb  7 22:50:33 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; constants.lisp
+;;;; system-constants.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.
@@ -545,6 +545,10 @@
 (defconstant +wm-sysdeadchar+              #x0107)
 (defconstant +wm-keylast+                  #x0109) ; for use with peek-message
 (defconstant +wm-command+                  #x0111)
+(defconstant +wm-initmenu+                 #x0116)
+(defconstant +wm-initmenupopup+            #x0117)
+(defconstant +wm-menuselect+               #x011F)
+(defconstant +wm-menuchar+                 #x0120)
 (defconstant +wm-mousefirst+               #x0200) ; for use with peek-message
 (defconstant +wm-mousemove+                #x0200)
 (defconstant +wm-lbuttondown+              #x0201)

Modified: trunk/src/uitoolkit/system/system-types.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-types.lisp	(original)
+++ trunk/src/uitoolkit/system/system-types.lisp	Tue Feb  7 22:50:33 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; types.lisp
+;;;; system-types.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp	(original)
+++ trunk/src/uitoolkit/system/system-utils.lisp	Tue Feb  7 22:50:33 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; utils.lisp
+;;;; system-utils.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Tue Feb  7 22:50:33 2006
@@ -38,10 +38,10 @@
   (:method (dispatcher time)
     (declare (ignorable dispatcher time))))
 
-(defgeneric event-arm (dispatcher time)
+(defgeneric event-arm (dispatcher time item)
   (:documentation "Implement this to respond to an object about to be selected.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher time item)
+    (declare (ignorable dispatcher time item))))
 
 (defgeneric event-close (dispatcher time)
   (:documentation "Implement this to respond to an object being closed.")

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Tue Feb  7 22:50:33 2006
@@ -131,7 +131,7 @@
   (gfus::def-window-proc hwnd msg wparam lparam))
 
 (defmethod process-message (hwnd (msg (eql gfus::+wm-close+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if w
       (event-close (dispatcher w) *last-event-time*)
@@ -166,8 +166,26 @@
       (error 'gfus:toolkit-error :detail "no object for hwnd")))
   0)
 
+(defmethod process-message (hwnd (msg (eql gfus::+wm-initmenupopup+)) wparam lparam)
+  (declare (ignorable hwnd lparam))
+  (let ((menu (get-widget (cffi:make-pointer wparam))))
+    (unless (null menu)
+      (let ((d (dispatcher menu)))
+        (unless (null d)
+          (event-activate d *last-event-time*)))))
+  0)
+
+(defmethod process-message (hwnd (msg (eql gfus::+wm-menuselect+)) wparam lparam)
+  (declare (ignorable hwnd lparam)) ; FIXME: handle system menus
+  (let ((item (get-menuitem (lo-word wparam))))
+    (unless (null item)
+      (let ((d (dispatcher item)))
+        (unless (null d)
+          (event-arm d *last-event-time* item)))))
+  0)
+
 (defmethod process-message (hwnd (msg (eql gfus::+wm-create+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (get-widget hwnd) ; has side-effect of setting handle slot
   0)
 
@@ -240,7 +258,7 @@
     (process-mouse-message #'event-mouse-move hwnd lparam btn-sym)))
 
 (defmethod process-message (hwnd (msg (eql gfus::+wm-move+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (when w
       (outer-location w *move-event-pnt*)
@@ -248,14 +266,14 @@
   0)
 
 (defmethod process-message (hwnd (msg (eql gfus::+wm-moving+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if (and w (event-pre-move (dispatcher w) *last-event-time*))
       1
       0)))
 
 (defmethod process-message (hwnd (msg (eql gfus::+wm-paint+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd))
         (gc (make-instance 'gfug:graphics-context)))
     (if w
@@ -303,7 +321,7 @@
   0)
 
 (defmethod process-message (hwnd (msg (eql gfus::+wm-sizing+)) wparam lparam)
-  (declare (ignore wparam) (ignore lparam))
+  (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if (and w (event-pre-resize (dispatcher w) *last-event-time*))
       1

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Tue Feb  7 22:50:33 2006
@@ -398,7 +398,7 @@
     (insert-separator (gfis:handle parent))))
 
 (defmethod define-menu ((gen menu-generator) label dispatcher)
-  (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu)))
+  (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher))
          (parent (first (menu-stack gen)))
          (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher))
          (id *next-menuitem-id*))


From junrue at common-lisp.net  Fri Feb 10 07:37:08 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Fri, 10 Feb 2006 01:37:08 -0600 (CST)
Subject: [graphic-forms-cvs] r4 - in trunk: . src src/intrinsics/system
	src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060210073708.0212F4F004@common-lisp.net>

Author: junrue
Date: Fri Feb 10 01:37:07 2006
New Revision: 4

Added:
   trunk/src/intrinsics/system/native-classes.lisp
      - copied, changed from r1, trunk/src/intrinsics/system/system-classes.lisp
   trunk/src/intrinsics/system/native-conditions.lisp
      - copied, changed from r1, trunk/src/intrinsics/system/system-conditions.lisp
Removed:
   trunk/src/intrinsics/system/system-classes.lisp
   trunk/src/intrinsics/system/system-conditions.lisp
Modified:
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/item.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed filename conflict; overhauled menu cleanup; implemented more menu mgmnt

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Fri Feb 10 01:37:07 2006
@@ -54,8 +54,8 @@
                       ((:file "datastruct-classes")))
                  (:module "system"
                     :components
-                      ((:file "system-classes")
-                       (:file "system-conditions")
+                      ((:file "native-classes")
+                       (:file "native-conditions")
                        (:file "native-object-generics")
                        (:file "native-object")))))
            (:module "uitoolkit"

Copied: trunk/src/intrinsics/system/native-classes.lisp (from r1, trunk/src/intrinsics/system/system-classes.lisp)
==============================================================================
--- trunk/src/intrinsics/system/system-classes.lisp	(original)
+++ trunk/src/intrinsics/system/native-classes.lisp	Fri Feb 10 01:37:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; classes.lisp
+;;;; native-classes.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Copied: trunk/src/intrinsics/system/native-conditions.lisp (from r1, trunk/src/intrinsics/system/system-conditions.lisp)
==============================================================================
--- trunk/src/intrinsics/system/system-conditions.lisp	(original)
+++ trunk/src/intrinsics/system/native-conditions.lisp	Fri Feb 10 01:37:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; conditions.lisp
+;;;; native-conditions.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Fri Feb 10 01:37:07 2006
@@ -310,6 +310,7 @@
     #:border-width
     #:caret
     #:checked-p
+    #:clear-all
     #:clear-item
     #:clear-selection
     #:clear-span
@@ -387,15 +388,16 @@
     #:header-visible-p
     #:iconify
     #:iconified-p
-    #:image
-    #:item-id
     #:hide
     #:hide-header
     #:hide-lines
     #:horizontal-scrollbar
+    #:image
+    #:item-append
     #:item-at
     #:item-count
     #:item-height
+    #:item-id
     #:item-index
     #:item-owner
     #:items
@@ -455,6 +457,7 @@
     #:startup
     #:step-increment
     #:style
+    #:sub-menu
     #:text
     #:text-height
     #:text-limit

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Fri Feb 10 01:37:07 2006
@@ -36,21 +36,21 @@
 (defconstant +btn-text-1+ "Push Me")
 (defconstant +btn-text-2+ "Again!")
 
-(defparameter *layout-win* nil)
+(defparameter *layout-tester-win* nil)
 
 (defun exit-layout-tester ()
-  (let ((w *layout-win*))
-    (setf *layout-win* nil)
+  (let ((w *layout-tester-win*))
+    (setf *layout-tester-win* nil)
     (gfis:dispose w))
   (gfuw:shutdown 0))
 
-(defclass fill-events (gfuw:event-dispatcher) ())
+(defclass layout-tester-events (gfuw:event-dispatcher) ())
 
-(defmethod gfuw:event-close ((d fill-events) time)
+(defmethod gfuw:event-close ((d layout-tester-events) time)
   (declare (ignore time))
   (exit-layout-tester))
 
-(defclass fill-btn-events (gfuw:event-dispatcher)
+(defclass layout-tester-btn-events (gfuw:event-dispatcher)
   ((button
     :accessor button
     :initarg :button
@@ -59,24 +59,40 @@
     :accessor toggle-fn
     :initform nil)))
 
-(defmethod gfuw:event-select ((d fill-btn-events) time item rect)
+(defmethod gfuw:event-select ((d layout-tester-btn-events) time item rect)
   (declare (ignorable time rect))
   (let ((btn (button d)))
     (setf (gfuw:text btn) (funcall (toggle-fn d)))))
 
-(defclass fill-exit-dispatcher (gfuw:event-dispatcher) ())
+(defclass layout-tester-child-menu-dispatcher (gfuw:event-dispatcher) ())
 
-(defmethod gfuw:event-select ((d fill-exit-dispatcher) time item rect)
+(defmethod gfuw:event-activate ((d layout-tester-child-menu-dispatcher) time)
+  (declare (ignore time))
+  (let* ((mb (gfuw:menu-bar *layout-tester-win*))
+         (menu (gfuw:sub-menu mb 1)))
+    (gfuw:clear-all menu)
+    (gfuw::visit-child-widgets *layout-tester-win*
+                               #'(lambda (child val)
+                                   (declare (ignore val))
+                                   (let ((it (make-instance 'gfuw:menu-item)))
+                                     (gfuw:item-append menu it)
+                                     (setf (gfuw:text it) (gfuw:text child))))
+                               0)))
+
+(defclass layout-tester-exit-dispatcher (gfuw:event-dispatcher) ())
+
+(defmethod gfuw:event-select ((d layout-tester-exit-dispatcher) time item rect)
   (declare (ignorable time item rect))
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()
   (let* ((menubar nil)
-         (md (make-instance 'fill-exit-dispatcher))
-         (bd (make-instance 'fill-btn-events))
-         (btn (make-instance 'gfuw:button :dispatcher bd)))
-    (setf (button bd) btn)
-    (setf (toggle-fn bd) (let ((flag nil))
+         (fed (make-instance 'layout-tester-exit-dispatcher))
+         (be (make-instance 'layout-tester-btn-events))
+         (cmd (make-instance 'layout-tester-child-menu-dispatcher))
+         (btn (make-instance 'gfuw:button :dispatcher be)))
+    (setf (button be) btn)
+    (setf (toggle-fn be) (let ((flag nil))
                            #'(lambda ()
                                (if (null flag)
                                  (progn
@@ -85,18 +101,19 @@
                                  (progn
                                    (setf flag nil)
                                    +btn-text-2+)))))
-    (setf *layout-win* (make-instance 'gfuw:window :dispatcher (make-instance 'fill-events)))
-    (gfuw:realize *layout-win* nil :style-workspace)
-    (setf (gfuw:size *layout-win*) (gfid:make-size :width 200 :height 150))
+    (setf *layout-tester-win* (make-instance 'gfuw:window :dispatcher (make-instance 'layout-tester-events)))
+    (gfuw:realize *layout-tester-win* nil :style-workspace)
+    (setf (gfuw:size *layout-tester-win*) (gfid:make-size :width 200 :height 150))
     (setf menubar (gfuw:defmenusystem `(((:menu "&File")
-                                           (:menuitem "E&xit" :dispatcher ,md))
-                                        ((:menu "&Children")))))
-    (setf (gfuw:menu-bar *layout-win*) menubar)
-    (gfuw:realize btn *layout-win* :push-button)
-    (setf (gfuw:text btn) (funcall (toggle-fn bd)))
+                                           (:menuitem "E&xit" :dispatcher ,fed))
+                                        ((:menu "&Children" :dispatcher ,cmd)
+                                           (:menuitem :separator)))))
+    (setf (gfuw:menu-bar *layout-tester-win*) menubar)
+    (gfuw:realize btn *layout-tester-win* :push-button)
+    (setf (gfuw:text btn) (funcall (toggle-fn be)))
     (setf (gfuw:location btn) (gfid:make-point))
     (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1))
-    (gfuw:show *layout-win*)
+    (gfuw:show *layout-tester-win*)
     (gfuw:run-default-message-loop)))
 
 (defun run-layout-tester ()

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Fri Feb 10 01:37:07 2006
@@ -211,6 +211,9 @@
 (defconstant +lr-copyfromresource+         #x4000)
 (defconstant +lr-shared+                   #x8000)
 
+(defconstant +mf-bycommand+            #x00000000)
+(defconstant +mf-byposition+           #x00000400)
+
 (defconstant +mfs-grayed+              #x00000003)
 (defconstant +mfs-disabled+            #x00000003)
 (defconstant +mfs-checked+             #x00000008)

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Fri Feb 10 01:37:07 2006
@@ -288,6 +288,13 @@
   (hdc HANDLE))
 
 (defcfun
+  ("RemoveMenu" remove-menu)
+  BOOL
+  (hmenu HANDLE)
+  (pos UINT)
+  (flags UINT))
+
+(defcfun
   ("SendMessageA" send-message)
   LRESULT
   (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/item.lisp	Fri Feb 10 01:37:07 2006
@@ -34,4 +34,4 @@
 (in-package :graphic-forms.uitoolkit.widgets)
 
 (defun items-equal-p (item1 item2)
-  (string= (text item1) (text item2)))
+  (= (item-id item1) (item-id item2)))

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Fri Feb 10 01:37:07 2006
@@ -75,7 +75,31 @@
           (cffi:foreign-free str-ptr)))
         result))))
 
-(defun insert-menuitem (hparent mid label hbmp)
+(defun set-menuitem-text (hmenu mid label)
+  (cffi:with-foreign-string (str-ptr label)
+    (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
+      (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
+                                 gfus::state gfus::id gfus::hsubmenu
+                                 gfus::hbmpchecked gfus::hbmpunchecked
+                                 gfus::idata gfus::tdata gfus::cch
+                                 gfus::hbmpitem)
+                                mii-ptr gfus::menuiteminfo)
+        (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
+        (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+))
+        (setf gfus::type 0)
+        (setf gfus::state 0)
+        (setf gfus::id mid)
+        (setf gfus::hsubmenu (cffi:null-pointer))
+        (setf gfus::hbmpchecked (cffi:null-pointer))
+        (setf gfus::hbmpunchecked (cffi:null-pointer))
+        (setf gfus::idata 0)
+        (setf gfus::tdata str-ptr)
+        (setf gfus::cch (length label))
+        (setf gfus::hbmpitem (cffi:null-pointer)))
+      (if (zerop (gfus::set-menu-item-info hmenu mid 0 mii-ptr))
+        (error 'gfus:win32-error :detail "set-menu-item-info failed")))))
+
+(defun insert-menuitem (howner mid label hbmp)
   (cffi:with-foreign-string (str-ptr label)
     (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
       (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
@@ -96,7 +120,7 @@
         (setf gfus::tdata str-ptr)
         (setf gfus::cch (length label))
         (setf gfus::hbmpitem hbmp))
-      (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
+      (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
         (error 'gfus::win32-error :detail "insert-menu-item failed")))))
 
 (defun insert-submenu (hparent mid label hbmp hchildmenu)
@@ -125,7 +149,7 @@
       (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
         (error 'gfus::win32-error :detail "insert-menu-item failed")))))
 
-(defun insert-separator (hparent)
+(defun insert-separator (howner)
   (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
     (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
                                gfus::state gfus::id gfus::hsubmenu
@@ -145,26 +169,35 @@
       (setf gfus::tdata (cffi:null-pointer))
       (setf gfus::cch 0)
       (setf gfus::hbmpitem (cffi:null-pointer)))
-    (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
+    (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
       (error 'gfus::win32-error :detail "insert-menu-item failed"))))
 
+(defun sub-menu (m index)
+  (if (gfis:disposed-p m)
+    (error 'gfis:disposed-error))
+  (let ((hwnd (gfus::get-submenu (gfis:handle m) index)))
+    (if (not (gfus:null-handle-p hwnd))
+      (get-widget hwnd)
+      nil)))
+
+(defun visit-menu-tree (menu fn)
+  (dotimes (index (item-count menu))
+    (let ((it (item-at menu index))
+          (child (sub-menu menu index)))
+      (unless (null child)
+        (visit-menu-tree child fn))
+      (funcall fn menu it))))
+
 ;;;
 ;;; menu methods
 ;;;
 
-(defun recursively-dispose-menuitem (it)
-  (let ((hsubmenu (gfis:handle it)))
-    (unless (gfus:null-handle-p hsubmenu)
-      (let ((m (get-widget hsubmenu)))
-        (if (null m)
-          (error 'gfus:toolkit-error :detail "no object for hmenu"))
-        (gfis:dispose m))))
-  (gfis:dispose it))
+(defun menu-cleanup-callback (menu item)
+  (remove-widget (gfis:handle menu))
+  (remove-menuitem item))
 
 (defmethod gfis:dispose ((m menu))
-  (let ((tmp (items m)))
-    (dotimes (i (length tmp))
-      (recursively-dispose-menuitem (elt tmp i))))
+  (visit-menu-tree m #'menu-cleanup-callback)
   (let ((hwnd (gfis:handle m)))
     (remove-widget hwnd)
     (if (not (gfus:null-handle-p hwnd))
@@ -172,6 +205,18 @@
         (error 'gfus:win32-error :detail "destroy-menu failed"))))
   (setf (slot-value m 'gfis:handle) nil))
 
+(defmethod item-append ((m menu) (it menu-item))
+  (let ((id *next-menuitem-id*)
+        (hmenu (gfis:handle m)))
+    (if (gfus:null-handle-p hmenu)
+      (error 'gfis:disposed-error))
+    (setf *next-menuitem-id* (1+ id))
+    (insert-menuitem (gfis:handle m) id " " (cffi:null-pointer))
+    (setf (item-id it) id)
+    (setf (slot-value it 'gfis:handle) hmenu)
+    (put-menuitem it)
+    (call-next-method)))
+
 ;;;
 ;;; item methods
 ;;;
@@ -179,14 +224,40 @@
 (defmethod gfis:dispose ((it menu-item))
   (setf (dispatcher it) nil)
   (remove-menuitem it)
-  (setf (item-id it) 0)
-  (setf (slot-value it 'gfis:handle) nil)) ; menu-item slot is for parent menu
-
-(defmethod text ((i menu-item))
-  (get-menuitem-text (gfis:handle (item-owner i)) (item-id i)))
+  (let ((id (item-id it))
+        (owner (item-owner it)))
+    (unless (null owner)
+      (gfus::remove-menu (gfis:handle owner) id gfus::+mf-bycommand+)
+      (let* ((index (item-index owner it))
+             (child-menu (sub-menu owner index)))
+        (unless (null child-menu)
+          (gfis:dispose child-menu))))
+    (setf (item-id it) 0)
+    (setf (slot-value it 'gfis:handle) nil)))
+
+(defmethod item-owner ((it menu-item))
+  (let ((hmenu (gfis:handle it)))
+    (if (gfus:null-handle-p hmenu)
+      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+    (let ((m (get-widget hmenu)))
+      (if (null m)
+        (error 'gfus:toolkit-error :detail "no owner menu"))
+      m)))
+
+(defmethod text ((it menu-item))
+  (let ((hmenu (gfis:handle it)))
+    (if (gfus:null-handle-p hmenu)
+      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+    (get-menuitem-text hmenu (item-id it))))
+
+(defmethod (setf text) (str (it menu-item))
+  (let ((hmenu (gfis:handle it)))
+    (if (gfus:null-handle-p hmenu)
+      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+    (set-menuitem-text hmenu (item-id it) str)))
 
 ;;;
-;;; DSL implementation
+;;; menu language compiler
 ;;;
 ;;; an example menubar definition:
 ;;;
@@ -268,7 +339,7 @@
     (when dispatcher
       (setf dispatcher (nth (1+ dispatcher) options))
       (if (null dispatcher)
-        (error 'toolkit-error :detail "missing dispatcher function")))
+        (error 'gfus:toolkit-error :detail "missing dispatcher function")))
     (values dispatcher)))
 
 (defun parse-menuitem-options (options)
@@ -280,23 +351,23 @@
         (sub (position-if #'submenu-option-p options)))
     (when sep
       (if (or disabled checked image sub)
-        (error 'toolkit-error :detail "invalid menu item options"))
+        (error 'gfus:toolkit-error :detail "invalid menu item options"))
       (return-from parse-menuitem-options (values nil nil nil nil t nil)))
     (when image
       (if sep
-        (error 'toolkit-error :detail "invalid menu item options"))
+        (error 'gfus:toolkit-error :detail "invalid menu item options"))
       (setf image (nth (1+ image) options))
       (if (null image)
-        (error 'toolkit-error :detail "missing image filename")))
+        (error 'gfus:toolkit-error :detail "missing image filename")))
     (when dispatcher
       (if sep
-        (error 'toolkit-error :detail "invalid menu item options"))
+        (error 'gfus:toolkit-error :detail "invalid menu item options"))
       (setf dispatcher (nth (1+ dispatcher) options))
       (if (null dispatcher)
-        (error 'toolkit-error :detail "missing dispatcher function")))
+        (error 'gfus:toolkit-error :detail "missing dispatcher function")))
     (when sub
       (if (or checked sep)
-        (error 'toolkit-error :detail "invalid menu item options"))
+        (error 'gfus:toolkit-error :detail "invalid menu item options"))
       (return-from parse-menuitem-options (values dispatcher disabled nil image nil t)))
     (values dispatcher disabled checked image nil nil)))
 
@@ -377,35 +448,39 @@
     (setf (menu-stack gen) (list m))))
 
 (defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image)
-  (let* ((parent (first (menu-stack gen)))
+  (let* ((owner (first (menu-stack gen)))
          (it (make-instance 'menu-item :dispatcher dispatcher))
-         (id *next-menuitem-id*))
+         (id *next-menuitem-id*)
+         (hmenu (gfis:handle owner)))
     (setf *next-menuitem-id* (1+ id))
+    (insert-menuitem hmenu id label (cffi:null-pointer))
     (setf (item-id it) id)
+    (setf (slot-value it 'gfis:handle) hmenu)
     (put-menuitem it)
-    (item-append parent it)
-    (insert-menuitem (gfis:handle parent) id label (cffi:null-pointer))))
+    (vector-push-extend it (items owner))))
 
 (defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image)
   (declare (ignore dispatcher) (ignore enabled) (ignore image))
   (process-menu gen submenu))
 
 (defmethod define-separator ((gen menu-generator))
-  (let* ((parent (first (menu-stack gen)))
-         (it (make-instance 'menu-item)))
+  (let* ((owner (first (menu-stack gen)))
+         (it (make-instance 'menu-item))
+         (hmenu (gfis:handle owner)))
     (put-menuitem it)
-    (item-append parent it)
-    (insert-separator (gfis:handle parent))))
+    (insert-separator hmenu)
+    (setf (slot-value it 'gfis:handle) hmenu)
+    (vector-push-extend it (items owner))))
 
 (defmethod define-menu ((gen menu-generator) label dispatcher)
   (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher))
          (parent (first (menu-stack gen)))
-         (it (make-instance 'menu-item :handle (gfis:handle m) :dispatcher dispatcher))
+         (it (make-instance 'menu-item :handle (gfis:handle parent) :dispatcher dispatcher))
          (id *next-menuitem-id*))
     (setf *next-menuitem-id* (1+ id))
-    (setf (item-id it) id)
-    (item-append parent it)
     (insert-submenu (gfis:handle parent) id label (cffi:null-pointer) (gfis:handle m))
+    (setf (item-id it) id)
+    (vector-push-extend it (items parent))
     (push m (menu-stack gen))
     (put-widget m)
     m))
@@ -414,11 +489,10 @@
   (setf (menu-stack gen) (cdr (menu-stack gen))))
 
 (defmacro defmenusystem (sexp)
-  `(let ((gen (gensym))
-         (var (gensym)))
-     (setf gen (make-instance 'menu-generator))
-     (mapcar #'(lambda (var) (process-menu gen var)) ,sexp)
-     (first (menu-stack gen))))
+  (let ((gen (gensym)))
+    `(let ((,gen (make-instance 'menu-generator)))
+       (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp)
+       (first (menu-stack ,gen)))))
 
 ;;;
 ;;; menuitems table management
@@ -437,18 +511,3 @@
         (if (eql k (item-id it))
           (remhash k *menuitems-by-id*)))
     *menuitems-by-id*))
-
-(defun recursively-cleanup-menuitem (it)
-  (let ((hsubmenu (gfis:handle it)))
-    (unless (gfus:null-handle-p hsubmenu)
-      (let ((m (get-widget hsubmenu)))
-        (if (null m)
-          (error 'gfus:toolkit-error :detail "no object for hmenu"))
-        (cleanup-menu-tables m))))
-  (remove-menuitem it))
-
-(defun cleanup-menu-tables (m)
-  (let ((tmp (items m)))
-    (dotimes (i (length tmp))
-      (recursively-cleanup-menuitem (elt tmp i))))
-  (remove-widget (gfis:handle m)))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Fri Feb 10 01:37:07 2006
@@ -47,11 +47,7 @@
   ((item-id
     :accessor item-id
     :initarg :item-id
-    :initform 0)
-   (item-owner
-    :accessor item-owner
-    :initarg :item-owner
-    :initform nil))
+    :initform 0))
   (:documentation "The item class is the base class for all non-windowed user interface objects."))
 
 (defclass menu-item (item) ()
@@ -72,7 +68,8 @@
 (defclass widget-with-items (widget)
   ((items
     :accessor items
-    :initform (make-array 7 :fill-pointer 0 :adjustable t))) ; allow subclasses to set size?
+     ;; FIXME: allow subclasses to set initial size?
+    :initform (make-array 7 :fill-pointer 0 :adjustable t)))
   (:documentation "The widget-with-items class is the base class for objects composed of fine-grained items."))
 
 (defclass menu (widget-with-items) ()

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Fri Feb 10 01:37:07 2006
@@ -213,6 +213,9 @@
 (defgeneric item-index (object other)
   (:documentation "Return the zero-based index of the location of the other object in this object."))
 
+(defgeneric item-owner (object)
+  (:documentation "Return the widget containing this item."))
+
 (defgeneric layout (object)
   (:documentation "Set the size and location of this object's children."))
 

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Fri Feb 10 01:37:07 2006
@@ -45,6 +45,11 @@
 (defun shutdown (exit-code)
   (gfus::post-quit-message exit-code))
 
+(defun clear-all (w)
+  (let ((count (gfuw:item-count w)))
+    (unless (zerop count)
+      (gfuw:clear-span w (gfid:make-span :start 0 :end (1- count))))))
+
 (defun create-window (class-name title parent-hwnd std-style ex-style)
   (cffi:with-foreign-string (cname-ptr class-name)
     (cffi:with-foreign-string (title-ptr title)

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Fri Feb 10 01:37:07 2006
@@ -33,9 +33,19 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
+(defmethod clear-item ((w widget-with-items) index)
+  (let ((it (item-at w index)))
+    (delete it (items w) :test #'items-equal-p)
+    (if (gfis:disposed-p it)
+      (error 'gfis:disposed-error))
+    (gfis:dispose it)))
+
+(defmethod clear-span ((w widget-with-items) (sp gfid:span))
+  (loop for index from (gfid:span-start sp) to (gfid:span-end sp)
+    collect (clear-item w index)))
+
 (defmethod item-append ((w widget-with-items) (i item))
-  (vector-push-extend i (items w))
-  (setf (item-owner i) w))
+  (vector-push-extend i (items w)))
 
 (defmethod item-at ((w widget-with-items) index)
   (elt (items w) index))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Fri Feb 10 01:37:07 2006
@@ -33,7 +33,7 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defconstant +workspace-window-classname+ "JCLUIT_WorkspaceWindow")
+(defconstant +workspace-window-classname+ "GraphicForms_WorkspaceWindow")
 
 (defconstant +default-window-title+ "New Window")
 
@@ -43,19 +43,22 @@
 ;;; helper functions
 ;;;
 
+;; FIXME: causes GPF
+;;
 (cffi:defcallback child_hwnd_collector
                   gfus::BOOL
                   ((hwnd gfus::HANDLE)
                    (lparam gfus::LPARAM))
   (let ((w (get-widget hwnd)))
     (unless (or (null w) (null *child-visiting-functions*))
-      (funcall (car *child-visiting-functions*) w lparam))))
+      (funcall (car *child-visiting-functions*) w lparam)))
+  1)
 
-(defun visit-child-windows (win func val)
+(defun visit-child-widgets (win func val)
   ;;
   ;; supplied closure should accept two parameters:
-  ;;  current child window
-  ;;  long value passed to map-child-windows
+  ;;  current child widget
+  ;;  long value passed to visit-child-windows
   ;;
   (push func *child-visiting-functions*)
   (unwind-protect
@@ -163,7 +166,8 @@
 (defmethod gfis:dispose ((win window))
   (let ((m (menu-bar win)))
     (unless (null m)
-      (cleanup-menu-tables m)))
+      (visit-menu-tree m #'menu-cleanup-callback)
+      (remove-widget (gfis:handle m))))
   (call-next-method))
 
 (defmethod hide ((win window))
@@ -175,7 +179,7 @@
       (return-from menu-bar nil))
     (let ((m (get-widget hmenu)))
       (if (null m)
-        (error 'gfus:toolkit-error :detail "no object for hmenu"))
+        (error 'gfus:toolkit-error :detail "no object for menu handle"))
       m)))
 
 (defmethod (setf menu-bar) ((m menu) (win window))


From junrue at common-lisp.net  Sat Feb 11 06:39:10 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sat, 11 Feb 2006 00:39:10 -0600 (CST)
Subject: [graphic-forms-cvs] r5 - in trunk: . src src/intrinsics/datastructs
	src/intrinsics/system src/tests/uitoolkit
	src/uitoolkit/graphics src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060211063910.B317CC016@common-lisp.net>

Author: junrue
Date: Sat Feb 11 00:39:07 2006
New Revision: 5

Modified:
   trunk/README.txt
   trunk/build.lisp
   trunk/src/intrinsics/datastructs/datastruct-classes.lisp
   trunk/src/intrinsics/system/native-classes.lisp
   trunk/src/intrinsics/system/native-conditions.lisp
   trunk/src/intrinsics/system/native-object-generics.lisp
   trunk/src/intrinsics/system/native-object.lisp
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/graphics/font.lisp
   trunk/src/uitoolkit/graphics/graphics-classes.lisp
   trunk/src/uitoolkit/graphics/graphics-context.lisp
   trunk/src/uitoolkit/graphics/image-data.lisp
   trunk/src/uitoolkit/graphics/image.lisp
   trunk/src/uitoolkit/system/system-utils.lisp
   trunk/src/uitoolkit/widgets/button.lisp
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-constants.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
package consolidation

Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt	(original)
+++ trunk/README.txt	Sat Feb 11 00:39:07 2006
@@ -23,7 +23,7 @@
 Execute the following forms from your REPL:
 
   (load "build.lisp")
-  (graphic-forms-system::build)
+  (gfsys::build)
 
 
 How To Run Tests And Samples

Modified: trunk/build.lisp
==============================================================================
--- trunk/build.lisp	(original)
+++ trunk/build.lisp	Sat Feb 11 00:39:07 2006
@@ -32,7 +32,7 @@
 ;;;;
 
 (defpackage #:graphic-forms-system
-  (:nicknames #:gfs)
+  (:nicknames #:gfsys)
   (:use :common-lisp :asdf))
 
 (in-package #:graphic-forms-system)

Modified: trunk/src/intrinsics/datastructs/datastruct-classes.lisp
==============================================================================
--- trunk/src/intrinsics/datastructs/datastruct-classes.lisp	(original)
+++ trunk/src/intrinsics/datastructs/datastruct-classes.lisp	Sat Feb 11 00:39:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; classes.lisp
+;;;; datastruct-classes.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.
@@ -31,7 +31,7 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.intrinsics.datastructs)
+(in-package :graphic-forms.intrinsics)
 
 (defstruct point (x 0) (y 0) (z 0))
 

Modified: trunk/src/intrinsics/system/native-classes.lisp
==============================================================================
--- trunk/src/intrinsics/system/native-classes.lisp	(original)
+++ trunk/src/intrinsics/system/native-classes.lisp	Sat Feb 11 00:39:07 2006
@@ -31,7 +31,7 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.intrinsics.system)
+(in-package :graphic-forms.intrinsics)
 
 (defclass native-object ()
   ((handle

Modified: trunk/src/intrinsics/system/native-conditions.lisp
==============================================================================
--- trunk/src/intrinsics/system/native-conditions.lisp	(original)
+++ trunk/src/intrinsics/system/native-conditions.lisp	Sat Feb 11 00:39:07 2006
@@ -31,6 +31,6 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.intrinsics.system)
+(in-package :graphic-forms.intrinsics)
 
 (define-condition disposed-error (error) ())

Modified: trunk/src/intrinsics/system/native-object-generics.lisp
==============================================================================
--- trunk/src/intrinsics/system/native-object-generics.lisp	(original)
+++ trunk/src/intrinsics/system/native-object-generics.lisp	Sat Feb 11 00:39:07 2006
@@ -31,7 +31,7 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.intrinsics.system)
+(in-package :graphic-forms.intrinsics)
 
 (defgeneric dispose (native-object)
   (:documentation "Discards native resources and executes other cleanup code."))

Modified: trunk/src/intrinsics/system/native-object.lisp
==============================================================================
--- trunk/src/intrinsics/system/native-object.lisp	(original)
+++ trunk/src/intrinsics/system/native-object.lisp	Sat Feb 11 00:39:07 2006
@@ -31,7 +31,10 @@
 ;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 ;;;;
 
-(in-package :graphic-forms.intrinsics.system)
+(in-package :graphic-forms.intrinsics)
 
 (defmethod disposed-p ((obj native-object))
   (null (handle obj)))
+
+(defmacro null-handle-p (handle)
+  `(cffi:null-pointer-p ,handle))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sat Feb 11 00:39:07 2006
@@ -33,12 +33,13 @@
 
 (in-package #:graphic-forms-system)
 
-(defpackage #:graphic-forms.intrinsics.datastructs
-  (:nicknames #:gfid)
+(defpackage #:graphic-forms.intrinsics
+  (:nicknames #:gfi)
   (:use #:common-lisp)
   (:export
 
 ;; classes and structs
+    #:native-object
     #:point
     #:rectangle
     #:size
@@ -47,10 +48,14 @@
 ;; constants
 
 ;; methods, functions, and macros
+    #:dispose
+    #:disposed-p
+    #:handle
     #:location
     #:make-point
     #:make-size
     #:make-span
+    #:null-handle-p
     #:point-x
     #:point-y
     #:point-z
@@ -64,26 +69,8 @@
 ;; conditions
     #:disposed-error))
 
-(defpackage #:graphic-forms.intrinsics.system
-  (:nicknames #:gfis)
-  (:use #:common-lisp)
-  (:export
-
-;; classes and structs
-    #:native-object
-
-;; constants
-
-;; methods, functions, and macros
-    #:dispose
-    #:disposed-p
-    #:handle
-
-;; conditions
-    #:disposed-error))
-
 (defpackage #:graphic-forms.uitoolkit.system
-  (:nicknames #:gfus)
+  (:nicknames #:gfs)
   (:shadow #:atom #:boolean)
   (:use #:common-lisp)
   (:export
@@ -99,7 +86,6 @@
     #:insert-menuitem
     #:insert-separator
     #:insert-submenu
-    #:null-handle-p
     #:process-message
     #:register-window-class
     #:with-retrieved-dc
@@ -111,7 +97,7 @@
     #:win32-warning))
 
 (defpackage #:graphic-forms.uitoolkit.graphics
-  (:nicknames #:gfug)
+  (:nicknames #:gfg)
   (:shadow #:load #:type)
   (:use #:common-lisp)
   (:export
@@ -215,7 +201,7 @@
     ))
 
 (defpackage #:graphic-forms.uitoolkit.widgets
-  (:nicknames #:gfuw)
+  (:nicknames #:gfw)
   (:use #:common-lisp)
   (:export
 

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sat Feb 11 00:39:07 2006
@@ -41,35 +41,35 @@
 (defun exit-event-tester ()
   (let ((w *event-tester-window*))
     (setf *event-tester-window* nil)
-    (gfis:dispose w))
-  (gfuw:shutdown 0))
+    (gfi:dispose w))
+  (gfw:shutdown 0))
 
-(defclass event-tester-window-events (gfuw:event-dispatcher) ())
+(defclass event-tester-window-events (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-paint ((d event-tester-window-events) time gc rect)
+(defmethod gfw:event-paint ((d event-tester-window-events) time gc rect)
   (declare (ignorable time rect))
-  (setf (gfug:background-color gc) gfug:+color-white+)
-  (setf (gfug:foreground-color gc) gfug:+color-blue+)
-  (let* ((sz (gfuw:client-size *event-tester-window*))
-         (pnt (gfid:make-point :x 0 :y (floor (/ (gfid:size-height sz) 2)))))
-    (gfug:draw-text gc *event-tester-text* pnt)))
+  (setf (gfg:background-color gc) gfg:+color-white+)
+  (setf (gfg:foreground-color gc) gfg:+color-blue+)
+  (let* ((sz (gfw:client-size *event-tester-window*))
+         (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2)))))
+    (gfg:draw-text gc *event-tester-text* pnt)))
 
-(defmethod gfuw:event-close ((d event-tester-window-events) time)
+(defmethod gfw:event-close ((d event-tester-window-events) time)
   (declare (ignore time))
   (exit-event-tester))
 
 (defun text-for-modifiers ()
   (format nil
           "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]"
-          (not (gfuw:key-down-p gfuw:+vk-shift+))
-          (not (gfuw:key-down-p gfuw:+vk-control+))
-          (not (gfuw:key-down-p gfuw:+vk-alt+))
-          (not (gfuw:key-down-p gfuw:+vk-left-win+))
-          (not (gfuw:key-down-p gfuw:+vk-right-win+))
-          (not (gfuw:key-toggled-p gfuw:+vk-escape+))
-          (not (gfuw:key-toggled-p gfuw:+vk-caps-lock+))
-          (not (gfuw:key-toggled-p gfuw:+vk-num-lock+))
-          (not (gfuw:key-toggled-p gfuw:+vk-scroll-lock+))))
+          (not (gfw:key-down-p gfw:+vk-shift+))
+          (not (gfw:key-down-p gfw:+vk-control+))
+          (not (gfw:key-down-p gfw:+vk-alt+))
+          (not (gfw:key-down-p gfw:+vk-left-win+))
+          (not (gfw:key-down-p gfw:+vk-right-win+))
+          (not (gfw:key-toggled-p gfw:+vk-escape+))
+          (not (gfw:key-toggled-p gfw:+vk-caps-lock+))
+          (not (gfw:key-toggled-p gfw:+vk-num-lock+))
+          (not (gfw:key-toggled-p gfw:+vk-scroll-lock+))))
 
 (defun text-for-mouse (action time button pnt)
   (format nil
@@ -77,8 +77,8 @@
           (incf *event-counter*)
           action
           button
-          (gfid:point-x pnt)
-          (gfid:point-y pnt)
+          (gfi:point-x pnt)
+          (gfi:point-y pnt)
           time
           (text-for-modifiers)))
 
@@ -106,8 +106,8 @@
           "~a resize action: ~s  size: (~d,~d)  time: 0x~x  ~s"
           (incf *event-counter*)
           (symbol-name type)
-          (gfid:size-width size)
-          (gfid:size-height size)
+          (gfi:size-width size)
+          (gfi:size-height size)
           time
           (text-for-modifiers)))
 
@@ -115,74 +115,74 @@
   (format nil
           "~a move  point: (~d,~d)  time: 0x~x  ~s"
           (incf *event-counter*)
-          (gfid:point-x pnt)
-          (gfid:point-y pnt)
+          (gfi:point-x pnt)
+          (gfi:point-y pnt)
           time
           (text-for-modifiers)))
           
-(defmethod gfuw:event-key-down ((d event-tester-window-events) time key-code char)
+(defmethod gfw:event-key-down ((d event-tester-window-events) time key-code char)
   (setf *event-tester-text* (text-for-key "down" time key-code char))
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-key-up ((d event-tester-window-events) time key-code char)
+(defmethod gfw:event-key-up ((d event-tester-window-events) time key-code char)
   (setf *event-tester-text* (text-for-key "up" time key-code char))
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-mouse-double ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-double ((d event-tester-window-events) time pnt button)
   (setf *event-tester-text* (text-for-mouse "double" time button pnt))
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-mouse-down ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-down ((d event-tester-window-events) time pnt button)
   (setf *event-tester-text* (text-for-mouse "down" time button pnt))
   (setf *mouse-down-flag* t)
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-mouse-move ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-move ((d event-tester-window-events) time pnt button)
   (when *mouse-down-flag*
     (setf *event-tester-text* (text-for-mouse "move" time button pnt))
-    (gfuw:redraw *event-tester-window*)))
+    (gfw:redraw *event-tester-window*)))
 
-(defmethod gfuw:event-mouse-up ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-up ((d event-tester-window-events) time pnt button)
   (setf *event-tester-text* (text-for-mouse "up" time button pnt))
   (setf *mouse-down-flag* nil)
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-move ((d event-tester-window-events) time pnt)
+(defmethod gfw:event-move ((d event-tester-window-events) time pnt)
   (setf *event-tester-text* (text-for-move time pnt))
-  (gfuw:redraw *event-tester-window*)
+  (gfw:redraw *event-tester-window*)
   0)
 
-(defmethod gfuw:event-resize ((d event-tester-window-events) time size type)
+(defmethod gfw:event-resize ((d event-tester-window-events) time size type)
   (setf *event-tester-text* (text-for-size type time size))
-  (gfuw:redraw *event-tester-window*)
+  (gfw:redraw *event-tester-window*)
   0)
 
-(defclass event-tester-exit-dispatcher (gfuw:event-dispatcher) ())
+(defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-select ((d event-tester-exit-dispatcher) time item rect)
+(defmethod gfw:event-select ((d event-tester-exit-dispatcher) time item rect)
   (declare (ignorable time item rect))
   (exit-event-tester))
 
-(defmethod gfuw:event-arm ((d event-tester-exit-dispatcher) time item)
+(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) time item)
   (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed"))
-  (gfuw:redraw *event-tester-window*))
+  (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+  (gfw:redraw *event-tester-window*))
 
-(defclass event-tester-echo-dispatcher (gfuw:event-dispatcher) ())
+(defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-select ((d event-tester-echo-dispatcher) time item rect)
+(defmethod gfw:event-select ((d event-tester-echo-dispatcher) time item rect)
   (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item selected"))
-  (gfuw:redraw *event-tester-window*))
+  (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected"))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-arm ((d event-tester-echo-dispatcher) time item)
+(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) time item)
   (declare (ignore rect))
-  (setf *event-tester-text* (text-for-item (gfuw:text item) time "item armed"))
-  (gfuw:redraw *event-tester-window*))
+  (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
+  (gfw:redraw *event-tester-window*))
 
-(defmethod gfuw:event-activate ((d event-tester-echo-dispatcher) time)
+(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) time)
   (setf *event-tester-text* (text-for-item "" time "menu activated"))
-  (gfuw:redraw *event-tester-window*))
+  (gfw:redraw *event-tester-window*))
 
 (defun run-event-tester-internal ()
   (setf *event-tester-text* "Hello!")
@@ -190,23 +190,23 @@
   (let ((echo-md (make-instance 'event-tester-echo-dispatcher))
         (exit-md (make-instance 'event-tester-exit-dispatcher))
         (menubar nil))
-    (setf *event-tester-window* (make-instance 'gfuw:window :dispatcher (make-instance 'event-tester-window-events)))
-    (gfuw:realize *event-tester-window* nil :style-workspace)
-    (setf menubar (gfuw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md)
-                                         (:menuitem "&Open..." :dispatcher ,echo-md)
-                                         (:menuitem "&Save..." :disabled :dispatcher ,echo-md)
-                                         (:menuitem :separator)
-                                         (:menuitem "E&xit" :dispatcher ,exit-md))
-                                        ((:menu "&Options" :dispatcher ,echo-md)
-                                         (:menuitem "&Enabled" :checked :dispatcher ,echo-md)
-                                         (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md)
-                                                              (:menuitem "&Fonts" :dispatcher ,echo-md :disabled)
-                                                              (:menuitem "&Colors" :dispatcher ,echo-md))))
-                                        ((:menu "&Help" :dispatcher ,echo-md)
-                                         (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
-    (setf (gfuw:menu-bar *event-tester-window*) menubar)
-    (gfuw:show *event-tester-window*)
-    (gfuw:run-default-message-loop)))
+    (setf *event-tester-window* (make-instance 'gfw:window :dispatcher (make-instance 'event-tester-window-events)))
+    (gfw:realize *event-tester-window* nil :style-workspace)
+    (setf menubar (gfw:defmenusystem `(((:menu "&File" :dispatcher ,echo-md)
+                                        (:menuitem "&Open..." :dispatcher ,echo-md)
+                                        (:menuitem "&Save..." :disabled :dispatcher ,echo-md)
+                                        (:menuitem :separator)
+                                        (:menuitem "E&xit" :dispatcher ,exit-md))
+                                       ((:menu "&Options" :dispatcher ,echo-md)
+                                        (:menuitem "&Enabled" :checked :dispatcher ,echo-md)
+                                        (:menuitem :submenu ((:menu "&Tools" :dispatcher ,echo-md)
+                                                             (:menuitem "&Fonts" :dispatcher ,echo-md :disabled)
+                                                             (:menuitem "&Colors" :dispatcher ,echo-md))))
+                                       ((:menu "&Help" :dispatcher ,echo-md)
+                                        (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
+    (setf (gfw:menu-bar *event-tester-window*) menubar)
+    (gfw:show *event-tester-window*)
+    (gfw:run-default-message-loop)))
 
 (defun run-event-tester ()
-  (gfuw:startup "Event Tester" #'run-event-tester-internal))
+  (gfw:startup "Event Tester" #'run-event-tester-internal))

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Sat Feb 11 00:39:07 2006
@@ -38,38 +38,38 @@
 (defun exit-hello-world ()
   (let ((w *hellowin*))
     (setf *hellowin* nil)
-    (gfis:dispose w))
-  (gfuw:shutdown 0))
+    (gfi:dispose w))
+  (gfw:shutdown 0))
 
-(defclass hellowin-events (gfuw:event-dispatcher) ())
+(defclass hellowin-events (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-close ((d hellowin-events) time)
+(defmethod gfw:event-close ((d hellowin-events) time)
   (declare (ignore time))
   (format t "hellowin-events event-close~%")
   (exit-hello-world))
 
-(defmethod gfuw:event-paint ((d hellowin-events) time (gc gfug:graphics-context) rect)
+(defmethod gfw:event-paint ((d hellowin-events) time (gc gfg:graphics-context) rect)
   (declare (ignore time) (ignore rect))
-  (setf (gfug:background-color gc) gfug:+color-red+)
-  (setf (gfug:foreground-color gc) gfug:+color-green+)
-  (gfug:draw-text gc "Hello World!" (gfid:make-point)))
+  (setf (gfg:background-color gc) gfg:+color-red+)
+  (setf (gfg:foreground-color gc) gfg:+color-green+)
+  (gfg:draw-text gc "Hello World!" (gfi:make-point)))
 
-(defclass hellowin-exit-dispatcher (gfuw:event-dispatcher) ())
+(defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-select ((d hellowin-exit-dispatcher) time item rect)
+(defmethod gfw:event-select ((d hellowin-exit-dispatcher) time item rect)
   (declare (ignorable time item rect))
   (exit-hello-world))
 
 (defun run-hello-world-internal ()
   (let ((menubar nil)
         (md (make-instance 'hellowin-exit-dispatcher)))
-    (setf *hellowin* (make-instance 'gfuw:window :dispatcher (make-instance 'hellowin-events)))
-    (gfuw:realize *hellowin* nil :style-workspace)
-    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
-                                         (:menuitem "E&xit" :dispatcher ,md)))))
-    (setf (gfuw:menu-bar *hellowin*) menubar)
-    (gfuw:show *hellowin*)
-    (gfuw:run-default-message-loop)))
+    (setf *hellowin* (make-instance 'gfw:window :dispatcher (make-instance 'hellowin-events)))
+    (gfw:realize *hellowin* nil :style-workspace)
+    (setf menubar (gfw:defmenusystem `(((:menu "&File")
+                                        (:menuitem "E&xit" :dispatcher ,md)))))
+    (setf (gfw:menu-bar *hellowin*) menubar)
+    (gfw:show *hellowin*)
+    (gfw:run-default-message-loop)))
 
 (defun run-hello-world ()
-  (gfuw:startup "Hello World" #'run-hello-world-internal))
+  (gfw:startup "Hello World" #'run-hello-world-internal))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sat Feb 11 00:39:07 2006
@@ -41,16 +41,16 @@
 (defun exit-layout-tester ()
   (let ((w *layout-tester-win*))
     (setf *layout-tester-win* nil)
-    (gfis:dispose w))
-  (gfuw:shutdown 0))
+    (gfi:dispose w))
+  (gfw:shutdown 0))
 
-(defclass layout-tester-events (gfuw:event-dispatcher) ())
+(defclass layout-tester-events (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-close ((d layout-tester-events) time)
+(defmethod gfw:event-close ((d layout-tester-events) time)
   (declare (ignore time))
   (exit-layout-tester))
 
-(defclass layout-tester-btn-events (gfuw:event-dispatcher)
+(defclass layout-tester-btn-events (gfw:event-dispatcher)
   ((button
     :accessor button
     :initarg :button
@@ -59,29 +59,29 @@
     :accessor toggle-fn
     :initform nil)))
 
-(defmethod gfuw:event-select ((d layout-tester-btn-events) time item rect)
+(defmethod gfw:event-select ((d layout-tester-btn-events) time item rect)
   (declare (ignorable time rect))
   (let ((btn (button d)))
-    (setf (gfuw:text btn) (funcall (toggle-fn d)))))
+    (setf (gfw:text btn) (funcall (toggle-fn d)))))
 
-(defclass layout-tester-child-menu-dispatcher (gfuw:event-dispatcher) ())
+(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-activate ((d layout-tester-child-menu-dispatcher) time)
+(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) time)
   (declare (ignore time))
-  (let* ((mb (gfuw:menu-bar *layout-tester-win*))
-         (menu (gfuw:sub-menu mb 1)))
-    (gfuw:clear-all menu)
-    (gfuw::visit-child-widgets *layout-tester-win*
+  (let* ((mb (gfw:menu-bar *layout-tester-win*))
+         (menu (gfw:sub-menu mb 1)))
+    (gfw:clear-all menu)
+    (gfw::visit-child-widgets *layout-tester-win*
                                #'(lambda (child val)
                                    (declare (ignore val))
-                                   (let ((it (make-instance 'gfuw:menu-item)))
-                                     (gfuw:item-append menu it)
-                                     (setf (gfuw:text it) (gfuw:text child))))
+                                   (let ((it (make-instance 'gfw:menu-item)))
+                                     (gfw:item-append menu it)
+                                     (setf (gfw:text it) (gfw:text child))))
                                0)))
 
-(defclass layout-tester-exit-dispatcher (gfuw:event-dispatcher) ())
+(defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfuw:event-select ((d layout-tester-exit-dispatcher) time item rect)
+(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) time item rect)
   (declare (ignorable time item rect))
   (exit-layout-tester))
 
@@ -90,7 +90,7 @@
          (fed (make-instance 'layout-tester-exit-dispatcher))
          (be (make-instance 'layout-tester-btn-events))
          (cmd (make-instance 'layout-tester-child-menu-dispatcher))
-         (btn (make-instance 'gfuw:button :dispatcher be)))
+         (btn (make-instance 'gfw:button :dispatcher be)))
     (setf (button be) btn)
     (setf (toggle-fn be) (let ((flag nil))
                            #'(lambda ()
@@ -101,20 +101,20 @@
                                  (progn
                                    (setf flag nil)
                                    +btn-text-2+)))))
-    (setf *layout-tester-win* (make-instance 'gfuw:window :dispatcher (make-instance 'layout-tester-events)))
-    (gfuw:realize *layout-tester-win* nil :style-workspace)
-    (setf (gfuw:size *layout-tester-win*) (gfid:make-size :width 200 :height 150))
-    (setf menubar (gfuw:defmenusystem `(((:menu "&File")
-                                           (:menuitem "E&xit" :dispatcher ,fed))
-                                        ((:menu "&Children" :dispatcher ,cmd)
-                                           (:menuitem :separator)))))
-    (setf (gfuw:menu-bar *layout-tester-win*) menubar)
-    (gfuw:realize btn *layout-tester-win* :push-button)
-    (setf (gfuw:text btn) (funcall (toggle-fn be)))
-    (setf (gfuw:location btn) (gfid:make-point))
-    (setf (gfuw:size btn) (gfuw:preferred-size btn -1 -1))
-    (gfuw:show *layout-tester-win*)
-    (gfuw:run-default-message-loop)))
+    (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)))
+    (gfw:realize *layout-tester-win* nil :style-workspace)
+    (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 200 :height 150))
+    (setf menubar (gfw:defmenusystem `(((:menu "&File")
+                                        (:menuitem "E&xit" :dispatcher ,fed))
+                                       ((:menu "&Children" :dispatcher ,cmd)
+                                        (:menuitem :separator)))))
+    (setf (gfw:menu-bar *layout-tester-win*) menubar)
+    (gfw:realize btn *layout-tester-win* :push-button)
+    (setf (gfw:text btn) (funcall (toggle-fn be)))
+    (setf (gfw:location btn) (gfi:make-point))
+    (setf (gfw:size btn) (gfw:preferred-size btn -1 -1))
+    (gfw:show *layout-tester-win*)
+    (gfw:run-default-message-loop)))
 
 (defun run-layout-tester ()
-  (gfuw:startup "Layout Tester" #'run-layout-tester-internal))
+  (gfw:startup "Layout Tester" #'run-layout-tester-internal))

Modified: trunk/src/uitoolkit/graphics/font.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/font.lisp	(original)
+++ trunk/src/uitoolkit/graphics/font.lisp	Sat Feb 11 00:39:07 2006
@@ -37,8 +37,8 @@
 ;;; methods
 ;;;
 
-(defmethod gfis:dispose ((fn font))
-  (let ((hgdi (gfis:handle fn)))
-    (unless (gfus:null-handle-p hgdi)
-      (gfus::delete-object hgdi)))
-  (setf (slot-value fn 'gfis:handle) nil))
+(defmethod gfi:dispose ((fn font))
+  (let ((hgdi (gfi:handle fn)))
+    (unless (gfi:null-handle-p hgdi)
+      (gfs::delete-object hgdi)))
+  (setf (slot-value fn 'gfi:handle) nil))

Modified: trunk/src/uitoolkit/graphics/graphics-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-classes.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-classes.lisp	Sat Feb 11 00:39:07 2006
@@ -49,57 +49,57 @@
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro ascent (metrics)
-    `(gfug::font-metrics-ascent ,metrics)))
+    `(gfg::font-metrics-ascent ,metrics)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro descent (metrics)
-    `(gfug::font-metrics-descent ,metrics)))
+    `(gfg::font-metrics-descent ,metrics)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro leading (metrics)
-    `(gfug::font-metrics-leading ,metrics)))
+    `(gfg::font-metrics-leading ,metrics)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro height (metrics)
-    `(+ (gfug::font-metrics-ascent ,metrics)
-        (gfug::font-metrics-descent ,metrics)
-        (gfug::font-metrics-leading ,metrics))))
+    `(+ (gfg::font-metrics-ascent ,metrics)
+        (gfg::font-metrics-descent ,metrics)
+        (gfg::font-metrics-leading ,metrics))))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro average-char-width (metrics)
-    `(gfug::font-metrics-avg-char-width ,metrics)))
+    `(gfg::font-metrics-avg-char-width ,metrics)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro maximum-char-width (metrics)
-    `(gfug::font-metrics-max-char-width ,metrics)))
+    `(gfg::font-metrics-max-char-width ,metrics)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defstruct image-data
     (pixels nil)            ; vector of bytes
     (bits-per-pixel 0)      ; number of bits per pixel
     (palette nil)           ; palette
-    (size (gfid:make-size)) ; width and height of image in pixels
+    (size (gfi:make-size))  ; width and height of image in pixels
     (type 'bmp)))           ; symbol corresponding to file extension (e.g., 'bmp)
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro bits-per-pixel (data)
-    `(gfug::image-data-bits-per-pixel ,data)))
+    `(gfg::image-data-bits-per-pixel ,data)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro image-palette (data)
-    `(gfug::image-data-palette ,data)))
+    `(gfg::image-data-palette ,data)))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro pixels (data)
-    `(gfug::image-data-pixels ,data)))
+    `(gfg::image-data-pixels ,data)))
 
-(defclass font (gfis:native-object) ()
+(defclass font (gfi:native-object) ()
   (:documentation "This class encapsulates a realized native font."))
 
-(defclass graphics-context (gfis:native-object) ()
+(defclass graphics-context (gfi:native-object) ()
   (:documentation "This class represents the context associated with drawing primitives."))
 
-(defclass image (gfis:native-object)
+(defclass image (gfi:native-object)
   ((transparency
     :accessor transparency-color
     :initarg :transparency-color
@@ -118,35 +118,35 @@
     (table nil)))  ; vector of COLOR structs
 
 (defmacro blue-mask (data)
-  `(gfug::palette-blue-mask ,data))
+  `(gfg::palette-blue-mask ,data))
 
 (defmacro blue-shift (data)
-  `(gfug::palette-blue-shift ,data))
+  `(gfg::palette-blue-shift ,data))
 
 (defmacro direct (data flag)
-  `(setf (gfug::palette-direct ,data) ,flag))
+  `(setf (gfg::palette-direct ,data) ,flag))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (defmacro direct-p (data)
-    `(null (gfug::palette-direct ,data))))
+    `(null (gfg::palette-direct ,data))))
 
 (defmacro green-mask (data)
-  `(gfug::palette-green-mask ,data))
+  `(gfg::palette-green-mask ,data))
 
 (defmacro green-shift (data)
-  `(gfug::palette-green-shift ,data))
+  `(gfg::palette-green-shift ,data))
 
 (defmacro red-mask (data)
-  `(gfug::palette-red-mask ,data))
+  `(gfg::palette-red-mask ,data))
 
 (defmacro red-shift (data)
-  `(gfug::palette-red-shift ,data))
+  `(gfg::palette-red-shift ,data))
 
 (defmacro color-table (data)
-  `(gfug::palette-table ,data))
+  `(gfg::palette-table ,data))
 
-(defclass pattern (gfis:native-object) ()
+(defclass pattern (gfi:native-object) ()
   (:documentation "This class represents a pattern to be used with a brush."))
 
-(defclass transform (gfis:native-object) ()
+(defclass transform (gfi:native-object) ()
   (:documentation "This class specifies how coordinates are transformed."))

Modified: trunk/src/uitoolkit/graphics/graphics-context.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/graphics-context.lisp	(original)
+++ trunk/src/uitoolkit/graphics/graphics-context.lisp	Sat Feb 11 00:39:07 2006
@@ -41,88 +41,88 @@
 ;;; methods
 ;;;
 
-(defmethod gfis:dispose ((gc graphics-context))
-  (gfus::delete-dc (gfis:handle gc))
-  (setf (slot-value gc 'gfis:handle) nil))
+(defmethod gfi:dispose ((gc graphics-context))
+  (gfs::delete-dc (gfi:handle gc))
+  (setf (slot-value gc 'gfi:handle) nil))
 
 (defmethod background-color ((gc graphics-context))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
-  (gfus::get-bk-color (gfis:handle gc)))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
+  (gfs::get-bk-color (gfi:handle gc)))
 
 (defmethod (setf background-color) ((clr color) (gc graphics-context))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
-  (let ((hdc (gfis:handle gc))
-        (hbrush (gfus::get-stock-object gfus::+dc-brush+))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
+  (let ((hdc (gfi:handle gc))
+        (hbrush (gfs::get-stock-object gfs::+dc-brush+))
         (rgb (color-as-rgb clr)))
-    (gfus::select-object hdc hbrush)
-    (gfus::set-dc-brush-color hdc rgb)
-    (gfus::set-bk-color hdc rgb)))
-
-(defmethod draw-image ((gc graphics-context) (im image) (pnt gfid:point))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
-  (if (gfis:disposed-p im)
-    (error 'gfis:disposed-error))
+    (gfs::select-object hdc hbrush)
+    (gfs::set-dc-brush-color hdc rgb)
+    (gfs::set-bk-color hdc rgb)))
+
+(defmethod draw-image ((gc graphics-context) (im image) (pnt gfi:point))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
+  (if (gfi:disposed-p im)
+    (error 'gfi:disposed-error))
   ;; TODO: support addressing elements within bitmap as if it were an array
   ;;
-  (let ((memdc (gfus::create-compatible-dc (gfis:handle gc)))
+  (let ((memdc (gfs::create-compatible-dc (gfi:handle gc)))
         oldhbm)
-    (if (gfus:null-handle-p memdc)
-    	(error 'gfus:win32-error :detail "create-compatible-dc failed"))
-    (setf oldhbm (gfus::select-object memdc (gfis:handle im)))
-    (cffi:with-foreign-object (bmp-ptr 'gfus::bitmap)
-      (gfus::get-object (gfis:handle im) (cffi:foreign-type-size 'gfus::bitmap) bmp-ptr)
-      (gfus::bit-blt (gfis:handle gc)
-                       (gfid:point-x pnt)
-                       (gfid:point-y pnt)
-                       (cffi:foreign-slot-value bmp-ptr 'gfus::bitmap 'gfus::width)
-                       (cffi:foreign-slot-value bmp-ptr 'gfus::bitmap 'gfus::height)
+    (if (gfi:null-handle-p memdc)
+    	(error 'gfs:win32-error :detail "create-compatible-dc failed"))
+    (setf oldhbm (gfs::select-object memdc (gfi:handle im)))
+    (cffi:with-foreign-object (bmp-ptr 'gfs::bitmap)
+      (gfs::get-object (gfi:handle im) (cffi:foreign-type-size 'gfs::bitmap) bmp-ptr)
+      (gfs::bit-blt (gfi:handle gc)
+                       (gfi:point-x pnt)
+                       (gfi:point-y pnt)
+                       (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::width)
+                       (cffi:foreign-slot-value bmp-ptr 'gfs::bitmap 'gfs::height)
                        memdc
                        0 0
-                       gfus::+blt-srccopy+))
-    (gfus::select-object memdc oldhbm)
-    (gfus::delete-dc memdc)))
-
-(defmethod draw-text ((gc graphics-context) text (pnt gfid:point))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
+                       gfs::+blt-srccopy+))
+    (gfs::select-object memdc oldhbm)
+    (gfs::delete-dc memdc)))
+
+(defmethod draw-text ((gc graphics-context) text (pnt gfi:point))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
   (cffi:with-foreign-string (text-ptr text)
-    (cffi:with-foreign-object (rect-ptr 'gfus::rect)
-      (cffi:with-foreign-slots ((gfus::left gfus::right gfus::top gfus::bottom)
-                                rect-ptr gfus::rect)
-        (setf gfus::left (gfid:point-x pnt))
-        (setf gfus::right (gfid:point-x pnt))
-        (setf gfus::top (gfid:point-y pnt))
-        (setf gfus::bottom (gfid:point-y pnt))
-        (gfus::draw-text (gfis:handle gc)
+    (cffi:with-foreign-object (rect-ptr 'gfs::rect)
+      (cffi:with-foreign-slots ((gfs::left gfs::right gfs::top gfs::bottom)
+                                rect-ptr gfs::rect)
+        (setf gfs::left (gfi:point-x pnt))
+        (setf gfs::right (gfi:point-x pnt))
+        (setf gfs::top (gfi:point-y pnt))
+        (setf gfs::bottom (gfi:point-y pnt))
+        (gfs::draw-text (gfi:handle gc)
                            text-ptr
                            (length text)
                            rect-ptr
-                           (logior gfus::+dt-calcrect+ gfus::+dt-singleline+)
+                           (logior gfs::+dt-calcrect+ gfs::+dt-singleline+)
                            (cffi:null-pointer))
-        (gfus::draw-text (gfis:handle gc)
+        (gfs::draw-text (gfi:handle gc)
                            text-ptr
                            (length text)
                            rect-ptr
-                           (logior gfus::+dt-noclip+
-                                   gfus::+dt-noprefix+
-                                   gfus::+dt-singleline+
-                                   gfus::+dt-vcenter+)
+                           (logior gfs::+dt-noclip+
+                                   gfs::+dt-noprefix+
+                                   gfs::+dt-singleline+
+                                   gfs::+dt-vcenter+)
                            (cffi:null-pointer))))))
 
 (defmethod foreground-color ((gc graphics-context))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
-  (gfus::get-text-color (gfis:handle gc)))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
+  (gfs::get-text-color (gfi:handle gc)))
 
 (defmethod (setf foreground-color) ((clr color) (gc graphics-context))
-  (if (gfis:disposed-p gc)
-    (error 'gfis:disposed-error))
-  (let ((hdc (gfis:handle gc))
-        (hpen (gfus::get-stock-object gfus::+dc-pen+))
+  (if (gfi:disposed-p gc)
+    (error 'gfi:disposed-error))
+  (let ((hdc (gfi:handle gc))
+        (hpen (gfs::get-stock-object gfs::+dc-pen+))
         (rgb (color-as-rgb clr)))
-    (gfus::select-object hdc hpen)
-    (gfus::set-dc-pen-color hdc rgb)
-    (gfus::set-text-color hdc rgb)))
+    (gfs::select-object hdc hpen)
+    (gfs::set-dc-pen-color hdc rgb)
+    (gfs::set-text-color hdc rgb)))

Modified: trunk/src/uitoolkit/graphics/image-data.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image-data.lisp	(original)
+++ trunk/src/uitoolkit/graphics/image-data.lisp	Sat Feb 11 00:39:07 2006
@@ -48,8 +48,8 @@
           (info (read-value 'BASE-BITMAPINFOHEADER in))
           (pix-bits nil))
       (declare (ignore header))
-      (unless (= (biCompression info) gfus::+bi-rgb+)
-        (error 'gfus:toolkit-error :detail "FIXME: not yet implemented"))
+      (unless (= (biCompression info) gfs::+bi-rgb+)
+        (error 'gfs:toolkit-error :detail "FIXME: not yet implemented"))
 
       ;; load color table
       ;;
@@ -92,7 +92,7 @@
       ;;
       (setf (image-data-pixels victim) pix-bits)
       (setf (image-data-bits-per-pixel victim) (biBitCount info))
-      (setf (size victim) (gfid:make-size :width (biWidth info) :height (biHeight info)))
+      (setf (size victim) (gfi:make-size :width (biWidth info) :height (biHeight info)))
       (setf (image-data-type victim) 'bmp)
       victim)))
 
@@ -110,13 +110,13 @@
 (defun bmp-loader (path)
   (let (hwnd)
     (cffi:with-foreign-string (ptr (namestring path))
-      (setf hwnd (gfus::load-image nil
+      (setf hwnd (gfs::load-image nil
                         ptr
-                        gfus::+image-bitmap+
+                        gfs::+image-bitmap+
                         0 0
-                        gfus::+lr-loadfromfile+)))
-    (if (gfus:null-handle-p hwnd)
-    	(error 'gfus:win32-error :detail "load-image failed"))
+                        gfs::+lr-loadfromfile+)))
+    (if (gfi:null-handle-p hwnd)
+    	(error 'gfs:win32-error :detail "load-image failed"))
     hwnd))
 |#
 
@@ -130,86 +130,86 @@
   "Associate a new (or replacement) loader function with the specified file type. \
 Returns the previous loader function, if any."
   (unless (typep file-type 'string)
-    (error 'gfus:toolkit-error :detail "file-type must be a string"))
+    (error 'gfs:toolkit-error :detail "file-type must be a string"))
   (unless (typep loader-fn 'function)
-    (error 'gfus:toolkit-error :detail "loader-fn must be a function"))
+    (error 'gfs:toolkit-error :detail "loader-fn must be a function"))
   (let ((old-fn (gethash file-type *loaders-by-type*)))
     (setf (gethash file-type *loaders-by-type*) loader-fn)
     old-fn))
 
 (defun image->data (hbmp)
   "Convert the native bitmap handle to an image-data."
-  (let ((mem-dc (gfus::create-compatible-dc (cffi:null-pointer)))
+  (let ((mem-dc (gfs::create-compatible-dc (cffi:null-pointer)))
         (raw-bits nil)
         (data nil)
         (sz nil)
         (byte-count 0))
-    (when (gfus:null-handle-p mem-dc)
-      (error 'gfus:win32-error :detail "create-compatible-dc failed"))
+    (when (gfi:null-handle-p mem-dc)
+      (error 'gfs:win32-error :detail "create-compatible-dc failed"))
     (unwind-protect
         (progn
-          (cffi:with-foreign-object (bc-ptr 'gfus::bitmapcoreheader)
-            (cffi:with-foreign-slots ((gfus::bcsize
-                                       gfus::bcwidth
-                                       gfus::bcheight
-                                       gfus::bcbitcount)
-                                      bc-ptr gfus::bitmapcoreheader)
-              (setf gfus::bcsize (cffi:foreign-type-size 'gfus::bitmapcoreheader))
-              (setf gfus::bcbitcount 0)
-              (when (zerop (gfus::get-di-bits mem-dc
+          (cffi:with-foreign-object (bc-ptr 'gfs::bitmapcoreheader)
+            (cffi:with-foreign-slots ((gfs::bcsize
+                                       gfs::bcwidth
+                                       gfs::bcheight
+                                       gfs::bcbitcount)
+                                      bc-ptr gfs::bitmapcoreheader)
+              (setf gfs::bcsize (cffi:foreign-type-size 'gfs::bitmapcoreheader))
+              (setf gfs::bcbitcount 0)
+              (when (zerop (gfs::get-di-bits mem-dc
                                                 hbmp
                                                 0 0
                                                 (cffi:null-pointer)
                                                 bc-ptr
-                                                gfus::+dib-rgb-colors+))
-                (error 'gfus:win32-error :detail "get-di-bits failed <1>"))
-              (setf sz (gfid:make-size :width gfus::bcwidth :height gfus::bcheight))
-              (setf data (make-image-data :bits-per-pixel gfus::bcbitcount :size sz))))
-          (setf byte-count (* (bmp-pixel-row-length (gfid:size-width sz) (bits-per-pixel data))
-                              (gfid:size-height sz)))
+                                                gfs::+dib-rgb-colors+))
+                (error 'gfs:win32-error :detail "get-di-bits failed <1>"))
+              (setf sz (gfi:make-size :width gfs::bcwidth :height gfs::bcheight))
+              (setf data (make-image-data :bits-per-pixel gfs::bcbitcount :size sz))))
+          (setf byte-count (* (bmp-pixel-row-length (gfi:size-width sz) (bits-per-pixel data))
+                              (gfi:size-height sz)))
           (setf raw-bits (cffi:foreign-alloc :unsigned-char :count byte-count))
-          (cffi:with-foreign-object (bi-ptr 'gfus::bitmapinfo)
-            (cffi:with-foreign-slots ((gfus::bisize
-                                       gfus::biwidth
-                                       gfus::biheight
-                                       gfus::biplanes
-                                       gfus::bibitcount
-                                       gfus::bicompression
-                                       gfus::biclrused
-                                       gfus::bmicolors)
-                                      bi-ptr gfus::bitmapinfo)
-              (setf gfus::bisize (cffi:foreign-type-size 'gfus::bitmapinfoheader))
-              (setf gfus::biwidth (gfid:size-width sz))
-              (setf gfus::biheight (gfid:size-height sz))
-              (setf gfus::biplanes 1)
-              (setf gfus::bibitcount (bits-per-pixel data))
-              (setf gfus::bicompression gfus::+bi-rgb+)
-              (when (zerop (gfus::get-di-bits mem-dc
+          (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
+            (cffi:with-foreign-slots ((gfs::bisize
+                                       gfs::biwidth
+                                       gfs::biheight
+                                       gfs::biplanes
+                                       gfs::bibitcount
+                                       gfs::bicompression
+                                       gfs::biclrused
+                                       gfs::bmicolors)
+                                      bi-ptr gfs::bitmapinfo)
+              (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader))
+              (setf gfs::biwidth (gfi:size-width sz))
+              (setf gfs::biheight (gfi:size-height sz))
+              (setf gfs::biplanes 1)
+              (setf gfs::bibitcount (bits-per-pixel data))
+              (setf gfs::bicompression gfs::+bi-rgb+)
+              (when (zerop (gfs::get-di-bits mem-dc
                                                 hbmp
-                                                0 (gfid:size-height sz)
+                                                0 (gfi:size-height sz)
                                                 raw-bits
                                                 bi-ptr
-                                                gfus::+dib-rgb-colors+))
-                (error 'gfus:win32-error :detail "get-di-bits failed <2>"))
+                                                gfs::+dib-rgb-colors+))
+                (error 'gfs:win32-error :detail "get-di-bits failed <2>"))
 
               ;; process the RGBQUADs
               ;;
               (let ((color-count 0))
-                (if (= gfus::biclrused 0)
+                (if (= gfs::biclrused 0)
                   (progn
                     (case (bits-per-pixel data)
                       (1 (setf color-count 2))
                       (4 (setf color-count 16))
                       (8 (setf color-count 256))))
-                  (setf color-count gfus::biclrused))
+                  (setf color-count gfs::biclrused))
                 (let ((colors (make-array color-count)))
                   (dotimes (i color-count)
-                    (cffi:with-foreign-slots ((gfus::rgbblue gfus::rgbgreen gfus::rgbred)
-                                              (cffi:mem-aref gfus::bmicolors 'gfus::rgbquad i)
-                                              gfus::rgbquad)
-                      (setf (aref colors i) (make-color :red gfus::rgbred
-                                                        :green gfus::rgbgreen
-                                                        :blue gfus::rgbblue))))
+                    (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen gfs::rgbred)
+                                              (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i)
+                                              gfs::rgbquad)
+                      (setf (aref colors i) (make-color :red gfs::rgbred
+                                                        :green gfs::rgbgreen
+                                                        :blue gfs::rgbblue))))
                   (setf (image-data-palette data) (make-palette :direct nil :table colors))))))
 
           ;; process the pixel data
@@ -220,45 +220,45 @@
             (setf (image-data-pixels data) pix-bytes)))
       (unless (cffi:null-pointer-p raw-bits)
         (cffi:foreign-free raw-bits))
-      (gfus::delete-dc mem-dc))
+      (gfs::delete-dc mem-dc))
     data))
 
 (defun data->image (data)
   "Convert the image-data object to a bitmap and return the native handle."
-  (cffi:with-foreign-object (bi-ptr 'gfus::bitmapinfo)
-    (cffi:with-foreign-slots ((gfus::bisize
-                               gfus::biwidth
-                               gfus::biheight
-                               gfus::biplanes
-                               gfus::bibitcount
-                               gfus::bicompression
-                               gfus::bisizeimage
-                               gfus::bixpels
-                               gfus::biypels
-                               gfus::biclrused
-                               gfus::biclrimp
-                               gfus::bmicolors)
-                              bi-ptr gfus::bitmapinfo)
+  (cffi:with-foreign-object (bi-ptr 'gfs::bitmapinfo)
+    (cffi:with-foreign-slots ((gfs::bisize
+                               gfs::biwidth
+                               gfs::biheight
+                               gfs::biplanes
+                               gfs::bibitcount
+                               gfs::bicompression
+                               gfs::bisizeimage
+                               gfs::bixpels
+                               gfs::biypels
+                               gfs::biclrused
+                               gfs::biclrimp
+                               gfs::bmicolors)
+                              bi-ptr gfs::bitmapinfo)
       (let* ((sz (size data))
              (colors (palette-table (image-palette data)))
              (bit-count (bits-per-pixel data))
-             (row-len (bmp-pixel-row-length (gfid:size-width sz) bit-count))
-             (byte-count (* row-len (gfid:size-height sz)))
+             (row-len (bmp-pixel-row-length (gfi:size-width sz) bit-count))
+             (byte-count (* row-len (gfi:size-height sz)))
              (data-bits (pixels data))
              (pix-bits (cffi:null-pointer))
              (hbmp (cffi:null-pointer))
-             (mem-dc (gfus::create-compatible-dc (cffi:null-pointer))))
-        (setf gfus::bisize (cffi:foreign-type-size 'gfus::bitmapinfoheader))
-        (setf gfus::biwidth (gfid:size-width sz))
-        (setf gfus::biheight (gfid:size-height sz))
-        (setf gfus::biplanes 1)
-        (setf gfus::bibitcount bit-count)
-        (setf gfus::bicompression gfus::+bi-rgb+)
-        (setf gfus::bisizeimage 0)
-        (setf gfus::bixpels 0)
-        (setf gfus::biypels 0)
-        (setf gfus::biclrused 0)
-        (setf gfus::biclrimp 0)
+             (mem-dc (gfs::create-compatible-dc (cffi:null-pointer))))
+        (setf gfs::bisize (cffi:foreign-type-size 'gfs::bitmapinfoheader))
+        (setf gfs::biwidth (gfi:size-width sz))
+        (setf gfs::biheight (gfi:size-height sz))
+        (setf gfs::biplanes 1)
+        (setf gfs::bibitcount bit-count)
+        (setf gfs::bicompression gfs::+bi-rgb+)
+        (setf gfs::bisizeimage 0)
+        (setf gfs::bixpels 0)
+        (setf gfs::biypels 0)
+        (setf gfs::biclrused 0)
+        (setf gfs::biclrimp 0)
 
         (unwind-protect
             (progn
@@ -267,14 +267,14 @@
               ;;
               (dotimes (i (length colors))
                 (let ((clr (aref colors i)))
-                  (cffi:with-foreign-slots ((gfus::rgbblue gfus::rgbgreen
-                                             gfus::rgbred gfus::rgbreserved)
-                                            (cffi:mem-aref gfus::bmicolors 'gfus::rgbquad i)
-                                            gfus::rgbquad)
-                    (setf gfus::rgbblue (color-blue clr))
-                    (setf gfus::rgbgreen (color-green clr))
-                    (setf gfus::rgbred (color-red clr))
-                    (setf gfus::rgbreserved 0))))
+                  (cffi:with-foreign-slots ((gfs::rgbblue gfs::rgbgreen
+                                             gfs::rgbred gfs::rgbreserved)
+                                            (cffi:mem-aref gfs::bmicolors 'gfs::rgbquad i)
+                                            gfs::rgbquad)
+                    (setf gfs::rgbblue (color-blue clr))
+                    (setf gfs::rgbgreen (color-green clr))
+                    (setf gfs::rgbred (color-red clr))
+                    (setf gfs::rgbreserved 0))))
 
               ;; populate the pixel data
               ;;
@@ -284,17 +284,17 @@
 
               ;; create the bitmap
               ;;
-              (setf hbmp (gfus::create-di-bitmap mem-dc
+              (setf hbmp (gfs::create-di-bitmap mem-dc
                                                    bi-ptr
-                                                   0 ; gfus::+cbm-init+
+                                                   0 ; gfs::+cbm-init+
                                                    pix-bits
                                                    bi-ptr
-                                                   gfus::+dib-rgb-colors+))
-              (if (gfus:null-handle-p hbmp)
-                (error 'gfus:win32-error :detail "create-di-bitmap failed")))
+                                                   gfs::+dib-rgb-colors+))
+              (if (gfi:null-handle-p hbmp)
+                (error 'gfs:win32-error :detail "create-di-bitmap failed")))
           (unless (cffi:null-pointer-p pix-bits)
             (cffi:foreign-free pix-bits))
-          (gfus::delete-dc mem-dc))
+          (gfs::delete-dc mem-dc))
         hbmp))))
 
 ;;;
@@ -307,11 +307,11 @@
                ((typep path 'string)
                  (parse-namestring path))
                (t
-                 (error 'gfus:toolkit-error :detail "pathname or string required"))))
+                 (error 'gfs:toolkit-error :detail "pathname or string required"))))
   (let* ((ptype (pathname-type path))
          (fn (gethash ptype *loaders-by-type*)))
     (if (null fn)
-      (error 'gfus:toolkit-error
+      (error 'gfs:toolkit-error
              :detail (format nil "no loader registered for type: ~a" ptype)))
     (funcall fn path d)
     d))
@@ -325,8 +325,8 @@
 (defmethod print-object ((obj image-data) stream)
   (print-unreadable-object (obj stream :type t)
     (format stream "type: ~a " (image-data-type obj))
-    (format stream "width: ~a " (gfid:size-width (image-data-size obj)))
-    (format stream "height: ~a " (gfid:size-height (image-data-size obj)))
+    (format stream "width: ~a " (gfi:size-width (image-data-size obj)))
+    (format stream "height: ~a " (gfi:size-height (image-data-size obj)))
     (format stream "bits per pixel: ~a " (bits-per-pixel obj))
     (format stream "pixel count: ~a " (length (pixels obj)))
     (format stream "palette: ~a" (image-palette obj))))

Modified: trunk/src/uitoolkit/graphics/image.lisp
==============================================================================
--- trunk/src/uitoolkit/graphics/image.lisp	(original)
+++ trunk/src/uitoolkit/graphics/image.lisp	Sat Feb 11 00:39:07 2006
@@ -41,22 +41,22 @@
 ;;; methods
 ;;;
 
-(defmethod gfis:dispose ((im image))
-  (let ((hgdi (gfis:handle im)))
-    (unless (gfus:null-handle-p hgdi)
-      (gfus::delete-object hgdi)))
+(defmethod gfi:dispose ((im image))
+  (let ((hgdi (gfi:handle im)))
+    (unless (gfi:null-handle-p hgdi)
+      (gfs::delete-object hgdi)))
   (setf (transparency-color im) nil)
-  (setf (slot-value im 'gfis:handle) nil))
+  (setf (slot-value im 'gfi:handle) nil))
 
 (defmethod data-obj ((im image))
-  (when (gfis:disposed-p im)
-    (error 'gfis:disposed-error))
-  (image->data (gfis:handle im)))
+  (when (gfi:disposed-p im)
+    (error 'gfi:disposed-error))
+  (image->data (gfi:handle im)))
 
 (defmethod (setf data-obj) ((id image-data) (im image))
-  (unless (gfis:disposed-p im)
-    (gfis:dispose im))
-  (setf (slot-value im 'gfis:handle) (data->image id)))
+  (unless (gfi:disposed-p im)
+    (gfi:dispose im))
+  (setf (slot-value im 'gfi:handle) (data->image id)))
 
 (defmethod load ((im image) path)
   (let ((data (make-image-data)))
@@ -65,7 +65,7 @@
     data))
 
 (defmethod size ((im image))
-  (error 'gfus:toolkit-error :detail "FIXME: not yet implemented"))
+  (error 'gfs:toolkit-error :detail "FIXME: not yet implemented"))
 
 (defmethod transparency-mask ((im image))
-  (error 'gfus:toolkit-error :detail "FIXME: not yet implemented"))
+  (error 'gfs:toolkit-error :detail "FIXME: not yet implemented"))

Modified: trunk/src/uitoolkit/system/system-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-utils.lisp	(original)
+++ trunk/src/uitoolkit/system/system-utils.lisp	Sat Feb 11 00:39:07 2006
@@ -37,15 +37,12 @@
 ;;; convenience macros
 ;;;
 
-(defmacro null-handle-p (handle)
-  `(cffi:null-pointer-p ,handle))
-
 (defmacro with-retrieved-dc ((hwnd dc-var) &body body)
    `(let ((,dc-var nil))
       (unwind-protect
           (progn
-            (setf ,dc-var (gfus::get-dc ,hwnd))
-            (if (gfus:null-handle-p ,dc-var)
-               (error 'gfus:win32-error :detail "get-dc failed"))
+            (setf ,dc-var (gfs::get-dc ,hwnd))
+            (if (gfi:null-handle-p ,dc-var)
+               (error 'gfs:win32-error :detail "get-dc failed"))
             , at body)
-        (gfus::release-dc ,hwnd ,dc-var))))
+        (gfs::release-dc ,hwnd ,dc-var))))

Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp	(original)
+++ trunk/src/uitoolkit/widgets/button.lisp	Sat Feb 11 00:39:07 2006
@@ -46,47 +46,47 @@
                   ;; primary button styles
                   ;;
                   ((eq sym :check-box)
-                    (setf std-flags gfus::+bs-checkbox+))
+                    (setf std-flags gfs::+bs-checkbox+))
                   ((eq sym :default-button)
-                    (setf std-flags gfus::+bs-defpushbutton+))
+                    (setf std-flags gfs::+bs-defpushbutton+))
                   ((eq sym :push-button)
-                    (setf std-flags gfus::+bs-pushbutton+))
+                    (setf std-flags gfs::+bs-pushbutton+))
                   ((eq sym :radio-button)
-                    (setf std-flags gfus::+bs-radiobutton+))
+                    (setf std-flags gfs::+bs-radiobutton+))
                   ((eq sym :toggle-button)
-                    (setf std-flags gfus::+bs-pushbox+))))
+                    (setf std-flags gfs::+bs-pushbox+))))
             (flatten style))
     (values std-flags ex-flags)))
 
 (defmethod preferred-size ((btn button) width-hint height-hint)
   (declare (ignorable width-hint height-hint))
-  (let ((hwnd (gfis:handle btn))
-        (sz (gfid:make-size))
+  (let ((hwnd (gfi:handle btn))
+        (sz (gfi:make-size))
         (count (length (text btn))))
-    (cffi:with-foreign-object (tm-ptr 'gfus::textmetrics)
-      (cffi:with-foreign-slots ((gfus::tmheight
-                                 gfus::tmexternalleading
-                                 gfus::tmavgcharwidth)
-                                tm-ptr gfus::textmetrics)
-        (gfus:with-retrieved-dc (hwnd dc)
-          (if (zerop (gfus::get-text-metrics dc tm-ptr))
-            (error 'gfus:win32-error :detail "get-text-metrics failed"))
-          (setf (gfid:size-width sz) (* gfus::tmavgcharwidth (+ count 2)))
-          (let ((tmp (+ gfus::tmexternalleading gfus::tmheight) ))
-            (setf (gfid:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1))))))
+    (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics)
+      (cffi:with-foreign-slots ((gfs::tmheight
+                                 gfs::tmexternalleading
+                                 gfs::tmavgcharwidth)
+                                tm-ptr gfs::textmetrics)
+        (gfs:with-retrieved-dc (hwnd dc)
+          (if (zerop (gfs::get-text-metrics dc tm-ptr))
+            (error 'gfs:win32-error :detail "get-text-metrics failed"))
+          (setf (gfi:size-width sz) (* gfs::tmavgcharwidth (+ count 2)))
+          (let ((tmp (+ gfs::tmexternalleading gfs::tmheight) ))
+            (setf (gfi:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1))))))
     sz))
 
 (defmethod realize ((btn button) parent &rest style)
   (multiple-value-bind (std-style ex-style)
       (compute-style-flags btn style)
-    (let ((hwnd (create-window gfus:+button-classname+
+    (let ((hwnd (create-window gfs:+button-classname+
                                " "
-                               (gfis:handle parent)
-                               (logior std-style gfus::+ws-child+ gfus::+ws-visible+)
+                               (gfi:handle parent)
+                               (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
                                ex-style)))
       (if (not hwnd)  
-        (error 'gfus:win32-error :detail "create-window failed"))
-      (setf (slot-value btn 'gfis:handle) hwnd))))
+        (error 'gfs:win32-error :detail "create-window failed"))
+      (setf (slot-value btn 'gfi:handle) hwnd))))
 
 (defmethod text ((btn button))
   (get-widget-text btn))

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Sat Feb 11 00:39:07 2006
@@ -39,23 +39,23 @@
 
 (defmethod preferred-size :before ((ctl control) width-hint height-hint)
   (declare (ignorable width-hint height-hint))
-  (if (gfis:disposed-p ctl)
-    (error 'gfis:disposed-error)))
+  (if (gfi:disposed-p ctl)
+    (error 'gfi:disposed-error)))
 
 (defmethod realize :before ((ctl control) parent &rest style)
-  (if (gfis:disposed-p parent)
-    (error 'gfis:disposed-error))
-  (if (not (gfis:disposed-p ctl))
-    (error 'gfus:toolkit-error :detail "object already realized")))
+  (if (gfi:disposed-p parent)
+    (error 'gfi:disposed-error))
+  (if (not (gfi:disposed-p ctl))
+    (error 'gfs:toolkit-error :detail "object already realized")))
 
 (defmethod realize :after ((ctl control) parent &rest style)
-  (let ((hwnd (gfis:handle ctl)))
+  (let ((hwnd (gfi:handle ctl)))
     (subclass-wndproc hwnd)
     (put-widget ctl)
-    (let ((hfont (gfus::get-stock-object gfus::+default-gui-font+)))
-      (unless (gfus:null-handle-p hfont)
-        (unless (zerop (gfus::send-message hwnd
-                                           gfus::+wm-setfont+
+    (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
+      (unless (gfi:null-handle-p hfont)
+        (unless (zerop (gfs::send-message hwnd
+                                           gfs::+wm-setfont+
                                            (cffi:pointer-address hfont)
                                            0))
-          (error 'gfus:win32-error :detail "send-message failed"))))))
+          (error 'gfs:win32-error :detail "send-message failed"))))))

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sat Feb 11 00:39:07 2006
@@ -33,35 +33,35 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defconstant +key-event-peek-flags+ (logior gfus::+pm-noremove+
-                                            gfus::+pm-noyield+
-                                            gfus::+pm-qs-input+
-                                            gfus::+pm-qs-postmessage+))
+(defconstant +key-event-peek-flags+ (logior gfs::+pm-noremove+
+                                            gfs::+pm-noyield+
+                                            gfs::+pm-qs-input+
+                                            gfs::+pm-qs-postmessage+))
 
 (defvar *last-event-time* 0)
 (defvar *last-virtual-key* 0)
-(defvar *mouse-event-pnt* (gfid:make-point))
-(defvar *move-event-pnt* (gfid:make-point))
-(defvar *size-event-size* (gfid:make-size))
+(defvar *mouse-event-pnt* (gfi:make-point))
+(defvar *move-event-pnt* (gfi:make-point))
+(defvar *size-event-size* (gfi:make-size))
 
 ;;;
 ;;; window procedures
 ;;;
 
 (cffi:defcallback uit_widgets_wndproc
-                  gfus::LONG
-                  ((hwnd gfus::HANDLE)
-                   (msg gfus::UINT)
-                   (wparam gfus::WPARAM)
-                   (lparam gfus::LPARAM))
+                  gfs::LONG
+                  ((hwnd gfs::HANDLE)
+                   (msg gfs::UINT)
+                   (wparam gfs::WPARAM)
+                   (lparam gfs::LPARAM))
   (process-message hwnd msg wparam lparam))
 
 (cffi:defcallback subclassing_wndproc
-                  gfus::LONG
-                  ((hwnd gfus::HANDLE)
-                   (msg gfus::UINT)
-                   (wparam gfus::WPARAM)
-                   (lparam gfus::LPARAM))
+                  gfs::LONG
+                  ((hwnd gfs::HANDLE)
+                   (msg gfs::UINT)
+                   (wparam gfs::WPARAM)
+                   (lparam gfs::LPARAM))
   (process-subclass-message hwnd msg wparam lparam))
 
 ;;;
@@ -69,24 +69,24 @@
 ;;;
 
 (defun run-default-message-loop ()
-  (cffi:with-foreign-object (msg-ptr 'gfus::msg)
+  (cffi:with-foreign-object (msg-ptr 'gfs::msg)
     (loop
-      (let ((gm (gfus::get-message msg-ptr (cffi:null-pointer) 0 0)))
-        (cffi:with-foreign-slots ((gfus::hwnd
-                                   gfus::message
-                                   gfus::wparam
-                                   gfus::lparam
-                                   gfus::time
-                                   gfus::pnt)
-                                  msg-ptr gfus::msg)
-          (setf *last-event-time* gfus::time)
+      (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)))
+        (cffi:with-foreign-slots ((gfs::hwnd
+                                   gfs::message
+                                   gfs::wparam
+                                   gfs::lparam
+                                   gfs::time
+                                   gfs::pnt)
+                                  msg-ptr gfs::msg)
+          (setf *last-event-time* gfs::time)
           (when (zerop gm)
-            (return-from run-default-message-loop gfus::wparam))
+            (return-from run-default-message-loop gfs::wparam))
           (when (= gm -1)
-            (warn 'gfus:win32-warning :detail "get-message failed")
-            (return-from run-default-message-loop gfus::wparam)))
-        (gfus::translate-message msg-ptr)
-        (gfus::dispatch-message msg-ptr)))))
+            (warn 'gfs:win32-warning :detail "get-message failed")
+            (return-from run-default-message-loop gfs::wparam)))
+        (gfs::translate-message msg-ptr)
+        (gfs::dispatch-message msg-ptr)))))
 
 (defmacro hi-word (lparam)
   `(ash (logand #xFFFF0000 ,lparam) -16))
@@ -96,49 +96,49 @@
 
 (defun key-down-p (key-code)
   "Return T if the key corresponding to key-code is currently down."
-  (= (logand (gfus::get-async-key-state key-code) #x8000) #x8000))
+  (= (logand (gfs::get-async-key-state key-code) #x8000) #x8000))
 
 (defun key-toggled-p (key-code)
   "Return T if the key corresponding to key-code is toggled on; nil otherwise."
-  (= (gfus::get-key-state key-code) 1))
+  (= (gfs::get-key-state key-code) 1))
 
 (defun process-mouse-message (fn hwnd lparam btn-symbol)
   (let ((w (get-widget hwnd)))
     (when w
-      (setf (gfid:point-x *mouse-event-pnt*) (lo-word lparam))
-      (setf (gfid:point-y *mouse-event-pnt*) (hi-word lparam))
+      (setf (gfi:point-x *mouse-event-pnt*) (lo-word lparam))
+      (setf (gfi:point-y *mouse-event-pnt*) (hi-word lparam))
       (funcall fn (dispatcher w) *last-event-time* *mouse-event-pnt* btn-symbol)))
   0)
 
 (defun get-class-wndproc (hwnd)
-  (let ((wndproc-val (gfus::get-class-long hwnd gfus::+gclp-wndproc+)))
+  (let ((wndproc-val (gfs::get-class-long hwnd gfs::+gclp-wndproc+)))
     (if (zerop wndproc-val)
-      (error 'gfus:win32-error :detail "get-class-long failed"))
+      (error 'gfs:win32-error :detail "get-class-long failed"))
     wndproc-val))
 
 (defun subclass-wndproc (hwnd)
-  (if (zerop (gfus::set-window-long hwnd
-                                    gfus::+gwlp-wndproc+
+  (if (zerop (gfs::set-window-long hwnd
+                                    gfs::+gwlp-wndproc+
                                     (cffi:pointer-address
                                       (cffi:get-callback 'subclassing_wndproc))))
-    (error 'gfus:win32-error :detail "set-window-long failed")))
+    (error 'gfs:win32-error :detail "set-window-long failed")))
 
 ;;;
 ;;; process-message methods
 ;;;
 
 (defmethod process-message (hwnd msg wparam lparam)
-  (gfus::def-window-proc hwnd msg wparam lparam))
+  (gfs::def-window-proc hwnd msg wparam lparam))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-close+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if w
       (event-close (dispatcher w) *last-event-time*)
-      (error 'gfus:toolkit-error :detail "no object for hwnd")))
+      (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-command+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam)
   (let ((wparam-hi (hi-word wparam))
         (owner (get-widget hwnd)))
     (if owner
@@ -146,27 +146,27 @@
         ((zerop lparam)
           (let ((item (get-menuitem (lo-word wparam))))
             (if (null item)
-              (error 'gfus:toolkit-error :detail "no menu item for id"))
+              (error 'gfs:toolkit-error :detail "no menu item for id"))
             (unless (null (dispatcher item))
               (event-select (dispatcher item)
                             *last-event-time*
                             item
-                            (make-instance 'gfid:rectangle))))) ; FIXME
+                            (make-instance 'gfi:rectangle))))) ; FIXME
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam))
         (t
           (let ((w (get-widget (cffi:make-pointer lparam))))
             (if (null w)
-              (error 'gfus:toolkit-error :detail "no object for hwnd"))
+              (error 'gfs:toolkit-error :detail "no object for hwnd"))
             (unless (null (dispatcher w))
               (event-select (dispatcher w)
                             *last-event-time*
                             w
-                            (make-instance 'gfid:rectangle)))))) ; FIXME
-      (error 'gfus:toolkit-error :detail "no object for hwnd")))
+                            (make-instance 'gfi:rectangle)))))) ; FIXME
+      (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-initmenupopup+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam)
   (declare (ignorable hwnd lparam))
   (let ((menu (get-widget (cffi:make-pointer wparam))))
     (unless (null menu)
@@ -175,7 +175,7 @@
           (event-activate d *last-event-time*)))))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-menuselect+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
   (declare (ignorable hwnd lparam)) ; FIXME: handle system menus
   (let ((item (get-menuitem (lo-word wparam))))
     (unless (null item)
@@ -184,17 +184,17 @@
           (event-arm d *last-event-time* item)))))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-create+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (get-widget hwnd) ; has side-effect of setting handle slot
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-destroy+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (remove-widget hwnd)
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-char+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
   (declare (ignore lparam))
   (let ((w (get-widget hwnd))
         (ch (code-char (lo-word wparam))))
@@ -202,62 +202,62 @@
       (event-key-down (dispatcher w) *last-event-time* *last-virtual-key* ch)))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-keydown+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
   (let* ((wparam-lo (lo-word wparam))
-         (ch (gfus::map-virtual-key wparam-lo 2))
+         (ch (gfs::map-virtual-key wparam-lo 2))
          (w (get-widget hwnd)))
     (setf *last-virtual-key* wparam-lo)
     (when (and w (= ch 0) (= (logand lparam #x40000000) 0))
       (event-key-down (dispatcher w) *last-event-time* wparam-lo (code-char ch))))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-keyup+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
   (declare (ignore lparam))
   (unless (zerop *last-virtual-key*)
     (let* ((wparam-lo (lo-word wparam))
-           (ch (gfus::map-virtual-key wparam-lo 2))
+           (ch (gfs::map-virtual-key wparam-lo 2))
            (w (get-widget hwnd)))
       (when w
         (event-key-up (dispatcher w) *last-event-time* wparam-lo (code-char ch)))))
   (setf *last-virtual-key* 0)
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttondblclk+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-double hwnd lparam 'left-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttondown+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondown+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-down hwnd lparam 'left-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-lbuttonup+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttonup+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-up hwnd lparam 'left-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttondblclk+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondblclk+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-double hwnd lparam 'middle-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttondown+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttondown+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-down hwnd lparam 'middle-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-mbuttonup+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-mbuttonup+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-up hwnd lparam 'middle-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-mousemove+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-mousemove+)) wparam lparam)
   (let ((btn-sym 'left-button))
     (cond
-      ((= (logand wparam gfus::+mk-mbutton+) gfus::+mk-mbutton+)
+      ((= (logand wparam gfs::+mk-mbutton+) gfs::+mk-mbutton+)
         (setf btn-sym 'middle-button))
-      ((= (logand wparam gfus::+mk-rbutton+) gfus::+mk-rbutton+)
+      ((= (logand wparam gfs::+mk-rbutton+) gfs::+mk-rbutton+)
         (setf btn-sym 'right-button))
       (t
         (setf btn-sym 'left-button)))
     (process-mouse-message #'event-mouse-move hwnd lparam btn-sym)))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-move+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (when w
@@ -265,62 +265,62 @@
       (event-move (dispatcher w) *last-event-time* *move-event-pnt*)))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-moving+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if (and w (event-pre-move (dispatcher w) *last-event-time*))
       1
       0)))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-paint+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd))
-        (gc (make-instance 'gfug:graphics-context)))
+        (gc (make-instance 'gfg:graphics-context)))
     (if w
-      (let ((rct (make-instance 'gfid:rectangle)))
-        (cffi:with-foreign-object (ps-ptr 'gfus::paintstruct)
-          (cffi:with-foreign-slots ((gfus::rcpaint-x
-                                     gfus::rcpaint-y
-                                     gfus::rcpaint-width
-                                     gfus::rcpaint-height)
-                                    ps-ptr gfus::paintstruct)
-          (setf (slot-value gc 'gfis:handle) (gfus::begin-paint hwnd ps-ptr))
-          (setf (gfid:location rct) (gfid:make-point :x gfus::rcpaint-x
-                                                     :y gfus::rcpaint-y))
-          (setf (gfid:size rct) (gfid:make-size :width  gfus::rcpaint-width
-                                                :height gfus::rcpaint-height))
+      (let ((rct (make-instance 'gfi:rectangle)))
+        (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct)
+          (cffi:with-foreign-slots ((gfs::rcpaint-x
+                                     gfs::rcpaint-y
+                                     gfs::rcpaint-width
+                                     gfs::rcpaint-height)
+                                    ps-ptr gfs::paintstruct)
+          (setf (slot-value gc 'gfi:handle) (gfs::begin-paint hwnd ps-ptr))
+          (setf (gfi:location rct) (gfi:make-point :x gfs::rcpaint-x
+                                                     :y gfs::rcpaint-y))
+          (setf (gfi:size rct) (gfi:make-size :width  gfs::rcpaint-width
+                                                :height gfs::rcpaint-height))
           (unwind-protect
               (event-paint (dispatcher w) *last-event-time* gc rct)
-            (gfus::end-paint hwnd ps-ptr)))))
-      (error 'gfus:toolkit-error :detail "no object for hwnd")))
+            (gfs::end-paint hwnd ps-ptr)))))
+      (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttondblclk+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondblclk+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-double hwnd lparam 'right-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttondown+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttondown+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-down hwnd lparam 'right-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-rbuttonup+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-rbuttonup+)) wparam lparam)
   (declare (ignore wparam))
   (process-mouse-message #'event-mouse-up hwnd lparam 'right-button))
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-size+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam)
   (declare (ignore lparam))
   (let ((w (get-widget hwnd))
         (type (cond
-                ((= wparam gfus::+size-maximized+) 'maximized)
-                ((= wparam gfus::+size-minimized+) 'minimized)
-                ((= wparam gfus::+size-restored+) 'restored)
+                ((= wparam gfs::+size-maximized+) 'maximized)
+                ((= wparam gfs::+size-minimized+) 'minimized)
+                ((= wparam gfs::+size-restored+) 'restored)
                 (t nil))))
     (when w
       (outer-size w *size-event-size*)
       (event-resize (dispatcher w) *last-event-time* *size-event-size* type)))
   0)
 
-(defmethod process-message (hwnd (msg (eql gfus::+wm-sizing+)) wparam lparam)
+(defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let ((w (get-widget hwnd)))
     (if (and w (event-pre-resize (dispatcher w) *last-event-time*))
@@ -334,10 +334,10 @@
 (defmethod process-subclass-message (hwnd msg wparam lparam)
   (let ((wndproc (get-class-wndproc hwnd)))
     (if wndproc
-      (gfus::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam)
-      (gfus::def-window-proc hwnd msg wparam lparam))))
+      (gfs::call-window-proc (cffi:make-pointer wndproc) hwnd msg wparam lparam)
+      (gfs::def-window-proc hwnd msg wparam lparam))))
 
-(defmethod process-subclass-message (hwnd (msg (eql gfus::+wm-destroy+)) wparam lparam)
+(defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (remove-widget hwnd)
   (call-next-method))
@@ -346,6 +346,6 @@
 ;;; event-dispatcher methods
 ;;;
 
-(defmethod gfis:dispose ((d event-dispatcher))
+(defmethod gfi:dispose ((d event-dispatcher))
   (setf (dispatcher d) nil)
   (call-next-method))

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Sat Feb 11 00:39:07 2006
@@ -42,141 +42,141 @@
 ;;;
 
 (defun get-menuitem-text (hmenu mid)
-  (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
-    (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
-                               gfus::state gfus::id gfus::hsubmenu
-                               gfus::hbmpchecked gfus::hbmpunchecked
-                               gfus::idata gfus::tdata gfus::cch
-                               gfus::hbmpitem)
-                              mii-ptr gfus::menuiteminfo)
-      (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
-      (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+))
-      (setf gfus::type 0)
-      (setf gfus::state 0)
-      (setf gfus::id mid)
-      (setf gfus::hsubmenu (cffi:null-pointer))
-      (setf gfus::hbmpchecked (cffi:null-pointer))
-      (setf gfus::hbmpunchecked (cffi:null-pointer))
-      (setf gfus::idata 0)
-      (setf gfus::tdata (cffi:null-pointer))
-      (setf gfus::cch 0)
-      (setf gfus::hbmpitem (cffi:null-pointer))
-      (if (zerop (gfus::get-menu-item-info hmenu mid 0 mii-ptr))
-        (error 'gfus::win32-error :detail "get-menu-item-info failed"))
-      (incf gfus::cch)
-      (let ((str-ptr (cffi:foreign-alloc :char :count gfus::cch))
+  (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+    (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                               gfs::state gfs::id gfs::hsubmenu
+                               gfs::hbmpchecked gfs::hbmpunchecked
+                               gfs::idata gfs::tdata gfs::cch
+                               gfs::hbmpitem)
+                              mii-ptr gfs::menuiteminfo)
+      (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+      (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+))
+      (setf gfs::type 0)
+      (setf gfs::state 0)
+      (setf gfs::id mid)
+      (setf gfs::hsubmenu (cffi:null-pointer))
+      (setf gfs::hbmpchecked (cffi:null-pointer))
+      (setf gfs::hbmpunchecked (cffi:null-pointer))
+      (setf gfs::idata 0)
+      (setf gfs::tdata (cffi:null-pointer))
+      (setf gfs::cch 0)
+      (setf gfs::hbmpitem (cffi:null-pointer))
+      (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
+        (error 'gfs::win32-error :detail "get-menu-item-info failed"))
+      (incf gfs::cch)
+      (let ((str-ptr (cffi:foreign-alloc :char :count gfs::cch))
             (result ""))
         (unwind-protect
             (progn
-              (setf gfus::tdata str-ptr)
-              (if (zerop (gfus::get-menu-item-info hmenu mid 0 mii-ptr))
-                (error 'gfus::win32-error :detail "get-menu-item-info failed"))
+              (setf gfs::tdata str-ptr)
+              (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
+                (error 'gfs::win32-error :detail "get-menu-item-info failed"))
               (setf result (cffi:foreign-string-to-lisp str-ptr))
           (cffi:foreign-free str-ptr)))
         result))))
 
 (defun set-menuitem-text (hmenu mid label)
   (cffi:with-foreign-string (str-ptr label)
-    (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
-      (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
-                                 gfus::state gfus::id gfus::hsubmenu
-                                 gfus::hbmpchecked gfus::hbmpunchecked
-                                 gfus::idata gfus::tdata gfus::cch
-                                 gfus::hbmpitem)
-                                mii-ptr gfus::menuiteminfo)
-        (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
-        (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+))
-        (setf gfus::type 0)
-        (setf gfus::state 0)
-        (setf gfus::id mid)
-        (setf gfus::hsubmenu (cffi:null-pointer))
-        (setf gfus::hbmpchecked (cffi:null-pointer))
-        (setf gfus::hbmpunchecked (cffi:null-pointer))
-        (setf gfus::idata 0)
-        (setf gfus::tdata str-ptr)
-        (setf gfus::cch (length label))
-        (setf gfus::hbmpitem (cffi:null-pointer)))
-      (if (zerop (gfus::set-menu-item-info hmenu mid 0 mii-ptr))
-        (error 'gfus:win32-error :detail "set-menu-item-info failed")))))
+    (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+      (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                                 gfs::state gfs::id gfs::hsubmenu
+                                 gfs::hbmpchecked gfs::hbmpunchecked
+                                 gfs::idata gfs::tdata gfs::cch
+                                 gfs::hbmpitem)
+                                mii-ptr gfs::menuiteminfo)
+        (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+        (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+))
+        (setf gfs::type 0)
+        (setf gfs::state 0)
+        (setf gfs::id mid)
+        (setf gfs::hsubmenu (cffi:null-pointer))
+        (setf gfs::hbmpchecked (cffi:null-pointer))
+        (setf gfs::hbmpunchecked (cffi:null-pointer))
+        (setf gfs::idata 0)
+        (setf gfs::tdata str-ptr)
+        (setf gfs::cch (length label))
+        (setf gfs::hbmpitem (cffi:null-pointer)))
+      (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr))
+        (error 'gfs:win32-error :detail "set-menu-item-info failed")))))
 
 (defun insert-menuitem (howner mid label hbmp)
   (cffi:with-foreign-string (str-ptr label)
-    (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
-      (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
-                                 gfus::state gfus::id gfus::hsubmenu
-                                 gfus::hbmpchecked gfus::hbmpunchecked
-                                 gfus::idata gfus::tdata gfus::cch
-                                 gfus::hbmpitem)
-                                mii-ptr gfus::menuiteminfo)
-        (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
-        (setf gfus::mask (logior gfus::+miim-id+ gfus::+miim-string+))
-        (setf gfus::type 0)
-        (setf gfus::state 0)
-        (setf gfus::id mid)
-        (setf gfus::hsubmenu (cffi:null-pointer))
-        (setf gfus::hbmpchecked (cffi:null-pointer))
-        (setf gfus::hbmpunchecked (cffi:null-pointer))
-        (setf gfus::idata 0)
-        (setf gfus::tdata str-ptr)
-        (setf gfus::cch (length label))
-        (setf gfus::hbmpitem hbmp))
-      (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
-        (error 'gfus::win32-error :detail "insert-menu-item failed")))))
+    (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+      (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                                 gfs::state gfs::id gfs::hsubmenu
+                                 gfs::hbmpchecked gfs::hbmpunchecked
+                                 gfs::idata gfs::tdata gfs::cch
+                                 gfs::hbmpitem)
+                                mii-ptr gfs::menuiteminfo)
+        (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+        (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-string+))
+        (setf gfs::type 0)
+        (setf gfs::state 0)
+        (setf gfs::id mid)
+        (setf gfs::hsubmenu (cffi:null-pointer))
+        (setf gfs::hbmpchecked (cffi:null-pointer))
+        (setf gfs::hbmpunchecked (cffi:null-pointer))
+        (setf gfs::idata 0)
+        (setf gfs::tdata str-ptr)
+        (setf gfs::cch (length label))
+        (setf gfs::hbmpitem hbmp))
+      (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+        (error 'gfs::win32-error :detail "insert-menu-item failed")))))
 
 (defun insert-submenu (hparent mid label hbmp hchildmenu)
   (cffi:with-foreign-string (str-ptr label)
-    (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
-      (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
-                                 gfus::state gfus::id gfus::hsubmenu
-                                 gfus::hbmpchecked gfus::hbmpunchecked
-                                 gfus::idata gfus::tdata gfus::cch
-                                 gfus::hbmpitem)
-                                mii-ptr gfus::menuiteminfo)
-        (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
-        (setf gfus::mask (logior gfus::+miim-id+
-                                   gfus::+miim-string+
-                                   gfus::+miim-submenu+))
-        (setf gfus::type 0)
-        (setf gfus::state 0)
-        (setf gfus::id mid)
-        (setf gfus::hsubmenu hchildmenu)
-        (setf gfus::hbmpchecked (cffi:null-pointer))
-        (setf gfus::hbmpunchecked (cffi:null-pointer))
-        (setf gfus::idata 0)
-        (setf gfus::tdata str-ptr)
-        (setf gfus::cch (length label))
-        (setf gfus::hbmpitem hbmp))
-      (if (zerop (gfus::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
-        (error 'gfus::win32-error :detail "insert-menu-item failed")))))
+    (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+      (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                                 gfs::state gfs::id gfs::hsubmenu
+                                 gfs::hbmpchecked gfs::hbmpunchecked
+                                 gfs::idata gfs::tdata gfs::cch
+                                 gfs::hbmpitem)
+                                mii-ptr gfs::menuiteminfo)
+        (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+        (setf gfs::mask (logior gfs::+miim-id+
+                                   gfs::+miim-string+
+                                   gfs::+miim-submenu+))
+        (setf gfs::type 0)
+        (setf gfs::state 0)
+        (setf gfs::id mid)
+        (setf gfs::hsubmenu hchildmenu)
+        (setf gfs::hbmpchecked (cffi:null-pointer))
+        (setf gfs::hbmpunchecked (cffi:null-pointer))
+        (setf gfs::idata 0)
+        (setf gfs::tdata str-ptr)
+        (setf gfs::cch (length label))
+        (setf gfs::hbmpitem hbmp))
+      (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
+        (error 'gfs::win32-error :detail "insert-menu-item failed")))))
 
 (defun insert-separator (howner)
-  (cffi:with-foreign-object (mii-ptr 'gfus::menuiteminfo)
-    (cffi:with-foreign-slots ((gfus::cbsize gfus::mask gfus::type
-                               gfus::state gfus::id gfus::hsubmenu
-                               gfus::hbmpchecked gfus::hbmpunchecked
-                               gfus::idata gfus::tdata gfus::cch
-                               gfus::hbmpitem)
-                              mii-ptr gfus::menuiteminfo)
-      (setf gfus::cbsize (cffi:foreign-type-size 'gfus::menuiteminfo))
-      (setf gfus::mask gfus::+miim-ftype+)
-      (setf gfus::type gfus::+mft-separator+)
-      (setf gfus::state 0)
-      (setf gfus::id 0)
-      (setf gfus::hsubmenu (cffi:null-pointer))
-      (setf gfus::hbmpchecked (cffi:null-pointer))
-      (setf gfus::hbmpunchecked (cffi:null-pointer))
-      (setf gfus::idata 0)
-      (setf gfus::tdata (cffi:null-pointer))
-      (setf gfus::cch 0)
-      (setf gfus::hbmpitem (cffi:null-pointer)))
-    (if (zerop (gfus::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
-      (error 'gfus::win32-error :detail "insert-menu-item failed"))))
+  (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+    (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                               gfs::state gfs::id gfs::hsubmenu
+                               gfs::hbmpchecked gfs::hbmpunchecked
+                               gfs::idata gfs::tdata gfs::cch
+                               gfs::hbmpitem)
+                              mii-ptr gfs::menuiteminfo)
+      (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+      (setf gfs::mask gfs::+miim-ftype+)
+      (setf gfs::type gfs::+mft-separator+)
+      (setf gfs::state 0)
+      (setf gfs::id 0)
+      (setf gfs::hsubmenu (cffi:null-pointer))
+      (setf gfs::hbmpchecked (cffi:null-pointer))
+      (setf gfs::hbmpunchecked (cffi:null-pointer))
+      (setf gfs::idata 0)
+      (setf gfs::tdata (cffi:null-pointer))
+      (setf gfs::cch 0)
+      (setf gfs::hbmpitem (cffi:null-pointer)))
+    (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+      (error 'gfs::win32-error :detail "insert-menu-item failed"))))
 
 (defun sub-menu (m index)
-  (if (gfis:disposed-p m)
-    (error 'gfis:disposed-error))
-  (let ((hwnd (gfus::get-submenu (gfis:handle m) index)))
-    (if (not (gfus:null-handle-p hwnd))
+  (if (gfi:disposed-p m)
+    (error 'gfi:disposed-error))
+  (let ((hwnd (gfs::get-submenu (gfi:handle m) index)))
+    (if (not (gfi:null-handle-p hwnd))
       (get-widget hwnd)
       nil)))
 
@@ -193,27 +193,27 @@
 ;;;
 
 (defun menu-cleanup-callback (menu item)
-  (remove-widget (gfis:handle menu))
+  (remove-widget (gfi:handle menu))
   (remove-menuitem item))
 
-(defmethod gfis:dispose ((m menu))
+(defmethod gfi:dispose ((m menu))
   (visit-menu-tree m #'menu-cleanup-callback)
-  (let ((hwnd (gfis:handle m)))
+  (let ((hwnd (gfi:handle m)))
     (remove-widget hwnd)
-    (if (not (gfus:null-handle-p hwnd))
-      (if (zerop (gfus::destroy-menu hwnd))
-        (error 'gfus:win32-error :detail "destroy-menu failed"))))
-  (setf (slot-value m 'gfis:handle) nil))
+    (if (not (gfi:null-handle-p hwnd))
+      (if (zerop (gfs::destroy-menu hwnd))
+        (error 'gfs:win32-error :detail "destroy-menu failed"))))
+  (setf (slot-value m 'gfi:handle) nil))
 
 (defmethod item-append ((m menu) (it menu-item))
   (let ((id *next-menuitem-id*)
-        (hmenu (gfis:handle m)))
-    (if (gfus:null-handle-p hmenu)
-      (error 'gfis:disposed-error))
+        (hmenu (gfi:handle m)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfi:disposed-error))
     (setf *next-menuitem-id* (1+ id))
-    (insert-menuitem (gfis:handle m) id " " (cffi:null-pointer))
+    (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer))
     (setf (item-id it) id)
-    (setf (slot-value it 'gfis:handle) hmenu)
+    (setf (slot-value it 'gfi:handle) hmenu)
     (put-menuitem it)
     (call-next-method)))
 
@@ -221,39 +221,39 @@
 ;;; item methods
 ;;;
 
-(defmethod gfis:dispose ((it menu-item))
+(defmethod gfi:dispose ((it menu-item))
   (setf (dispatcher it) nil)
   (remove-menuitem it)
   (let ((id (item-id it))
         (owner (item-owner it)))
     (unless (null owner)
-      (gfus::remove-menu (gfis:handle owner) id gfus::+mf-bycommand+)
+      (gfs::remove-menu (gfi:handle owner) id gfs::+mf-bycommand+)
       (let* ((index (item-index owner it))
              (child-menu (sub-menu owner index)))
         (unless (null child-menu)
-          (gfis:dispose child-menu))))
+          (gfi:dispose child-menu))))
     (setf (item-id it) 0)
-    (setf (slot-value it 'gfis:handle) nil)))
+    (setf (slot-value it 'gfi:handle) nil)))
 
 (defmethod item-owner ((it menu-item))
-  (let ((hmenu (gfis:handle it)))
-    (if (gfus:null-handle-p hmenu)
-      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
     (let ((m (get-widget hmenu)))
       (if (null m)
-        (error 'gfus:toolkit-error :detail "no owner menu"))
+        (error 'gfs:toolkit-error :detail "no owner menu"))
       m)))
 
 (defmethod text ((it menu-item))
-  (let ((hmenu (gfis:handle it)))
-    (if (gfus:null-handle-p hmenu)
-      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
     (get-menuitem-text hmenu (item-id it))))
 
 (defmethod (setf text) (str (it menu-item))
-  (let ((hmenu (gfis:handle it)))
-    (if (gfus:null-handle-p hmenu)
-      (error 'gfus:toolkit-error :detail "null owner menu handle"))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
     (set-menuitem-text hmenu (item-id it) str)))
 
 ;;;
@@ -339,7 +339,7 @@
     (when dispatcher
       (setf dispatcher (nth (1+ dispatcher) options))
       (if (null dispatcher)
-        (error 'gfus:toolkit-error :detail "missing dispatcher function")))
+        (error 'gfs:toolkit-error :detail "missing dispatcher function")))
     (values dispatcher)))
 
 (defun parse-menuitem-options (options)
@@ -351,23 +351,23 @@
         (sub (position-if #'submenu-option-p options)))
     (when sep
       (if (or disabled checked image sub)
-        (error 'gfus:toolkit-error :detail "invalid menu item options"))
+        (error 'gfs:toolkit-error :detail "invalid menu item options"))
       (return-from parse-menuitem-options (values nil nil nil nil t nil)))
     (when image
       (if sep
-        (error 'gfus:toolkit-error :detail "invalid menu item options"))
+        (error 'gfs:toolkit-error :detail "invalid menu item options"))
       (setf image (nth (1+ image) options))
       (if (null image)
-        (error 'gfus:toolkit-error :detail "missing image filename")))
+        (error 'gfs:toolkit-error :detail "missing image filename")))
     (when dispatcher
       (if sep
-        (error 'gfus:toolkit-error :detail "invalid menu item options"))
+        (error 'gfs:toolkit-error :detail "invalid menu item options"))
       (setf dispatcher (nth (1+ dispatcher) options))
       (if (null dispatcher)
-        (error 'gfus:toolkit-error :detail "missing dispatcher function")))
+        (error 'gfs:toolkit-error :detail "missing dispatcher function")))
     (when sub
       (if (or checked sep)
-        (error 'gfus:toolkit-error :detail "invalid menu item options"))
+        (error 'gfs:toolkit-error :detail "invalid menu item options"))
       (return-from parse-menuitem-options (values dispatcher disabled nil image nil t)))
     (values dispatcher disabled checked image nil nil)))
 
@@ -381,7 +381,7 @@
 
 (defun process-menuitem (generator sexp)
   (if (not (menuitem-form-p sexp))
-    (error 'gfus:toolkit-error :detail (format nil "form ~a not a menu item definition" sexp)))
+    (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu item definition" sexp)))
   (multiple-value-bind (label options body)
       (parse-menuitem-form sexp)
     (multiple-value-bind (dispatcher disabled checked image sep sub)
@@ -393,7 +393,7 @@
 
 (defun process-menu (generator sexp)
   (if (not (menu-form-p (car sexp)))
-    (error 'gfus:toolkit-error :detail (format nil "form ~a not a menu definition" (car sexp))))
+    (error 'gfs:toolkit-error :detail (format nil "form ~a not a menu definition" (car sexp))))
   (multiple-value-bind (label options body)
       (parse-menu-form sexp)
     (multiple-value-bind (dispatcher)
@@ -443,7 +443,7 @@
                :initform nil)))
 
 (defmethod initialize-instance :after ((gen menu-generator) &key)
-  (let ((m (make-instance 'menu :handle (gfus::create-menu))))
+  (let ((m (make-instance 'menu :handle (gfs::create-menu))))
     (put-widget m)
     (setf (menu-stack gen) (list m))))
 
@@ -451,11 +451,11 @@
   (let* ((owner (first (menu-stack gen)))
          (it (make-instance 'menu-item :dispatcher dispatcher))
          (id *next-menuitem-id*)
-         (hmenu (gfis:handle owner)))
+         (hmenu (gfi:handle owner)))
     (setf *next-menuitem-id* (1+ id))
     (insert-menuitem hmenu id label (cffi:null-pointer))
     (setf (item-id it) id)
-    (setf (slot-value it 'gfis:handle) hmenu)
+    (setf (slot-value it 'gfi:handle) hmenu)
     (put-menuitem it)
     (vector-push-extend it (items owner))))
 
@@ -466,19 +466,19 @@
 (defmethod define-separator ((gen menu-generator))
   (let* ((owner (first (menu-stack gen)))
          (it (make-instance 'menu-item))
-         (hmenu (gfis:handle owner)))
+         (hmenu (gfi:handle owner)))
     (put-menuitem it)
     (insert-separator hmenu)
-    (setf (slot-value it 'gfis:handle) hmenu)
+    (setf (slot-value it 'gfi:handle) hmenu)
     (vector-push-extend it (items owner))))
 
 (defmethod define-menu ((gen menu-generator) label dispatcher)
-  (let* ((m (make-instance 'menu :handle (gfus::create-popup-menu) :dispatcher dispatcher))
+  (let* ((m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
          (parent (first (menu-stack gen)))
-         (it (make-instance 'menu-item :handle (gfis:handle parent) :dispatcher dispatcher))
+         (it (make-instance 'menu-item :handle (gfi:handle parent) :dispatcher dispatcher))
          (id *next-menuitem-id*))
     (setf *next-menuitem-id* (1+ id))
-    (insert-submenu (gfis:handle parent) id label (cffi:null-pointer) (gfis:handle m))
+    (insert-submenu (gfi:handle parent) id label (cffi:null-pointer) (gfi:handle m))
     (setf (item-id it) id)
     (vector-push-extend it (items parent))
     (push m (menu-stack gen))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Sat Feb 11 00:39:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; classes.lisp
+;;;; widget-classes.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.
@@ -36,7 +36,7 @@
 (defclass event-dispatcher () ()
   (:documentation "Instances of this class receive events on behalf of user interface objects."))
 
-(defclass event-source (gfis:native-object)
+(defclass event-source (gfi:native-object)
   ((dispatcher
     :accessor dispatcher
     :initarg :dispatcher

Modified: trunk/src/uitoolkit/widgets/widget-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-constants.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-constants.lisp	Sat Feb 11 00:39:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; constants.lisp
+;;;; widget-constants.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Sat Feb 11 00:39:07 2006
@@ -1,5 +1,5 @@
 ;;;;
-;;;; widgets-generics.lisp
+;;;; widget-generics.lisp
 ;;;;
 ;;;; Copyright (C) 2006, Jack D. Unrue
 ;;;; All rights reserved.

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Sat Feb 11 00:39:07 2006
@@ -43,25 +43,25 @@
               (mp:process-run-function thread-name nil start-fn))
 
 (defun shutdown (exit-code)
-  (gfus::post-quit-message exit-code))
+  (gfs::post-quit-message exit-code))
 
 (defun clear-all (w)
-  (let ((count (gfuw:item-count w)))
+  (let ((count (gfw:item-count w)))
     (unless (zerop count)
-      (gfuw:clear-span w (gfid:make-span :start 0 :end (1- count))))))
+      (gfw:clear-span w (gfi:make-span :start 0 :end (1- count))))))
 
 (defun create-window (class-name title parent-hwnd std-style ex-style)
   (cffi:with-foreign-string (cname-ptr class-name)
     (cffi:with-foreign-string (title-ptr title)
-      (gfus::create-window
+      (gfs::create-window
         ex-style
         cname-ptr
         title-ptr
         std-style
-        gfus::+cw-usedefault+
-        gfus::+cw-usedefault+
-        gfus::+cw-usedefault+
-        gfus::+cw-usedefault+
+        gfs::+cw-usedefault+
+        gfs::+cw-usedefault+
+        gfs::+cw-usedefault+
+        gfs::+cw-usedefault+
         parent-hwnd
         (cffi:null-pointer)
         (cffi:null-pointer)
@@ -73,46 +73,46 @@
     (mapcan (function flatten) tree)))
 
 (defun get-widget-text (w)
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
   (let* ((text "")
-         (hwnd (gfis:handle w))
-         (len (gfus::get-window-text-length hwnd)))
+         (hwnd (gfi:handle w))
+         (len (gfs::get-window-text-length hwnd)))
     (unless (zerop len)
       (let ((str-ptr (cffi:foreign-alloc :char :count len)))
         (unwind-protect
-            (unless (zerop (gfus::get-window-text hwnd str-ptr len))
+            (unless (zerop (gfs::get-window-text hwnd str-ptr len))
               (setf text (cffi:foreign-string-to-lisp str-ptr)))
           (cffi:foreign-free str-ptr))))
     text))
 
 (defun outer-location (w pnt)
-  (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo)
-    (cffi:with-foreign-slots ((gfus::cbsize
-                               gfus::windowleft
-                               gfus::windowtop)
-                              wi-ptr gfus::windowinfo)
-      (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo))
-      (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr))
-        (error 'gfus:win32-error :detail "get-window-info failed"))
-      (setf (gfid:point-x pnt) gfus::windowleft)
-      (setf (gfid:point-y pnt) gfus::windowtop))))
+  (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
+    (cffi:with-foreign-slots ((gfs::cbsize
+                               gfs::windowleft
+                               gfs::windowtop)
+                              wi-ptr gfs::windowinfo)
+      (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
+      (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr))
+        (error 'gfs:win32-error :detail "get-window-info failed"))
+      (setf (gfi:point-x pnt) gfs::windowleft)
+      (setf (gfi:point-y pnt) gfs::windowtop))))
 
 (defun outer-size (w sz)
-  (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo)
-    (cffi:with-foreign-slots ((gfus::cbsize
-                               gfus::windowleft
-                               gfus::windowtop
-                               gfus::windowright
-                               gfus::windowbottom)
-                              wi-ptr gfus::windowinfo)
-      (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo))
-      (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr))
-        (error 'gfus:win32-error :detail "get-window-info failed"))
-      (setf (gfid:size-width sz) (- gfus::windowright gfus::windowleft))
-      (setf (gfid:size-height sz) (- gfus::windowbottom gfus::windowtop)))))
+  (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
+    (cffi:with-foreign-slots ((gfs::cbsize
+                               gfs::windowleft
+                               gfs::windowtop
+                               gfs::windowright
+                               gfs::windowbottom)
+                              wi-ptr gfs::windowinfo)
+      (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
+      (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr))
+        (error 'gfs:win32-error :detail "get-window-info failed"))
+      (setf (gfi:size-width sz) (- gfs::windowright gfs::windowleft))
+      (setf (gfi:size-height sz) (- gfs::windowbottom gfs::windowtop)))))
 
 (defun set-widget-text (w str)
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
-  (gfus::set-window-text (gfis:handle w) str))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (gfs::set-window-text (gfi:handle w) str))

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Sat Feb 11 00:39:07 2006
@@ -36,12 +36,12 @@
 (defmethod clear-item ((w widget-with-items) index)
   (let ((it (item-at w index)))
     (delete it (items w) :test #'items-equal-p)
-    (if (gfis:disposed-p it)
-      (error 'gfis:disposed-error))
-    (gfis:dispose it)))
+    (if (gfi:disposed-p it)
+      (error 'gfi:disposed-error))
+    (gfi:dispose it)))
 
-(defmethod clear-span ((w widget-with-items) (sp gfid:span))
-  (loop for index from (gfid:span-start sp) to (gfid:span-end sp)
+(defmethod clear-span ((w widget-with-items) (sp gfi:span))
+  (loop for index from (gfi:span-start sp) to (gfi:span-end sp)
     collect (clear-item w index)))
 
 (defmethod item-append ((w widget-with-items) (i item))
@@ -51,7 +51,7 @@
   (elt (items w) index))
 
 (defmethod (setf item-at) (index (i item) (w widget-with-items))
-  (error 'gfus:toolkit-error :detail "not yet implemented"))
+  (error 'gfs:toolkit-error :detail "not yet implemented"))
 
 (defmethod item-count ((w widget-with-items))
   (length (items w)))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sat Feb 11 00:39:07 2006
@@ -46,81 +46,81 @@
 ;;;
 
 (defmethod client-size ((w widget))
-  (cffi:with-foreign-object (wi-ptr 'gfus::windowinfo)
-    (cffi:with-foreign-slots ((gfus::cbsize
-                               gfus::clientleft
-                               gfus::clienttop
-                               gfus::clientright
-                               gfus::clientbottom)
-                              wi-ptr gfus::windowinfo)
-      (setf gfus::cbsize (cffi::foreign-type-size 'gfus::windowinfo))
-      (when (zerop (gfus::get-window-info (gfis:handle w) wi-ptr))
-        (error 'gfus:win32-error :detail "get-window-info failed"))
-      (gfid:make-size :width (- gfus::clientright gfus::clientleft)
-                       :height (- gfus::clientbottom gfus::clienttop)))))
+  (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
+    (cffi:with-foreign-slots ((gfs::cbsize
+                               gfs::clientleft
+                               gfs::clienttop
+                               gfs::clientright
+                               gfs::clientbottom)
+                              wi-ptr gfs::windowinfo)
+      (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
+      (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr))
+        (error 'gfs:win32-error :detail "get-window-info failed"))
+      (gfi:make-size :width (- gfs::clientright gfs::clientleft)
+                       :height (- gfs::clientbottom gfs::clienttop)))))
 
-(defmethod gfis:dispose ((w widget))
+(defmethod gfi:dispose ((w widget))
   (unless (null (dispatcher w))
     (event-dispose (dispatcher w) 0))
-  (let ((hwnd (gfis:handle w)))
-    (if (not (gfus:null-handle-p hwnd))
-      (if (zerop (gfus::destroy-window hwnd))
-        (error 'gfus:win32-error :detail "destroy-window failed"))))
-  (setf (slot-value w 'gfis:handle) nil))
+  (let ((hwnd (gfi:handle w)))
+    (if (not (gfi:null-handle-p hwnd))
+      (if (zerop (gfs::destroy-window hwnd))
+        (error 'gfs:win32-error :detail "destroy-window failed"))))
+  (setf (slot-value w 'gfi:handle) nil))
 
 (defmethod hide :before ((w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error)))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
 
 (defmethod location ((w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
-  (let ((pnt (gfid:make-point)))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (let ((pnt (gfi:make-point)))
     (outer-location w pnt)
     pnt))
 
-(defmethod (setf location) ((pnt gfid:point) (w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
-  (if (zerop (gfus::set-window-pos (gfis:handle w)
+(defmethod (setf location) ((pnt gfi:point) (w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (if (zerop (gfs::set-window-pos (gfi:handle w)
                                    (cffi:null-pointer)
-                                   (gfid:point-x pnt)
-                                   (gfid:point-y pnt)
+                                   (gfi:point-x pnt)
+                                   (gfi:point-y pnt)
                                    0 0
-                                   gfus::+swp-nosize+))
-    (error 'gfus:win32-error :detail "set-window-pos failed")))
+                                   gfs::+swp-nosize+))
+    (error 'gfs:win32-error :detail "set-window-pos failed")))
 
 (defmethod redraw ((w widget))
-  (let ((hwnd (gfis:handle w)))
-    (unless (gfus:null-handle-p hwnd)
-      (gfus::invalidate-rect hwnd nil 1))))
+  (let ((hwnd (gfi:handle w)))
+    (unless (gfi:null-handle-p hwnd)
+      (gfs::invalidate-rect hwnd nil 1))))
 
 (defmethod size ((w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
-  (let ((sz (gfid:make-size)))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (let ((sz (gfi:make-size)))
     (outer-size w sz)
     sz))
 
-(defmethod (setf size) ((sz gfid:size) (w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error))
-  (if (zerop (gfus::set-window-pos (gfis:handle w)
+(defmethod (setf size) ((sz gfi:size) (w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (if (zerop (gfs::set-window-pos (gfi:handle w)
                                    (cffi:null-pointer)
                                    0 0
-                                   (gfid:size-width sz)
-                                   (gfid:size-height sz)
-                                   gfus::+swp-nomove+))
-    (error 'gfus:win32-error :detail "set-window-pos failed")))
+                                   (gfi:size-width sz)
+                                   (gfi:size-height sz)
+                                   gfs::+swp-nomove+))
+    (error 'gfs:win32-error :detail "set-window-pos failed")))
 
 (defmethod show :before ((w widget))
-  (if (gfis:disposed-p w)
-    (error 'gfis:disposed-error)))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
 
 (defmethod update ((w widget))
-  (let ((hwnd (gfis:handle w)))
-    (unless (gfus:null-handle-p hwnd)
-      (gfus::update-window hwnd))))
+  (let ((hwnd (gfi:handle w)))
+    (unless (gfi:null-handle-p hwnd)
+      (gfs::update-window hwnd))))
 
 ;;;
 ;;; widget table management
@@ -134,13 +134,13 @@
 
 (defun get-widget (hwnd)
   (when *widget-in-progress*
-    (setf (slot-value *widget-in-progress* 'gfis:handle) hwnd)
+    (setf (slot-value *widget-in-progress* 'gfi:handle) hwnd)
     (return-from get-widget *widget-in-progress*))
-  (unless (gfus:null-handle-p hwnd)
+  (unless (gfi:null-handle-p hwnd)
     (gethash (cffi:pointer-address hwnd) *widgets-by-hwnd*)))
 
 (defun put-widget (w)
-  (setf (gethash (cffi:pointer-address (gfis:handle w)) *widgets-by-hwnd*) w))
+  (setf (gethash (cffi:pointer-address (gfi:handle w)) *widgets-by-hwnd*) w))
 
 (defun remove-widget (hwnd)
   (when (not *widget-in-progress*)

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sat Feb 11 00:39:07 2006
@@ -46,9 +46,9 @@
 ;; FIXME: causes GPF
 ;;
 (cffi:defcallback child_hwnd_collector
-                  gfus::BOOL
-                  ((hwnd gfus::HANDLE)
-                   (lparam gfus::LPARAM))
+                  gfs::BOOL
+                  ((hwnd gfs::HANDLE)
+                   (lparam gfs::LPARAM))
   (let ((w (get-widget hwnd)))
     (unless (or (null w) (null *child-visiting-functions*))
       (funcall (car *child-visiting-functions*) w lparam)))
@@ -62,49 +62,49 @@
   ;;
   (push func *child-visiting-functions*)
   (unwind-protect
-      (gfus::enum-child-windows (gfis:handle win) (cffi:get-callback 'child_hwnd_collector) val)
+      (gfs::enum-child-windows (gfi:handle win) (cffi:get-callback 'child_hwnd_collector) val)
     (pop *child-visiting-functions*)))
 
 (defun register-window-class (class-name proc-ptr st)
   (let ((retval 0))
     (cffi:with-foreign-string (str-ptr class-name)
-      (cffi:with-foreign-object (wc-ptr 'gfus::wndclassex)
-        (cffi:with-foreign-slots ((gfus::cbsize gfus::style gfus::wndproc
-                                   gfus::clsextra gfus::wndextra gfus::hinst
-                                   gfus::hicon gfus::hcursor gfus::hbrush
-                                   gfus::menuname gfus::classname gfus::smallicon)
-                                  wc-ptr gfus::wndclassex)
+      (cffi:with-foreign-object (wc-ptr 'gfs::wndclassex)
+        (cffi:with-foreign-slots ((gfs::cbsize gfs::style gfs::wndproc
+                                   gfs::clsextra gfs::wndextra gfs::hinst
+                                   gfs::hicon gfs::hcursor gfs::hbrush
+                                   gfs::menuname gfs::classname gfs::smallicon)
+                                  wc-ptr gfs::wndclassex)
           ;; FIXME: move this if form outside of with-foreign-slots
           ;;
-          (if (zerop (gfus::get-class-info (gfus::get-module-handle (cffi:null-pointer))
+          (if (zerop (gfs::get-class-info (gfs::get-module-handle (cffi:null-pointer))
                                            str-ptr wc-ptr))
             (progn
-              (setf gfus::cbsize (cffi:foreign-type-size 'gfus::wndclassex))
-              (setf gfus::style st)
-              (setf gfus::wndproc proc-ptr)
-              (setf gfus::clsextra 0)
-              (setf gfus::wndextra 0)
-              (setf gfus::hinst (gfus::get-module-handle (cffi:null-pointer)))
-              (setf gfus::hicon (cffi:null-pointer))
-              (setf gfus::hcursor (gfus::load-image (cffi:null-pointer)
-                                      (cffi:make-pointer gfus::+ocr-normal+)
-                                      gfus::+image-cursor+ 0 0
-                                      (logior gfus::+lr-defaultcolor+
-                                              gfus::+lr-shared+)))
-              (setf gfus::hbrush (cffi:make-pointer (1+ gfus::+color-appworkspace+)))
-              (setf gfus::menuname (cffi:null-pointer))
-              (setf gfus::classname str-ptr)
-              (setf gfus::smallicon (cffi:null-pointer))
-              (setf retval (gfus::register-class wc-ptr)))
+              (setf gfs::cbsize (cffi:foreign-type-size 'gfs::wndclassex))
+              (setf gfs::style st)
+              (setf gfs::wndproc proc-ptr)
+              (setf gfs::clsextra 0)
+              (setf gfs::wndextra 0)
+              (setf gfs::hinst (gfs::get-module-handle (cffi:null-pointer)))
+              (setf gfs::hicon (cffi:null-pointer))
+              (setf gfs::hcursor (gfs::load-image (cffi:null-pointer)
+                                      (cffi:make-pointer gfs::+ocr-normal+)
+                                      gfs::+image-cursor+ 0 0
+                                      (logior gfs::+lr-defaultcolor+
+                                              gfs::+lr-shared+)))
+              (setf gfs::hbrush (cffi:make-pointer (1+ gfs::+color-appworkspace+)))
+              (setf gfs::menuname (cffi:null-pointer))
+              (setf gfs::classname str-ptr)
+              (setf gfs::smallicon (cffi:null-pointer))
+              (setf retval (gfs::register-class wc-ptr)))
             (setf retval 1))
           (if (/= retval 0)
             retval
-            (error 'gfus::win32-error :detail "register-class failed")))))))
+            (error 'gfs::win32-error :detail "register-class failed")))))))
 
 (defun register-workspace-window-class ()
   (register-window-class +workspace-window-classname+
                          (cffi:get-callback 'uit_widgets_wndproc)
-                         (logior gfus::+cs-hredraw+ gfus::+cs-vredraw+)))
+                         (logior gfs::+cs-hredraw+ gfs::+cs-vredraw+)))
 
 ;;;
 ;;; methods
@@ -119,85 +119,85 @@
                   ;; styles that can be combined
                   ;;
                   ((eq sym :style-hscroll)
-                    (setf std-flags (logior std-flags gfus::+ws-hscroll+)))
+                    (setf std-flags (logior std-flags gfs::+ws-hscroll+)))
                   ((eq sym :style-max)
-                    (setf std-flags (logior std-flags gfus::+ws-maximizebox+)))
+                    (setf std-flags (logior std-flags gfs::+ws-maximizebox+)))
                   ((eq sym :style-min)
-                    (setf std-flags (logior std-flags gfus::+ws-minimizebox+)))
+                    (setf std-flags (logior std-flags gfs::+ws-minimizebox+)))
                   ((eq sym :style-resize)
-                    (setf std-flags (logior std-flags gfus::+ws-thickframe+)))
+                    (setf std-flags (logior std-flags gfs::+ws-thickframe+)))
                   ((eq sym :style-sysmenu)
-                    (setf std-flags (logior std-flags gfus::+ws-sysmenu+)))
+                    (setf std-flags (logior std-flags gfs::+ws-sysmenu+)))
                   ((eq sym :style-title)
-                    (setf std-flags (logior std-flags gfus::+ws-caption+)))
+                    (setf std-flags (logior std-flags gfs::+ws-caption+)))
                   ((eq sym :style-top)
-                    (setf ex-flags (logior ex-flags gfus::+ws-ex-topmost+)))
+                    (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+)))
                   ((eq sym :style-vscroll)
-                    (setf std-flags (logior std-flags gfus::+ws-vscroll+)))
+                    (setf std-flags (logior std-flags gfs::+ws-vscroll+)))
 
                   ;; pre-packaged combinations of window styles
                   ;;
                   ((eq sym :style-no-title)
                     (setf std-flags 0)
-                    (setf ex-flags gfus::+ws-ex-windowedge+))
+                    (setf ex-flags gfs::+ws-ex-windowedge+))
                   ((eq sym :style-splash)
-                    (setf std-flags (logior gfus::+ws-overlapped+
-                                            gfus::+ws-popup+
-                                            gfus::+ws-clipsiblings+
-                                            gfus::+ws-border+
-                                            gfus::+ws-visible+))
+                    (setf std-flags (logior gfs::+ws-overlapped+
+                                            gfs::+ws-popup+
+                                            gfs::+ws-clipsiblings+
+                                            gfs::+ws-border+
+                                            gfs::+ws-visible+))
                     (setf ex-flags 0))
                   ((eq sym :style-tool)
                     (setf std-flags 0)
-                    (setf ex-flags gfus::+ws-ex-palettewindow+))
+                    (setf ex-flags gfs::+ws-ex-palettewindow+))
                   ((eq sym :style-workspace)
-                    (setf std-flags (logior gfus::+ws-overlapped+
-                                            gfus::+ws-clipsiblings+
-                                            gfus::+ws-clipchildren+
-                                            gfus::+ws-caption+
-                                            gfus::+ws-sysmenu+
-                                            gfus::+ws-thickframe+
-                                            gfus::+ws-minimizebox+
-                                            gfus::+ws-maximizebox+))
+                    (setf std-flags (logior gfs::+ws-overlapped+
+                                            gfs::+ws-clipsiblings+
+                                            gfs::+ws-clipchildren+
+                                            gfs::+ws-caption+
+                                            gfs::+ws-sysmenu+
+                                            gfs::+ws-thickframe+
+                                            gfs::+ws-minimizebox+
+                                            gfs::+ws-maximizebox+))
                     (setf ex-flags 0))))
             (flatten style))
     (values std-flags ex-flags)))
 
-(defmethod gfis:dispose ((win window))
+(defmethod gfi:dispose ((win window))
   (let ((m (menu-bar win)))
     (unless (null m)
       (visit-menu-tree m #'menu-cleanup-callback)
-      (remove-widget (gfis:handle m))))
+      (remove-widget (gfi:handle m))))
   (call-next-method))
 
 (defmethod hide ((win window))
-  (gfus::show-window (gfis:handle win) gfus::+sw-hide+))
+  (gfs::show-window (gfi:handle win) gfs::+sw-hide+))
 
 (defmethod menu-bar ((win window))
-  (let ((hmenu (gfus::get-menu (gfis:handle win))))
-    (if (gfus:null-handle-p hmenu)
+  (let ((hmenu (gfs::get-menu (gfi:handle win))))
+    (if (gfi:null-handle-p hmenu)
       (return-from menu-bar nil))
     (let ((m (get-widget hmenu)))
       (if (null m)
-        (error 'gfus:toolkit-error :detail "no object for menu handle"))
+        (error 'gfs:toolkit-error :detail "no object for menu handle"))
       m)))
 
 (defmethod (setf menu-bar) ((m menu) (win window))
-  (let* ((hwnd (gfis:handle win))
-         (hmenu (gfus::get-menu hwnd))
+  (let* ((hwnd (gfi:handle win))
+         (hmenu (gfs::get-menu hwnd))
          (old-menu (get-widget hmenu)))
-    (unless (gfus:null-handle-p hmenu)
-      (gfus::destroy-menu hmenu))
+    (unless (gfi:null-handle-p hmenu)
+      (gfs::destroy-menu hmenu))
     (unless (null old-menu)
-      (gfis:dispose old-menu))
-    (gfus::set-menu hwnd (gfis:handle m))
-    (gfus::draw-menu-bar hwnd)))
+      (gfi:dispose old-menu))
+    (gfs::set-menu hwnd (gfi:handle m))
+    (gfs::draw-menu-bar hwnd)))
 
 (defmethod realize ((win window) parent &rest style)
   (if (not (null parent))
-    (error 'gfus:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future
-  (if (not (gfis:disposed-p win))
-    (error 'gfus:toolkit-error :detail "object already realized"))
+    (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future
+  (if (not (gfi:disposed-p win))
+    (error 'gfs:toolkit-error :detail "object already realized"))
   (set-widget-in-progress win)
   (register-workspace-window-class)
   (multiple-value-bind (std-style ex-style)
@@ -208,12 +208,12 @@
                    std-style
                    ex-style))
   (clear-widget-in-progress)
-  (let ((hwnd (gfis:handle win)))
+  (let ((hwnd (gfi:handle win)))
     (if (not hwnd) ; handle slot should have been set during create-window
-      (error 'gfus:win32-error :detail "create-window failed"))
+      (error 'gfs:win32-error :detail "create-window failed"))
     (put-widget win)))
 
 (defmethod show ((win window))
-  (let ((hwnd (gfis:handle win)))
-    (gfus::show-window hwnd gfus::+sw-shownormal+)
-    (gfus::update-window hwnd)))
+  (let ((hwnd (gfi:handle win)))
+    (gfs::show-window hwnd gfs::+sw-shownormal+)
+    (gfs::update-window hwnd)))


From junrue at common-lisp.net  Sun Feb 12 08:29:46 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 12 Feb 2006 02:29:46 -0600 (CST)
Subject: [graphic-forms-cvs] r6 - in trunk/src/uitoolkit: system widgets
Message-ID: <20060212082946.9B13C7800B@common-lisp.net>

Author: junrue
Date: Sun Feb 12 02:29:46 2006
New Revision: 6

Modified:
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
cannot specific stdcall for CFFI callable funcs, use vendor-specific FFI instead for visit-child-widgets

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Sun Feb 12 02:29:46 2006
@@ -116,12 +116,40 @@
   (hwnd HANDLE)
   (ps LPTR))
 
+;;; FIXME: uncomment this when CFFI callbacks can
+;;; be tagged as stdcall or cdecl (only the latter
+;;; is supported as of 0.9.0)
+;;;
+#|
 (defcfun
   ("EnumChildWindows" enum-child-windows)
   BOOL
   (hwnd HANDLE)
   (func :pointer)
   (lparam LPARAM))
+|#
+
+#+lispworks
+(fli:define-foreign-function
+  (enum-child-windows "EnumChildWindows" :result-type :int)
+  ((hwnd :pointer)
+   (func :pointer)
+   (lparam :long)))
+
+#+clisp
+(ffi:def-call-out enum-child-windows
+  (:name "EnumChildWindows")
+  (:library "user32.dll")
+  (:language :stdc)
+  (:arguments (hwnd ffi:c-pointer)
+              (func (ffi:c-function
+                (:arguments
+                  (hwnd ffi:c-pointer)
+                  (lparam ffi:long))
+                (:return-type ffi:int)
+                (:language :stdc-stdcall)))
+              (lparam ffi:long))
+  (:return-type ffi:int))
 
 (defcfun
   ("GetAsyncKeyState" get-async-key-state)

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Sun Feb 12 02:29:46 2006
@@ -79,6 +79,7 @@
          (hwnd (gfi:handle w))
          (len (gfs::get-window-text-length hwnd)))
     (unless (zerop len)
+      (incf len)
       (let ((str-ptr (cffi:foreign-alloc :char :count len)))
         (unwind-protect
             (unless (zerop (gfs::get-window-text hwnd str-ptr len))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 12 02:29:46 2006
@@ -43,15 +43,21 @@
 ;;; helper functions
 ;;;
 
-;; FIXME: causes GPF
-;;
-(cffi:defcallback child_hwnd_collector
-                  gfs::BOOL
-                  ((hwnd gfs::HANDLE)
-                   (lparam gfs::LPARAM))
+#+lispworks
+(fli:define-foreign-callable
+  ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
+  ((hwnd :pointer)
+   (lparam :long))
   (let ((w (get-widget hwnd)))
     (unless (or (null w) (null *child-visiting-functions*))
-      (funcall (car *child-visiting-functions*) w lparam)))
+      (funcall (first *child-visiting-functions*) w lparam)))
+  1)
+
+#+clisp
+(defun child_window_visitor (hwnd lparam)
+  (let ((w (get-widget hwnd)))
+    (unless (or (null w) (null *child-visiting-functions*))
+      (funcall (first *child-visiting-functions*) w lparam)))
   1)
 
 (defun visit-child-widgets (win func val)
@@ -62,7 +68,17 @@
   ;;
   (push func *child-visiting-functions*)
   (unwind-protect
-      (gfs::enum-child-windows (gfi:handle win) (cffi:get-callback 'child_hwnd_collector) val)
+#+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win)))
+                                     (fli:make-pointer :symbol-name "child_window_visitor")
+                                     0)
+#+clisp     (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
+              (setf ptr (ffi:set-foreign-pointer
+                          (ffi:unsigned-foreign-address
+                            (cffi:pointer-address (gfi:handle win)))
+                          ptr))
+              (gfs::enum-child-windows ptr
+                                       #'child_window_visitor
+                                       0))
     (pop *child-visiting-functions*)))
 
 (defun register-window-class (class-name proc-ptr st)


From junrue at common-lisp.net  Mon Feb 13 01:25:37 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 12 Feb 2006 19:25:37 -0600 (CST)
Subject: [graphic-forms-cvs] r7 - in trunk/src: . tests/uitoolkit
	uitoolkit/system uitoolkit/widgets
Message-ID: <20060213012537.8DA146B013@common-lisp.net>

Author: junrue
Date: Sun Feb 12 19:25:36 2006
New Revision: 7

Modified:
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
now mapping widget screen coordinates to parent window coordinates; implemented enum windows callback with vendor-specific FFI because CFFI does not yet support stdcall as a language type

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sun Feb 12 19:25:36 2006
@@ -290,6 +290,7 @@
     #:accelerator
     #:active
     #:alignment
+    #:ancestor-p
     #:append-item
     #:background-color
     #:background-pattern
@@ -390,7 +391,6 @@
     #:key-down-p
     #:key-toggled-p
     #:layout
-    #:layout-children
     #:layout-manager
     #:layout-p
     #:lines-visible-p
@@ -458,6 +458,7 @@
     #:vertical-scrollbar
     #:visible-item-count
     #:visible-p
+    #:with-children
 
 ;; conditions
   ))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 12 19:25:36 2006
@@ -33,8 +33,10 @@
 
 (in-package #:graphic-forms.uitoolkit.tests)
 
-(defconstant +btn-text-1+ "Push Me")
-(defconstant +btn-text-2+ "Again!")
+(defconstant +btn-text-before+ "Push Me")
+(defconstant +btn-text-after+ "Again!")
+
+(defvar *button-counter* 0)
 
 (defparameter *layout-tester-win* nil)
 
@@ -50,18 +52,55 @@
   (declare (ignore time))
   (exit-layout-tester))
 
-(defclass layout-tester-btn-events (gfw:event-dispatcher)
-  ((button
-    :accessor button
-    :initarg :button
+(defclass layout-tester-widget-events (gfw:event-dispatcher)
+  ((widget
+    :accessor widget
+    :initarg :widget
     :initform nil)
    (toggle-fn
     :accessor toggle-fn
-    :initform nil)))
+    :initform nil)
+   (id
+    :accessor id
+    :initarg :id
+    :initform 0)))
+
+(defun add-layout-tester-widget (primary-type sub-type)
+  (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
+         (w (make-instance primary-type :dispatcher be)))
+    (setf (widget be) w)
+    (cond
+      ((eql sub-type :push-button)
+         (setf (toggle-fn be) (let ((flag nil))
+                                #'(lambda ()
+                                    (if (null flag)
+                                      (progn
+                                        (setf flag t)
+                                        (format nil "~d ~a" (id be) +btn-text-before+))
+                                      (progn
+                                        (setf flag nil)
+                                        (format nil "~d ~a" (id be) +btn-text-after+))))))
+         (incf *button-counter*)))
+    (gfw:realize w *layout-tester-win* sub-type)
+    (setf (gfw:text w) (funcall (toggle-fn be)))
+    (let ((pnt (gfi:make-point)))
+      (gfw:with-children (*layout-tester-win* child-list)
+        (let ((last-child (car (last (cdr child-list)))))
+          (unless (null last-child)
+(format t "****~%")
+(format t "widget: ~a~%" (gfw:text last-child))
+(format t "location: ~a~%" (gfw:location last-child))
+(format t "size: ~a~%" (gfw:size last-child))
+            (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child))
+                                       (gfi:size-width (gfw:size last-child)))))))
+      (setf (gfw:location w) pnt)
+(format t "++++~%")
+(format t "location: ~a~%" (gfw:location w)))
+    (setf (gfw:size w) (gfw:preferred-size w -1 -1))))
 
-(defmethod gfw:event-select ((d layout-tester-btn-events) time item rect)
+(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
   (declare (ignorable time rect))
-  (let ((btn (button d)))
+  (let ((btn (widget d)))
     (setf (gfw:text btn) (funcall (toggle-fn d)))))
 
 (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
@@ -71,13 +110,12 @@
   (let* ((mb (gfw:menu-bar *layout-tester-win*))
          (menu (gfw:sub-menu mb 1)))
     (gfw:clear-all menu)
-    (gfw::visit-child-widgets *layout-tester-win*
-                               #'(lambda (child val)
-                                   (declare (ignore val))
-                                   (let ((it (make-instance 'gfw:menu-item)))
-                                     (gfw:item-append menu it)
-                                     (setf (gfw:text it) (gfw:text child))))
-                               0)))
+    (gfw:with-children (*layout-tester-win* child-list)
+      (mapc #'(lambda (child)
+                (let ((it (make-instance 'gfw:menu-item)))
+                      (gfw:item-append menu it)
+                  (setf (gfw:text it) (gfw:text child))))
+            child-list))))
 
 (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
@@ -86,33 +124,21 @@
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()
+  (setf *button-counter* 0)
   (let* ((menubar nil)
          (fed (make-instance 'layout-tester-exit-dispatcher))
-         (be (make-instance 'layout-tester-btn-events))
-         (cmd (make-instance 'layout-tester-child-menu-dispatcher))
-         (btn (make-instance 'gfw:button :dispatcher be)))
-    (setf (button be) btn)
-    (setf (toggle-fn be) (let ((flag nil))
-                           #'(lambda ()
-                               (if (null flag)
-                                 (progn
-                                   (setf flag t)
-                                   +btn-text-1+)
-                                 (progn
-                                   (setf flag nil)
-                                   +btn-text-2+)))))
+         (cmd (make-instance 'layout-tester-child-menu-dispatcher)))
     (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)))
     (gfw:realize *layout-tester-win* nil :style-workspace)
-    (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 200 :height 150))
+    (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150))
     (setf menubar (gfw:defmenusystem `(((:menu "&File")
                                         (:menuitem "E&xit" :dispatcher ,fed))
                                        ((:menu "&Children" :dispatcher ,cmd)
                                         (:menuitem :separator)))))
     (setf (gfw:menu-bar *layout-tester-win*) menubar)
-    (gfw:realize btn *layout-tester-win* :push-button)
-    (setf (gfw:text btn) (funcall (toggle-fn be)))
-    (setf (gfw:location btn) (gfi:make-point))
-    (setf (gfw:size btn) (gfw:preferred-size btn -1 -1))
+    (add-layout-tester-widget 'gfw:button :push-button)
+    (add-layout-tester-widget 'gfw:button :push-button)
+    (add-layout-tester-widget 'gfw:button :push-button)
     (gfw:show *layout-tester-win*)
     (gfw:run-default-message-loop)))
 

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Sun Feb 12 19:25:36 2006
@@ -172,6 +172,10 @@
 (defconstant +dt-hideprefix+           #x00100000)
 (defconstant +dt-prefixonly+           #x00200000)
 
+(defconstant +ga-parent+                        1)
+(defconstant +ga-root+                          2)
+(defconstant +ga-rootowner+                     3)
+
 (defconstant +gclp-menuname+                   -8)
 (defconstant +gclp-hbrbackground+             -10)
 (defconstant +gclp-hcursor+                   -12)

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Sun Feb 12 19:25:36 2006
@@ -39,6 +39,12 @@
 (load-foreign-library "user32.dll")
 
 (defcfun
+  ("GetAncestor" get-ancestor)
+  HANDLE
+  (hwnd HANDLE)
+  (flags UINT))
+
+(defcfun
   ("BeginPaint" begin-paint)
   HANDLE
   (hwnd HANDLE)
@@ -323,6 +329,12 @@
   (flags UINT))
 
 (defcfun
+  ("ScreenToClient" screen-to-client)
+  BOOL
+  (hwnd HANDLE)
+  (pnt :pointer))
+
+(defcfun
   ("SendMessageA" send-message)
   LRESULT
   (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Sun Feb 12 19:25:36 2006
@@ -42,6 +42,9 @@
 (defgeneric alignment (object)
   (:documentation "Returns an integer describing the position of internal content within the object."))
 
+(defgeneric ancestor-p (ancestor descendant)
+  (:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise."))
+
 (defgeneric append-item (object new-item)
   (:documentation "Adds the new item to the end of the object's list."))
 
@@ -219,9 +222,6 @@
 (defgeneric layout (object)
   (:documentation "Set the size and location of this object's children."))
 
-(defgeneric layout-children (object)
-  (:documentation "Return the children of this object which are organized via a layout manager."))
-
 (defgeneric layout-manager (object)
   (:documentation "Returns the layout manager associated with this object."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sun Feb 12 19:25:36 2006
@@ -45,6 +45,15 @@
 ;;; widget methods
 ;;;
 
+(defmethod ancestor-p ((ancestor widget) (descendant widget))
+  (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+))
+         (parent (get-widget parent-hwnd)))
+    (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd)
+      (return-from ancestor-p t))
+    (if (null parent)
+      (error 'gfs:toolkit-error :detail "no widget for parent handle"))
+    (ancestor-p ancestor parent)))
+
 (defmethod client-size ((w widget))
   (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
     (cffi:with-foreign-slots ((gfs::cbsize
@@ -57,7 +66,7 @@
       (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr))
         (error 'gfs:win32-error :detail "get-window-info failed"))
       (gfi:make-size :width (- gfs::clientright gfs::clientleft)
-                       :height (- gfs::clientbottom gfs::clienttop)))))
+                     :height (- gfs::clientbottom gfs::clienttop)))))
 
 (defmethod gfi:dispose ((w widget))
   (unless (null (dispatcher w))
@@ -73,11 +82,21 @@
     (error 'gfi:disposed-error)))
 
 (defmethod location ((w widget))
-  (if (gfi:disposed-p w)
-    (error 'gfi:disposed-error))
-  (let ((pnt (gfi:make-point)))
-    (outer-location w pnt)
-    pnt))
+  (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
+    (cffi:with-foreign-slots ((gfs::cbsize
+                               gfs::clientleft
+                               gfs::clienttop)
+                              wi-ptr gfs::windowinfo)
+      (setf gfs::cbsize (cffi::foreign-type-size 'gfs::windowinfo))
+      (when (zerop (gfs::get-window-info (gfi:handle w) wi-ptr))
+        (error 'gfs:win32-error :detail "get-window-info failed"))
+      (cffi:with-foreign-object (pnt-ptr 'gfs::point)
+        (cffi:with-foreign-slots ((gfs::x gfs::y)
+                                 pnt-ptr gfs::point)
+          (setf gfs::x gfs::clientleft)
+          (setf gfs::y gfs::clienttop)
+          (gfs::screen-to-client (gfi:handle w) pnt-ptr)
+          (gfi:make-point :x gfs::x :y gfs::y))))))
 
 (defmethod (setf location) ((pnt gfi:point) (w widget))
   (if (gfi:disposed-p w)
@@ -96,11 +115,7 @@
       (gfs::invalidate-rect hwnd nil 1))))
 
 (defmethod size ((w widget))
-  (if (gfi:disposed-p w)
-    (error 'gfi:disposed-error))
-  (let ((sz (gfi:make-size)))
-    (outer-size w sz)
-    sz))
+  (client-size w))
 
 (defmethod (setf size) ((sz gfi:size) (w widget))
   (if (gfi:disposed-p w)

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 12 19:25:36 2006
@@ -48,29 +48,31 @@
   ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
   ((hwnd :pointer)
    (lparam :long))
-  (let ((w (get-widget hwnd)))
-    (unless (or (null w) (null *child-visiting-functions*))
-      (funcall (first *child-visiting-functions*) w lparam)))
+  (let ((child (get-widget hwnd))
+        (parent (get-widget (cffi:make-pointer lparam))))
+    (unless (or (null parent) (null child) (null *child-visiting-functions*))
+      (funcall (first *child-visiting-functions*) parent child)))
   1)
 
 #+clisp
 (defun child_window_visitor (hwnd lparam)
-  (let ((w (get-widget hwnd)))
-    (unless (or (null w) (null *child-visiting-functions*))
-      (funcall (first *child-visiting-functions*) w lparam)))
+  (let ((child (get-widget hwnd))
+        (parent (get-widget (cffi:make-pointer lparam))))
+    (unless (or (null child) (null parent) (null *child-visiting-functions*))
+      (funcall (first *child-visiting-functions*) parent child)))
   1)
 
-(defun visit-child-widgets (win func val)
+(defun visit-child-widgets (win func)
   ;;
-  ;; supplied closure should accept two parameters:
+  ;; supplied closure should expect two parameters:
+  ;;  parent window object
   ;;  current child widget
-  ;;  long value passed to visit-child-windows
   ;;
   (push func *child-visiting-functions*)
   (unwind-protect
 #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win)))
                                      (fli:make-pointer :symbol-name "child_window_visitor")
-                                     0)
+                                     (cffi:pointer-address (gfi:handle win)))
 #+clisp     (let ((ptr (ffi:foreign-pointer (ffi:unsigned-foreign-address 0))))
               (setf ptr (ffi:set-foreign-pointer
                           (ffi:unsigned-foreign-address
@@ -78,7 +80,7 @@
                           ptr))
               (gfs::enum-child-windows ptr
                                        #'child_window_visitor
-                                       0))
+                                       (cffi:pointer-address (gfi:handle win))))
     (pop *child-visiting-functions*)))
 
 (defun register-window-class (class-name proc-ptr st)
@@ -117,6 +119,13 @@
             retval
             (error 'gfs::win32-error :detail "register-class failed")))))))
 
+(defmacro with-children ((win var) &body body)
+  `(let ((,var nil))
+     (visit-child-widgets ,win #'(lambda (parent child)
+                                  (if (gfw:ancestor-p parent child)
+                                    (push child ,var))))
+     , at body))
+
 (defun register-workspace-window-class ()
   (register-window-class +workspace-window-classname+
                          (cffi:get-callback 'uit_widgets_wndproc)
@@ -189,6 +198,13 @@
 (defmethod hide ((win window))
   (gfs::show-window (gfi:handle win) gfs::+sw-hide+))
 
+(defmethod location ((w window))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (let ((pnt (gfi:make-point)))
+    (outer-location w pnt)
+    pnt))
+
 (defmethod menu-bar ((win window))
   (let ((hmenu (gfs::get-menu (gfi:handle win))))
     (if (gfi:null-handle-p hmenu)
@@ -233,3 +249,10 @@
   (let ((hwnd (gfi:handle win)))
     (gfs::show-window hwnd gfs::+sw-shownormal+)
     (gfs::update-window hwnd)))
+
+(defmethod size ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error))
+  (let ((sz (gfi:make-size)))
+    (outer-size w sz)
+    sz))


From junrue at common-lisp.net  Mon Feb 13 06:52:19 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 13 Feb 2006 00:52:19 -0600 (CST)
Subject: [graphic-forms-cvs] r8 - in trunk: . src src/uitoolkit/system
	src/uitoolkit/widgets
Message-ID: <20060213065219.B738A48013@common-lisp.net>

Author: junrue
Date: Mon Feb 13 00:52:17 2006
New Revision: 8

Added:
   trunk/src/uitoolkit/widgets/thread-context.lisp
Modified:
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/packages.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
moved majority of global data into pre-thread data structure

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Mon Feb 13 00:52:17 2006
@@ -87,6 +87,7 @@
                     :components
                       ((:file "widget-constants")
                        (:file "widget-classes")
+                       (:file "thread-context")
                        (:file "message-generics")
                        (:file "event-generics")
                        (:file "layout-generics")

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Mon Feb 13 00:52:17 2006
@@ -82,12 +82,6 @@
 
 ;; methods, functions, macros
     #:detail
-    #:get-menuitem-text
-    #:insert-menuitem
-    #:insert-separator
-    #:insert-submenu
-    #:process-message
-    #:register-window-class
     #:with-retrieved-dc
 
 ;; conditions

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Mon Feb 13 00:52:17 2006
@@ -306,6 +306,14 @@
   (remove-msg UINT))
 
 (defcfun
+  ("PostMessageA" post-message)
+  BOOL
+  (hwnd HANDLE)
+  (msg UINT)
+  (wparam WPARAM)
+  (lparam LPARAM))
+
+(defcfun
   ("PostQuitMessage" post-quit-message)
   :void
   (exit-code INT))
@@ -339,8 +347,8 @@
   LRESULT
   (hwnd HANDLE)
   (msg UINT)
-  (wp WPARAM)
-  (lp WPARAM))
+  (wparam WPARAM)
+  (lparam WPARAM))
 
 (defcfun
   ("SetMenu" set-menu)

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Mon Feb 13 00:52:17 2006
@@ -51,7 +51,7 @@
 (defmethod realize :after ((ctl control) parent &rest style)
   (let ((hwnd (gfi:handle ctl)))
     (subclass-wndproc hwnd)
-    (put-widget ctl)
+    (put-widget (thread-context) ctl)
     (let ((hfont (gfs::get-stock-object gfs::+default-gui-font+)))
       (unless (gfi:null-handle-p hfont)
         (unless (zerop (gfs::send-message hwnd

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Mon Feb 13 00:52:17 2006
@@ -38,12 +38,6 @@
                                             gfs::+pm-qs-input+
                                             gfs::+pm-qs-postmessage+))
 
-(defvar *last-event-time* 0)
-(defvar *last-virtual-key* 0)
-(defvar *mouse-event-pnt* (gfi:make-point))
-(defvar *move-event-pnt* (gfi:make-point))
-(defvar *size-event-size* (gfi:make-size))
-
 ;;;
 ;;; window procedures
 ;;;
@@ -79,7 +73,7 @@
                                    gfs::time
                                    gfs::pnt)
                                   msg-ptr gfs::msg)
-          (setf *last-event-time* gfs::time)
+          (setf (event-time (thread-context)) gfs::time)
           (when (zerop gm)
             (return-from run-default-message-loop gfs::wparam))
           (when (= gm -1)
@@ -103,11 +97,12 @@
   (= (gfs::get-key-state key-code) 1))
 
 (defun process-mouse-message (fn hwnd lparam btn-symbol)
-  (let ((w (get-widget hwnd)))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd)))
     (when w
-      (setf (gfi:point-x *mouse-event-pnt*) (lo-word lparam))
-      (setf (gfi:point-y *mouse-event-pnt*) (hi-word lparam))
-      (funcall fn (dispatcher w) *last-event-time* *mouse-event-pnt* btn-symbol)))
+      (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam))
+      (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam))
+      (funcall fn (dispatcher w) (event-time tc) (mouse-event-pnt tc) btn-symbol)))
   0)
 
 (defun get-class-wndproc (hwnd)
@@ -132,35 +127,37 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (let ((w (get-widget hwnd)))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd)))
     (if w
-      (event-close (dispatcher w) *last-event-time*)
+      (event-close (dispatcher w) (event-time tc))
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam)
-  (let ((wparam-hi (hi-word wparam))
-        (owner (get-widget hwnd)))
+  (let* ((tc (thread-context))
+         (wparam-hi (hi-word wparam))
+         (owner (get-widget tc hwnd)))
     (if owner
       (cond
         ((zerop lparam)
-          (let ((item (get-menuitem (lo-word wparam))))
+          (let ((item (get-menuitem tc (lo-word wparam))))
             (if (null item)
               (error 'gfs:toolkit-error :detail "no menu item for id"))
             (unless (null (dispatcher item))
               (event-select (dispatcher item)
-                            *last-event-time*
+                            (event-time tc)
                             item
                             (make-instance 'gfi:rectangle))))) ; FIXME
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam))
         (t
-          (let ((w (get-widget (cffi:make-pointer lparam))))
+          (let ((w (get-widget tc (cffi:make-pointer lparam))))
             (if (null w)
               (error 'gfs:toolkit-error :detail "no object for hwnd"))
             (unless (null (dispatcher w))
               (event-select (dispatcher w)
-                            *last-event-time*
+                            (event-time tc)
                             w
                             (make-instance 'gfi:rectangle)))))) ; FIXME
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
@@ -168,58 +165,63 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam)
   (declare (ignorable hwnd lparam))
-  (let ((menu (get-widget (cffi:make-pointer wparam))))
+  (let* ((tc (thread-context))
+         (menu (get-widget tc (cffi:make-pointer wparam))))
     (unless (null menu)
       (let ((d (dispatcher menu)))
         (unless (null d)
-          (event-activate d *last-event-time*)))))
+          (event-activate d (event-time tc))))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
   (declare (ignorable hwnd lparam)) ; FIXME: handle system menus
-  (let ((item (get-menuitem (lo-word wparam))))
+  (let* ((tc (thread-context))
+         (item (get-menuitem tc (lo-word wparam))))
     (unless (null item)
       (let ((d (dispatcher item)))
         (unless (null d)
-          (event-arm d *last-event-time* item)))))
+          (event-arm d (event-time tc) item)))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (get-widget hwnd) ; has side-effect of setting handle slot
+  (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (remove-widget hwnd)
+  (remove-widget (thread-context) hwnd)
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam)
   (declare (ignore lparam))
-  (let ((w (get-widget hwnd))
-        (ch (code-char (lo-word wparam))))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd))
+         (ch (code-char (lo-word wparam))))
     (when w
-      (event-key-down (dispatcher w) *last-event-time* *last-virtual-key* ch)))
+      (event-key-down (dispatcher w) (event-time tc) (virtual-key tc) ch)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
-  (let* ((wparam-lo (lo-word wparam))
+  (let* ((tc (thread-context))
+         (wparam-lo (lo-word wparam))
          (ch (gfs::map-virtual-key wparam-lo 2))
-         (w (get-widget hwnd)))
-    (setf *last-virtual-key* wparam-lo)
+         (w (get-widget tc hwnd)))
+    (setf (virtual-key tc) wparam-lo)
     (when (and w (= ch 0) (= (logand lparam #x40000000) 0))
-      (event-key-down (dispatcher w) *last-event-time* wparam-lo (code-char ch))))
+      (event-key-down (dispatcher w) (event-time tc) wparam-lo (code-char ch))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
   (declare (ignore lparam))
-  (unless (zerop *last-virtual-key*)
-    (let* ((wparam-lo (lo-word wparam))
-           (ch (gfs::map-virtual-key wparam-lo 2))
-           (w (get-widget hwnd)))
-      (when w
-        (event-key-up (dispatcher w) *last-event-time* wparam-lo (code-char ch)))))
-  (setf *last-virtual-key* 0)
+  (let ((tc (thread-context)))
+    (unless (zerop (virtual-key tc))
+      (let* ((wparam-lo (lo-word wparam))
+             (ch (gfs::map-virtual-key wparam-lo 2))
+             (w (get-widget tc hwnd)))
+        (when w
+          (event-key-up (dispatcher w) (event-time tc) wparam-lo (code-char ch)))))
+    (setf (virtual-key tc) 0))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-lbuttondblclk+)) wparam lparam)
@@ -259,23 +261,26 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-move+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (let ((w (get-widget hwnd)))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd)))
     (when w
-      (outer-location w *move-event-pnt*)
-      (event-move (dispatcher w) *last-event-time* *move-event-pnt*)))
+      (outer-location w (move-event-pnt tc))
+      (event-move (dispatcher w) (event-time tc) (move-event-pnt tc))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (let ((w (get-widget hwnd)))
-    (if (and w (event-pre-move (dispatcher w) *last-event-time*))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd)))
+    (if (and w (event-pre-move (dispatcher w) (event-time tc)))
       1
       0)))
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (let ((w (get-widget hwnd))
-        (gc (make-instance 'gfg:graphics-context)))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd))
+         (gc (make-instance 'gfg:graphics-context)))
     (if w
       (let ((rct (make-instance 'gfi:rectangle)))
         (cffi:with-foreign-object (ps-ptr 'gfs::paintstruct)
@@ -290,7 +295,7 @@
           (setf (gfi:size rct) (gfi:make-size :width  gfs::rcpaint-width
                                                 :height gfs::rcpaint-height))
           (unwind-protect
-              (event-paint (dispatcher w) *last-event-time* gc rct)
+              (event-paint (dispatcher w) (event-time tc) gc rct)
             (gfs::end-paint hwnd ps-ptr)))))
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
@@ -309,21 +314,23 @@
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-size+)) wparam lparam)
   (declare (ignore lparam))
-  (let ((w (get-widget hwnd))
-        (type (cond
-                ((= wparam gfs::+size-maximized+) 'maximized)
-                ((= wparam gfs::+size-minimized+) 'minimized)
-                ((= wparam gfs::+size-restored+) 'restored)
-                (t nil))))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd))
+         (type (cond
+                 ((= wparam gfs::+size-maximized+) 'maximized)
+                 ((= wparam gfs::+size-minimized+) 'minimized)
+                 ((= wparam gfs::+size-restored+) 'restored)
+                 (t nil))))
     (when w
-      (outer-size w *size-event-size*)
-      (event-resize (dispatcher w) *last-event-time* *size-event-size* type)))
+      (outer-size w (size-event-size tc))
+      (event-resize (dispatcher w) (event-time tc) (size-event-size tc) type)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (let ((w (get-widget hwnd)))
-    (if (and w (event-pre-resize (dispatcher w) *last-event-time*))
+  (let* ((tc (thread-context))
+         (w (get-widget tc hwnd)))
+    (if (and w (event-pre-resize (dispatcher w) (event-time tc)))
       1
       0)))
 
@@ -339,7 +346,7 @@
 
 (defmethod process-subclass-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
   (declare (ignorable wparam lparam))
-  (remove-widget hwnd)
+  (remove-widget (thread-context) hwnd)
   (call-next-method))
 
 ;;;

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Mon Feb 13 00:52:17 2006
@@ -33,10 +33,6 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defparameter *next-menuitem-id* 10000)
-
-(defvar *menuitems-by-id* (make-hash-table :test #'eql))
-
 ;;;
 ;;; helper functions
 ;;;
@@ -177,7 +173,7 @@
     (error 'gfi:disposed-error))
   (let ((hwnd (gfs::get-submenu (gfi:handle m) index)))
     (if (not (gfi:null-handle-p hwnd))
-      (get-widget hwnd)
+      (get-widget (thread-context) hwnd)
       nil)))
 
 (defun visit-menu-tree (menu fn)
@@ -193,28 +189,30 @@
 ;;;
 
 (defun menu-cleanup-callback (menu item)
-  (remove-widget (gfi:handle menu))
-  (remove-menuitem item))
+  (let ((tc (thread-context)))
+    (remove-widget tc (gfi:handle menu))
+    (remove-menuitem tc item)))
 
 (defmethod gfi:dispose ((m menu))
   (visit-menu-tree m #'menu-cleanup-callback)
   (let ((hwnd (gfi:handle m)))
-    (remove-widget hwnd)
+    (remove-widget (thread-context) hwnd)
     (if (not (gfi:null-handle-p hwnd))
       (if (zerop (gfs::destroy-menu hwnd))
         (error 'gfs:win32-error :detail "destroy-menu failed"))))
   (setf (slot-value m 'gfi:handle) nil))
 
 (defmethod item-append ((m menu) (it menu-item))
-  (let ((id *next-menuitem-id*)
-        (hmenu (gfi:handle m)))
+  (let* ((tc (thread-context))
+         (id (next-menuitem-id tc))
+         (hmenu (gfi:handle m)))
     (if (gfi:null-handle-p hmenu)
       (error 'gfi:disposed-error))
-    (setf *next-menuitem-id* (1+ id))
+    (increment-menuitem-id tc)
     (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer))
     (setf (item-id it) id)
     (setf (slot-value it 'gfi:handle) hmenu)
-    (put-menuitem it)
+    (put-menuitem tc it)
     (call-next-method)))
 
 ;;;
@@ -223,7 +221,7 @@
 
 (defmethod gfi:dispose ((it menu-item))
   (setf (dispatcher it) nil)
-  (remove-menuitem it)
+  (remove-menuitem (thread-context) it)
   (let ((id (item-id it))
         (owner (item-owner it)))
     (unless (null owner)
@@ -239,7 +237,7 @@
   (let ((hmenu (gfi:handle it)))
     (if (gfi:null-handle-p hmenu)
       (error 'gfs:toolkit-error :detail "null owner menu handle"))
-    (let ((m (get-widget hmenu)))
+    (let ((m (get-widget (thread-context) hmenu)))
       (if (null m)
         (error 'gfs:toolkit-error :detail "no owner menu"))
       m)))
@@ -444,19 +442,20 @@
 
 (defmethod initialize-instance :after ((gen menu-generator) &key)
   (let ((m (make-instance 'menu :handle (gfs::create-menu))))
-    (put-widget m)
+    (put-widget (thread-context) m)
     (setf (menu-stack gen) (list m))))
 
 (defmethod define-menuitem ((gen menu-generator) label dispatcher enabled checked image)
-  (let* ((owner (first (menu-stack gen)))
+  (let* ((tc (thread-context))
+         (owner (first (menu-stack gen)))
          (it (make-instance 'menu-item :dispatcher dispatcher))
-         (id *next-menuitem-id*)
+         (id (next-menuitem-id tc))
          (hmenu (gfi:handle owner)))
-    (setf *next-menuitem-id* (1+ id))
+    (increment-menuitem-id tc)
     (insert-menuitem hmenu id label (cffi:null-pointer))
     (setf (item-id it) id)
     (setf (slot-value it 'gfi:handle) hmenu)
-    (put-menuitem it)
+    (put-menuitem tc it)
     (vector-push-extend it (items owner))))
 
 (defmethod define-submenu ((gen menu-generator) submenu dispatcher enabled image)
@@ -467,22 +466,23 @@
   (let* ((owner (first (menu-stack gen)))
          (it (make-instance 'menu-item))
          (hmenu (gfi:handle owner)))
-    (put-menuitem it)
+    (put-menuitem (thread-context) it)
     (insert-separator hmenu)
     (setf (slot-value it 'gfi:handle) hmenu)
     (vector-push-extend it (items owner))))
 
 (defmethod define-menu ((gen menu-generator) label dispatcher)
-  (let* ((m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
+  (let* ((tc (thread-context))
+         (m (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher))
          (parent (first (menu-stack gen)))
          (it (make-instance 'menu-item :handle (gfi:handle parent) :dispatcher dispatcher))
-         (id *next-menuitem-id*))
-    (setf *next-menuitem-id* (1+ id))
+         (id (next-menuitem-id tc)))
+    (increment-menuitem-id tc)
     (insert-submenu (gfi:handle parent) id label (cffi:null-pointer) (gfi:handle m))
     (setf (item-id it) id)
     (vector-push-extend it (items parent))
     (push m (menu-stack gen))
-    (put-widget m)
+    (put-widget tc m)
     m))
 
 (defmethod complete-menu ((gen menu-generator))
@@ -493,21 +493,3 @@
     `(let ((,gen (make-instance 'menu-generator)))
        (mapcar #'(lambda (var) (process-menu ,gen var)) ,sexp)
        (first (menu-stack ,gen)))))
-
-;;;
-;;; menuitems table management
-;;;
-
-(defun get-menuitem (id)
-  (gethash id *menuitems-by-id*))
-
-(defun put-menuitem (it)
-  (setf (gethash (item-id it) *menuitems-by-id*) it))
-
-(defun remove-menuitem (it)
-  (maphash
-    #'(lambda (k v)
-        (declare (ignore v))
-        (if (eql k (item-id it))
-          (remhash k *menuitems-by-id*)))
-    *menuitems-by-id*))

Added: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Mon Feb 13 00:52:17 2006
@@ -0,0 +1,133 @@
+;;;;
+;;;; thread-context.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.widgets)
+
+(defclass thread-context ()
+  ((child-visitor-stack   :initform nil)
+   (image-loaders-by-type :initform (make-hash-table :test #'equal))
+   (job-table             :initform (make-hash-table :test #'equal))
+   (job-table-lock        :initform nil)
+   (event-time            :initform 0 :accessor event-time)
+   (virtual-key           :initform 0 :accessor virtual-key)
+   (menuitems-by-id       :initform (make-hash-table :test #'equal))
+   (mouse-event-pnt       :initform (gfi:make-point) :accessor mouse-event-pnt)
+   (move-event-pnt        :initform (gfi:make-point) :accessor move-event-pnt)
+   (next-menuitem-id      :initform 10000 :reader next-menuitem-id)
+   (size-event-size       :initform (gfi:make-size) :accessor size-event-size)
+   (widgets-by-hwnd       :initform (make-hash-table :test #'equal))
+   (wip                   :initform nil))
+  (:documentation "Thread context objects maintain 'global' data for each thread possessing an event loop."))
+
+;; TODO: change this when CLISP acquires MT support
+;;
+#+clisp (defvar *the-thread-context* nil)
+
+#+clisp     (defun thread-context ()
+              *the-thread-context*)
+
+#+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))
+                tc))
+
+(defmethod call-child-visitor-func ((tc thread-context) parent child)
+  "Call the closure at the top of the child window visitor function stack."
+  (let ((fn (first (slot-value tc 'child-visitor-stack))))
+    (if (null fn)
+      (error 'gfs:toolkit-error :detail "child visitor function stack is empty"))
+    (funcall fn parent child)))
+
+(defmethod push-child-visitor-func ((tc thread-context) func)
+  "Push the supplied closure onto the child window visitor function stack."
+  (if (not (functionp func))
+    (error 'gfs:toolkit-error :detail "function argument required"))
+  (push func (slot-value tc 'child-visitor-stack))
+  nil)
+
+(defmethod pop-child-visitor-func ((tc thread-context))
+  "Pop the top of the child window visitor function stack; returns the closure if the stack was not already empty."
+  (pop (slot-value tc 'child-visitor-stack)))
+
+(defmethod get-widget ((tc thread-context) hwnd)
+  "Return the widget object corresponding to the specified native window handle."
+  (let ((tmp-widget (slot-value tc 'wip)))
+    (when tmp-widget
+      (setf (slot-value tmp-widget 'gfi:handle) hwnd)
+      (return-from get-widget tmp-widget)))
+  (unless (gfi:null-handle-p hwnd)
+    (gethash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
+
+(defmethod put-widget ((tc thread-context) (w widget))
+  "Add the specified widget to the widget table using its native handle as the key."
+  (setf (gethash (cffi:pointer-address (gfi:handle w)) (slot-value tc 'widgets-by-hwnd)) w))
+
+(defmethod remove-widget ((tc thread-context) hwnd)
+  "Remove the widget object corresponding to the specified native window handle."
+  (when (not (slot-value tc 'wip))
+    (remhash (cffi:pointer-address hwnd) (slot-value tc 'widgets-by-hwnd))))
+
+(defmethod widget-in-progress ((tc thread-context))
+  "Return the widget currently under construction."
+  (slot-value tc 'wip))
+
+(defmethod (setf widget-in-progress) ((w widget) (tc thread-context))
+  "Store the widget currently under construction."
+  (setf (slot-value tc 'wip) w))
+
+(defmethod clear-widget-in-progress ((tc thread-context))
+  "Store the widget currently under construction."
+  (setf (slot-value tc 'wip) nil))
+
+(defmethod get-menuitem ((tc thread-context) id)
+  "Returns the menu item identified by id."
+  (gethash id (slot-value tc 'menuitems-by-id)))
+
+(defmethod put-menuitem ((tc thread-context) (it menu-item))
+  "Stores a menu item using its id as the key."
+  (setf (gethash (item-id it) (slot-value tc 'menuitems-by-id)) it))
+
+(defmethod remove-menuitem ((tc thread-context) (it menu-item))
+  "Removes the menu item using its id as the key."
+  (maphash
+    #'(lambda (k v)
+        (declare (ignore v))
+        (if (eql k (item-id it))
+          (remhash k (slot-value tc 'menuitems-by-id))))
+    (slot-value tc 'menuitems-by-id)))
+
+(defmethod increment-menuitem-id ((tc thread-context))
+  "Bump up the next menu item ID."
+  (incf (slot-value tc 'next-menuitem-id)))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Mon Feb 13 00:52:17 2006
@@ -35,6 +35,7 @@
 
 #+clisp (defun startup (thread-name start-fn)
           (declare (ignore thread-name))
+          (setf *the-thread-context* (make-instance 'thread-context))
           (funcall start-fn))
 
 #+lispworks (defun startup (thread-name start-fn)

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Mon Feb 13 00:52:17 2006
@@ -42,7 +42,7 @@
 
 (defmethod clear-span ((w widget-with-items) (sp gfi:span))
   (loop for index from (gfi:span-start sp) to (gfi:span-end sp)
-    collect (clear-item w index)))
+    collect (clear-item w 0)))
 
 (defmethod item-append ((w widget-with-items) (i item))
   (vector-push-extend i (items w)))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Mon Feb 13 00:52:17 2006
@@ -33,10 +33,6 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defvar *widgets-by-hwnd* (make-hash-table :test #'equal))
-
-(defvar *widget-in-progress* nil)
-
 ;;;
 ;;; helper functions
 ;;;
@@ -47,7 +43,7 @@
 
 (defmethod ancestor-p ((ancestor widget) (descendant widget))
   (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+))
-         (parent (get-widget parent-hwnd)))
+         (parent (get-widget (thread-context) parent-hwnd)))
     (if (cffi:pointer-eq (gfi:handle ancestor) parent-hwnd)
       (return-from ancestor-p t))
     (if (null parent)
@@ -136,27 +132,3 @@
   (let ((hwnd (gfi:handle w)))
     (unless (gfi:null-handle-p hwnd)
       (gfs::update-window hwnd))))
-
-;;;
-;;; widget table management
-;;;
-
-(defun clear-widget-in-progress ()
-  (setf *widget-in-progress* nil))
-
-(defun set-widget-in-progress (w)
-  (setf *widget-in-progress* w))
-
-(defun get-widget (hwnd)
-  (when *widget-in-progress*
-    (setf (slot-value *widget-in-progress* 'gfi:handle) hwnd)
-    (return-from get-widget *widget-in-progress*))
-  (unless (gfi:null-handle-p hwnd)
-    (gethash (cffi:pointer-address hwnd) *widgets-by-hwnd*)))
-
-(defun put-widget (w)
-  (setf (gethash (cffi:pointer-address (gfi:handle w)) *widgets-by-hwnd*) w))
-
-(defun remove-widget (hwnd)
-  (when (not *widget-in-progress*)
-    (remhash (cffi:pointer-address hwnd) *widgets-by-hwnd*)))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Mon Feb 13 00:52:17 2006
@@ -37,8 +37,6 @@
 
 (defconstant +default-window-title+ "New Window")
 
-(defvar *child-visiting-functions* nil)
-
 ;;;
 ;;; helper functions
 ;;;
@@ -48,18 +46,20 @@
   ("child_window_visitor" :result-type :integer :calling-convention :stdcall)
   ((hwnd :pointer)
    (lparam :long))
-  (let ((child (get-widget hwnd))
-        (parent (get-widget (cffi:make-pointer lparam))))
-    (unless (or (null parent) (null child) (null *child-visiting-functions*))
-      (funcall (first *child-visiting-functions*) parent child)))
+  (let* ((tc (thread-context))
+         (child (get-widget tc hwnd))
+         (parent (get-widget tc (cffi:make-pointer lparam))))
+    (unless (or (null parent) (null child))
+      (call-child-visitor-func tc parent child)))
   1)
 
 #+clisp
 (defun child_window_visitor (hwnd lparam)
-  (let ((child (get-widget hwnd))
-        (parent (get-widget (cffi:make-pointer lparam))))
-    (unless (or (null child) (null parent) (null *child-visiting-functions*))
-      (funcall (first *child-visiting-functions*) parent child)))
+  (let* ((tc (thread-context))
+         (child (get-widget tc hwnd))
+        (parent (get-widget tc (cffi:make-pointer lparam))))
+    (unless (or (null child) (null parent))
+      (call-child-visitor-func tc parent child)))
   1)
 
 (defun visit-child-widgets (win func)
@@ -68,8 +68,9 @@
   ;;  parent window object
   ;;  current child widget
   ;;
-  (push func *child-visiting-functions*)
-  (unwind-protect
+  (let ((tc (thread-context)))
+    (push-child-visitor-func tc func)
+    (unwind-protect
 #+lispworks (gfs::enum-child-windows (fli:make-pointer :address (cffi:pointer-address (gfi:handle win)))
                                      (fli:make-pointer :symbol-name "child_window_visitor")
                                      (cffi:pointer-address (gfi:handle win)))
@@ -81,7 +82,8 @@
               (gfs::enum-child-windows ptr
                                        #'child_window_visitor
                                        (cffi:pointer-address (gfi:handle win))))
-    (pop *child-visiting-functions*)))
+      (pop-child-visitor-func tc)))
+  nil)
 
 (defun register-window-class (class-name proc-ptr st)
   (let ((retval 0))
@@ -192,7 +194,7 @@
   (let ((m (menu-bar win)))
     (unless (null m)
       (visit-menu-tree m #'menu-cleanup-callback)
-      (remove-widget (gfi:handle m))))
+      (remove-widget (thread-context) (gfi:handle m))))
   (call-next-method))
 
 (defmethod hide ((win window))
@@ -209,7 +211,7 @@
   (let ((hmenu (gfs::get-menu (gfi:handle win))))
     (if (gfi:null-handle-p hmenu)
       (return-from menu-bar nil))
-    (let ((m (get-widget hmenu)))
+    (let ((m (get-widget (thread-context) hmenu)))
       (if (null m)
         (error 'gfs:toolkit-error :detail "no object for menu handle"))
       m)))
@@ -217,7 +219,7 @@
 (defmethod (setf menu-bar) ((m menu) (win window))
   (let* ((hwnd (gfi:handle win))
          (hmenu (gfs::get-menu hwnd))
-         (old-menu (get-widget hmenu)))
+         (old-menu (get-widget (thread-context) hmenu)))
     (unless (gfi:null-handle-p hmenu)
       (gfs::destroy-menu hmenu))
     (unless (null old-menu)
@@ -230,29 +232,30 @@
     (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future
   (if (not (gfi:disposed-p win))
     (error 'gfs:toolkit-error :detail "object already realized"))
-  (set-widget-in-progress win)
-  (register-workspace-window-class)
-  (multiple-value-bind (std-style ex-style)
-      (compute-style-flags win style)
-    (create-window +workspace-window-classname+
-                   +default-window-title+
-                   (cffi:null-pointer)
-                   std-style
-                   ex-style))
-  (clear-widget-in-progress)
-  (let ((hwnd (gfi:handle win)))
-    (if (not hwnd) ; handle slot should have been set during create-window
-      (error 'gfs:win32-error :detail "create-window failed"))
-    (put-widget win)))
+  (let ((tc (thread-context)))
+    (setf (widget-in-progress tc) win)
+    (register-workspace-window-class)
+    (multiple-value-bind (std-style ex-style)
+        (compute-style-flags win style)
+      (create-window +workspace-window-classname+
+                     +default-window-title+
+                     (cffi:null-pointer)
+                     std-style
+                     ex-style))
+    (clear-widget-in-progress tc)
+    (let ((hwnd (gfi:handle win)))
+      (if (not hwnd) ; handle slot should have been set during create-window
+        (error 'gfs:win32-error :detail "create-window failed"))
+      (put-widget tc win))))
 
 (defmethod show ((win window))
   (let ((hwnd (gfi:handle win)))
     (gfs::show-window hwnd gfs::+sw-shownormal+)
     (gfs::update-window hwnd)))
 
-(defmethod size ((w widget))
-  (if (gfi:disposed-p w)
+(defmethod size ((win window))
+  (if (gfi:disposed-p win)
     (error 'gfi:disposed-error))
   (let ((sz (gfi:make-size)))
-    (outer-size w sz)
+    (outer-size win sz)
     sz))


From junrue at common-lisp.net  Tue Feb 14 03:15:35 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 13 Feb 2006 21:15:35 -0600 (CST)
Subject: [graphic-forms-cvs] r9 - in trunk/src: tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060214031535.0AE2878010@common-lisp.net>

Author: junrue
Date: Mon Feb 13 21:15:34 2006
New Revision: 9

Modified:
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
invoke default message loop on behalf of application code

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Mon Feb 13 21:15:34 2006
@@ -205,8 +205,7 @@
                                        ((:menu "&Help" :dispatcher ,echo-md)
                                         (:menuitem "&About" :dispatcher ,echo-md :image "foobar.bmp")))))
     (setf (gfw:menu-bar *event-tester-window*) menubar)
-    (gfw:show *event-tester-window*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *event-tester-window*)))
 
 (defun run-event-tester ()
   (gfw:startup "Event Tester" #'run-event-tester-internal))

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Mon Feb 13 21:15:34 2006
@@ -68,8 +68,7 @@
     (setf menubar (gfw:defmenusystem `(((:menu "&File")
                                         (:menuitem "E&xit" :dispatcher ,md)))))
     (setf (gfw:menu-bar *hellowin*) menubar)
-    (gfw:show *hellowin*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *hellowin*)))
 
 (defun run-hello-world ()
   (gfw:startup "Hello World" #'run-hello-world-internal))

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Mon Feb 13 21:15:34 2006
@@ -139,8 +139,7 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
-    (gfw:show *layout-tester-win*)
-    (gfw:run-default-message-loop)))
+    (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()
   (gfw:startup "Layout Tester" #'run-layout-tester-internal))

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Mon Feb 13 21:15:34 2006
@@ -36,12 +36,17 @@
 #+clisp (defun startup (thread-name start-fn)
           (declare (ignore thread-name))
           (setf *the-thread-context* (make-instance 'thread-context))
-          (funcall start-fn))
+          (funcall start-fn)
+          (run-default-message-loop))
 
 #+lispworks (defun startup (thread-name start-fn)
               (when (null (mp:list-all-processes))
                 (mp:initialize-multiprocessing))
-              (mp:process-run-function thread-name nil start-fn))
+              (mp:process-run-function thread-name
+                                       nil
+                                       #'(lambda () (progn
+                                                      (funcall start-fn)
+                                                      (run-default-message-loop)))))
 
 (defun shutdown (exit-code)
   (gfs::post-quit-message exit-code))


From junrue at common-lisp.net  Tue Feb 14 06:27:31 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 14 Feb 2006 00:27:31 -0600 (CST)
Subject: [graphic-forms-cvs] r10 - in trunk/src: . tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060214062731.B39B878010@common-lisp.net>

Author: junrue
Date: Tue Feb 14 00:27:31 2006
New Revision: 10

Modified:
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/layout-generics.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
initial implementation of window side of the layout management protocol

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Tue Feb 14 00:27:31 2006
@@ -304,7 +304,8 @@
     #:column-index
     #:column-order
     #:columns
-    #:compute-trim
+    #:compute-outer-size
+    #:compute-size
     #:copy
     #:copy-area
     #:current-font
@@ -407,6 +408,7 @@
     #:parent
     #:paste
     #:peer
+    #:perform-layout
     #:preferred-size
     #:realize
     #:redraw

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Tue Feb 14 00:27:31 2006
@@ -67,7 +67,8 @@
 
 (defun add-layout-tester-widget (primary-type sub-type)
   (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
-         (w (make-instance primary-type :dispatcher be)))
+         (w (make-instance primary-type :dispatcher be))
+         (pnt (gfi:make-point)))
     (setf (widget be) w)
     (cond
       ((eql sub-type :push-button)
@@ -81,22 +82,18 @@
                                         (setf flag nil)
                                         (format nil "~d ~a" (id be) +btn-text-after+))))))
          (incf *button-counter*)))
+#|
+    (gfw:with-children (*layout-tester-win* child-list)
+      (let ((child (first (reverse (rest child-list)))))
+        (unless (null child)
+          (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child))
+                                     (gfi:size-width (gfw:size child)))))))
+|#
+    (setf (gfi:point-x pnt) (* 77 (1- *button-counter*)))
     (gfw:realize w *layout-tester-win* sub-type)
     (setf (gfw:text w) (funcall (toggle-fn be)))
-    (let ((pnt (gfi:make-point)))
-      (gfw:with-children (*layout-tester-win* child-list)
-        (let ((last-child (car (last (cdr child-list)))))
-          (unless (null last-child)
-(format t "****~%")
-(format t "widget: ~a~%" (gfw:text last-child))
-(format t "location: ~a~%" (gfw:location last-child))
-(format t "size: ~a~%" (gfw:size last-child))
-            (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location last-child))
-                                       (gfi:size-width (gfw:size last-child)))))))
-      (setf (gfw:location w) pnt)
-(format t "++++~%")
-(format t "location: ~a~%" (gfw:location w)))
-    (setf (gfw:size w) (gfw:preferred-size w -1 -1))))
+    (gfw:pack w)
+    (setf (gfw:location w) pnt)))
 
 (defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
   (declare (ignorable time rect))

Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layout-generics.lisp	Tue Feb 14 00:27:31 2006
@@ -32,3 +32,9 @@
 ;;;;
 
 (in-package :graphic-forms.uitoolkit.widgets)
+
+(defgeneric compute-size (mgr win width-hint height-hint)
+  (:documentation "Computes and returns the size of the window's client area based on this layout's strategy."))
+
+(defgeneric perform-layout (mgr win)
+  (:documentation "Lays out the children of the window based on this layout's strategy."))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Tue Feb 14 00:27:31 2006
@@ -36,6 +36,9 @@
 (defclass event-dispatcher () ()
   (:documentation "Instances of this class receive events on behalf of user interface objects."))
 
+(defclass layout-manager () ()
+  (:documentation "Subclasses implement layout strategies on behalf of window objects."))
+
 (defclass event-source (gfi:native-object)
   ((dispatcher
     :accessor dispatcher
@@ -75,5 +78,12 @@
 (defclass menu (widget-with-items) ()
   (:documentation "The menu class represents a container for menu items (and submenus)."))
 
-(defclass window (widget) ()
-  (:documentation "The window class is the base class for top-level window objects."))
+(defclass window (widget)
+  ((layout-p
+    :reader :layout-p
+    :initform t)
+   (layout-manager
+    :accessor layout-manager
+    :initarg :layout-manager
+    :initform nil))
+  (:documentation "The window class is the base class for widgets that serve as containers (including top-level windows)."))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Tue Feb 14 00:27:31 2006
@@ -96,8 +96,8 @@
 (defgeneric compute-style-flags (object &rest style)
   (:documentation "Convert a list of keyword symbols to a pair of native bitmasks; the first conveys normal/standard flags, whereas the second any extended flags that the system supports."))
 
-(defgeneric compute-trim (object desired-rect)
-  (:documentation "Return a rectangle describing the area require to enclose the specified desired client area and this object's trim."))
+(defgeneric compute-outer-size (object desired-client-size)
+  (:documentation "Return a size object describing the dimensions of the area required to enclose the specified desired client area and this object's trim."))
 
 (defgeneric copy (object)
   (:documentation "Copies the current selection to the clipboard."))
@@ -222,12 +222,6 @@
 (defgeneric layout (object)
   (:documentation "Set the size and location of this object's children."))
 
-(defgeneric layout-manager (object)
-  (:documentation "Returns the layout manager associated with this object."))
-
-(defgeneric layout-p (object)
-  (:documentation "Return T if this object is configured to allow layout management of children, or nil if layout has been disabled."))
-
 (defgeneric lines-visible-p (object)
   (:documentation "Returns T if the object's lines are visible; nil otherwise."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Tue Feb 14 00:27:31 2006
@@ -105,6 +105,9 @@
                                    gfs::+swp-nosize+))
     (error 'gfs:win32-error :detail "set-window-pos failed")))
 
+(defmethod pack ((w widget))
+  (setf (size w) (preferred-size w -1 -1)))
+
 (defmethod redraw ((w widget))
   (let ((hwnd (gfi:handle w)))
     (unless (gfi:null-handle-p hwnd)

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Tue Feb 14 00:27:31 2006
@@ -137,6 +137,17 @@
 ;;; methods
 ;;;
 
+(defmethod compute-outer-size ((win window) desired-client-size)
+  (let ((client-sz (client-size win))
+        (outer-sz (size win))
+        (trim-sz (gfi:make-size :width (gfi:size-width desired-client-size)
+                                :height (gfi:size-height desired-client-size))))
+    (incf (gfi:size-width trim-sz) (- (gfi:size-width outer-sz)
+                                      (gfi:size-width client-sz)))
+    (incf (gfi:size-height trim-sz) (- (gfi:size-height outer-sz)
+                                       (gfi:size-height client-sz)))
+    trim-sz))
+
 (defmethod compute-style-flags ((win window) &rest style)
   (declare (ignore win))
   (let ((std-flags 0)
@@ -190,6 +201,9 @@
             (flatten style))
     (values std-flags ex-flags)))
 
+(defmethod disable-layout ((win window))
+  (setf (slot-value win 'layout-p) nil))
+
 (defmethod gfi:dispose ((win window))
   (let ((m (menu-bar win)))
     (unless (null m)
@@ -197,6 +211,10 @@
       (remove-widget (thread-context) (gfi:handle m))))
   (call-next-method))
 
+(defmethod enable-layout ((win window))
+  (setf (slot-value win 'layout-p) t)
+  (layout win))
+
 (defmethod hide ((win window))
   (gfs::show-window (gfi:handle win) gfs::+sw-hide+))
 
@@ -207,6 +225,11 @@
     (outer-location w pnt)
     pnt))
 
+(defmethod layout ((win window))
+  (let ((mgr (layout-manager win)))
+    (when (and (layout-p win) mgr)
+      (perform-layout mgr win))))
+
 (defmethod menu-bar ((win window))
   (let ((hmenu (gfs::get-menu (gfi:handle win))))
     (if (gfi:null-handle-p hmenu)
@@ -227,6 +250,17 @@
     (gfs::set-menu hwnd (gfi:handle m))
     (gfs::draw-menu-bar hwnd)))
 
+(defmethod pack ((win window))
+  (layout win)
+  (call-next-method))
+
+(defmethod preferred-size ((win window) width-hint height-hint)
+  (let ((mgr (layout-manager win)))
+    (if (and (layout-p win) mgr)
+      (let ((new-client-sz (compute-size mgr win width-hint height-hint)))
+        (compute-outer-size win new-client-sz))
+      (size win))))
+
 (defmethod realize ((win window) parent &rest style)
   (if (not (null parent))
     (error 'gfs:toolkit-error :detail "FIXME: not implemented")) ; may allow MDI in the future


From junrue at common-lisp.net  Sun Feb 19 21:50:51 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 19 Feb 2006 15:50:51 -0600 (CST)
Subject: [graphic-forms-cvs] r11 - in trunk: . src src/tests/uitoolkit
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060219215051.CAF245800D@common-lisp.net>

Author: junrue
Date: Sun Feb 19 15:50:50 2006
New Revision: 11

Added:
   trunk/src/uitoolkit/widgets/layout-classes.lisp
   trunk/src/uitoolkit/widgets/layouts.lisp
Modified:
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/layout-generics.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
flow layout implementation

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Sun Feb 19 15:50:50 2006
@@ -87,6 +87,7 @@
                     :components
                       ((:file "widget-constants")
                        (:file "widget-classes")
+                       (:file "layout-classes")
                        (:file "thread-context")
                        (:file "message-generics")
                        (:file "event-generics")
@@ -100,4 +101,5 @@
                        (:file "widget-with-items")
                        (:file "menu")
                        (:file "event")
-                       (:file "window")))))))))
+                       (:file "window")
+                       (:file "layouts")))))))))

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Sun Feb 19 15:50:50 2006
@@ -205,7 +205,9 @@
     #:control
     #:event-dispatcher
     #:event-source
+    #:flow-layout
     #:item
+    #:layout-manager
     #:menu
     #:menu-item
     #:widget
@@ -305,7 +307,6 @@
     #:column-order
     #:columns
     #:compute-outer-size
-    #:compute-size
     #:copy
     #:copy-area
     #:current-font
@@ -408,7 +409,6 @@
     #:parent
     #:paste
     #:peer
-    #:perform-layout
     #:preferred-size
     #:realize
     #:redraw

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 19 15:50:50 2006
@@ -67,8 +67,7 @@
 
 (defun add-layout-tester-widget (primary-type sub-type)
   (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
-         (w (make-instance primary-type :dispatcher be))
-         (pnt (gfi:make-point)))
+         (w (make-instance primary-type :dispatcher be)))
     (setf (widget be) w)
     (cond
       ((eql sub-type :push-button)
@@ -89,11 +88,8 @@
           (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child))
                                      (gfi:size-width (gfw:size child)))))))
 |#
-    (setf (gfi:point-x pnt) (* 77 (1- *button-counter*)))
     (gfw:realize w *layout-tester-win* sub-type)
-    (setf (gfw:text w) (funcall (toggle-fn be)))
-    (gfw:pack w)
-    (setf (gfw:location w) pnt)))
+    (setf (gfw:text w) (funcall (toggle-fn be)))))
 
 (defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
   (declare (ignorable time rect))
@@ -107,12 +103,11 @@
   (let* ((mb (gfw:menu-bar *layout-tester-win*))
          (menu (gfw:sub-menu mb 1)))
     (gfw:clear-all menu)
-    (gfw:with-children (*layout-tester-win* child-list)
-      (mapc #'(lambda (child)
-                (let ((it (make-instance 'gfw:menu-item)))
-                      (gfw:item-append menu it)
-                  (setf (gfw:text it) (gfw:text child))))
-            child-list))))
+    (gfw:with-children (*layout-tester-win* kids)
+      (loop for k in kids
+            do (let ((it (make-instance 'gfw:menu-item)))
+                 (gfw:item-append menu it)
+                 (setf (gfw:text it) (gfw:text k)))))))
 
 (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
@@ -125,7 +120,8 @@
   (let* ((menubar nil)
          (fed (make-instance 'layout-tester-exit-dispatcher))
          (cmd (make-instance 'layout-tester-child-menu-dispatcher)))
-    (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)))
+    (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
+                                                         :layout-manager (make-instance 'gfw:flow-layout)))
     (gfw:realize *layout-tester-win* nil :style-workspace)
     (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150))
     (setf menubar (gfw:defmenusystem `(((:menu "&File")
@@ -136,6 +132,7 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
+    (gfw:layout *layout-tester-win*)
     (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Sun Feb 19 15:50:50 2006
@@ -39,10 +39,9 @@
 (load-foreign-library "user32.dll")
 
 (defcfun
-  ("GetAncestor" get-ancestor)
+  ("BeginDeferWindowPos" begin-defer-window-pos)
   HANDLE
-  (hwnd HANDLE)
-  (flags UINT))
+  (numwin INT))
 
 (defcfun
   ("BeginPaint" begin-paint)
@@ -89,6 +88,18 @@
   (param LPVOID))
 
 (defcfun
+  ("DeferWindowPos" defer-window-pos)
+  HANDLE
+  (posinfo HANDLE)
+  (hwnd HANDLE)
+  (hwndafter HANDLE)
+  (x INT)
+  (y INT)
+  (cx INT)
+  (cy INT)
+  (flags UINT))
+
+(defcfun
   ("DefWindowProcA" def-window-proc)
   LRESULT
   (hwnd HANDLE)
@@ -117,6 +128,11 @@
   (hwnd HANDLE))
 
 (defcfun
+  ("EndDeferWindowPos" end-defer-window-pos)
+  BOOL
+  (posinfo HANDLE))
+
+(defcfun
   ("EndPaint" end-paint)
   BOOL
   (hwnd HANDLE)
@@ -158,6 +174,12 @@
   (:return-type ffi:int))
 
 (defcfun
+  ("GetAncestor" get-ancestor)
+  HANDLE
+  (hwnd HANDLE)
+  (flags UINT))
+
+(defcfun
   ("GetAsyncKeyState" get-async-key-state)
   SHORT
   (virtkey INT))

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Sun Feb 19 15:50:50 2006
@@ -121,7 +121,7 @@
 (defgeneric event-mouse-down (dispatcher time point btn)
   (:documentation "Implement this to respond to a mouse down event.")
   (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time ptn btn))))
+    (declare (ignorable dispatcher time point btn))))
 
 (defgeneric event-mouse-enter (dispatcher time point btn)
   (:documentation "Implement this to respond to a mouse passing into the bounds of an object.")

Added: trunk/src/uitoolkit/widgets/layout-classes.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/layout-classes.lisp	Sun Feb 19 15:50:50 2006
@@ -0,0 +1,44 @@
+;;;;
+;;;; layout-classes.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.widgets)
+
+(defclass layout-manager ()
+  ((style
+    :accessor style
+    :initarg :style
+    :initform nil))
+  (:documentation "Subclasses implement layout strategies on behalf of window objects."))
+
+(defclass flow-layout (layout-manager) ()
+  (:documentation "Window children are arranged in a row or column."))

Modified: trunk/src/uitoolkit/widgets/layout-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layout-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layout-generics.lisp	Sun Feb 19 15:50:50 2006
@@ -33,8 +33,8 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defgeneric compute-size (mgr win width-hint height-hint)
-  (:documentation "Computes and returns the size of the window's client area based on this layout's strategy."))
+(defgeneric compute-size (layout win width-hint height-hint)
+  (:documentation "Computes and returns the size of the window's client area based on the layout's strategy."))
 
-(defgeneric perform-layout (mgr win)
-  (:documentation "Lays out the children of the window based on this layout's strategy."))
+(defgeneric compute-layout (layout win width-hint height-hint)
+  (:documentation "Returns a list of conses (window . rectangle) describing the new bounds of each child window."))

Added: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/layouts.lisp	Sun Feb 19 15:50:50 2006
@@ -0,0 +1,106 @@
+;;;;
+;;;; layouts.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.widgets)
+
+(defconstant +window-pos-flags+ (logior gfs::+swp-nozorder+
+                                        gfs::+swp-noownerzorder+
+                                        gfs::+swp-noactivate+
+                                        gfs::+swp-nocopybits+))
+
+(defun perform-layout (layout win)
+  "Calls compute-layout and then handles the actual moving and resizing of a window's children."
+  (let* ((win-size (client-size win))
+         (kids (compute-layout layout win (gfi:size-width win-size) (gfi:size-height win-size)))
+         (hdwp (gfs::begin-defer-window-pos (length kids))))
+    (loop for k in kids
+          do (let* ((rect (cdr k))
+                    (sz (gfi:size rect))
+                    (pnt (gfi:location rect)))
+               (if (gfi:null-handle-p hdwp)
+                 (gfs::set-window-pos (gfi:handle (car k))
+                                      (cffi:null-pointer)
+                                      (gfi:point-x pnt)
+                                      (gfi:point-y pnt)
+                                      (gfi:size-width sz)
+                                      (gfi:size-height sz)
+                                      +window-pos-flags+)
+                 (setf hdwp (gfs::defer-window-pos hdwp
+                                                   (gfi:handle (car k))
+                                                   (cffi:null-pointer)
+                                                   (gfi:point-x pnt)
+                                                   (gfi:point-y pnt)
+                                                   (gfi:size-width sz)
+                                                   (gfi:size-height sz)
+                                                   +window-pos-flags+)))))
+    (unless (gfi:null-handle-p hdwp)
+      (gfs::end-defer-window-pos hdwp))))
+
+;;;
+;;; flow-layout methods
+;;;
+
+(defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
+  (error "not yet implemented"))
+
+(defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
+  (let ((layout-style (gfw:style layout))
+        (entries nil)
+        (last-coord 0)
+        (last-dim 0))
+    (with-children (win kids)
+      (loop for k in kids
+            do (let ((kid-size (preferred-size k width-hint height-hint))
+                     (pnt (gfi:make-point)))
+                 (if (not (find :vertical layout-style))
+                   (progn
+                     (setf (gfi:point-x pnt) (+ last-coord last-dim))
+                     (if (>= height-hint 0)
+                       (setf (gfi:size-height kid-size) height-hint))
+                     (setf last-coord (gfi:point-x pnt))
+                     (setf last-dim (gfi:size-width kid-size)))
+                   (progn
+                     (setf (gfi:point-y pnt) (+ last-coord last-dim))
+                     (if (>= width-hint 0)
+                       (setf (gfi:size-width kid-size) width-hint))
+                     (setf last-coord (gfi:point-y pnt))
+                     (setf last-dim (gfi:size-height kid-size))))
+                 (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))
+    (reverse entries)))
+
+(defmethod initialize-instance :after ((layout flow-layout) &key style)
+  (unless (listp style)
+    (setf style (list style)))
+  (if (and (null (find :horizontal style)) (null (find :vertical style)))
+    (setf (slot-value layout 'style) '(:horizontal))
+    (setf (slot-value layout 'style) style)))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Sun Feb 19 15:50:50 2006
@@ -36,9 +36,6 @@
 (defclass event-dispatcher () ()
   (:documentation "Instances of this class receive events on behalf of user interface objects."))
 
-(defclass layout-manager () ()
-  (:documentation "Subclasses implement layout strategies on behalf of window objects."))
-
 (defclass event-source (gfi:native-object)
   ((dispatcher
     :accessor dispatcher
@@ -80,7 +77,7 @@
 
 (defclass window (widget)
   ((layout-p
-    :reader :layout-p
+    :reader layout-p
     :initform t)
    (layout-manager
     :accessor layout-manager

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 19 15:50:50 2006
@@ -126,6 +126,7 @@
      (visit-child-widgets ,win #'(lambda (parent child)
                                   (if (gfw:ancestor-p parent child)
                                     (push child ,var))))
+     (nreverse ,var)
      , at body))
 
 (defun register-workspace-window-class ()
@@ -215,6 +216,10 @@
   (setf (slot-value win 'layout-p) t)
   (layout win))
 
+(defmethod event-resize ((d dispatcher) time size type)
+  (declare (ignorable time size type))
+  (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here!
+
 (defmethod hide ((win window))
   (gfs::show-window (gfi:handle win) gfs::+sw-hide+))
 


From junrue at common-lisp.net  Sun Feb 19 23:57:22 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 19 Feb 2006 17:57:22 -0600 (CST)
Subject: [graphic-forms-cvs] r12 - in trunk/src: tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060219235722.E0A742A018@common-lisp.net>

Author: junrue
Date: Sun Feb 19 17:57:22 2006
New Revision: 12

Modified:
   trunk/src/tests/uitoolkit/event-tester.lisp
   trunk/src/tests/uitoolkit/hello-world.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/event-generics.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
revised event generic methods to also pass receiving widget

Modified: trunk/src/tests/uitoolkit/event-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/event-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/event-tester.lisp	Sun Feb 19 17:57:22 2006
@@ -46,16 +46,16 @@
 
 (defclass event-tester-window-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-paint ((d event-tester-window-events) time gc rect)
+(defmethod gfw:event-paint ((d event-tester-window-events) window time gc rect)
   (declare (ignorable time rect))
   (setf (gfg:background-color gc) gfg:+color-white+)
   (setf (gfg:foreground-color gc) gfg:+color-blue+)
-  (let* ((sz (gfw:client-size *event-tester-window*))
+  (let* ((sz (gfw:client-size window))
          (pnt (gfi:make-point :x 0 :y (floor (/ (gfi:size-height sz) 2)))))
     (gfg:draw-text gc *event-tester-text* pnt)))
 
-(defmethod gfw:event-close ((d event-tester-window-events) time)
-  (declare (ignore time))
+(defmethod gfw:event-close ((d event-tester-window-events) widget time)
+  (declare (ignore widget time))
   (exit-event-tester))
 
 (defun text-for-modifiers ()
@@ -120,68 +120,68 @@
           time
           (text-for-modifiers)))
           
-(defmethod gfw:event-key-down ((d event-tester-window-events) time key-code char)
+(defmethod gfw:event-key-down ((d event-tester-window-events) window time key-code char)
   (setf *event-tester-text* (text-for-key "down" time key-code char))
-  (gfw:redraw *event-tester-window*))
+  (gfw:redraw window))
 
-(defmethod gfw:event-key-up ((d event-tester-window-events) time key-code char)
+(defmethod gfw:event-key-up ((d event-tester-window-events) window time key-code char)
   (setf *event-tester-text* (text-for-key "up" time key-code char))
-  (gfw:redraw *event-tester-window*))
+  (gfw:redraw window))
 
-(defmethod gfw:event-mouse-double ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-double ((d event-tester-window-events) window time pnt button)
   (setf *event-tester-text* (text-for-mouse "double" time button pnt))
-  (gfw:redraw *event-tester-window*))
+  (gfw:redraw window))
 
-(defmethod gfw:event-mouse-down ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-down ((d event-tester-window-events) window time pnt button)
   (setf *event-tester-text* (text-for-mouse "down" time button pnt))
   (setf *mouse-down-flag* t)
-  (gfw:redraw *event-tester-window*))
+  (gfw:redraw window))
 
-(defmethod gfw:event-mouse-move ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-move ((d event-tester-window-events) window time pnt button)
   (when *mouse-down-flag*
     (setf *event-tester-text* (text-for-mouse "move" time button pnt))
-    (gfw:redraw *event-tester-window*)))
+    (gfw:redraw window)))
 
-(defmethod gfw:event-mouse-up ((d event-tester-window-events) time pnt button)
+(defmethod gfw:event-mouse-up ((d event-tester-window-events) window time pnt button)
   (setf *event-tester-text* (text-for-mouse "up" time button pnt))
   (setf *mouse-down-flag* nil)
-  (gfw:redraw *event-tester-window*))
+  (gfw:redraw window))
 
-(defmethod gfw:event-move ((d event-tester-window-events) time pnt)
+(defmethod gfw:event-move ((d event-tester-window-events) window time pnt)
   (setf *event-tester-text* (text-for-move time pnt))
-  (gfw:redraw *event-tester-window*)
+  (gfw:redraw window)
   0)
 
-(defmethod gfw:event-resize ((d event-tester-window-events) time size type)
+(defmethod gfw:event-resize ((d event-tester-window-events) window time size type)
   (setf *event-tester-text* (text-for-size type time size))
-  (gfw:redraw *event-tester-window*)
+  (gfw:redraw window)
   0)
 
 (defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-exit-dispatcher) time item rect)
-  (declare (ignorable time item rect))
+(defmethod gfw:event-select ((d event-tester-exit-dispatcher) item time rect)
+  (declare (ignorable item time rect))
   (exit-event-tester))
 
-(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) time item)
+(defmethod gfw:event-arm ((d event-tester-exit-dispatcher) item time)
   (declare (ignore rect))
   (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
   (gfw:redraw *event-tester-window*))
 
 (defclass event-tester-echo-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d event-tester-echo-dispatcher) time item rect)
+(defmethod gfw:event-select ((d event-tester-echo-dispatcher) item time rect)
   (declare (ignore rect))
   (setf *event-tester-text* (text-for-item (gfw:text item) time "item selected"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) time item)
+(defmethod gfw:event-arm ((d event-tester-echo-dispatcher) item time)
   (declare (ignore rect))
   (setf *event-tester-text* (text-for-item (gfw:text item) time "item armed"))
   (gfw:redraw *event-tester-window*))
 
-(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) time)
-  (setf *event-tester-text* (text-for-item "" time "menu activated"))
+(defmethod gfw:event-activate ((d event-tester-echo-dispatcher) widget time)
+  (setf *event-tester-text* (text-for-item (format nil "~a" widget) time "menu activated"))
   (gfw:redraw *event-tester-window*))
 
 (defun run-event-tester-internal ()

Modified: trunk/src/tests/uitoolkit/hello-world.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/hello-world.lisp	(original)
+++ trunk/src/tests/uitoolkit/hello-world.lisp	Sun Feb 19 17:57:22 2006
@@ -43,21 +43,20 @@
 
 (defclass hellowin-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((d hellowin-events) time)
-  (declare (ignore time))
-  (format t "hellowin-events event-close~%")
+(defmethod gfw:event-close ((d hellowin-events) widget time)
+  (declare (ignore widget time))
   (exit-hello-world))
 
-(defmethod gfw:event-paint ((d hellowin-events) time (gc gfg:graphics-context) rect)
-  (declare (ignore time) (ignore rect))
+(defmethod gfw:event-paint ((d hellowin-events) window time gc rect)
+  (declare (ignorable window time ignore rect))
   (setf (gfg:background-color gc) gfg:+color-red+)
   (setf (gfg:foreground-color gc) gfg:+color-green+)
   (gfg:draw-text gc "Hello World!" (gfi:make-point)))
 
 (defclass hellowin-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d hellowin-exit-dispatcher) time item rect)
-  (declare (ignorable time item rect))
+(defmethod gfw:event-select ((d hellowin-exit-dispatcher) item time rect)
+  (declare (ignorable item time rect))
   (exit-hello-world))
 
 (defun run-hello-world-internal ()

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 19 17:57:22 2006
@@ -48,8 +48,8 @@
 
 (defclass layout-tester-events (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-close ((d layout-tester-events) time)
-  (declare (ignore time))
+(defmethod gfw:event-close ((d layout-tester-events) widget time)
+  (declare (ignore widget time))
   (exit-layout-tester))
 
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
@@ -91,28 +91,26 @@
     (gfw:realize w *layout-tester-win* sub-type)
     (setf (gfw:text w) (funcall (toggle-fn be)))))
 
-(defmethod gfw:event-select ((d layout-tester-widget-events) time item rect)
-  (declare (ignorable time rect))
+(defmethod gfw:event-select ((d layout-tester-widget-events) item time rect)
+  (declare (ignorable item time rect))
   (let ((btn (widget d)))
     (setf (gfw:text btn) (funcall (toggle-fn d)))))
 
 (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) time)
+(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) menu time)
   (declare (ignore time))
-  (let* ((mb (gfw:menu-bar *layout-tester-win*))
-         (menu (gfw:sub-menu mb 1)))
-    (gfw:clear-all menu)
-    (gfw:with-children (*layout-tester-win* kids)
-      (loop for k in kids
-            do (let ((it (make-instance 'gfw:menu-item)))
-                 (gfw:item-append menu it)
-                 (setf (gfw:text it) (gfw:text k)))))))
+  (gfw:clear-all menu)
+  (gfw:with-children (*layout-tester-win* kids)
+    (loop for k in kids
+          do (let ((it (make-instance 'gfw:menu-item)))
+               (gfw:item-append menu it)
+               (setf (gfw:text it) (gfw:text k))))))
 
 (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
-(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) time item rect)
-  (declare (ignorable time item rect))
+(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
+  (declare (ignorable item time rect))
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()

Modified: trunk/src/uitoolkit/widgets/event-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event-generics.lisp	Sun Feb 19 17:57:22 2006
@@ -33,157 +33,157 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
-(defgeneric event-activate (dispatcher time)
+(defgeneric event-activate (dispatcher widget time)
   (:documentation "Implement this to respond to an object being activated.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-arm (dispatcher time item)
+(defgeneric event-arm (dispatcher item time)
   (:documentation "Implement this to respond to an object about to be selected.")
-  (:method (dispatcher time item)
-    (declare (ignorable dispatcher time item))))
+  (:method (dispatcher item time)
+    (declare (ignorable dispatcher item time))))
 
-(defgeneric event-close (dispatcher time)
+(defgeneric event-close (dispatcher widget time)
   (:documentation "Implement this to respond to an object being closed.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-collapse (dispatcher time item rect)
+(defgeneric event-collapse (dispatcher item time rect)
   (:documentation "Implement this to respond to an object (or item within) being collapsed.")
-  (:method (dispatcher time item rect)
-    (declare (ignorable dispatcher time item rect))))
+  (:method (dispatcher item time rect)
+    (declare (ignorable dispatcher item time rect))))
 
-(defgeneric event-deactivate (dispatcher time)
+(defgeneric event-deactivate (dispatcher widget time)
   (:documentation "Implement this to respond to an object being deactivated.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-deiconify (dispatcher time)
+(defgeneric event-deiconify (dispatcher widget time)
   (:documentation "Implement this to respond to an object being deiconified.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-dispose (dispatcher time)
+(defgeneric event-dispose (dispatcher widget time)
   (:documentation "Implement this to respond to an object being disposed (via dispose, not the GC).")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-expand (dispatcher time item rect)
+(defgeneric event-expand (dispatcher item time rect)
   (:documentation "Implement this to respond to an object (or item within) being expanded.")
-  (:method (dispatcher time item rect)
-    (declare (ignorable dispatcher time item rect))))
+  (:method (dispatcher item time rect)
+    (declare (ignorable dispatcher item time rect))))
 
-(defgeneric event-focus-gain (dispatcher time)
+(defgeneric event-focus-gain (dispatcher widget time)
   (:documentation "Implement this to respond to an object gaining keyboard focus.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-focus-loss (dispatcher time)
+(defgeneric event-focus-loss (dispatcher widget time)
   (:documentation "Implement this to respond to an object losing keyboard focus.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-hide (dispatcher time)
+(defgeneric event-hide (dispatcher widget time)
   (:documentation "Implement this to respond to an object being hidden.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-iconify (dispatcher time)
+(defgeneric event-iconify (dispatcher widget time)
   (:documentation "Implement this to respond to an object being iconified.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-key-down (dispatcher time keycode char)
+(defgeneric event-key-down (dispatcher widget time keycode char)
   (:documentation "Implement this to respond to a key down event.")
-  (:method (dispatcher time keycode char)
-    (declare (ignorable dispatcher time keycode char))))
+  (:method (dispatcher widget time keycode char)
+    (declare (ignorable dispatcher widget time keycode char))))
 
-(defgeneric event-key-traverse (dispatcher time keycode char type)
+(defgeneric event-key-traverse (dispatcher widget time keycode char type)
   (:documentation "Implement this to respond to a key traversal event.")
-  (:method (dispatcher time keycode char type)
-    (declare (ignorable dispatcher time keycode char type))))
+  (:method (dispatcher widget time keycode char type)
+    (declare (ignorable dispatcher widget time keycode char type))))
 
-(defgeneric event-key-up (dispatcher time keycode char)
+(defgeneric event-key-up (dispatcher widget time keycode char)
   (:documentation "Implement this to respond to a key up event.")
-  (:method (dispatcher time keycode char)
-    (declare (ignorable dispatcher time keycode char))))
+  (:method (dispatcher widget time keycode char)
+    (declare (ignorable dispatcher widget time keycode char))))
 
-(defgeneric event-modify (dispatcher time)
+(defgeneric event-modify (dispatcher widget time)
   (:documentation "Implement this to respond to content (e.g., text) in an object being modified.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-mouse-double (dispatcher time point btn)
+(defgeneric event-mouse-double (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse double-click.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-down (dispatcher time point btn)
+(defgeneric event-mouse-down (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse down event.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-enter (dispatcher time point btn)
+(defgeneric event-mouse-enter (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse passing into the bounds of an object.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-exit (dispatcher time point btn)
+(defgeneric event-mouse-exit (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse leaving the bounds an object.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-hover (dispatcher time point btn)
+(defgeneric event-mouse-hover (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse that stops moving for a period of time within an object.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-move (dispatcher time point btn)
+(defgeneric event-mouse-move (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse move event.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-mouse-up (dispatcher time point btn)
+(defgeneric event-mouse-up (dispatcher widget time point button)
   (:documentation "Implement this to respond to a mouse up event.")
-  (:method (dispatcher time point btn)
-    (declare (ignorable dispatcher time point btn))))
+  (:method (dispatcher widget time point button)
+    (declare (ignorable dispatcher widget time point button))))
 
-(defgeneric event-move (dispatcher time point)
+(defgeneric event-move (dispatcher widget time point)
   (:documentation "Implement this to respond to an object being moved within its parent's coordinate system.")
-  (:method (dispatcher time point)
-    (declare (ignorable dispatcher time point))))
+  (:method (dispatcher widget time point)
+    (declare (ignorable dispatcher widget time point))))
 
-(defgeneric event-paint (dispatcher time gc rect)
+(defgeneric event-paint (dispatcher widget time gc rect)
   (:documentation "Implement this to respond to paint requests.")
-  (:method (dispatcher time gc rect)
-    (declare (ignorable dispatcher time gc rect))))
+  (:method (dispatcher widget time gc rect)
+    (declare (ignorable dispatcher widget time gc rect))))
 
-(defgeneric event-pre-modify (dispatcher time keycode char span new-content)
+(defgeneric event-pre-modify (dispatcher widget time keycode char span new-content)
   (:documentation "Implement this to respond to content (e.g., text) in an object about to be modified.")
-  (:method (dispatcher time keycode char span new-content)
-    (declare (ignorable dispatcher time keycode char span new-content))))
+  (:method (dispatcher widget time keycode char span new-content)
+    (declare (ignorable dispatcher widget time keycode char span new-content))))
 
-(defgeneric event-pre-move (dispatcher time)
+(defgeneric event-pre-move (dispatcher widget time)
   (:documentation "Implement this to preempt moving; return T if processed or nil if not.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-pre-resize (dispatcher time)
+(defgeneric event-pre-resize (dispatcher widget time)
   (:documentation "Implement this to preempt resizing; return T if processed or nil if not.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))
 
-(defgeneric event-resize (dispatcher time size type)
+(defgeneric event-resize (dispatcher widget time size type)
   (:documentation "Implement this to respond to an object being resized.")
-  (:method (dispatcher time size type)
-    (declare (ignorable dispatcher time size type))))
+  (:method (dispatcher widget time size type)
+    (declare (ignorable dispatcher widget time size type))))
 
-(defgeneric event-select (dispatcher time item rect)
+(defgeneric event-select (dispatcher item time rect)
   (:documentation "Implement this to respond to an object (or item within) being selected.")
-  (:method (dispatcher time item rect)
-    (declare (ignorable dispatcher time item rect))))
+  (:method (dispatcher item time rect)
+    (declare (ignorable dispatcher item time rect))))
 
-(defgeneric event-show (dispatcher time)
+(defgeneric event-show (dispatcher widget time)
   (:documentation "Implement this to respond to an object being shown.")
-  (:method (dispatcher time)
-    (declare (ignorable dispatcher time))))
+  (:method (dispatcher widget time)
+    (declare (ignorable dispatcher widget time))))

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Feb 19 17:57:22 2006
@@ -102,7 +102,7 @@
     (when w
       (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam))
       (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam))
-      (funcall fn (dispatcher w) (event-time tc) (mouse-event-pnt tc) btn-symbol)))
+      (funcall fn (dispatcher w) w (event-time tc) (mouse-event-pnt tc) btn-symbol)))
   0)
 
 (defun get-class-wndproc (hwnd)
@@ -130,7 +130,7 @@
   (let* ((tc (thread-context))
          (w (get-widget tc hwnd)))
     (if w
-      (event-close (dispatcher w) (event-time tc))
+      (event-close (dispatcher w) w (event-time tc))
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
 
@@ -146,8 +146,8 @@
               (error 'gfs:toolkit-error :detail "no menu item for id"))
             (unless (null (dispatcher item))
               (event-select (dispatcher item)
-                            (event-time tc)
                             item
+                            (event-time tc)
                             (make-instance 'gfi:rectangle))))) ; FIXME
         ((eq wparam-hi 1)
           (format t "accelerator wparam: ~x  lparam: ~x~%" wparam lparam))
@@ -157,8 +157,8 @@
               (error 'gfs:toolkit-error :detail "no object for hwnd"))
             (unless (null (dispatcher w))
               (event-select (dispatcher w)
-                            (event-time tc)
                             w
+                            (event-time tc)
                             (make-instance 'gfi:rectangle)))))) ; FIXME
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
@@ -170,7 +170,7 @@
     (unless (null menu)
       (let ((d (dispatcher menu)))
         (unless (null d)
-          (event-activate d (event-time tc))))))
+          (event-activate d menu (event-time tc))))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-menuselect+)) wparam lparam)
@@ -180,7 +180,7 @@
     (unless (null item)
       (let ((d (dispatcher item)))
         (unless (null d)
-          (event-arm d (event-time tc) item)))))
+          (event-arm d item (event-time tc))))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
@@ -199,7 +199,7 @@
          (w (get-widget tc hwnd))
          (ch (code-char (lo-word wparam))))
     (when w
-      (event-key-down (dispatcher w) (event-time tc) (virtual-key tc) ch)))
+      (event-key-down (dispatcher w) w (event-time tc) (virtual-key tc) ch)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keydown+)) wparam lparam)
@@ -209,7 +209,7 @@
          (w (get-widget tc hwnd)))
     (setf (virtual-key tc) wparam-lo)
     (when (and w (= ch 0) (= (logand lparam #x40000000) 0))
-      (event-key-down (dispatcher w) (event-time tc) wparam-lo (code-char ch))))
+      (event-key-down (dispatcher w) w (event-time tc) wparam-lo (code-char ch))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-keyup+)) wparam lparam)
@@ -220,7 +220,7 @@
              (ch (gfs::map-virtual-key wparam-lo 2))
              (w (get-widget tc hwnd)))
         (when w
-          (event-key-up (dispatcher w) (event-time tc) wparam-lo (code-char ch)))))
+          (event-key-up (dispatcher w) w (event-time tc) wparam-lo (code-char ch)))))
     (setf (virtual-key tc) 0))
   0)
 
@@ -265,14 +265,14 @@
          (w (get-widget tc hwnd)))
     (when w
       (outer-location w (move-event-pnt tc))
-      (event-move (dispatcher w) (event-time tc) (move-event-pnt tc))))
+      (event-move (dispatcher w) w (event-time tc) (move-event-pnt tc))))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-moving+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let* ((tc (thread-context))
          (w (get-widget tc hwnd)))
-    (if (and w (event-pre-move (dispatcher w) (event-time tc)))
+    (if (and w (event-pre-move (dispatcher w) w (event-time tc)))
       1
       0)))
 
@@ -295,7 +295,7 @@
           (setf (gfi:size rct) (gfi:make-size :width  gfs::rcpaint-width
                                                 :height gfs::rcpaint-height))
           (unwind-protect
-              (event-paint (dispatcher w) (event-time tc) gc rct)
+              (event-paint (dispatcher w) w (event-time tc) gc rct)
             (gfs::end-paint hwnd ps-ptr)))))
       (error 'gfs:toolkit-error :detail "no object for hwnd")))
   0)
@@ -323,14 +323,14 @@
                  (t nil))))
     (when w
       (outer-size w (size-event-size tc))
-      (event-resize (dispatcher w) (event-time tc) (size-event-size tc) type)))
+      (event-resize (dispatcher w) w (event-time tc) (size-event-size tc) type)))
   0)
 
 (defmethod process-message (hwnd (msg (eql gfs::+wm-sizing+)) wparam lparam)
   (declare (ignorable wparam lparam))
   (let* ((tc (thread-context))
          (w (get-widget tc hwnd)))
-    (if (and w (event-pre-resize (dispatcher w) (event-time tc)))
+    (if (and w (event-pre-resize (dispatcher w) w (event-time tc)))
       1
       0)))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Sun Feb 19 17:57:22 2006
@@ -66,7 +66,7 @@
 
 (defmethod gfi:dispose ((w widget))
   (unless (null (dispatcher w))
-    (event-dispose (dispatcher w) 0))
+    (event-dispose (dispatcher w) w 0))
   (let ((hwnd (gfi:handle w)))
     (if (not (gfi:null-handle-p hwnd))
       (if (zerop (gfs::destroy-window hwnd))

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 19 17:57:22 2006
@@ -216,9 +216,9 @@
   (setf (slot-value win 'layout-p) t)
   (layout win))
 
-(defmethod event-resize ((d dispatcher) time size type)
-  (declare (ignorable time size type))
-  (layout win)) ; FIXME: this is a big flaw in event handling -- need the window here!
+(defmethod event-resize ((d event-dispatcher) (win window) time size type)
+  (declare (ignorable d time size type))
+  (layout win))
 
 (defmethod hide ((win window))
   (gfs::show-window (gfi:handle win) gfs::+sw-hide+))


From junrue at common-lisp.net  Mon Feb 20 03:23:23 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 19 Feb 2006 21:23:23 -0600 (CST)
Subject: [graphic-forms-cvs] r13 - in trunk/src: tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060220032323.D7E3765015@common-lisp.net>

Author: junrue
Date: Sun Feb 19 21:23:23 2006
New Revision: 13

Modified:
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/event.lisp
   trunk/src/uitoolkit/widgets/window.lisp
Log:
fixed regression in with-children under LispWorks

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 19 21:23:23 2006
@@ -53,11 +53,7 @@
   (exit-layout-tester))
 
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
-  ((widget
-    :accessor widget
-    :initarg :widget
-    :initform nil)
-   (toggle-fn
+  ((toggle-fn
     :accessor toggle-fn
     :initform nil)
    (id
@@ -68,7 +64,6 @@
 (defun add-layout-tester-widget (primary-type sub-type)
   (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
          (w (make-instance primary-type :dispatcher be)))
-    (setf (widget be) w)
     (cond
       ((eql sub-type :push-button)
          (setf (toggle-fn be) (let ((flag nil))
@@ -81,20 +76,13 @@
                                         (setf flag nil)
                                         (format nil "~d ~a" (id be) +btn-text-after+))))))
          (incf *button-counter*)))
-#|
-    (gfw:with-children (*layout-tester-win* child-list)
-      (let ((child (first (reverse (rest child-list)))))
-        (unless (null child)
-          (setf (gfi:point-x pnt) (+ (gfi:point-x (gfw:location child))
-                                     (gfi:size-width (gfw:size child)))))))
-|#
     (gfw:realize w *layout-tester-win* sub-type)
     (setf (gfw:text w) (funcall (toggle-fn be)))))
 
-(defmethod gfw:event-select ((d layout-tester-widget-events) item time rect)
-  (declare (ignorable item time rect))
-  (let ((btn (widget d)))
-    (setf (gfw:text btn) (funcall (toggle-fn d)))))
+(defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
+  (declare (ignorable time rect))
+  (setf (gfw:text btn) (funcall (toggle-fn d)))
+  (gfw:layout *layout-tester-win*))
 
 (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
 
@@ -130,7 +118,6 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
-    (gfw:layout *layout-tester-win*)
     (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Sun Feb 19 21:23:23 2006
@@ -113,9 +113,9 @@
 
 (defun subclass-wndproc (hwnd)
   (if (zerop (gfs::set-window-long hwnd
-                                    gfs::+gwlp-wndproc+
-                                    (cffi:pointer-address
-                                      (cffi:get-callback 'subclassing_wndproc))))
+                                   gfs::+gwlp-wndproc+
+                                   (cffi:pointer-address
+                                     (cffi:get-callback 'subclassing_wndproc))))
     (error 'gfs:win32-error :detail "set-window-long failed")))
 
 ;;;

Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp	(original)
+++ trunk/src/uitoolkit/widgets/window.lisp	Sun Feb 19 21:23:23 2006
@@ -121,13 +121,14 @@
             retval
             (error 'gfs::win32-error :detail "register-class failed")))))))
 
-(defmacro with-children ((win var) &body body)
-  `(let ((,var nil))
-     (visit-child-widgets ,win #'(lambda (parent child)
-                                  (if (gfw:ancestor-p parent child)
-                                    (push child ,var))))
-     (nreverse ,var)
-     , at body))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro with-children ((win var) &body body)
+    `(let ((,var nil))
+       (visit-child-widgets ,win #'(lambda (parent child)
+                                     (when (gfw:ancestor-p parent child)
+                                       (push child ,var))))
+       (setf ,var (reverse ,var))
+       , at body)))
 
 (defun register-workspace-window-class ()
   (register-window-class +workspace-window-classname+


From junrue at common-lisp.net  Mon Feb 20 03:46:03 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Sun, 19 Feb 2006 21:46:03 -0600 (CST)
Subject: [graphic-forms-cvs] r14 - in trunk/src: tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060220034603.7DE1D6B00C@common-lisp.net>

Author: junrue
Date: Sun Feb 19 21:46:03 2006
New Revision: 14

Modified:
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/layouts.lisp
Log:
implemented flow layout compute-size; window pack now works

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Sun Feb 19 21:46:03 2006
@@ -82,7 +82,7 @@
 (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
   (declare (ignorable time rect))
   (setf (gfw:text btn) (funcall (toggle-fn d)))
-  (gfw:layout *layout-tester-win*))
+  (gfw:pack *layout-tester-win*))
 
 (defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
 
@@ -118,6 +118,7 @@
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
     (add-layout-tester-widget 'gfw:button :push-button)
+    (gfw:pack *layout-tester-win*)
     (gfw:show *layout-tester-win*)))
 
 (defun run-layout-tester ()

Modified: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layouts.lisp	Sun Feb 19 21:46:03 2006
@@ -71,7 +71,24 @@
 ;;;
 
 (defmethod compute-size ((layout flow-layout) (win window) width-hint height-hint)
-  (error "not yet implemented"))
+  (let ((max -1)
+        (total 0)
+        (vert-orient (find :vertical (gfw:style layout))))
+    (with-children (win kids)
+      (loop for k in kids
+            do (let ((kid-size (preferred-size k width-hint height-hint)))
+                 (if (not vert-orient)
+                   (progn
+                     (incf total (gfi:size-width kid-size))
+                     (if (< max (gfi:size-height kid-size))
+                       (setf max (gfi:size-height kid-size))))
+                   (progn
+                     (incf total (gfi:size-height kid-size))
+                     (if (< max (gfi:size-width kid-size))
+                       (setf max (gfi:size-width kid-size))))))))
+    (if vert-orient
+      (gfi:make-size :width max :height total)
+      (gfi:make-size :width total :height max))))
 
 (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
   (let ((layout-style (gfw:style layout))


From junrue at common-lisp.net  Mon Feb 20 06:58:34 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 20 Feb 2006 00:58:34 -0600 (CST)
Subject: [graphic-forms-cvs] r15 - in trunk/src: tests/uitoolkit
	uitoolkit/system uitoolkit/widgets
Message-ID: <20060220065834.188E18090@common-lisp.net>

Author: junrue
Date: Mon Feb 20 00:58:33 2006
New Revision: 15

Modified:
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/system/user32.lisp
   trunk/src/uitoolkit/widgets/layouts.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
implemented widget visibility interaction with flow layout

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Mon Feb 20 00:58:33 2006
@@ -52,6 +52,12 @@
   (declare (ignore widget time))
   (exit-layout-tester))
 
+(defclass pack-layout-dispatcher (gfw:event-dispatcher) ())
+
+(defmethod gfw:event-select ((d pack-layout-dispatcher) item time rect)
+  (declare (ignorable item time rect))
+  (gfw:pack *layout-tester-win*))
+
 (defclass layout-tester-widget-events (gfw:event-dispatcher)
   ((toggle-fn
     :accessor toggle-fn
@@ -61,11 +67,11 @@
     :initarg :id
     :initform 0)))
 
-(defun add-layout-tester-widget (primary-type sub-type)
+(defun add-layout-tester-widget (widget-class subtype)
   (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
-         (w (make-instance primary-type :dispatcher be)))
+         (w (make-instance widget-class :dispatcher be)))
     (cond
-      ((eql sub-type :push-button)
+      ((eql subtype :push-button)
          (setf (toggle-fn be) (let ((flag nil))
                                 #'(lambda ()
                                     (if (null flag)
@@ -76,25 +82,88 @@
                                         (setf flag nil)
                                         (format nil "~d ~a" (id be) +btn-text-after+))))))
          (incf *button-counter*)))
-    (gfw:realize w *layout-tester-win* sub-type)
+    (gfw:realize w *layout-tester-win* subtype)
     (setf (gfw:text w) (funcall (toggle-fn be)))))
 
 (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
   (declare (ignorable time rect))
   (setf (gfw:text btn) (funcall (toggle-fn d)))
+  (gfw:layout *layout-tester-win*))
+
+(defclass add-child-dispatcher (gfw:event-dispatcher)
+  ((widget-class
+    :accessor widget-class
+    :initarg :widget-class
+    :initform 'gfw:button)
+   (subtype
+    :accessor subtype
+    :initarg :subtype
+    :initform :push-button)))
+
+(defmethod gfw:event-select ((d add-child-dispatcher) item time rect)
+  (declare (ignorable item time rect))
+  (add-layout-tester-widget (widget-class d) (subtype d))
   (gfw:pack *layout-tester-win*))
 
-(defclass layout-tester-child-menu-dispatcher (gfw:event-dispatcher) ())
+(defclass child-menu-dispatcher (gfw:event-dispatcher)
+  ((item-disp-class
+    :accessor item-disp-class
+    :initarg :item-disp-class
+    :initform nil)))
 
-(defmethod gfw:event-activate ((d layout-tester-child-menu-dispatcher) menu time)
+(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
   (declare (ignore time))
   (gfw:clear-all menu)
   (gfw:with-children (*layout-tester-win* kids)
     (loop for k in kids
           do (let ((it (make-instance 'gfw:menu-item)))
                (gfw:item-append menu it)
+               (unless (null (item-disp-class d))
+                 (setf (gfw:dispatcher it) (make-instance (item-disp-class d))))
                (setf (gfw:text it) (gfw:text k))))))
 
+(defclass remove-child-dispatcher (gfw:event-dispatcher) ())  
+
+(defmethod gfw:event-select ((d remove-child-dispatcher) item time rect)
+  (declare (ignorable time rect))
+  (let ((text (gfw:text item))
+        (victim nil))
+    (gfw:with-children (*layout-tester-win* kids)
+      (loop for k in kids
+            do (if (string= (gfw:text k) text)
+                 (setf victim k))))
+    (unless (null victim)
+      (gfi:dispose victim)
+      (gfw:layout *layout-tester-win*))))
+
+(defclass hide-child-dispatcher (gfw:event-dispatcher) ())  
+
+(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect)
+  (declare (ignorable time rect))
+  (let ((text (gfw:text item))
+        (victim nil))
+    (gfw:with-children (*layout-tester-win* kids)
+      (loop for k in kids
+            do (if (string= (gfw:text k) text)
+                 (setf victim k))))
+    (unless (null victim)
+      (gfw:hide victim)
+      (gfw:layout *layout-tester-win*))))
+
+(defclass show-child-dispatcher (gfw:event-dispatcher) ())  
+
+(defmethod gfw:event-select ((d show-child-dispatcher) item time rect)
+  (declare (ignorable time rect))
+  (let ((text (gfw:text item))
+        (victim nil))
+    (gfw:with-children (*layout-tester-win* kids)
+      (loop for k in kids
+            do (if (string= (gfw:text k) text)
+                 (setf victim k))))
+    (unless (null victim)
+      (gfw:show victim)
+      (gfw:pack *layout-tester-win*))))
+
 (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
@@ -103,21 +172,36 @@
 
 (defun run-layout-tester-internal ()
   (setf *button-counter* 0)
-  (let* ((menubar nil)
-         (fed (make-instance 'layout-tester-exit-dispatcher))
-         (cmd (make-instance 'layout-tester-child-menu-dispatcher)))
+  (let ((menubar nil)
+        (exit-disp (make-instance 'layout-tester-exit-dispatcher))
+        (pack-disp (make-instance 'pack-layout-dispatcher))
+        (add-btn-disp (make-instance 'add-child-dispatcher))
+        (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher))
+        (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher))
+        (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher)))
     (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
                                                          :layout-manager (make-instance 'gfw:flow-layout)))
     (gfw:realize *layout-tester-win* nil :style-workspace)
-    (setf (gfw:size *layout-tester-win*) (gfi:make-size :width 250 :height 150))
     (setf menubar (gfw:defmenusystem `(((:menu "&File")
-                                        (:menuitem "E&xit" :dispatcher ,fed))
-                                       ((:menu "&Children" :dispatcher ,cmd)
-                                        (:menuitem :separator)))))
+                                        (:menuitem "E&xit" :dispatcher ,exit-disp))
+                                       ((:menu "&Children")
+                                        (:menuitem :submenu ((:menu "Add")
+                                                             (:menuitem "Button" :dispatcher ,add-btn-disp)))
+                                        (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)
+                                                             (:menuitem :separator)))
+                                        (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp)
+                                                             (:menuitem :separator)))
+                                        (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp)
+                                                             (:menuitem :separator))))
+                                       ((:menu "&Window")
+                                        (:menuitem "Pack" :dispatcher ,pack-disp)
+                                        (:menuitem :submenu ((:menu "Select Layout")
+                                                             (:menuitem "Flow")))
+                                        (:menuitem :submenu ((:menu "Modify Layout")
+                                                             (:menuitem :separator)))))))
     (setf (gfw:menu-bar *layout-tester-win*) menubar)
-    (add-layout-tester-widget 'gfw:button :push-button)
-    (add-layout-tester-widget 'gfw:button :push-button)
-    (add-layout-tester-widget 'gfw:button :push-button)
+    (dotimes (i 3)
+      (add-layout-tester-widget 'gfw:button :push-button))
     (gfw:pack *layout-tester-win*)
     (gfw:show *layout-tester-win*)))
 

Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp	(original)
+++ trunk/src/uitoolkit/system/user32.lisp	Mon Feb 20 00:58:33 2006
@@ -303,6 +303,11 @@
   (erase BOOL))
 
 (defcfun
+  ("IsWindowVisible" is-window-visible)
+  BOOL
+  (hwnd HANDLE))
+
+(defcfun
   ("LoadImageA" load-image)
   HANDLE
   (instance HANDLE)

Modified: trunk/src/uitoolkit/widgets/layouts.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/layouts.lisp	(original)
+++ trunk/src/uitoolkit/widgets/layouts.lisp	Mon Feb 20 00:58:33 2006
@@ -77,42 +77,44 @@
     (with-children (win kids)
       (loop for k in kids
             do (let ((kid-size (preferred-size k width-hint height-hint)))
-                 (if (not vert-orient)
-                   (progn
-                     (incf total (gfi:size-width kid-size))
-                     (if (< max (gfi:size-height kid-size))
-                       (setf max (gfi:size-height kid-size))))
-                   (progn
-                     (incf total (gfi:size-height kid-size))
-                     (if (< max (gfi:size-width kid-size))
-                       (setf max (gfi:size-width kid-size))))))))
+                 (when (or (visible-p k) (not (visible-p win)))
+                   (if (not vert-orient)
+                     (progn
+                       (incf total (gfi:size-width kid-size))
+                       (if (< max (gfi:size-height kid-size))
+                         (setf max (gfi:size-height kid-size))))
+                     (progn
+                       (incf total (gfi:size-height kid-size))
+                       (if (< max (gfi:size-width kid-size))
+                         (setf max (gfi:size-width kid-size)))))))))
     (if vert-orient
       (gfi:make-size :width max :height total)
       (gfi:make-size :width total :height max))))
 
 (defmethod compute-layout ((layout flow-layout) (win window) width-hint height-hint)
-  (let ((layout-style (gfw:style layout))
-        (entries nil)
+  (let ((entries nil)
         (last-coord 0)
-        (last-dim 0))
+        (last-dim 0)
+        (vert-orient (find :vertical (gfw:style layout))))
     (with-children (win kids)
       (loop for k in kids
             do (let ((kid-size (preferred-size k width-hint height-hint))
                      (pnt (gfi:make-point)))
-                 (if (not (find :vertical layout-style))
-                   (progn
-                     (setf (gfi:point-x pnt) (+ last-coord last-dim))
-                     (if (>= height-hint 0)
-                       (setf (gfi:size-height kid-size) height-hint))
-                     (setf last-coord (gfi:point-x pnt))
-                     (setf last-dim (gfi:size-width kid-size)))
-                   (progn
-                     (setf (gfi:point-y pnt) (+ last-coord last-dim))
-                     (if (>= width-hint 0)
-                       (setf (gfi:size-width kid-size) width-hint))
-                     (setf last-coord (gfi:point-y pnt))
-                     (setf last-dim (gfi:size-height kid-size))))
-                 (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries))))
+                 (when (or (visible-p k) (not (visible-p win)))
+                   (if (not vert-orient)
+                     (progn
+                       (setf (gfi:point-x pnt) (+ last-coord last-dim))
+                       (if (>= height-hint 0)
+                         (setf (gfi:size-height kid-size) height-hint))
+                       (setf last-coord (gfi:point-x pnt))
+                       (setf last-dim (gfi:size-width kid-size)))
+                     (progn
+                       (setf (gfi:point-y pnt) (+ last-coord last-dim))
+                       (if (>= width-hint 0)
+                         (setf (gfi:size-width kid-size) width-hint))
+                       (setf last-coord (gfi:point-y pnt))
+                       (setf last-dim (gfi:size-height kid-size))))
+                   (push (cons k (make-instance 'gfi:rectangle :size kid-size :location pnt)) entries)))))
     (reverse entries)))
 
 (defmethod initialize-instance :after ((layout flow-layout) &key style)

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Mon Feb 20 00:58:33 2006
@@ -77,6 +77,9 @@
   (if (gfi:disposed-p w)
     (error 'gfi:disposed-error)))
 
+(defmethod hide ((w widget))
+  (gfs::show-window (gfi:handle w) gfs::+sw-hide+))
+
 (defmethod location ((w widget))
   (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
     (cffi:with-foreign-slots ((gfs::cbsize
@@ -131,7 +134,17 @@
   (if (gfi:disposed-p w)
     (error 'gfi:disposed-error)))
 
+(defmethod show ((w widget))
+  (gfs::show-window (gfi:handle w) gfs::+sw-showna+))
+
 (defmethod update ((w widget))
   (let ((hwnd (gfi:handle w)))
     (unless (gfi:null-handle-p hwnd)
       (gfs::update-window hwnd))))
+
+(defmethod visible-p :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod visible-p ((w widget))
+  (not (zerop (gfs::is-window-visible (gfi:handle w)))))


From junrue at common-lisp.net  Tue Feb 21 03:58:23 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Mon, 20 Feb 2006 21:58:23 -0600 (CST)
Subject: [graphic-forms-cvs] r16 - in trunk/src: . tests/uitoolkit
	uitoolkit/widgets
Message-ID: <20060221035823.3675C4C010@common-lisp.net>

Author: junrue
Date: Mon Feb 20 21:58:21 2006
New Revision: 16

Modified:
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/control.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget-with-items.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
implement menu item check/uncheck; cleaned up some widget method names; added additional native handle error checking

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Mon Feb 20 21:58:21 2006
@@ -292,6 +292,8 @@
     #:background-pattern
     #:border-width
     #:caret
+    #:check
+    #:check-all
     #:checked-p
     #:clear-all
     #:clear-item
@@ -376,7 +378,6 @@
     #:hide-lines
     #:horizontal-scrollbar
     #:image
-    #:item-append
     #:item-at
     #:item-count
     #:item-height
@@ -422,8 +423,9 @@
     #:retrieve-span
     #:run-default-message-loop
     #:scroll
+    #:select
     #:select-all
-    #:selected
+    #:selected-p
     #:selection-count
     #:selection-index
     #:selection-indices
@@ -450,6 +452,8 @@
     #:traverse-order
     #:trim-sizes
     #:unlock
+    #:uncheck
+    #:uncheck-all
     #:update
     #:vertical-scrollbar
     #:visible-item-count

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Mon Feb 20 21:58:21 2006
@@ -109,6 +109,10 @@
   ((item-disp-class
     :accessor item-disp-class
     :initarg :item-disp-class
+    :initform nil)
+   (check-test-fn
+    :accessor check-test-fn
+    :initarg :check-test-fn
     :initform nil)))
 
 (defmethod gfw:event-activate ((d child-menu-dispatcher) menu time)
@@ -117,10 +121,14 @@
   (gfw:with-children (*layout-tester-win* kids)
     (loop for k in kids
           do (let ((it (make-instance 'gfw:menu-item)))
-               (gfw:item-append menu it)
+               (gfw:append-item menu it)
                (unless (null (item-disp-class d))
                  (setf (gfw:dispatcher it) (make-instance (item-disp-class d))))
-               (setf (gfw:text it) (gfw:text k))))))
+               (setf (gfw:text it) (gfw:text k))
+               (unless (null (check-test-fn d))
+                 (if (funcall (check-test-fn d) k)
+                   (gfw::check it)
+                   (gfw::uncheck it)))))))
 
 (defclass remove-child-dispatcher (gfw:event-dispatcher) ())  
 
@@ -136,9 +144,9 @@
       (gfi:dispose victim)
       (gfw:layout *layout-tester-win*))))
 
-(defclass hide-child-dispatcher (gfw:event-dispatcher) ())  
+(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())  
 
-(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect)
+(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect)
   (declare (ignorable time rect))
   (let ((text (gfw:text item))
         (victim nil))
@@ -147,23 +155,11 @@
             do (if (string= (gfw:text k) text)
                  (setf victim k))))
     (unless (null victim)
-      (gfw:hide victim)
+      (if (gfw:visible-p victim)
+        (gfw:hide victim)
+        (gfw:show victim))
       (gfw:layout *layout-tester-win*))))
 
-(defclass show-child-dispatcher (gfw:event-dispatcher) ())  
-
-(defmethod gfw:event-select ((d show-child-dispatcher) item time rect)
-  (declare (ignorable time rect))
-  (let ((text (gfw:text item))
-        (victim nil))
-    (gfw:with-children (*layout-tester-win* kids)
-      (loop for k in kids
-            do (if (string= (gfw:text k) text)
-                 (setf victim k))))
-    (unless (null victim)
-      (gfw:show victim)
-      (gfw:pack *layout-tester-win*))))
-
 (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())
 
 (defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect)
@@ -177,8 +173,8 @@
         (pack-disp (make-instance 'pack-layout-dispatcher))
         (add-btn-disp (make-instance 'add-child-dispatcher))
         (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher))
-        (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher))
-        (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher)))
+        (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher
+                                                             :check-test-fn #'gfw:visible-p)))
     (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events)
                                                          :layout-manager (make-instance 'gfw:flow-layout)))
     (gfw:realize *layout-tester-win* nil :style-workspace)
@@ -187,18 +183,13 @@
                                        ((:menu "&Children")
                                         (:menuitem :submenu ((:menu "Add")
                                                              (:menuitem "Button" :dispatcher ,add-btn-disp)))
-                                        (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)
-                                                             (:menuitem :separator)))
-                                        (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp)
-                                                             (:menuitem :separator)))
-                                        (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp)
-                                                             (:menuitem :separator))))
+                                        (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)))
+                                        (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp))))
                                        ((:menu "&Window")
                                         (:menuitem "Pack" :dispatcher ,pack-disp)
                                         (:menuitem :submenu ((:menu "Select Layout")
                                                              (:menuitem "Flow")))
-                                        (:menuitem :submenu ((:menu "Modify Layout")
-                                                             (:menuitem :separator)))))))
+                                        (:menuitem :submenu ((:menu "Modify Layout")))))))
     (setf (gfw:menu-bar *layout-tester-win*) menubar)
     (dotimes (i 3)
       (add-layout-tester-widget 'gfw:button :push-button))

Modified: trunk/src/uitoolkit/widgets/control.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/control.lisp	(original)
+++ trunk/src/uitoolkit/widgets/control.lisp	Mon Feb 20 21:58:21 2006
@@ -43,12 +43,14 @@
     (error 'gfi:disposed-error)))
 
 (defmethod realize :before ((ctl control) parent &rest style)
+  (declare (ignore style))
   (if (gfi:disposed-p parent)
     (error 'gfi:disposed-error))
   (if (not (gfi:disposed-p ctl))
     (error 'gfs:toolkit-error :detail "object already realized")))
 
 (defmethod realize :after ((ctl control) parent &rest style)
+  (declare (ignorable parent style))
   (let ((hwnd (gfi:handle ctl)))
     (subclass-wndproc hwnd)
     (put-widget (thread-context) ctl)

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Mon Feb 20 21:58:21 2006
@@ -95,7 +95,54 @@
       (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr))
         (error 'gfs:win32-error :detail "set-menu-item-info failed")))))
 
-(defun insert-menuitem (howner mid label hbmp)
+(defun check-menuitem (hmenu mid checked)
+  (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+    (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                               gfs::state gfs::id gfs::hsubmenu
+                               gfs::hbmpchecked gfs::hbmpunchecked
+                               gfs::idata gfs::tdata gfs::cch
+                               gfs::hbmpitem)
+                              mii-ptr gfs::menuiteminfo)
+      (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+      (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+))
+      (setf gfs::type 0)
+      (setf gfs::state (if checked gfs::+mfs-checked+ gfs::+mfs-unchecked+))
+      (setf gfs::id mid)
+      (setf gfs::hsubmenu (cffi:null-pointer))
+      (setf gfs::hbmpchecked (cffi:null-pointer))
+      (setf gfs::hbmpunchecked (cffi:null-pointer))
+      (setf gfs::idata 0)
+      (setf gfs::tdata (cffi:null-pointer))
+      (setf gfs::cch 0)
+      (setf gfs::hbmpitem (cffi:null-pointer)))
+    (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr))
+      (error 'gfs:win32-error :detail "set-menu-item-info failed"))))
+
+(defun is-menuitem-checked (hmenu mid)
+  (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
+    (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
+                               gfs::state gfs::id gfs::hsubmenu
+                               gfs::hbmpchecked gfs::hbmpunchecked
+                               gfs::idata gfs::tdata gfs::cch
+                               gfs::hbmpitem)
+                              mii-ptr gfs::menuiteminfo)
+      (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
+      (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+))
+      (setf gfs::type 0)
+      (setf gfs::state 0)
+      (setf gfs::id mid)
+      (setf gfs::hsubmenu (cffi:null-pointer))
+      (setf gfs::hbmpchecked (cffi:null-pointer))
+      (setf gfs::hbmpunchecked (cffi:null-pointer))
+      (setf gfs::idata 0)
+      (setf gfs::tdata (cffi:null-pointer))
+      (setf gfs::cch 0)
+      (setf gfs::hbmpitem (cffi:null-pointer))
+      (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr))
+        (error 'gfs:win32-error :detail "set-menu-item-info failed"))
+      (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
+
+(defun insert-menuitem (hmenu mid label hbmp)
   (cffi:with-foreign-string (str-ptr label)
     (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
       (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
@@ -116,7 +163,7 @@
         (setf gfs::tdata str-ptr)
         (setf gfs::cch (length label))
         (setf gfs::hbmpitem hbmp))
-      (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+      (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
         (error 'gfs::win32-error :detail "insert-menu-item failed")))))
 
 (defun insert-submenu (hparent mid label hbmp hchildmenu)
@@ -145,7 +192,7 @@
       (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
         (error 'gfs::win32-error :detail "insert-menu-item failed")))))
 
-(defun insert-separator (howner)
+(defun insert-separator (hmenu)
   (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
     (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
                                gfs::state gfs::id gfs::hsubmenu
@@ -165,7 +212,7 @@
       (setf gfs::tdata (cffi:null-pointer))
       (setf gfs::cch 0)
       (setf gfs::hbmpitem (cffi:null-pointer)))
-    (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr))
+    (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
       (error 'gfs::win32-error :detail "insert-menu-item failed"))))
 
 (defun sub-menu (m index)
@@ -188,6 +235,19 @@
 ;;; menu methods
 ;;;
 
+(defmethod append-item ((m menu) (it menu-item))
+  (let* ((tc (thread-context))
+         (id (next-menuitem-id tc))
+         (hmenu (gfi:handle m)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfi:disposed-error))
+    (increment-menuitem-id tc)
+    (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer))
+    (setf (item-id it) id)
+    (setf (slot-value it 'gfi:handle) hmenu)
+    (put-menuitem tc it)
+    (call-next-method)))
+
 (defun menu-cleanup-callback (menu item)
   (let ((tc (thread-context)))
     (remove-widget tc (gfi:handle menu))
@@ -202,23 +262,22 @@
         (error 'gfs:win32-error :detail "destroy-menu failed"))))
   (setf (slot-value m 'gfi:handle) nil))
 
-(defmethod item-append ((m menu) (it menu-item))
-  (let* ((tc (thread-context))
-         (id (next-menuitem-id tc))
-         (hmenu (gfi:handle m)))
-    (if (gfi:null-handle-p hmenu)
-      (error 'gfi:disposed-error))
-    (increment-menuitem-id tc)
-    (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer))
-    (setf (item-id it) id)
-    (setf (slot-value it 'gfi:handle) hmenu)
-    (put-menuitem tc it)
-    (call-next-method)))
-
 ;;;
-;;; item methods
+;;; menu-item methods
 ;;;
 
+(defmethod check ((it menu-item))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
+    (check-menuitem hmenu (item-id it) t)))
+
+(defmethod checked-p ((it menu-item))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
+    (is-menuitem-checked hmenu (item-id it))))
+
 (defmethod gfi:dispose ((it menu-item))
   (setf (dispatcher it) nil)
   (remove-menuitem (thread-context) it)
@@ -254,6 +313,12 @@
       (error 'gfs:toolkit-error :detail "null owner menu handle"))
     (set-menuitem-text hmenu (item-id it) str)))
 
+(defmethod uncheck ((it menu-item))
+  (let ((hmenu (gfi:handle it)))
+    (if (gfi:null-handle-p hmenu)
+      (error 'gfs:toolkit-error :detail "null owner menu handle"))
+    (check-menuitem hmenu (item-id it) nil)))
+
 ;;;
 ;;; menu language compiler
 ;;;

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Mon Feb 20 21:58:21 2006
@@ -60,8 +60,14 @@
 (defgeneric caret-position (object)
   (:documentation "Returns a point describing the line number and character position of the caret."))
 
+(defgeneric check (object)
+  (:documentation "Sets the object into the checked state."))
+
+(defgeneric check-all (object)
+  (:documentation "Sets all items in this object to the checked state."))
+
 (defgeneric checked-p (object)
-  (:documentation "Returns T if the item is checked; nil otherwise."))
+  (:documentation "Returns T if the object is in the checked state; nil otherwise."))
 
 (defgeneric clear-item (object index)
   (:documentation "Clears the item at the zero-based index."))
@@ -117,8 +123,8 @@
 (defgeneric deiconified-p (object)
   (:documentation "Returns T if the object is in its normal, not iconified state."))
 
-(defgeneric deselect (object index)
-  (:documentation "Deselects the item at the given zero-based index in the object."))
+(defgeneric deselect (object)
+  (:documentation "Sets the object into the unselected state."))
 
 (defgeneric deselect-all (object)
   (:documentation "Deselects all items in the object."))
@@ -201,9 +207,6 @@
 (defgeneric image (object)
   (:documentation "Returns the object's image object if it has one, or nil otherwise."))
 
-(defgeneric item-append (object other)
-  (:documentation "Adds the item to the object."))
-
 (defgeneric item-at (object index)
   (:documentation "Return the item at the given zero-based index from the object."))
 
@@ -213,10 +216,10 @@
 (defgeneric item-height (object)
   (:documentation "Return the height of the area if one of the object's items were displayed."))
 
-(defgeneric item-index (object other)
+(defgeneric item-index (object item)
   (:documentation "Return the zero-based index of the location of the other object in this object."))
 
-(defgeneric item-owner (object)
+(defgeneric item-owner (item)
   (:documentation "Return the widget containing this item."))
 
 (defgeneric layout (object)
@@ -315,10 +318,13 @@
 (defgeneric scroll (object dest-pnt src-rect children-too)
   (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
 
+(defgeneric select (object)
+  (:documentation "Set this object into the selected state."))
+
 (defgeneric select-all (object)
   (:documentation "Set all items of this object to the selected state."))
 
-(defgeneric selected (object)
+(defgeneric selected-p (object)
   (:documentation "Returns T if the object is in the selected state; nil otherwise."))
 
 (defgeneric selection-count (object)
@@ -384,6 +390,12 @@
 (defgeneric unlock (object)
   (:documentation "Allows this object's contents to be modified."))
 
+(defgeneric uncheck (object)
+  (:documentation "Sets the object into the unchecked state."))
+
+(defgeneric uncheck-all (object)
+  (:documentation "Sets all items in this object to the unchecked state."))
+
 (defgeneric update (object)
   (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))
 

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-with-items.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-with-items.lisp	Mon Feb 20 21:58:21 2006
@@ -33,6 +33,19 @@
 
 (in-package :graphic-forms.uitoolkit.widgets)
 
+(defmethod append-item :before ((w widget-with-items) (it item))
+  (declare (ignore it))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod append-item ((w widget-with-items) (it item))
+  (vector-push-extend it (items w)))
+
+(defmethod clear-item :before ((w widget-with-items) index)
+  (declare (ignore index))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod clear-item ((w widget-with-items) index)
   (let ((it (item-at w index)))
     (delete it (items w) :test #'items-equal-p)
@@ -40,24 +53,45 @@
       (error 'gfi:disposed-error))
     (gfi:dispose it)))
 
+(defmethod clear-span :before ((w widget-with-items) (sp gfi:span))
+  (declare (ignore sp))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod clear-span ((w widget-with-items) (sp gfi:span))
   (loop for index from (gfi:span-start sp) to (gfi:span-end sp)
     collect (clear-item w 0)))
 
-(defmethod item-append ((w widget-with-items) (i item))
-  (vector-push-extend i (items w)))
+(defmethod item-at :before ((w widget-with-items) index)
+  (declare (ignore index))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
 
 (defmethod item-at ((w widget-with-items) index)
   (elt (items w) index))
 
-(defmethod (setf item-at) (index (i item) (w widget-with-items))
+(defmethod (setf item-at) :before (index (it item) (w widget-with-items))
+  (declare (ignorable index it))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod (setf item-at) (index (it item) (w widget-with-items))
   (error 'gfs:toolkit-error :detail "not yet implemented"))
 
+(defmethod item-count :before ((w widget-with-items))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod item-count ((w widget-with-items))
   (length (items w)))
 
-(defmethod item-index ((w widget-with-items) (i item))
-  (let ((pos (position i (items w) :test #'items-equal-p)))
+(defmethod item-index :before ((w widget-with-items) (it item))
+  (declare (ignore it))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod item-index ((w widget-with-items) (it item))
+  (let ((pos (position it (items w) :test #'items-equal-p)))
     (if (null pos)
       (return-from item-index 0))
     0))

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Mon Feb 20 21:58:21 2006
@@ -41,6 +41,11 @@
 ;;; widget methods
 ;;;
 
+(defmethod ancestor-p :before ((ancestor widget) (descendant widget))
+  (declare (ignore descendant))
+  (if (gfi:disposed-p ancestor)
+    (error 'gfi:disposed-error)))
+
 (defmethod ancestor-p ((ancestor widget) (descendant widget))
   (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+))
          (parent (get-widget (thread-context) parent-hwnd)))
@@ -50,6 +55,18 @@
       (error 'gfs:toolkit-error :detail "no widget for parent handle"))
     (ancestor-p ancestor parent)))
 
+(defmethod checked-p :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod checked-p ((w widget))
+  (declare (ignore w))
+  nil)
+
+(defmethod client-size :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod client-size ((w widget))
   (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
     (cffi:with-foreign-slots ((gfs::cbsize
@@ -80,6 +97,10 @@
 (defmethod hide ((w widget))
   (gfs::show-window (gfi:handle w) gfs::+sw-hide+))
 
+(defmethod location :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod location ((w widget))
   (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo)
     (cffi:with-foreign-slots ((gfs::cbsize
@@ -97,9 +118,12 @@
           (gfs::screen-to-client (gfi:handle w) pnt-ptr)
           (gfi:make-point :x gfs::x :y gfs::y))))))
 
-(defmethod (setf location) ((pnt gfi:point) (w widget))
+(defmethod (setf location) :before ((pnt gfi:point) (w widget))
+  (declare (ignore pnt))
   (if (gfi:disposed-p w)
-    (error 'gfi:disposed-error))
+    (error 'gfi:disposed-error)))
+
+(defmethod (setf location) ((pnt gfi:point) (w widget))
   (if (zerop (gfs::set-window-pos (gfi:handle w)
                                    (cffi:null-pointer)
                                    (gfi:point-x pnt)
@@ -108,17 +132,38 @@
                                    gfs::+swp-nosize+))
     (error 'gfs:win32-error :detail "set-window-pos failed")))
 
+(defmethod pack :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod pack ((w widget))
   (setf (size w) (preferred-size w -1 -1)))
 
+(defmethod redraw :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod redraw ((w widget))
   (let ((hwnd (gfi:handle w)))
     (unless (gfi:null-handle-p hwnd)
       (gfs::invalidate-rect hwnd nil 1))))
 
+(defmethod selected-p :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
+(defmethod selected-p ((w widget))
+  (declare (ignore w))
+  nil)
+
 (defmethod size ((w widget))
   (client-size w))
 
+(defmethod (setf size) :before ((sz gfi:size) (w widget))
+  (declare (ignore sz))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod (setf size) ((sz gfi:size) (w widget))
   (if (gfi:disposed-p w)
     (error 'gfi:disposed-error))
@@ -137,6 +182,10 @@
 (defmethod show ((w widget))
   (gfs::show-window (gfi:handle w) gfs::+sw-showna+))
 
+(defmethod update :before ((w widget))
+  (if (gfi:disposed-p w)
+    (error 'gfi:disposed-error)))
+
 (defmethod update ((w widget))
   (let ((hwnd (gfi:handle w)))
     (unless (gfi:null-handle-p hwnd)


From junrue at common-lisp.net  Tue Feb 21 06:31:23 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Tue, 21 Feb 2006 00:31:23 -0600 (CST)
Subject: [graphic-forms-cvs] r17 - in trunk: . src/tests/uitoolkit
	src/uitoolkit/system src/uitoolkit/widgets
Message-ID: <20060221063123.EA8E35C016@common-lisp.net>

Author: junrue
Date: Tue Feb 21 00:31:22 2006
New Revision: 17

Added:
   trunk/src/uitoolkit/widgets/text-label.lisp
Modified:
   trunk/graphic-forms-uitoolkit.asd
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/system/system-constants.lisp
   trunk/src/uitoolkit/widgets/button.lisp
   trunk/src/uitoolkit/widgets/widget-classes.lisp
   trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
implemented text-label widget, although mouse events currently cause a foreign type error

Modified: trunk/graphic-forms-uitoolkit.asd
==============================================================================
--- trunk/graphic-forms-uitoolkit.asd	(original)
+++ trunk/graphic-forms-uitoolkit.asd	Tue Feb 21 00:31:22 2006
@@ -97,6 +97,7 @@
                        (:file "item")
                        (:file "widget")
                        (:file "control")
+                       (:file "text-label")
                        (:file "button")
                        (:file "widget-with-items")
                        (:file "menu")

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Tue Feb 21 00:31:22 2006
@@ -35,8 +35,9 @@
 
 (defconstant +btn-text-before+ "Push Me")
 (defconstant +btn-text-after+ "Again!")
+(defconstant +label-text+ "Test Label")
 
-(defvar *button-counter* 0)
+(defvar *widget-counter* 0)
 
 (defparameter *layout-tester-win* nil)
 
@@ -68,7 +69,7 @@
     :initform 0)))
 
 (defun add-layout-tester-widget (widget-class subtype)
-  (let* ((be (make-instance 'layout-tester-widget-events :id *button-counter*))
+  (let* ((be (make-instance 'layout-tester-widget-events :id *widget-counter*))
          (w (make-instance widget-class :dispatcher be)))
     (cond
       ((eql subtype :push-button)
@@ -80,10 +81,12 @@
                                         (format nil "~d ~a" (id be) +btn-text-before+))
                                       (progn
                                         (setf flag nil)
-                                        (format nil "~d ~a" (id be) +btn-text-after+))))))
-         (incf *button-counter*)))
+                                        (format nil "~d ~a" (id be) +btn-text-after+)))))))
+      ((eql subtype :text-label)
+         (setf (toggle-fn be) #'(lambda () (format nil "~d ~a" (id be) +label-text+)))))
     (gfw:realize w *layout-tester-win* subtype)
-    (setf (gfw:text w) (funcall (toggle-fn be)))))
+    (setf (gfw:text w) (funcall (toggle-fn be)))
+    (incf *widget-counter*)))
 
 (defmethod gfw:event-select ((d layout-tester-widget-events) btn time rect)
   (declare (ignorable time rect))
@@ -167,11 +170,13 @@
   (exit-layout-tester))
 
 (defun run-layout-tester-internal ()
-  (setf *button-counter* 0)
+  (setf *widget-counter* 0)
   (let ((menubar nil)
         (exit-disp (make-instance 'layout-tester-exit-dispatcher))
         (pack-disp (make-instance 'pack-layout-dispatcher))
         (add-btn-disp (make-instance 'add-child-dispatcher))
+        (add-text-label-disp (make-instance 'add-child-dispatcher :widget-class 'gfw::text-label
+                                                                  :subtype :text-label))
         (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher))
         (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher
                                                              :check-test-fn #'gfw:visible-p)))
@@ -182,7 +187,8 @@
                                         (:menuitem "E&xit" :dispatcher ,exit-disp))
                                        ((:menu "&Children")
                                         (:menuitem :submenu ((:menu "Add")
-                                                             (:menuitem "Button" :dispatcher ,add-btn-disp)))
+                                                             (:menuitem "Button" :dispatcher ,add-btn-disp)
+                                                             (:menuitem "Label" :dispatcher ,add-text-label-disp)))
                                         (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp)))
                                         (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp))))
                                        ((:menu "&Window")

Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp	(original)
+++ trunk/src/uitoolkit/system/system-constants.lisp	Tue Feb 21 00:31:22 2006
@@ -34,6 +34,7 @@
 (in-package :graphic-forms.uitoolkit.system)
 
 (defconstant +button-classname+          "button")
+(defconstant +static-classname+          "static")
 
 (defconstant +bi-rgb+                           0)
 (defconstant +bi-rle8+                          1)
@@ -467,6 +468,39 @@
 (defconstant +sm-remotecontrol+            #x2001)
 (defconstant +sm-caretblinkingenabled+     #x2002)
 
+(defconstant +ss-left+                 #x00000000)
+(defconstant +ss-center+               #x00000001)
+(defconstant +ss-right+                #x00000002)
+(defconstant +ss-icon+                 #x00000003)
+(defconstant +ss-blackrect+            #x00000004)
+(defconstant +ss-grayrect+             #x00000005)
+(defconstant +ss-whiterect+            #x00000006)
+(defconstant +ss-blackframe+           #x00000007)
+(defconstant +ss-grayframe+            #x00000008)
+(defconstant +ss-whiteframe+           #x00000009)
+(defconstant +ss-useritem+             #x0000000A)
+(defconstant +ss-simple+               #x0000000B)
+(defconstant +ss-leftnowordwrap+       #x0000000C)
+(defconstant +ss-ownerdraw+            #x0000000D)
+(defconstant +ss-bitmap+               #x0000000E)
+(defconstant +ss-enhmetafile+          #x0000000F)
+(defconstant +ss-etchedhorz+           #x00000010)
+(defconstant +ss-etchedvert+           #x00000011)
+(defconstant +ss-etchedframe+          #x00000012)
+(defconstant +ss-typemask+             #x0000001F)
+(defconstant +ss-realsizecontrol+      #x00000040)
+(defconstant +ss-noprefix+             #x00000080)
+(defconstant +ss-notify+               #x00000100)
+(defconstant +ss-centerimage+          #x00000200)
+(defconstant +ss-rightjust+            #x00000400)
+(defconstant +ss-realsizeimage+        #x00000800)
+(defconstant +ss-sunken+               #x00001000)
+(defconstant +ss-editcontrol+          #x00002000)
+(defconstant +ss-endellipsis+          #x00004000)
+(defconstant +ss-pathellipsis+         #x00008000)
+(defconstant +ss-wordellipsis+         #x0000C000)
+(defconstant +ss-ellipsismask+         #x0000C000)
+
 (defconstant +sw-hide+                          0)
 (defconstant +sw-shownormal+                    1)
 (defconstant +sw-normal+                        1)

Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp	(original)
+++ trunk/src/uitoolkit/widgets/button.lisp	Tue Feb 21 00:31:22 2006
@@ -41,40 +41,34 @@
   (declare (ignore btn))
   (let ((std-flags 0)
         (ex-flags 0))
-    (mapcar #'(lambda (sym)
-                (cond
-                  ;; primary button styles
-                  ;;
-                  ((eq sym :check-box)
-                    (setf std-flags gfs::+bs-checkbox+))
-                  ((eq sym :default-button)
-                    (setf std-flags gfs::+bs-defpushbutton+))
-                  ((eq sym :push-button)
-                    (setf std-flags gfs::+bs-pushbutton+))
-                  ((eq sym :radio-button)
-                    (setf std-flags gfs::+bs-radiobutton+))
-                  ((eq sym :toggle-button)
-                    (setf std-flags gfs::+bs-pushbox+))))
-            (flatten style))
+    (setf style (flatten style))
+    ;; FIXME: check whether any of the primary button
+    ;; styles were specified, default to :push-button
+    ;;
+    (loop for sym in style
+          do (cond
+               ;; primary button styles
+               ;;
+               ((eq sym :check-box)
+                  (setf std-flags gfs::+bs-checkbox+))
+               ((eq sym :default-button)
+                  (setf std-flags gfs::+bs-defpushbutton+))
+               ((eq sym :push-button)
+                  (setf std-flags gfs::+bs-pushbutton+))
+               ((eq sym :radio-button)
+                  (setf std-flags gfs::+bs-radiobutton+))
+               ((eq sym :toggle-button)
+                  (setf std-flags gfs::+bs-pushbox+))))
     (values std-flags ex-flags)))
 
 (defmethod preferred-size ((btn button) width-hint height-hint)
-  (declare (ignorable width-hint height-hint))
-  (let ((hwnd (gfi:handle btn))
-        (sz (gfi:make-size))
-        (count (length (text btn))))
-    (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics)
-      (cffi:with-foreign-slots ((gfs::tmheight
-                                 gfs::tmexternalleading
-                                 gfs::tmavgcharwidth)
-                                tm-ptr gfs::textmetrics)
-        (gfs:with-retrieved-dc (hwnd dc)
-          (if (zerop (gfs::get-text-metrics dc tm-ptr))
-            (error 'gfs:win32-error :detail "get-text-metrics failed"))
-          (setf (gfi:size-width sz) (* gfs::tmavgcharwidth (+ count 2)))
-          (let ((tmp (+ gfs::tmexternalleading gfs::tmheight) ))
-            (setf (gfi:size-height sz) (+ (floor (/ (* tmp 7) 5)) 1))))))
-    sz))
+  (text-widget-preferred-size btn
+                              width-hint
+                              height-hint
+                              #'(lambda (char-width char-count)
+                                  (* char-width (+ char-count 2)))
+                              #'(lambda (char-height)
+                                  (+ (floor (/ (* char-height 7) 5)) 1))))
 
 (defmethod realize ((btn button) parent &rest style)
   (multiple-value-bind (std-style ex-style)

Added: trunk/src/uitoolkit/widgets/text-label.lisp
==============================================================================
--- (empty file)
+++ trunk/src/uitoolkit/widgets/text-label.lisp	Tue Feb 21 00:31:22 2006
@@ -0,0 +1,100 @@
+;;;;
+;;;; text-label.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.widgets)
+
+;;;
+;;; methods
+;;;
+
+(defmethod compute-style-flags ((label text-label) &rest style)
+  (declare (ignore label))
+  (let ((std-flags 0)
+        (ex-flags 0))
+    (setf style (flatten style))
+    (unless (or (find :beginning style)
+                (find :center style)
+                (find :end style))
+      (setf std-flags gfs::+ss-leftnowordwrap+))
+    (loop for sym in style
+          do (cond
+               ;; primary static styles
+               ;;
+               ((eq sym :beginning)
+                  (setf std-flags gfs::+ss-leftnowordwrap+)) ; FIXME: i18n
+               ((eq sym :center)
+                  (setf std-flags gfs::+ss-center+))
+               ((eq sym :end)
+                  (setf std-flags gfs::+ss-right+)) ; FIXME: i18n
+
+               ;; styles that can be combined
+               ;;
+               ((eq sym :ellipsis)
+                  (setf std-flags (logior std-flags gfs::+ss-endellipsis+)))
+               ((eq sym :raised)
+                  (setf std-flags (logand (lognot gfs::+ss-sunken+) std-flags))
+                  (setf std-flags (logior std-flags gfs::+ss-etchedframe+)))
+               ((eq sym :sunken)
+                  (setf std-flags (logand (lognot gfs::+ss-etchedframe+) std-flags))
+                  (setf std-flags (logior std-flags gfs::+ss-sunken+)))
+               ((eq sym :wrap)
+                  (setf std-flags (logand (lognot gfs::+ss-leftnowordwrap+) std-flags))
+                  (setf std-flags (logior std-flags gfs::+ss-left+)))))
+    (values std-flags ex-flags)))
+
+(defmethod preferred-size ((label text-label) width-hint height-hint)
+  (text-widget-preferred-size label
+                              width-hint
+                              height-hint
+                              #'(lambda (char-width char-count)
+                                  (+ (* char-width char-count) 2))
+                              #'(lambda (char-height)
+                                  (+ char-height 2))))
+
+(defmethod realize ((label text-label) parent &rest style)
+  (multiple-value-bind (std-style ex-style)
+      (compute-style-flags label style)
+    (let ((hwnd (create-window gfs::+static-classname+
+                               " "
+                               (gfi:handle parent)
+                               (logior std-style gfs::+ws-child+ gfs::+ws-visible+)
+                               ex-style)))
+      (if (not hwnd)  
+        (error 'gfs:win32-error :detail "create-window failed"))
+      (setf (slot-value label 'gfi:handle) hwnd))))
+
+(defmethod text ((label text-label))
+  (get-widget-text label))
+
+(defmethod (setf text) (str (label text-label))
+  (set-widget-text label str))

Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp	Tue Feb 21 00:31:22 2006
@@ -65,6 +65,12 @@
 (defclass button (control) ()
   (:documentation "This class represents selectable controls that issue notifications when clicked."))
 
+(defclass image-label (control) ()
+  (:documentation "This class represents non-selectable controls that display an image."))
+
+(defclass text-label (control) ()
+  (:documentation "This class represents non-selectable controls that display a string."))
+
 (defclass widget-with-items (widget)
   ((items
     :accessor items

Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp	Tue Feb 21 00:31:22 2006
@@ -123,3 +123,23 @@
   (if (gfi:disposed-p w)
     (error 'gfi:disposed-error))
   (gfs::set-window-text (gfi:handle w) str))
+
+(defun text-widget-preferred-size (widget width-hint height-hint width-calc height-calc)
+  ;; FIXME: implement width-hint and height-hint constraints
+  ;;
+  (declare (ignorable width-hint height-hint))
+  (let ((hwnd (gfi:handle widget))
+        (sz (gfi:make-size))
+        (count (length (text widget))))
+    (cffi:with-foreign-object (tm-ptr 'gfs::textmetrics)
+      (cffi:with-foreign-slots ((gfs::tmheight
+                                 gfs::tmexternalleading
+                                 gfs::tmavgcharwidth)
+                                tm-ptr gfs::textmetrics)
+        (gfs:with-retrieved-dc (hwnd dc)
+          (if (zerop (gfs::get-text-metrics dc tm-ptr))
+            (error 'gfs:win32-error :detail "get-text-metrics failed"))
+          (setf (gfi:size-width sz) (funcall width-calc gfs::tmavgcharwidth count))
+          (setf (gfi:size-height sz) (funcall height-calc (+ gfs::tmexternalleading
+                                                             gfs::tmheight))))))
+    sz))


From junrue at common-lisp.net  Thu Feb 23 02:55:47 2006
From: junrue at common-lisp.net (junrue at common-lisp.net)
Date: Wed, 22 Feb 2006 20:55:47 -0600 (CST)
Subject: [graphic-forms-cvs] r18 - trunk/src/uitoolkit/widgets
Message-ID: <20060223025547.EBC2844016@common-lisp.net>

Author: junrue
Date: Wed Feb 22 20:55:47 2006
New Revision: 18

Modified:
   trunk/src/uitoolkit/widgets/event.lisp
Log:
fixed a mis-declaration of the msg parameter for wndproc defcallbacks

Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp	(original)
+++ trunk/src/uitoolkit/widgets/event.lisp	Wed Feb 22 20:55:47 2006
@@ -43,7 +43,7 @@
 ;;;
 
 (cffi:defcallback uit_widgets_wndproc
-                  gfs::LONG
+                  gfs::UINT
                   ((hwnd gfs::HANDLE)
                    (msg gfs::UINT)
                    (wparam gfs::WPARAM)
@@ -51,7 +51,7 @@
   (process-message hwnd msg wparam lparam))
 
 (cffi:defcallback subclassing_wndproc
-                  gfs::LONG
+                  gfs::UINT
                   ((hwnd gfs::HANDLE)
                    (msg gfs::UINT)
                    (wparam gfs::WPARAM)
@@ -98,11 +98,12 @@
 
 (defun process-mouse-message (fn hwnd lparam btn-symbol)
   (let* ((tc (thread-context))
-         (w (get-widget tc hwnd)))
+         (w (get-widget tc hwnd))
+         (pnt (mouse-event-pnt tc)))
     (when w
-      (setf (gfi:point-x (mouse-event-pnt tc)) (lo-word lparam))
-      (setf (gfi:point-y (mouse-event-pnt tc)) (hi-word lparam))
-      (funcall fn (dispatcher w) w (event-time tc) (mouse-event-pnt tc) btn-symbol)))
+      (setf (gfi:point-x pnt) (lo-word lparam))
+      (setf (gfi:point-y pnt) (hi-word lparam))
+      (funcall fn (dispatcher w) w (event-time tc) pnt btn-symbol)))
   0)
 
 (defun get-class-wndproc (hwnd)