[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
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")) ,@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)))
graphic-forms-cvs@common-lisp.net
-
junrue＠common-lisp.net