[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
junrue at common-lisp.net
junrue at common-lisp.net
Sat Feb 11 06:39:10 UTC 2006
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)))
More information about the Graphic-forms-cvs
mailing list